エクセルVBAでの画像ファイル名取得他

質問

VBAについての質問です。
http://hp.vector.co.jp/authors/VA033788/kowaza.html#0158
上記をベースに、なんとかVBAを下記のように書き換えました。

Sub LoadPictures3()
Dim Fnames As Variant
Dim Fn As Variant
Dim i As Integer
Dim Pic As Picture
Dim R As Range
Dim R2 As Range
Dim Pc As Integer

Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True)
If TypeName(Fnames) = "Boolean" Then Exit Sub

Application.ScreenUpdating = False

'一枚目の貼付け位置
Set R = Range("B5")
Set R2 = R.Offset(35)
Pc = 0

For i = 1 To UBound(Fnames)
Set Pic = ActiveSheet.Pictures.Insert(Fnames(i))
Select Case (i - 1) Mod 4 + 1

Case 1
Pc = Pc + 1
If Pc >= 2 Then
ActiveSheet.HPageBreaks.Add R2
End If
With R
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
End With

Case 2
With R.Offset(0, 6) '一枚目に対する二枚目の相対位置
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
End With

Case 3
With R.Offset(18, 0)
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
End With

Case 4
With R.Offset(18, 6)
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
End With

'次ページの相対位置
Set R = R.Offset(39)
End Select
Next
Application.ScreenUpdating = True
End Sub

ここで、画像の上の位置（B5のセル位置の画像の場合、B4）に
元々の画像ファイル名を取得し、表記させたいのですが
調べた所、multiselect:=Trueで複数ファイルを選択するときに
画像名が図1、図2に変わっているようで、どうしていいかわかりません。

後、画像を300×225の「変倍」画像にしたいのですが
どのようにすれば可能でしょうか？

全くVBAの知識がなく、上のURLを参考に、単語を調べつつ書き換えている状態で、変数やらなんやらの指定・書き方等わかりません。
どなたかご教授願います。

回答No.3

lul · ベストアンサー

縦横比を保持しないという設定に関しては
以下の部分に1行付け加えれば大丈夫です。
前回の修正とあわせて2行の追加ですね。
With R
Pic.ShapeRange.LockAspectRatio = msoFalse '←ここを追加
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
Pic.Name = FSO.GetBaseName(Fnames(i)) '←ここを追加
End With
これでどうでしょう？

お礼

レスありがとうございます。
返信が遅くなりましてすみません。

色々ありがとうございます、理想通りに上手くいきました！
他、ファイル名の配置の方も無事解決できました。
これで、仕事がスムーズに進みます！

色々お世話になりました。
本当にありがとうございます！！！

回答No.2

pkh4989

正確ではないけど、参考にしてください。

Sub LoadPictures3()
　　Dim Fnames　As Variant
　　Dim Fn　　　As Variant
　　Dim i　　　 As Integer
　　Dim Pic　　 As Picture
　　Dim R　　　 As Range
　　Dim R2　　　As Range
　　Dim Pc　　　As Integer
　　Dim wH　　　As Integer
　　Dim wW　　　As Integer
　　'
　　wH = 1　　　'←高さの倍率を設定 (小数点、マイナス等は出来ません)
　　wW = 2　　　'←幅の倍率を設定
　　Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True)
　　If TypeName(Fnames) = "Boolean" Then Exit Sub

　　Application.ScreenUpdating = False

　　'一枚目の貼付け位置
　　Set R = Range("B5")
　　Set R2 = R.Offset(35 * wH)
　　Pc = 0

　　For i = 1 To UBound(Fnames)
　　　　Set Pic = ActiveSheet.Pictures.Insert(Fnames(i))
　　　　nm = Get_Name(Fnames(i))　　　　'←ファイル名称取得
　　　　Select Case (i - 1) Mod 4 + 1
　　　　　　Case 1
　　　　　　　　Pc = Pc + 1
　　　　　　　　If Pc >= 2 Then
　　　　　　　　　　ActiveSheet.HPageBreaks.Add R2
　　　　　　　　End If
　　　　　　　　With R
　　　　　　　　　　Pic.Left = .Left
　　　　　　　　　　Pic.Top = .Top
　　　　　　　　　　Pic.Width = 300 * wW
　　　　　　　　　　Pic.Height = 225 * wH
　　　　　　　　End With
　　　　　　Case 2
　　　　　　　　With R.Offset(0, 6 * wW) '一枚目に対する二枚目の相対位置
　　　　　　　　　　Pic.Left = .Left
　　　　　　　　　　Pic.Top = .Top
　　　　　　　　　　Pic.Width = 300 * wW
　　　　　　　　　　Pic.Height = 225 * wH
　　　　　　　　End With
　　　　　　Case 3
　　　　　　　　With R.Offset(18 * wH, 0)
　　　　　　　　　　Pic.Left = .Left
　　　　　　　　　　Pic.Top = .Top
　　　　　　　　　　Pic.Width = 300 * wW
　　　　　　　　　　Pic.Height = 225 * wH
　　　　　　　　End With
　　　　　　Case 4
　　　　　　　　With R.Offset(18 * wH, 6 * wW)
　　　　　　　　　　Pic.Left = .Left
　　　　　　　　　　Pic.Top = .Top
　　　　　　　　　　Pic.Width = 300 * wW
　　　　　　　　　　Pic.Height = 225 * wH
　　　　　　　　End With
　　　　　　　　'次ページの相対位置
　　　　　　　　Set R = R.Offset(39 * wH)
　　　　End Select
　　　　ActiveSheet.Pictures(i).Name = nm　　　 '←ファイル名称設定
　　Next
　　Application.ScreenUpdating = True
End Sub
'ファイル名称取得
Function Get_Name(wNm As Variant) As String
　　Dim wI　　　As Integer
　　Dim wSt　　 As String
　　Dim ExitFlg As Boolean
　　wSt = wNm
　　Do While ExitFlg = False
　　　　wI = InStr(wSt, "\")
　　　　If wI = 0 Then
　　　　　　ExitFlg = True
　　　　Else
　　　　　　wSt = Mid(wSt, wI + 1)
　　　　End If
　　Loop
　　Get_Name = wSt
End Function

お礼

レスありがとうございます。
返信が遅くなりましてすみません。

このやり方だと、縦横比が一律になってしまいますよね。
複数の、色々なサイズの画像を強制的に同じサイズにしたかったんです。
説明の仕方が下手ですみません。

ファイル名取得については、このやり方だと場所の情報になるんですね。
色々なことができるのだなぁ、と勉強になりました。
今回は、lulさんの方法で解決しましたが、ありがとうございます!!

回答No.1

lul

名前に関してはプログラム始まってすぐの所で
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
を宣言しておいて
以下の部分に1行付け加えれば大丈夫です。
With R
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
Pic.Name = FSO.GetBaseName(Fnames(i)) '←ここを追加
End With

Excel2000で試してみましたが、サイズに関してはちゃんと出来ているぽいですよ。
ピクセルとcmは違うので気をつけて下さいね。

お礼

早々にありがとうございます！
試した所、無事名前を書き換えることができました!!
（まだ、上手くセルに配置できていませんが、
もう少し試行錯誤してみます）

画像サイズについては、説明不足で申し訳ありません、
縦横比が元画像と同じまま配置されてしまうので、
これを強制的に300×225にしたいのです。
（例えば、縦の画像も変形させて、横に配置したいということです）
検索はしてみたのですが、近い物がみつからなくて…。。。