图片标注VBA完整版

图片标注VBA完整版

Sub 图片标注工具()

'//查找图片文件夹 Dim dig As Object

Set dig = Application.FileDialog(msoFileDialogFolderPicker) With dig

.InitialFileName = \ .Show

picfilename = dig.SelectedItems(1) End With

Set dig = Nothing

'//指定主键

Dim rng1 As Range Do

On Error Resume Next

Set rng1 = Application.InputBox(\请选择任一参照单元格:\单元格选择\ If rng1 Is Nothing Then Exit Sub

If rng1.Count > 1 Then MsgBox \选择的单元格过多!\ Loop While rng1.Count > 1

rngcolumn1 = rng1.Column

'//指定标注列 Dim rng2 As Range Do

On Error Resume Next

Set rng2 = Application.InputBox(\请选择任一待标注单元格:\单元格选择\ If rng2 Is Nothing Then Exit Sub

If rng2.Count > 1 Then MsgBox \选择的单元格过多!\ Loop While rng2.Count > 1

rngcolumn2 = rng2.Column

pn_mrow = ActiveSheet.Cells(1, 1).End(xlDown).Row

'//循环标注

Dim tRan As Range Dim Path As String pn_temp = 0

For i = 2 To pn_mrow '//构造单元格

rng_no = Cells(i, rngcolumn1).Value

Set tRan = ActiveSheet.Cells(i, rngcolumn2)

'//构造图片

Path = picfilename & \

'//判定并标注

If FileFolderExists(Path) Then

tRan.ClearComments

tRan.AddComment.Shape.Fill.UserPicture Path Else

pn_temp = pn_temp + 1

End If

Next i

If pn_temp > 0 Then MsgBox \图片文件夹中不存在欲标注图片！\

End Sub

'//判定文件夹是否存在的自定义过程

Public Function FileFolderExists(strFullPath As String) As Boolean

On Error GoTo EarlyExit

If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True EarlyExit:

On Error GoTo 0

End Function

本文来源：https://www.bwwdw.com/article/cpu5.html