HOME > Q&A > Excel （VBA）

Excel （VBA）
Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2016)
『画像貼付⇒サイズ変更』をループさせたい
投稿日時: 21/02/22 23:27:36
投稿者: kazu_cyo

色々調べながら作成しましたが、画像サイズ変更がループ出来ず困ってます。
コードを添付するので、修正点を教えて頂きたいです。
 
＜やりたい事＞
　・フォルダー内の写真を1ページに3枚ずつ貼付け。
　・画像サイズを縦横比固定の高さ215に変更。
 
＜修正したい事＞
　画像４枚目から、サイズ変更が出来ない。
 
すいません、回答をお願いします。
 
Sub 画像挿入()
    Dim i As Integer '「i」は「行」に相当
    Dim j As Integer
    Dim myDir As String
    Dim myFName As String
    Dim shp As Shape
    myDir = Application.GetOpenFilename(filefilter:="すべての図(*.JPG),*.JPG")
    If myDir = "false" Then Exit Sub
    myDir = Left(myDir, Len(myDir) - Len(Dir(myDir)))
    Application.ScreenUpdating = False
    ActiveSheet.DrawingObjects.Delete
    i = 8 '画像挿入開始行の指定
    j = 1
    myFName = Dir(myDir & "*.JPG")
    Do While myFName <> ""
        With Cells(i, 2) '画像挿入列の指定　Cells(行,列)
            .Activate
        End With
        With ActiveSheet
             .Shapes.AddPicture myDir & myFName, msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1
        Set shp = ActiveSheet.Shapes(1)
         With shp
          .LockAspectRatio = msoTrue
          .Height = 215
        End With
        End With
        Cells(i, 3).Value = myFName '画像名称挿入列の指定
        myFName = Dir
        i = i + 17 '２枚目の画像挿入位置指定
        j = j + 1
        With Cells(i, 2) '↓２枚目の画像挿入
            .Activate
        End With
                With ActiveSheet
             .Shapes.AddPicture myDir & myFName, msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1
        Set shp = ActiveSheet.Shapes(2)
         With shp
          .LockAspectRatio = msoTrue
          .Height = 215
        End With
        End With
        Cells(i, 3).Value = myFName
        myFName = Dir
        i = i + 17
        j = j + 1
        With Cells(i, 2) '↓３枚目の画像挿入
            .Activate
        End With
                With ActiveSheet
             .Shapes.AddPicture myDir & myFName, msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1
        Set shp = ActiveSheet.Shapes(3)
         With shp
          .LockAspectRatio = msoTrue
          .Height = 215
        End With
        End With
        Cells(i, 3).Value = myFName
        myFName = Dir
        i = i + 25 '次のページへ
        j = j + 1
    Loop 'Do While 〜 に戻り繰り返し
    Application.ScreenUpdating = True
End Sub
回答
投稿日時: 21/02/23 06:10:31
投稿者: simple

画像の挿入位置は、
・通常は17行毎とするが、
・3枚終了したタイミングで、25行と広めにとる
と読み解きました。（合っていますか？）
以下は、その前提でのコードです。
私だったらこんな風に書きます。
 

Sub 画像挿入()
    Dim counter As Long       '画像のカウンター
    Dim i       As Long       '画像書込先の行番号
    Dim myDir   As String
    Dim myFName As String

    ActiveSheet.DrawingObjects.Delete

    'フォルダの指定
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            myDir = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    myDir = myDir & "\"

    Application.ScreenUpdating = False
    counter = 1
    i = 8    '画像挿入開始行の初期指定
    myFName = Dir(myDir & "*.JPG")

    Do While myFName <> ""
        Call myAddPicture(myDir, myFName, i, 2)

        myFName = Dir
        i = i + IIf(counter Mod 3 = 0, 25, 17)
        counter = counter + 1
    Loop
    Application.ScreenUpdating = True
End Sub

' myDir配下のmyFNameファイルを  Cells(r,c)に読み込む
Function myAddPicture(myDir As String, myFName As String, r As Long, c As Long)
    Dim rng As Range
    Dim myPath As String

    Set rng = Cells(r, c)
    myPath = myDir & myFName
    With ActiveSheet.Shapes.AddPicture(myPath, msoFalse, msoTrue, rng.Left, rng.Top, -1, -1)
        .LockAspectRatio = msoTrue
        .Height = 215
    End With
    rng.Offset(, 1).Value = myFName
End Function
回答
投稿日時: 21/02/23 15:41:37
投稿者: simple

若干の補足をしておきます。
 
既におわかりのように、問題は、↓ここです。
4枚目の画像を読んだときに、 

With ActiveSheet
     .Shapes.AddPicture myDir & myFName, msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1
     Set shp = ActiveSheet.Shapes(1)
と、一枚目のshpを使ってしまうからです。
 
AddPictureメソッドのヘルプを読むと、
戻り値はShapeオブジェクトであることがわかります。 
Set shp = .Shapes.AddPicture(myDir & myFName, msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1)
とすれば、それが何枚目かなどという指定は不要です。
(戻り値を使う場合は、引数をカッコに入れないといけないことに注意（仕様です））
 
ここさえクリアーできれば、正しく動くものになるでしょう。
あとは、同じことの繰り返しは避けることを念頭において修正すればよいでしょう。
提示したコードを参考にしてください。
 
(補足1)
なお、順序としては、こう書くのが自然でした。 
    i = 8    '画像挿入開始行の初期指定
    counter = 1
    myFName = Dir(myDir & "*.JPG")

    Do While myFName <> ""
        Call myAddPicture(myDir, myFName, i, 2)
        i = i + IIf(counter Mod 3 = 0, 25, 17)
        counter = counter + 1
        myFName = Dir
    Loop
(補足2)
また、C列のファイル名も事前に消去しておいたほうがいいでしょうか。 
    ActiveSheet.DrawingObjects.Delete
    Columns("C").ClearContents

投稿日時: 21/02/23 20:49:44
投稿者: kazu_cyo

simpleさん
早速の回答、ありがとうございます。
 
説明不足にも関わらず、色々解釈して頂き助かりました。
 
頂いたコードは明日、会社で試してみます。
 
また分からないことあったら、質問させてください。
 
本当にありがとうございました。