Нужна помощь с использованием VBA для вставки гиперссылок в excel на указанные изображения на моем компьютере

avatar
njroe001
1 июля 2021 в 15:56
59
1
0

У меня более 600 изображений в папке на моем компьютере, и я хочу связать каждое из них с отдельной ячейкой в ​​файле Excel с помощью vba вместо того, чтобы просматривать и связывать каждое из них вручную. Я не очень хорошо разбираюсь в 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)

avatar
Алексей Р
1 июля 2021 в 17:32
0

Попробуйте этот код:

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

Снимок экрана