VBA插入批注图片--如何设置固定文件夹路径

股理乾坤

求助
因工作需要在批注中插入图片，频繁更新等，所以本人在网找了个脚本，做了些修更，但还是有一个功能无法改出来，特来请大家帮忙。问题如下


1、现在的程序可以正常插入批注图片，就是每次执行VBA（插入批注图片）按钮时，都要去指定一次图片所在的文件夹，我想实现一个，当我把图片所在的文件夹地址写到如图N1单元格中（后期修改方便），不要像现在这样每次去指定一次，就能正像插入批注图片。


2、表格和图片不在同一个文件夹，可以任意放，只要把正确的图片文件夹路径输入到N1单元格


3、图片文件夹地址可能会出现局域网共享文件夹地址，比如：\\张三电脑\产品图片\   ，也有可能是：F:\办公神器\BK000010，因为图库是专人管理，不方便把图片拷贝到别处。


4、如何设置批注图片的大小？

3190496160

模板--一键批注图片.rar (378.11 KB, 下载次数: 50)

2021-10-14 07:47 上传

点击文件名下载附件

liulang0808

Private Sub CommandButton3_Click()

Call 删除批注

'批注插图按钮

On Error Resume Next

'Set obj = Application.FileDialog(msoFileDialogFolderPicker)
'
'With obj
'
'If .Show = -1 Then
'
'spath = .SelectedItems(1)
'
'End If
'
'
'
'End With
If Len([n1]) = 0 Then Exit Sub
spath = [n1]

row_b = 3 '代表从第3行开始，Val(InputBox("请输入序号启始行号，如第1行输 1"))

row_e = Cells(Rows.Count, 4).End(3).Row '代表最下一行,Val(InputBox("请输入序号结束行号，如第10行输 10"))

col_ = 4 '索引编号或图片名称所在列号，Val(InputBox("请输入序号所在的列号，如第1列输 1"))

pcol_ = 4 '把图片插入到第几列中的列号，Val(InputBox("请输入要图片所在的列号，如第2列输 2"))

For i = row_b To row_e

Cells(i, pcol_).AddComment

Cells(i, pcol_).Comment.Shape.Fill.UserPicture (spath & "\" & Cells(i, col_).Value & ".jpg")
Cells(i, pcol_).Comment.Shape.Height = 100
Cells(i, pcol_).Comment.Shape.Width = 100

Cells(i, pcol_).Comment.Visible = False

Next
End Sub

liulang0808

供参考。。。。。

股理乾坤

liulang0808 发表于 2021-10-14 08:05
供参考。。。。。

这个修改是可以的，但是如何批准在执行插入时，没有找到对应图片，就会插入一个空的批准，是否可以再次帮忙修改下，如果没有图片或缺少N张图片，做个弹窗提醒呢

股理乾坤

可以用，但是出了个问题。就是当没有找到对应图片时，程序会报错，请看如下图片

liulang0808

股理乾坤 发表于 2021-10-14 22:54
可以用，但是出了个问题。就是当没有找到对应图片时，程序会报错，请看如下图片

使用dir 对文件是否存在进行判断，然后再决定是否插入图片

Lost_in_Star

1. 写了一个多格式图片到批注，代码如下：
   
2. Sub AddPicturesToComments()
   
3.     Dim rng As Range
   
4.     Dim cell As Range
   
5.     Dim i As Integer
   
6.     Dim arr()
   
7.     ' Set the range to be processed as the first column of the selected area.
   
8.     Set rng = Selection
   
9.    
   
10.     For Each cell In rng.Cells
    
11.         
    
12.         ' Retrieve the value of the current cell and construct a string for the file path of an image.
    
13.         Dim imagePath As String
    
14.         arr = Array(".jpg", ".png", ".bmp", ".jepg", ".jfif")
    
15.        For i = 0 To UBound(arr)
    
16.         imagePath = "D:\Photos" & CStr(cell.Value) & arr(i)
    
17. 
    
18.        If Dir(imagePath) <> "" Then   ' Retrieve the value of the current cell and construct a string for the image file path.
    
19.             
    
20.             With cell.AddComment
    
21.                
    
22.                 .Visible = False     ' Get the value of the current cell and construct a string for the image file path.
    
23.                
    
24.                 .Shape.Fill.UserPicture (imagePath)
    
25.                
    
26.                 .Shape.Height = 300
    
27.                
    
28.                 .Shape.Width = 300
    
29.             End With
    
30.             
    
31.          End If
    
32.   Next i
    
33.       Next cell
    
34.       
    
35. End Sub

复制代码

qwe1314ooo

Lost_in_Star 发表于 2024-3-20 18:47

大佬，这个怎么用不了呀

GG函数

你可以免费使用