添加图像作为评论 VBA
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/21396983/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
add image as comment VBA
提问by Makdaddy
I found this code to insert images into excel 2013 but the images are large than the cells they're going into. I think the best option it to load the images as comments.
我发现这段代码可以将图像插入到 excel 2013 中，但图像比它们要插入的单元格大。我认为最好的选择是将图像加载为注释。
Can someone modify this VBA below to add this as a comment?
有人可以修改下面的这个 VBA 以将其添加为评论吗？
Sub URLPictureInsert()
Dim cell, shp As Shape, target As Range
Set rng = ActiveSheet.Range("R2:R5") ' range with URLs
For Each cell In rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set shp = Selection.ShapeRange.Item(1)
With shp
.LockAspectRatio = msoTrue
.Width = 50
.Height = 50
.Cut
End With
Cells(cell.Row, cell.Column + 5).PasteSpecial
Next
End Sub
回答by DeanBDean
I believe The following link has what you are looking for
我相信以下链接有你要找的东西
http://en.kioskea.net/faq/8619-excel-a-macro-to-automatically-insert-image-in-a-comment-box
http://en.kioskea.net/faq/8619-excel-a-macro-to-automatically-insert-image-in-a-comment-box
Sub Img_in_Commentbox()
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:="*.jpg", Position:=1
.Title = "Choose image"
If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
End With
'No file selected
If TheFile = 0 Then
MsgBox ("No image selected")
Exit Sub
End If
Range("A1").AddComment
Range("A1").Comment.Visible = True
[A1].Comment.Shape.Fill.UserPicture TheFile
End Sub
回答by hstay
If you want your images to match your destination cell height size use:
如果您希望图像与目标单元格高度大小匹配，请使用：
With shp
.LockAspectRatio = msoTrue
'.Width = Cells(cell.Row, cell.Column + 5).Width 'Uncomment this line and comment out .Height line to match cell width
.Height = Cells(cell.Row, cell.Column + 5).Height
.Cut
End With
If you want to match both cell with and height use:
如果要同时匹配单元格和高度，请使用：
With shp
.LockAspectRatio = msoFalse
.Width = Cells(cell.Row, cell.Column + 5).Width
.Height = Cells(cell.Row, cell.Column + 5).Height
.Cut
End With
回答by Andrew
I updated code above and also I take path to the image from Column "B" (Column 2). I raun my macro on cell click:
我更新了上面的代码，并从“B”列（第 2 列）获取图像的路径。我在单元格单击时运行我的宏：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim listWS As Worksheet
Dim targetCol, targetRow As Long
Dim TheFile As String
Set listWS = Application.ThisWorkbook.Sheets("Catalogue")
If Target.Column = 2 Then
targetCol = Target.Column
targetRow = Target.Row
TheFile = listWS.Cells(targetRow, targetCol).Value
With listWS.Range(listWS.Cells(targetRow, 4), listWS.Cells(targetRow, 4))
.AddComment
.Comment.Visible = True
.Comment.Shape.Fill.UserPicture TheFile
End With
End If
End Sub
回答by Cody
This will add a picture as a comment quickly on the cell you are clicked on. It also resizes it to what I liked for the project I was doing.
这将在您单击的单元格上快速添加图片作为评论。它还将其调整为我喜欢的项目的大小。
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:="*.png", Position:=1
.Title = "Choose image"
If .Show = -1 Then TheFile = .SelectedItems(1) Else TheFile = 0
End With
'No file selected
If TheFile = 0 Then
MsgBox ("No image selected")
Exit Sub
End If
Selection.AddComment
Selection.Comment.Visible = True
Selection.Comment.Shape.Fill.UserPicture TheFile
Selection.Comment.Shape.Select True
Selection.ShapeRange.ScaleWidth 2.6, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 2.8, msoFalse, msoScaleFromTopLeft
ActiveCell.Comment.Visible = False
回答by Varadharajan
Paste the below code in ThisWorkbook and then close it and open it. Whenever you paste the screenshot in Cell it will automatically resize
将以下代码粘贴到 ThisWorkbook 中，然后关闭并打开它。每当您将屏幕截图粘贴到 Cell 中时，它都会自动调整大小
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
#Else
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
#End If
Private WithEvents CmndBras As CommandBars
Private Sub Workbook_Open()
Set CmndBras = Application.CommandBars
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
Set CmndBras = Application.CommandBars
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set CmndBras = Nothing
End Sub
Private Sub CmndBras_OnUpdate()
Dim oShp As Shape
On Error Resume Next
If TypeName(Selection) <> "Range" Then
If ScreenShotInClipBoard Then
Set oShp = Selection.Parent.Shapes(Selection.Name)
With oShp
If .AlternativeText <> "Tagged" Then
If .Type = msoPicture Then
If Err.Number = 0 Then
.AlternativeText = "Tagged"
.Visible = False
.LockAspectRatio = msoFalse
.Top = ActiveWindow.RangeSelection.Top
.Left = ActiveWindow.RangeSelection.Left
.Width = ActiveWindow.RangeSelection.Width
.Height = ActiveWindow.RangeSelection.Height
ActiveWindow.RangeSelection.Activate
.Visible = True
End If
End If
End If
End With
End If
End If
End Sub
Private Function ScreenShotInClipBoard() As Boolean
Dim sClipboardFormatName As String, sBuffer As String
Dim CF_Format As Long, i As Long
Dim bDtataInClipBoard As Boolean
If OpenClipboard(0) Then
CF_Format = EnumClipboardFormats(0&)
Do While CF_Format <> 0
sClipboardFormatName = String(255, vbNullChar)
i = GetClipboardFormatName(CF_Format, sClipboardFormatName, 255)
sBuffer = sBuffer & Left(sClipboardFormatName, i)
bDtataInClipBoard = True
CF_Format = EnumClipboardFormats(CF_Format)
Loop
CloseClipboard
End If
ScreenShotInClipBoard = bDtataInClipBoard And Len(sBuffer) = 0
End Function
回答by Directionsky
this can be used for batch operations add a bunch of images as comment in one go
这可用于批量操作，一次性添加一堆图像作为注释
Sub Fill_Selection_with_Image_As_Comments()
Dim n As Integer
Dim i As Integer
Dim cmt As Comment
Dim rng As Range
Dim Workrng As Range
Dim strPic As String
On Error Resume Next
Set Workrng = Application.Selection
Set Workrng = Application.InputBox(Prompt:="Please select a range!", Title:="Range to target", Type:=8)
i = 1
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Title = "Select Images"
.ButtonName = "Select"
If .Show <> -1 Then
Exit Sub
End If
n = .SelectedItems.Count
For Each rng In Workrng
rng.AddComment
Set cmt = rng.Comment
If Not cmt Is Nothing Then
strPic = .SelectedItems(i)
With cmt.Shape
.Height = 400
.Width = 500
.Fill.UserPicture strPic
End With
End If
i = i + 1
If i = n + 1 Then
Exit Sub
End If
Next rng
End With
MsgBox "Done"
End Sub
Hope this helps some one who is finding a batch operations work.
希望这对正在寻找批处理操作的人有所帮助。
