| |
大変お世話になります．
エクセルに画像ファイル名（100.jpg）等を入力しておき，フォルダにある画像
からその画像を抽出し，エクセル画像名を記載したセルの左のセルへ画像を取り込むﾏｸﾛをつくりたいです．以下全ての画像を読み込むﾏｸﾛはできたのですが，画像
の指定がうまくいきません．詳しい方がいらっしゃいましたらご教示よろしくお願い致します．
' 指定したフォルダにある画像ファイルを読み込み、EXCELに貼り付ける。
'
Sub EggFunc_pasteDirImage()
' 変数定義
Dim fileName As String
Dim targetCol As Integer
Dim targetRow As Integer
Dim targetCell As Range
Dim shell, myPath
Dim pos As Integer
Dim extention As String
Dim isImage As Boolean
' 選択セルを取得
targetCol = ActiveCell.Column
targetRow = ActiveCell.Row
' フォルダ選択画面を表示
Set shell = CreateObject("Shell.Application")
Set myPath = shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
Set shell = Nothing
' フォルダを選択したら...
If Not myPath Is Nothing Then
fileName = Dir(myPath.Items.Item.Path + "\")
Do While fileName <> ""
' ファイル拡張子の判別
isImage = True
pos = InStrRev(fileName, ".")
If pos > 0 Then
Select Case LCase(Mid(fileName, pos + 1))
Case "jpeg"
Case "jpg"
Case "gif"
Case Else
isImage = False
End Select
Else
isImage = False
End If
' 拡張子が画像であれば
If isImage = True Then
' 貼り付け先を選択
Cells(targetRow, targetCol).Select
Set targetCell = ActiveCell
' 画像読込み
ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select
' 画像が大きい場合、画像サイズをセル幅に合わせる
If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then
If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then
Selection.Height = Selection.Height * (targetCell.Width / Selection.Width)
Selection.Width = targetCell.Width
Else
Selection.Width = Selection.Width * (targetCell.Height / Selection.Height)
Selection.Height = targetCell.Height
End If
End If
' 貼り付け先行を+1
targetRow = targetRow + 1
End If
fileName = Dir()
Loop
MsgBox "画像の読込みが終了しました"
End If
End Sub
|
|
ぴょんぴょん
- 12/2/7(火) 9:24 -
