Excel VBA 宏:创建评论框并以全尺寸插入图片
Excel VBA Macro: Create comment box and insert picture in full size
为了在 Excel 中装饰尺寸 table,我需要添加许多分配给行的图片。在不调整行大小的情况下,唯一的选择是将每张图片添加到鼠标悬停时显示的评论框中。另一个重要的要求是以全尺寸显示图片。默认评论框尺寸太小。
可以手动添加带有图片背景的评论框,但每张图片需要多次点击,这非常耗时。
宏是什么样子的,可以让您在单元格上右键单击选项以显示 FileChooser window 并将所选图片以全尺寸插入新创建的评论框中?
我终于制作了这个宏,从不同教程的部分内容复制而来。希望这也能帮助其他人。
有了这个,您可以 right-click 一个单元格,选择一张图片,它将作为完整比例的评论插入。
将此添加到工作表以将宏添加到 right-click 菜单:
Private Sub Workbook_Deactivate()
On Error Resume Next
With Application
.CommandBars("Cell").Controls("CommentPic").Delete
End With
On Error GoTo 0
End Sub
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim cmdBtn As CommandBarButton
On Error Resume Next
With Application
.CommandBars("Cell").Controls("CommentPic").Delete
Set cmdBtn = .CommandBars("Cell").Controls.Add(Temporary:=True)
End With
With cmdBtn
.Caption = "CommentPic"
.Style = msoButtonCaption
.OnAction = "CommentPic"
End With
On Error GoTo 0
End Sub
从路径向单元格添加缩放图片的子方法
Sub CommentPic()
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False 'Only one file
.InitialFileName = CurDir 'directory to open the window
.Filters.Clear 'Cancel the filter
.Filters.Add Description:="Images", Extensions:="*.*", Position:=1
.Title = "Choose image"
If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
End With
Dim myfile As String
myfile = TheFile
With Selection
'--- delete any existing comment just for testing
If Not Selection.Comment Is Nothing Then
Selection.Comment.Delete
End If
InsertCommentWithImage Selection, myfile, 1#
Selection.Value = "IMG"
End With
End Sub
Sub InsertCommentWithImage(imgCell As Range, _
imgPath As String, _
imgScale As Double)
'--- first check if the image file exists in the
' specified path
If Dir(imgPath) <> vbNullString Then
If imgCell.Comment Is Nothing Then
imgCell.AddComment
End If
'--- establish a Windows Image Acquisition Automation object
' to get the image's dimensions
Dim imageObj As Object
Set imageObj = CreateObject("WIA.ImageFile")
imageObj.LoadFile (imgPath)
Dim width As Long
Dim height As Long
width = imageObj.width
height = imageObj.height
'--- simple scaling that keeps the image's
' original aspect ratio
With imgCell.Comment
.Shape.Fill.UserPicture imgPath
.Shape.height = height * imgScale
.Shape.width = width * imgScale
End With
End If
End Sub
为了在 Excel 中装饰尺寸 table,我需要添加许多分配给行的图片。在不调整行大小的情况下,唯一的选择是将每张图片添加到鼠标悬停时显示的评论框中。另一个重要的要求是以全尺寸显示图片。默认评论框尺寸太小。 可以手动添加带有图片背景的评论框,但每张图片需要多次点击,这非常耗时。 宏是什么样子的,可以让您在单元格上右键单击选项以显示 FileChooser window 并将所选图片以全尺寸插入新创建的评论框中?
我终于制作了这个宏,从不同教程的部分内容复制而来。希望这也能帮助其他人。 有了这个,您可以 right-click 一个单元格,选择一张图片,它将作为完整比例的评论插入。
将此添加到工作表以将宏添加到 right-click 菜单:
Private Sub Workbook_Deactivate()
On Error Resume Next
With Application
.CommandBars("Cell").Controls("CommentPic").Delete
End With
On Error GoTo 0
End Sub
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim cmdBtn As CommandBarButton
On Error Resume Next
With Application
.CommandBars("Cell").Controls("CommentPic").Delete
Set cmdBtn = .CommandBars("Cell").Controls.Add(Temporary:=True)
End With
With cmdBtn
.Caption = "CommentPic"
.Style = msoButtonCaption
.OnAction = "CommentPic"
End With
On Error GoTo 0
End Sub
从路径向单元格添加缩放图片的子方法
Sub CommentPic()
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False 'Only one file
.InitialFileName = CurDir 'directory to open the window
.Filters.Clear 'Cancel the filter
.Filters.Add Description:="Images", Extensions:="*.*", Position:=1
.Title = "Choose image"
If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
End With
Dim myfile As String
myfile = TheFile
With Selection
'--- delete any existing comment just for testing
If Not Selection.Comment Is Nothing Then
Selection.Comment.Delete
End If
InsertCommentWithImage Selection, myfile, 1#
Selection.Value = "IMG"
End With
End Sub
Sub InsertCommentWithImage(imgCell As Range, _
imgPath As String, _
imgScale As Double)
'--- first check if the image file exists in the
' specified path
If Dir(imgPath) <> vbNullString Then
If imgCell.Comment Is Nothing Then
imgCell.AddComment
End If
'--- establish a Windows Image Acquisition Automation object
' to get the image's dimensions
Dim imageObj As Object
Set imageObj = CreateObject("WIA.ImageFile")
imageObj.LoadFile (imgPath)
Dim width As Long
Dim height As Long
width = imageObj.width
height = imageObj.height
'--- simple scaling that keeps the image's
' original aspect ratio
With imgCell.Comment
.Shape.Fill.UserPicture imgPath
.Shape.height = height * imgScale
.Shape.width = width * imgScale
End With
End If
End Sub