Excel VBA質問箱 IV

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

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


6471 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

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

引用なし
パスワード
   素人でスミマセン。

エクセルに決まったフォルダからJPGの写真を呼出して貼り付けて行きたいのですが、どうすれば良いでしょうか?
大きさも自動的に調整したいです。

A4サイズのシートに6枚程度(2列x3段)貼り付けたいのですが。

決まったセルにカーソルを合わせて、JPGのファイル名を打ち込むようなイメージでしょうか。

よろしくお願いします。

【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

【44860】Re:写真貼り付け
お礼  やっぱり猫が好き  - 06/12/4(月) 12:33 -

引用なし
パスワード
   有難う御座います!
早速トライしてみます。

【44861】Re:写真貼り付け
回答  Kein  - 06/12/4(月) 13:28 -

引用なし
パスワード
   右クリックイベントを使う方法です。
以下のコードをシートモジュールに入れ、任意の2つ以上のセル範囲を
選択し、右クリックして下さい。すでに画像を挿入している範囲に重なると、
メッセージで警告して処理を中止します。画像が挿入されてない範囲であれば、
画像ファイルを保存しているフォルダーから、ファイルを選択して開くための
ダイアログが出ますから、選択してOKして下さい。初めに選択したセル範囲に
ぴったり収まる位置・大きさで挿入することが出来ます。


Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
Cancel As Boolean)
  Dim Lp As Single, Tp As Single
  Dim Hp As Single, Wp As Single
  Dim i As Long
  Dim MyF As String
  Const PicFol As String = _
  "C:\Documents and Settings\User\My Documents\My Pictures"
  '↑実際に画像ファイルを保存しているフォルダーのパスに変更しておく。
 
  Cancel = True
  With Target
   If .Count = 1 Then Exit Sub
   Lp = .Left: Tp = .Top
   Wp = .Width: Hp = .Height
  End With
  With ActiveSheet.Pictures
   If .Count > 0 Then
     For i = 1 To .Count
      If Not Intersect(Target, _
      Range(.Item(i).TopLeftCell, .Item(i).BottomRightCell)) _
       Is Nothing Then
        MsgBox "そのセル範囲には画像を挿入できません", 48: Exit Sub
      End If
     Next
   End If
   ChDir PicFol
   MyF = Application.GetOpenFilename("画像ファイル(*.jpg),*.jpg")
   If MyF = "False" Then GoTo ELine
   Application.ScreenUpdating = False
   With .Insert(MyF)
     .Left = Lp: .Top = Tp
     .Width = Wp: .Height = Hp
   End With
  End With
ELine:
  With Application
   ChDir .DefaultFilePath
   .ScreenUpdating = True
  End With
End Sub

【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

【45074】Re:写真貼り付け
お礼  やっぱり猫が好き  - 06/12/12(火) 9:56 -

引用なし
パスワード
   返信有難う御座います。

見た感じ、あまり見慣れないマクロのように感じたので...
自分には未だ難しいかなの思いつつ...
じっくり読み込んで悩んでみます。

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