「複数の画像を挿入」の部分修正

質問

過去ログから、失礼致します。
下記、コードを修正したいのですがどこを修正すればよいか分からないので
ご教示願います。
１、ファイル名表示を、アドレス部分（C:\～）と拡張子部分を除いての表記にしたい。
２、縦４×横２の台帳なので横２列に対応するものに変更したい。
　　（縦４×横１であれば対応セルを変更すればよいのですが２列だとどうすればよいのか）
３、挿入したら範囲内で中央配置にしたい
　　（挿入後手修正しようとしても中央配置が選択できない）

---------------------------------------------
Sub 複数の画像を挿入()

　　Dim strFilter As String
　　Dim Filenames As Variant
　　Dim PIC　　　 As Picture

　　' 「ファイルを開く」ダイアログでファイル名を取得
　　strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
　　Filenames = Application.GetOpenFilename( _
　　　　　　　　　　FileFilter:=strFilter, _
　　　　　　　　　　Title:="図の挿入(複数選択可）", _
　　　　　　　　　　MultiSelect:=True)
　　If Not IsArray(Filenames) Then Exit Sub

　　' ファイル名をソート
　　Call BubbleSort_Str(Filenames, True, vbTextCompare)

　　' 貼り付け開始セルを選択
　　Range("C5").Select

　　' マクロ実行中の画面描写を停止
　　Application.ScreenUpdating = False
　　' 順番に画像を挿入
　　For i = LBound(Filenames) To UBound(Filenames)
　　　　Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

　　　　'-------------------------------------------------------------
　　　　' 画像の各種プロパティ変更
　　　　'-------------------------------------------------------------
　　　　With PIC
　　　　　　.Top = ActiveCell.Top　　　　' 位置：アクティブセルの上側に重ねる
　　　　　　.Left = ActiveCell.Left　　　' 位置：アクティブセルの左側に重ねる
　　　　　　.Placement = xlMove　　　　　' 移動するがサイズ変更しない
　　　　　　.PrintObject = True　　　　　' 印刷する
　　　　End With
　　　　With PIC.ShapeRange
　　　　　　.LockAspectRatio = msoTrue　 ' 縦横比維持
　　　　　　' 画像の高さをアクティブセルにあわせる
　　　　　　' 結合セルの場合でも対応
　　　　　　.Height = ActiveCell.MergeArea.Height
　　　　End With

　　　　' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル]
　　　　ActiveCell.Offset(5).Select

　　　　Set PIC = Nothing
　　Next i

　　' 終了
　　Application.ScreenUpdating = True
　　MsgBox i & "枚の画像を挿入しました", vbInformation

End Sub

' バブルソート（文字列）
Private Sub BubbleSort_Str( _
　　ByRef Source As Variant, _
　　Optional ByVal SortAsc As Boolean = True, _
　　Optional ByVal Compare As VbCompareMethod = vbTextCompare)

　　If Not IsArray(Source) Then Exit Sub

