Excel VBA質問箱 IV

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

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


36834 / 76732 ←次へ | 前へ→

【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

0 hits

【44855】写真貼り付け やっぱり猫が好き 06/12/4(月) 9:02 質問
【44857】Re:写真貼り付け ハチ 06/12/4(月) 10:44 回答
【44860】Re:写真貼り付け やっぱり猫が好き 06/12/4(月) 12:33 お礼
【45073】Re:写真貼り付け やっぱり猫が好き 06/12/12(火) 9:51 お礼
【44861】Re:写真貼り付け Kein 06/12/4(月) 13:28 回答
【45074】Re:写真貼り付け やっぱり猫が好き 06/12/12(火) 9:56 お礼

36834 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free