1. 程式人生 > >Excel VBA 新增標註參考圖.vba

Excel VBA 新增標註參考圖.vba

Sub 新增標註參考圖()
'
On Error Resume Next
    'Set rngTemp = Application.InputBox("圖片插入區域:", "選擇單元格",

    Dim j_h, j_w, ww
    ww = 400
    For Each k In Selection
        Set p = Nothing
        '用相對路徑,有時出錯。
        filepath = ThisWorkbook.Path & "\images\" & k.Value & ".png"
        Filename = Dir(filepath)
        '載入圖片,用於獲取長寬。
        Set p = ActiveSheet.Pictures.Insert(filepath)
        If p Is Nothing Then
            k.Interior.Color = RGB(192, 0, 0) '紅色
            GoTo gotoEnd
        End If
        '這貨他媽的不是畫素是 點
        j_h = p.ShapeRange.Height
        j_w = p.ShapeRange.Width
        '如果圖片大於 400 等比縮放到 600 高度
        If j_h > ww Then
            j_h = ww
            j_w = ww / j_h * j_w
        End If
        
        'MsgBox filepath
        With k
           ' If k <> "" And Filename <> "" Then
           If Not k Is Nothing And Not Filename Is Nothing Then
                 .ClearComments
                 .AddComment
                 .Comment.Shape.Fill.UserPicture filepath
                 .Comment.Shape.Height = j_h
                 .Comment.Shape.Width = j_w
                  'Filename = ""
                 '.Interior.Color = RGB(155, 187, 89)
            End If
        End With
        '刪除圖片
        ActiveSheet.Pictures.Delete
gotoEnd:
    Next

End Sub