写真の取込方法について（Pictures.Insert,Shapes.AddPicture）

最終更新日：2013-05-28

写真の取込方法について（Pictures.Insert,Shapes.AddPicture）

写真を取り込んで、アルバムのようにしたり、

各種の資料を作ったりと、写真をエクセルに取り込む機会は多いようです。

しかし、最近は写真のサイズも大きくなり、

手動で取り込んだままではスクロールもままならない状態となってしまいます。

そこで、写真ファイルを指定し、A列に上から順番に貼り付け、

さらにセル内に収まるように縮小するマクロになります。

まずは、マクロの記録でも使われている
Pictures.Insert
を使って


  
    
      Sub sample1()

　　Dim i As Long

　　Dim j As Long

　　Dim FileName As Variant

　　Dim dblScal As Double

　　Dim sp As Shape

　　FileName = Application.GetOpenFilename( _

　　　　FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _

　　　　MultiSelect:=True)

　　If Not IsArray(FileName) Then

　　　　Exit Sub

　　End If

　　For Each sp In ActiveSheet.Shapes

　　　　If sp.TopLeftCell.Column = 1 Then

　　　　　　sp.Delete

　　　　End If

　　Next

　　j = 1

　　For i = LBound(FileName) To UBound(FileName)

　　　　Cells(j, 1).Select

      　　　　With ActiveSheet.Pictures.Insert(FileName(i))

      　　　　　　'サイズ調整、セル内に収める

　　　　　　If Cells(j, 1).Width / .Width < Cells(j, 1).Height / .Height Then

　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Width / .Width, 2)

　　　　　　Else

　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Height / .Height, 2)

　　　　　　End If

　　　　　　.Width = .Width * dblScal '縦横比を維持して縮小される

　　　　End With

　　　　j = j + 1

　　Next i

End Sub

これで、とりあえず、ちゃんと貼りつきました。

しかし、元ファイルが、取り込んだ時のフォルダーに存在しないと表示できません。

これは不都合です。

エクセルファイルを配布できません。

以下では、写真をリンクではなくエクセルに貼り付けています。

Shapes.AddPicture
を使ってリンクせずに取込


  
    
      Sub sample2()

　　Dim i As Long

　　Dim j As Long

　　Dim FileName As Variant

　　Dim dblScal As Double

　　Dim sp As Shape

　　FileName = Application.GetOpenFilename( _

　　　　FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _

　　　　MultiSelect:=True)

　　If Not IsArray(FileName) Then

　　　　Exit Sub

　　End If

　　For Each sp In ActiveSheet.Shapes

　　　　If sp.TopLeftCell.Column = 1 Then

　　　　　　sp.Delete

　　　　End If

　　Next

　　j = 1

　　For i = LBound(FileName) To UBound(FileName)

　　　　Cells(j, 1).Select

      　　　　With ActiveSheet.Shapes.AddPicture( _

　　　　　　　　FileName:=FileName(i), _

　　　　　　　　LinkToFile:=False, _

      　　　　　　　　SaveWithDocument:=True, _

　　　　　　　　Left:=Selection.Left, _

　　　　　　　　Top:=Selection.Top, _

      　　　　　　　　Width:=0, _

      　　　　　　　　Height:=0)

      　　　　　　'一旦、元のサイズに戻す

　　　　　　.ScaleHeight 1, msoTrue

      　　　　　　.ScaleWidth 1, msoTrue

      　　　　　　'サイズ調整、セル内に収める

　　　　　　If Cells(j, 1).Width / .Width < Cells(j, 1).Height / .Height Then

　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Width / .Width, 2)

　　　　　　Else

　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Height / .Height, 2)

　　　　　　End If

　　　　　　.Width = .Width * dblScal

　　　　　　.Height = .Height * dblScal

　　　　End With

　　　　j = j + 1

　　Next i

End Sub