|
有難う御座います。
上手く張り付け出来ました。
写真が存在しない時エラーで
With ActiveSheet.Pictures.Insert(myPath & Dir_Type)
のところで止まってしまうのでメッセージ(Yes/No)か無視して次に進めたいのですが、どうすればよろしいでしょうか?
Option Explicit
Private myPath As String
Private Pic_Size As Single
Private Ran As Range
Private Sub CommandButton1_Click()
Dim myFile As String
Dim Dir_Type As String
Dim h As Integer
Dim i As Integer
Dim j As Integer
Dim Retsu As String
Dim Srl As String
Pic_Size = 0.22 '画像の大きさを指定
myPath = "C:\" '画像ファイルのあるPath & "\"を指定
For i = 0 To 15 '行繰返し
For h = 0 To 1 '列繰返し
Retsu = ""
If h = 0 Then
Retsu = "B"
Srl = "B"
ElseIf h = 1 Then
Retsu = "G"
Srl = "B"
ElseIf h = 2 Then
Retsu = "L"
Srl = "B"
End If
With ActiveSheet
If h = 0 Then
Dir_Type = .Range(Srl & Trim(Str(5 + i * 19))).Value & "" & ".JPG" '
ElseIf h = 1 Then
Dir_Type = .Range(Srl & Trim(Str(5 + i * 19))).Value & "@" & ".JPG" '
ElseIf h = 2 Then
Dir_Type = .Range(Srl & Trim(Str(5 + i * 19))).Value & "@@" & ".JPG" '
End If
Set Ran = .Range(Retsu & Trim(Str(6 + i * 19))) '
End With
myFile = Dir(myPath & Dir_Type)
Do Until myFile = ""
ListBox1.AddItem myFile
myFile = Dir()
Loop
ListBox1.MultiSelect = fmMultiSelectMulti
j = 1
Ran.Areas(j).Activate
With ActiveSheet.Pictures.Insert(myPath & Dir_Type)
.ShapeRange.ScaleWidth Pic_Size, msoFalse,
msoScaleFromTopLeft
.ShapeRange.ScaleHeight Pic_Size, msoFalse, msoScaleFromTopLeft
End With
Next h
Next i
End Sub
|
|