VBA100本ノック 29本目：画像の挿入 - bimori466のエクセルブログ

この記事から得るもの

フォルダから選択した画像を、Activeセルの幅に揃えて貼り付ける。
フォルダ内のすべての画像を、セル幅に合わせて貼り付ける。

目次
　１　今回のお題
　２　今回のお題の意図
　３　回答
　４　ファイル内の画像を連続貼り付け　
　５　感想　

１　今回のお題

ファイル選択ダイアログで画像ファイルを指定し、その画像をアクティブセルにリンクしない図として貼り付けてください。
貼り付けた画像は、縦横比を維持したままセル内に収めてください。
セル内の位置はなるべく真ん中に。
※選択できる拡張子は適当に。

f:id:bimori466:20201129141735p:plain

excel-ubara.com

２　今回のお題の意図

Activeセル内に写真を中央に寄せて埋め込む。

３　回答

今回は自分らしい回答が思いつかなかったので、サイト管理者の答えにコメントを加えて貼り付けておきます。

サイト管理者の回答

Sub ノック29本目_勉強()

Dim rng As Range
Set rng = ActiveCell

Dim FileName As Variant
FileName = Application.GetOpenFilename(FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif")
If FileName = False Then
    Exit Sub
End If


'画像の貼り付け処理
With Worksheets(1).Shapes.AddPicture _
    (FileName:=FileName, LinkToFile:=False, SaveWithDocument:=True, _
    Left:=rng.Left, Top:=rng.Top, Width:=0, Height:=0)

    .LockAspectRatio = msoTrue  '縦横比固定
    .Placement = xlMoveAndSize  '移動&サイズ変更
    .ScaleHeight 1, msoTrue     '縦を元のサイズに
    .ScaleWidth 1, msoTrue      '横を元のサイズに
    
    If .Width > rng.Width - 2 Then .Width = rng.Width - 2
    If .Height > rng.Height - 2 Then .Height = rng.Height - 2

    .Top = .Top + ((rng.Height - .Height) / 2)
    .Left = .Left + ((rng.Width - .Width) / 2)  'セルの中央に持ってくる処理

End With

End Sub

このお題の回答の肝は、「Shapes.AddPicture」です。この処理で画像を貼り付けます。
７つの引数は省略不可です（FileName、LinkToFile、SaveWithDocument、Left、Top、Width、Height）。

４　ファイル内の画像を連続貼り付け

今回も自分では回答できなかったので、自分で別の処理を考えました。
Twitterに投稿した「写真の連続貼り付けです」

Ａ列に、ファイル名
Ｂ列に、写真の画像を貼り付けます。

写真のサイズは、セルの大きさに合わせています。
セルのサイズを変えて再実行すれば、
写真のサイズはセルの大きさに揃えます。 pic.twitter.com/FzE7GiijgE
— かずやん (@y8bV4ty1wbkTjPd) 2020年11月28日

動画の通り、Ａ列に「ファイル名」を転記し、B列に「画像を挿入」します。

写真の連続貼り付けのコード

Sub 画像連続挿入()

Dim ws As Worksheet: Set ws = Worksheets(1)
Dim rng As Range

'FSOを宣言
Dim fso_lord As Object: Set fso_lord = CreateObject("scripting.filesystemobject")
Dim myPicturs As Object

'pathの設定（画像読込先のファイルパス）
wbPath = "C:\Mypath\"

'写真のフォルダを読込む
Set myPicturs = fso_lord.getfolder(wbPath).Files

Application.ScreenUpdating = False


Write_IX = 0

For Each myPictur In myPicturs
    '書き込み先のセルを設定
    Write_IX = Write_IX + 1
    Set rng = ws.Cells(Write_IX, 2)
    
    ws.Cells(Write_IX, 1) = myPictur.Name
    
    
    '写真を貼り付ける
    ws.Shapes.AddPicture _
        FileName:=myPictur.Path, LinkToFile:=False, SaveWithDocument:=True, _
        Left:=rng.Left + 2, Top:=rng.Top + 2, Width:=rng.Width - 4, Height:=rng.Height - 4
    
Next

End Sub

解説

FSO（FileSystemObject）を使います。変数「wbPath」に画像読込先のファイルパスを設定します。FSOとして宣言したfso_lordのフォルダを取得する「getfolder」で、オブジェクト変数「myPicturs」にフォルダのファイルをSetします。
For each in NextでmyPictursをループします。まず、変数rngに画像貼り付け先のセルをSetします。
FSOでファイルの名前を取得（myPictur.Name）し、Ａ列に転記します。
次に、画像の貼り付けです。前の説明で、Shapes.AddPictureは７つの引数を（FileName、LinkToFile、SaveWithDocument、Left、Top、Width、Height）省略できないと記述しました。
引数のFileNameは、FSOのPathを取得する（myPictur.Path）。
Left、Top、Width、Heightは、オブジェクト変数の「rng」で取得します。これらを±してバランスを整えます。

このように、FSOとRangeから取得できるプロパティを利用して簡単に貼り付け先のPathと、貼り付け先の画像の位置とサイズを調整できます。
これで、画像の数だけセルに画像を貼り付けることができました。

５　感想

１００本ノックのお題は、１つの画像を選択してActiveセルに画像を貼り付けます。しかし、大量の画像をセルに貼り付けたいという処理をしたい場合があると思い、「画像連続挿入処理」を考えました。どこかでお役に立てれば幸いです。

ではでは、この辺で(^^)/~~~

この記事から得るもの

１ 今回のお題

２ 今回のお題の意図

３ 回答