箸休め_5

2024年1月6日 20:35

2024初投稿です。本年もどうぞよろしくお願いします。
今回は、「画像取り込み」により、アルバムもどきを作ろうと思っています。その中で「プルダウンリストの設定」や「フォルダ内表示」等の便利な機能も紹介します。

それでは、今回も準備から始めます。
Desktop等にFolder「画像処理」を作成し、その中にFolder「画像」を作ってください。
次に、Excelの空白Bookを開いて二つのシートを作ってください。
まずは、2枚目のシートを下図のように作り、シート名「アルバム」としてください。

上下2段を両面印刷することで、見開きのアルバムになるよう想定しています。
1枚目のシートはシート名「操作卓」として実行ボタン等を作成してください。

操作メニューを見て、今回の処理概要がイメージできましたか？
ここまでを一旦保存して終了しましょう。
Book名を「アルバム作成」保存先を「画像処理」として「マクロを含む(.xlsm)」を忘れないように。

準備が完了したところでBreak Timeにしましょう。

それでは「アルバム作成.xlsm」を開いて再開しましょう。
今回の目的は、セルに画像を貼り付けることなので、その画像をFolder「画像」に収納するところから始めます。
通常の手作業によるとDesktopの「画像処理」を開いて、その中の「画像」を開いて画像ファイルをコピーして…となりますが、この内のFolder「画像」を開くところをVBAで作ります。

Sub FLD()

    DR = ActiveWorkbook.Path & "¥画像"
    Shell "C:¥Windows¥Explorer.exe " & DR, vbNormalFocus  'Folder内表示

End Sub

とするとFolder「画像」を開くことができます。画像Folder Openの右側の実行ボタンに関連付けておきましょう。
実行ボタンをクリックして、開いた「画像」に10枚ほどの画像ファイルをコピーしてください。

それでは、画像ファイル名をセルに取り込んでみましょう。
「VBAでBingo5_7」を参考にすると

Sub FIS()

    LR = Cells(Rows.Count, "H").End(xlUp).Row
    If LR < 4 Then LR = 4
    Range("H4:H" & LR) = ""
    
    DR = ThisWorkbook.Path & "¥画像"
    Fn = Dir(DR & "¥*.jpg")

    Do Until Fn = ""
    
       P = P + 1
       Cells(P + 3, "H") = Fn
       Fn = Dir()
    
    Loop

End Sub

ができます。
今回は、今後も繰り返し使うことを想定して、書き出す前に既存データを消去するようにしています。
画像File名検索に関連付けてください。
実行ボタンをクリックすると、画像ファイル名が表示されます。

次は、このファイル名をプルダウンリストの選択肢として利用できるようにしましょう。