　　Dim i As Long, j As Long
　　Dim vntTmp As Variant
　　For i = LBound(Source) To UBound(Source) - 1
　　　　For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
　　　　　　If StrComp(Source(IIf(SortAsc, j, j + 1)), _
　　　　　　　　　　　 Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
　　　　　　　　vntTmp = Source(j)
　　　　　　　　Source(j) = Source(j + 1)
　　　　　　　　Source(j + 1) = vntTmp
　　　　　　End If
　　　　Next j
　　Next i

End Sub
-----------------------------------------

回答No.2

imogasi

＃１の補足。
#Iのコードはセルの現状の位置に頼り、セル幅、セル高さを適当に手動で調節するやり方です。（プログラムでもできますが）
間の１行は画像名など入れることを考慮してます。
写真間隔を行高で調節するならB２の次はB5、その次はB8・・です。B4,B7・・の高さで調節します
列の間はC、E・・列が幅調節に使えます。
ーー
別に
参考までに、セルの位置や高さや幅を使わずに、規則正しく配置するロジックは、
３列、５行の場合
Sub test11()
ActiveSheet.DrawingObjects.Delete
t = 50: l = 20: w = 30: h = 15
tk = 30: yk = 70
tw = t: lw = l
For j = 1 To 3
For i = 1 To 5
ActiveSheet.Shapes.AddShape msoShapeRectangle, lw, tw, w, h
tw = tw + tk
Next i
tw = t
lw = lw + yk
Next j
End Sub
ActiveSheet.Shapes.AddShape msoShapeRectangle, lw, tw, w, h
のところが、本件質問の場合なら、画像挿入のコードに置き換えます。
これが一番簡潔なコードかと思う。
ただし印刷された場合などの実際の大きさや間隔を考えると、エクセルでは相当知識が必要でしょう。WordVBAでは、オブジェクトの幅などに、（例）Application.CentimetersToPoints(5)　の
ようなのが使えて、使い物になる（印刷物は指定長になる）ようです。

回答No.1

imogasi

思い付いたらすぐ、元のコードをコピペして質問してるね。
丸投げのようだし、修正力がなければ、回答してもらっても、役立たないでしょう。
VBではなく、エクセルVBAの質問らしいね。表題にでも,はっきり書くこと。VBとVBAは違うものだよ。
今回は影響は少ないようだが、エクセルのバージョンを書くこと（下記は２０１３でテスト）。
自分で、検索語を考え、Googleなどで照会し、WEBなど調べて、それを参考にして、いろいろやってみて、できない点に質問点を絞って、質問をすべきでしょう。
質問者の今の段階では、サムネイル画像を作り、印刷などが行える、フリーソフトなどを探すべき段階（他人の作ったソフトをそのまま使う）ではないですか。
一般に、だんだん処理対象も複雑化して、自分でプログラムを作るといううのは、時間がかかり、内容が複雑になっていて、遠ざかりつつあると思う。
この質問掲載コードでは、その後に、印刷しているのか。
本質問でも、シートに目的の画像の挿入・配置を実現後どうしたいのか。
もう少し本件でやりたいことの目的を広く説明しておくべきではないか。
４ｘ２列の８つの場所に入れる順番は何も書いてないがどうする。下記コードでは
（A)か（B)か。
ーーー
関連した、テストプログラム（参考）セルに順番の数字が出る。
Sub test02()
'a = Array(0, "b2", "d2", "B4", "D4", "b6", "d6", "B8", "D8") '-->(A)
a = Array(0, "B2", "B4", "B6", "B8", "D2", "D4", "D6", "D8") '-->(B)
For i = 1 To 8
Range(a(i)) = i
Next i
End Sub
ー－－
もっと画像の位置が多い場合は、上記のような直接セル番地指定方式ではなく（本質問は８個なのでわかりやすく、変更のしやすい本方式を上げてみたが）、
１シート上に、５０や１００画像になるとロジックで、「繰り返し法」に持ち込んでやることになるとおもう。
８以上の画像は、考えないのか。
印刷して９番目以後を繰り返すのか。他シートなどに順次保存するのか。
ーー
参考コードとして
Sub test03()
'a = Array(0, "B2", "D2", "B4", "D4", "b6", "d6", "B8", "D8")
a = Array("B2", "B4", "B6", "B8", "D2", "D4", "D6", "D8")
g = Array("", "PC040625.JPG", "PC040626.JPG", "PC040627.JPG", "PC040628.JPG", "PC040629.JPG", "PC040630.JPG", "PC040631.JPG", "PC040632.JPG")
i = 0
ActiveSheet.DrawingObjects.Delete
Application.ScreenUpdating = False
'---
For Each x In a
Range(x).Select
i = i + 1
y = g(i)
Filename = "C:\Users\XXXX\Pictures\" & y
Set myShape = ActiveSheet.Shapes.AddPicture(Filename:=Filename, _
LinkToFile:=True, _
SaveWithDocument:=False, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=Selection.Width, _
Height:=Selection.Height)
Next x
'----
Application.ScreenUpdating = True
End Sub
----
>範囲内で中央配置にしたい
なんのこと。上記では、セルの形（大きさ）通りにぴったりの大きさにしている。セルとセルの幅と高さで調節するか。Left:=Selection.Left,＋１０などの調節をしてみるか。
この点を凝るのは、もっと勉強してからと思う。
＞ファイル名表示を、アドレス部分（C:\～）と拡張子部分を除いての表記にしたい。
これぐらいできるだろう。上記ではArrayの部分とそれ以前を分けて文字列に分ければよい。
どこにファイル名を表示したいのか。上記プログラムでは略しているが、直下のセルにでも代入すればしまい、では。
＞ソートなどの部分は、本件回答対象外にしている。