Excel VBA質問箱 IV

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

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


37055 / 76738 ←次へ | 前へ→

【44857】Re:写真貼り付け
回答  ハチ  - 06/12/4(月) 10:44 -

引用なし
パスワード
   ▼やっぱり猫が好き さん:

かなり丸投げな感じの投稿ですが・・
興味が湧いたので作ってみました。

サムネイル表示したいということだと思いますが、
提示したコードで??なら専用のデジカメソフトでも買ったほうが良いと思います。

JPGファイルは同じフォルダ内(サブフォルダなし)にあり
コードのあるxlsファイルが同一フォルダにある。
UserForm1にListBox1,CommandButton1を作成。
位置とサイズは、_Initializeの
Pic_Size,Ran をウマいこと調整してみてください。

'UserForm1モジュール
Option Explicit
Private myPath As String
Private Pic_Size As Single
Private Ran As Range

Private Sub UserForm_Initialize()
  Dim myFile As String
  Dim Dir_Type As String
  
  Pic_Size = 0.23 '画像の大きさを指定
  myPath = ThisWorkbook.Path & "\"  '画像ファイルのあるPath & "\"を指定
  Dir_Type = "*.JPG"
  With ActiveSheet
    Set Ran = .Range("A5,E5,A15,E15,A25,E25")  '貼り付ける場所を指定
  End With
  
  myFile = Dir(myPath & Dir_Type)
  Do Until myFile = ""
    ListBox1.AddItem myFile
    myFile = Dir()
  Loop
  ListBox1.MultiSelect = fmMultiSelectMulti
End Sub

Private Sub CommandButton1_Click()
  Dim i As Integer
  Dim j As Integer
  j = 1
  For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
      If j > Ran.Areas.Count Then
        MsgBox "選択枚数が" & Ran.Areas.Count & "を越えています"
        Exit Sub
      End If
      Ran.Areas(j).Activate
      With ActiveSheet.Pictures.Insert(myPath & ListBox1.List(i))
        .ShapeRange.ScaleWidth Pic_Size, msoFalse, msoScaleFromTopLeft
        .ShapeRange.ScaleHeight Pic_Size, msoFalse, msoScaleFromTopLeft
      End With
      j = j + 1
    End If
  Next i
End Sub
1 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 お礼

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