使用方法：
1. 选中C列照片名称
2. 运行宏addpicturecomment
3. 选择照片所在文件夹
4. 可以把用选择性粘贴的方式把批注再贴到需要的地方。
参考：
http://oicu.cc.blog.163.com/blog/static/123039471201211852154486/
https://www.mrexcel.com/forum/excel-questions/803671-stuck-trying-resize-image-before-inserting-comment.html
代码如下：
Option Explicit
Sub AddPictureComment()
Dim T As Range
Dim PicDir As
String
Dim FileExt As
String
Dim FileFullPath As
String
Dim tmpPic As
Object
Dim fs As Object
Dim fd As Object
Set fs =
CreateObject("Scripting.FileSystemObject")
'
设置了以下4种调用图片文件夹的方法，根据需求任选其一
' PicDir =
"E:\pic" '
直接设定文件夹，最后不要\符号
' PicDir =
ActiveWorkbook.Path '
使用Excel文件所在文件夹
' PicDir =
ActiveWorkbook.Path & "\pic"
' 用Excel文件所在位置的子文件夹pic
'
注意不要使用ThisWorkbook.Path，返回的是宏所在的工作簿路径！
Set fd =
Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1
Then
PicDir = fd.SelectedItems(1)
' 记录所选的文件夹名，只能选一个文件夹
Else
Exit Sub '
无选择或取消则退出
End If
FileExt =
"" ' 如果单元格内容是 001.jpg
这样的完整文件名，这里设置为空。
' 如果单元格内容没写文件扩展名，需要在这里设置图片的格式，
' 如jpg、png、gif、bmp等，使用统一格式。
' 为了方便，在这里要加.符号，如 FileExt = ".jpg"
For Each T In
Selection
FileFullPath = PicDir & "" & T.Value
& FileExt
Call scalePicture(PicDir & "", T.Value
& FileExt, "temp.jpg", 50) '50是指压缩50%
'MsgBox "pause"
If fs.FileExists(PicDir & "" &
"temp.jpg") Then
If
T.Comment Is Nothing Then
T.AddComment
Else
T.Comment.Delete
T.AddComment
End
If
With
T.Comment.Shape
Set tmpPic =
ActiveSheet.Pictures.Insert(PicDir & "" &
"temp.jpg")
.Width =
tmpPic.ShapeRange.Width
.Height =
tmpPic.ShapeRange.Height
.Fill.Visible = msoTrue
.Fill.UserPicture PicDir
& "" & "temp.jpg"
.LockAspectRatio =
msoTrue ' 锁定纵横比
If .Width > 640 Then
.Width = 320
If .Height > 480 Then
.Width = 240
.Locked =
msoTrue ' 属性-锁定
'
Application.SendKeys
"%(oe)~{TAB}~"
''Application.CommandBars.ExecuteMso "PicturesCompress"
tmpPic.Delete
Call DeleteFile(PicDir &
"" & "temp.jpg")
End
With
End If
Next T
End Sub
Private Sub scalePicture(PictureDir As String, PictureFile As
String, PictureFileOut As String, Optional PictureScale As Integer
= 20)
' ref
http://www.ozgrid.com/forum/showthread.php?t=145666
' ref
for delete file
http://stackoverflow.com/questions/67835/deleting-a-file-in-vba
Dim chtDummyChart As
Excel.ChartObject
Dim strExportFilename As
String
Dim intImagePercent As
Integer
Dim sngScaleFactor As
Single
Dim tmpSheet As String '
temp values for resetting active cell back to original cell
Dim tmpRange As
String
intImagePercent =
PictureScale ' maximum value here of 100 - ie full-size default is
20
sngScaleFactor = 100 /
intImagePercent
tmpSheet =
ActiveSheet.Name
tmpRange =
ActiveCell.Address
With ActiveSheet
.Range("A1").Select
.Pictures.Insert (PictureDir &
PictureFile)
.Pictures.Select
.Pictures.Copy
'By altering the value of the
the width & height properties to smaller values -> rescales
image!
'remember to use the same
intScaleFactor for both .Pictures(1).width and _
.Pictures(1).height Or the image ratio will be
distorted
Set chtDummyChart = .ChartObjects.Add(0, 0,
((.Pictures(1).Width + 1) / sngScaleFactor), _
((.Pictures(1).Height + 1) /
sngScaleFactor))
End With
strExportFilename =
PictureDir & PictureFileOut
With chtDummyChart
.Chart.Paste
.Chart.Export strExportFilename, "jpg"
.Delete
End With
With ActiveSheet
.Range("A1").Select
.Pictures.Delete
End With
Worksheets(tmpSheet).Select
Range(tmpRange).Select
Set chtDummyChart =
Nothing
' Unload Me
End Sub
Sub DeleteFile(ByVal FileToDelete As String)
If
FileExists(FileToDelete) Then
SetAttr FileToDelete,
vbNormal
Kill
FileToDelete
End If
End Sub
' functions used in macros
Function FileExists(ByVal FileToTest As String) As
Boolean
FileExists =
(Dir(FileToTest) <> "")
End Function
加载中，请稍候......
加载中…
喜欢