Excel VBA 新增標註參考圖.vba
阿新 • • 發佈:2018-12-17
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