需要帮助使用 VBA 在 excel 中将超链接插入到我计算机上的指定图片

Posted 2023-03-25

【中文标题】需要帮助使用 VBA 在 excel 中将超链接插入到我计算机上的指定图片

【英文标题】：Need help using VBA to insert hyperlinks in excel to specified pictures on my computer

【发布时间】：2021-09-13 17:05:43

【问题描述】：

我的计算机上的一个文件夹中有 600 多张图片，我想使用 vba 将每张图片链接到 excel 文件中的不同单元格，而不是手动浏览和链接每张图片。我不是很擅长 vba，但最终目标是一个可以在 excel 中下线并从我的文件中提取指定图片并链接它然后转到下一个的代码。

到目前为止，我的代码部分偏离了我在这里看到的另一篇文章，它只是尝试插入第一张图片的第一步，但我遇到了麻烦：

Dim Picture_1 As String
With ActiveSheet.Pictures.Insert("X:\roena10\Q ear crack pictures")
.Left = ActiveSheet.Range("photograph").Left + 2
.Top = ActiveSheet.Range("photograph").Top + 2
Picture_1 = .Name
End With
ActiveSheet.Pictures(profile).Select
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Width = 20
.Height = 20
End With

感谢任何帮助！

【参考方案1】：

试试这个代码：

Sub AddImages()
    Const path = "c:\test\", W = 20, H = 20, h_gap = 5
    Dim img As Shape, cl As Range, ws As Worksheet
    Dim fname As String, ext As String, pos As Integer, T As Long, L As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set cl = ws.Range("B1")
    
    fname = Dir(path & "*", vbNormal)
    Do While Len(fname) > 0
        pos = InStrRev(fname, ".")
        ext = vbNullString
        If pos > 0 Then ext = LCase(Mid(fname, pos + 1))
        Select Case ext
            Case "jpg", "png", "bmp" 'and so on
                With cl
                    T = .Top + 2
                    L = .Left + 2
                    .EntireRow.RowHeight = H + h_gap
                End With
                Set img = ws.Shapes.AddPicture(Filename:=path & fname, _
                          LinkToFile:=msoTrue, SaveWithDocument:=True, _
                          Left:=L, Top:=T, Width:=-1, Height:=-1)
                img.LockAspectRatio = msoTrue
                img.Height = H
                With img.Line
                    .Visible = msoTrue
                    .ForeColor.RGB = vbBlack
                    .Transparency = 0
                End With
                ws.Hyperlinks.Add Anchor:=img, Address:=path & fname
                T = T + H + h_gap
                Set cl = cl.Offset(1)
        End Select
        fname = Dir
    Loop
End Sub

Screenshot