Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

36840 / 76738

←次へ　｜　前へ→


	【45073】Re:写真貼り付け

やっぱり猫が好き - 06/12/12(火) 9:51 -


	引用なし

	パスワード

有難う御座います。
上手く張り付け出来ました。

写真が存在しない時エラーで

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

1 hits

▼

【44855】写真貼り付け やっぱり猫が好き 06/12/4(月) 9:02