1. 程式人生 > >Excel VBA-批量插圖.vba

Excel VBA-批量插圖.vba

'大家好,我是笨笨,笨笨的笨,笨笨的笨,謝謝!
'excel 2010
'選中單元格,按其內容,插入圖片
'2014-08-08

Sub inputImg()
     On Error Resume Next
     Dim Cell As Range
     Dim Pics As String
     Dim ErrCell As String
     Dim PictruePath As String '圖片路徑
     Dim PictrueFormat As String '圖片格式
     
     'PictruePath = "E:\BuildingCity\Working\"
     '用相對路徑,xls所在目錄下的 images 資料夾
     PictruePath = ThisWorkbook.Path & "\images\"
     PictrueFormat = "png"
     
     Selection.ClearComments
     
    For Each Cell In Selection
        Pics = PictruePath & Cell.Value & "." & PictrueFormat
        
        If Dir(Pics) = "" Then
           ErrCell = ErrCell & "" & Cell.Address(0, 0)
        Else
            'Cell.Select
            '引用
            'ActiveSheet.Pictures.Insert(Pics).Select
            'Selection.ShapeRange.Height = 150
            '插入
           ' ActiveSheet.Shapes.AddPicture(Pics, False, True, Range("B" & n).Left, Range("B" & n).Top, 96 * i, 96).Select
            'ActiveCell
            With Cell
            ActiveSheet.Shapes.AddPicture Filename:=Pics, _
                    LinkToFile:=True, SaveWithDocument:=True, _
                    Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height
            End With
            '如果插入圖片成功,把字改成白色。
            Cell.Font.ColorIndex = 2 '白色的索引
        End If
    Next
    ' MsgBox "以下單元格沒有圖片哦!" & vbCrLf & ErrCell
End Sub