History source of Excelマクロ集(No. 1)

History
View the diff.
View the diff current.
Go to Excelマクロ集.
- 1 (2009-11-14 (Sat) 16:44:42)
- 2 (2009-11-14 (Sat) 16:44:42)
- 3 (2009-11-21 (Sat) 00:16:10)

***選択範囲のセルの値が画像ファイルへのパスの場合、その画像をセルに配置するマクロ [#kefcf6ff]
複数のセルを選択して同時に処理することもできる。DBに画像ファイルのパスのみ格納しててそれをExcelに出力したときに画像を配置できるので超便利。画像は自動でセルの中央に配置される。画像ファイルが見つからない場合、もしくはセルの値が画像でない場合は処理をスキップする。
 Sub InsertPicture()
    On Error Resume Next
    
    For Each cell In Selection.Cells
        cell.Select
        ActiveSheet.Pictures.Insert(cell.Value).Select
        If Err.Number <> 0 Then
            GoTo EndOfForeach
        End If
        
        Selection.ShapeRange.LockAspectRatio = msoTrue
        'Selection.Placement = xlMoveAndSize
                
        Dim pictWidth As Double
        Dim pictHeight As Double
        Dim cellWidth As Double
        Dim cellHeight As Double
        
        pictWidth = Selection.Width
        pictHeight = Selection.Height
        cellWidth = cell.Width
        cellHeight = cell.Height
        
        If pictWidth / pictHeight > cellWidth / cellHeight Then
            Selection.Height = (pictHeight * cellWidth) / pictWidth
            Selection.Width = cellWidth
            Selection.Top = cell.Top + (cell.Height - Selection.Height) / 2
        Else
            Selection.Width = (pictWidth * cellHeight) / pictHeight
            Selection.Height = cellHeight
            Selection.Left = cell.Left + (cell.Width - Selection.Width) / 2
        End If
        
        cell.Value = ""
 EndOfForeach:
    Next
 End Sub

----
[[CategoryMicrosoftOffice]]

History source of Excelマクロ集 (No. 1)