LR = Cells(Rows.Count, "H").End(xlUp).Row
With Sheets("アルバム").Cells(3, ”F").Validation
    .Delete   '既存のPullDown_LISTをDEL
　  .Add Type:=xlValidateList, Formula1:="=操作卓!$H4:$H$" & LR '新規のPullDown_LISTをPUT
End With

とすることで、3行目F列にプルダウンリストを設定することができます。
最終的には、すべての画像貼り付けセルに設定したいので、もう少し考えてみましょう。

具体的には、シート「アルバム」の3行目F列・17行目F列・31行目F列・45行目B列・59行目B列・73行目B列に設定することになります。
毎度のことですが、ここでもFor to ～ Next を使います。行は、3、17．31…と14ずつ増えているのでFor ｎ=3 to 73 Step 14 とします。今回はこのStepがポイントです。Stepがないときは、Nextでのｎの増分は1ですが、Stepをつけることで増分を任意に設定することが可能です。しかも小数や負数でも自由に設定できます。
そして、列はｎが45より小さいときはF列、それ以外はB列とします。完成形は

Sub PDL()

    LR = Cells(Rows.Count, "H").End(xlUp).Row
    For n = 3 To 73 Step 14

      If n < 45 Then C = "F" Else C = "B"

      With Sheets("アルバム").Cells(n, C).Validation
          .Delete    '既存のPullDown_LISTをDEL
          .Add Type:=xlValidateList, Formula1:="=操作卓!$H4:$H$" & LR '新規のPullDown_LISTをPUT
      End With

    Next n

End Sub

PullDown_List設定に関連付けて実行後、シート「アルバム」の画像貼り付けセルに画像ファイル名を選択してください。

さて、いよいよ今回メインの画像貼り付けです。
基本形は

    DR = ThisWorkbook.Path & "¥画像¥"
    With Sheets("アルバム").Pictures.Insert(DR & Sheets("アルバム").Cells(3, "F"))  '貼付画像File
        .Width = Sheets("アルバム").Cell(3,"F").Width
        .Top = Sheets("アルバム").Cell(3,"F").Top + Sheets("アルバム").Cell(3,"F").Height / 6
        .Left = Sheets("アルバム").Cell(3,"F").Left
     End With

として、Excelさんに画像ファイル名と貼り付ける位置を伝えると、処理完了です。
概要を説明すると、「ThisWorkbook.Path & "¥画像"」にあるファイル名（Cell(3,"F")の値）をセル3行目F列に貼り付けて、大きさをそのセルの幅に合わせてください。となりますが、今回貼り付ける位置は複数のセルが結合してできているので、その範囲をRangeで指定することになり実際は、Range("F3:I14")となります。
そしてもう一点、横長画像と縦長画像が混在する場合、画像サイズがネックとなります。ここでは幅を基準に調整しているので縦長の場合は上下が枠からはみ出してしまいます。
そこで、画像のタイプを判定して縦長の場合は、セルの高さを基準に大きさを調整するようにします。そのために

    Set PPP = LoadPicture(DR & Sheets("アルバム").Cell(3,"F")
    縦 = CDbl(PPP.Height): 横 = CDbl(PPP.Width) '画像サイズGET
    If 縦 > 横 Then VH = "V" Else VH = ""

を貼り付け処理の前に追加します。
Set PPPで任意の変数PPPに画像ファイルのプロパティがセットされます。その中から高さのデータと幅のデータを取り出して、縦長・横長の判定をします。
最後に、複数のセルに貼り付けるための工夫をします。
貼り付ける位置をRange(RC)として、RCの値を繰り返しの中で編集します。
完成サンプルは

Sub PTG(DR, n)

    If n < 45 Then C = "F": W = "I" Else C = "B": W = "E"

    Set PPP = LoadPicture(DR & Sheets("アルバム").Cells(n, C))
    縦 = CDbl(PPP.Height): 横 = CDbl(PPP.Width) '画像サイズGET
    If 縦 > 横 Then VH = "V" Else VH = ""

    RC = C & n & ":" & W & n + 11
    With Sheets("アルバム").Pictures.Insert(DR & Sheets("アルバム").Cells(n, C))  '画像貼付

      If VH = "V" Then '縦長
        .Height = Sheets("アルバム").Range(RC).Height
        .Top = Sheets("アルバム").Range(RC).Top
        .Left = Sheets("アルバム").Range(RC).Left + Sheets("アルバム").Range(RC).Width / 6
      Else             '横長
        .Width = Sheets("アルバム").Range(RC).Width
        .Top = Sheets("アルバム").Range(RC).Top + Sheets("アルバム").Range(RC).Height / 6
        .Left = Sheets("アルバム").Range(RC).Left
      End If
             
     End With

End Sub

となります。
実際に繰り返す部分は別に作り、Folder「画像」のPath DR と繰り返しの指数ｎを受け渡すようにします。

Sub PPT()

    DR = ThisWorkbook.Path & "¥画像¥"
    For n = 3 To 73 Step 14

      PTG DR, n

    Next n

End Sub

画像取込みにはこちらを関連付けてください。

2ページを両面印刷して、何枚か重ねるとアルバムもどきができると思います。

ついでに、貼り付けた画像を消去するには

Sub PTD()

    For Each Pc In Sheets("アルバム").Pictures: Pc.Delete: Next Pc  '画像削除

End Sub

とします。シート「アルバム」に在るすべての画像が一括して消去されるので、MessageBoxで意思確認を入れた方が良いかもしれませんね。

なお、MessageBoxの詳細は、VBAでBingo5_5でご覧いただけます。
今回は両面1枚分を作りましたが、同様にVBAでBingo5_5を参考に複数シートを作り、それをPDFで出力する方法等も考えてみてください。

今回も最後までご覧いただき、ありがとうございました。

この記事が気に入ったらサポートをしてみませんか？