使用vba从路径导入图片

Question

我是 VBA 领域的新手，我正在使用 Excel 电子表格来运行每月客户报告，并且我要为每个客户添加不同的图片。所有图片都以相同的名称保存，但在每个客户文件夹中，这意味着我的每个报告的路径都会更改。 所以我使用下面的代码从我在报告的单元格 M6 中设置的路径导入图片，但是我收到“-2147319765 (8002802b) 自动化错误”。

Sub ImportPicture()
'Import Site Access Picture
Dim myPict As Picture
Dim curWks As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim myPictName As Variant

Set curWks = Sheets("Monthly Report")

'curWks.Pictures.Delete

With curWks
Set myRng = .Range("$M$6", .Cells(.Rows.Count, "M").End(xlUp))
End With

For Each myCell In myRng.Cells
If Trim(myCell.Value) = "" Then
    'do nothing
ElseIf Dir(CStr(myCell.Value)) = "" Then
    'picture not there!
    MsgBox myCell.Value & " Doesn't exist!"
Else
    With myCell.Offset(5, -11)
        Set myPict = myCell.Parent.Pictures.Insert(myCell.Value)
        myPict.Top = .Top
        'myPict.Width = .Width
        'myPict.Height = .Height
        myPict.Left = .Left
        'myPict.Placement = xlMoveAndSize

    End With
End If
Next myCell

End Sub

Answer 1

您可以像这样列出ColumnA中的所有路径。

Option Explicit

Sub ListAllFiles()
    searchForFiles "C:\your_path_here\", "writefilestosheet", "*.*", True, True
End Sub

Sub processOneFile(ByVal aFilename As String)
    Debug.Print aFilename
End Sub

Sub writeFilesToSheet(ByVal aFilename As String)
    With ActiveSheet
    .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = aFilename
        End With
End Sub

    Private Sub processFiles(ByVal DirToSearch As String, _
            ByVal ProcToCall As String, _
            ByVal FileTypeToFind As String)
        Dim aFile As String
        aFile = Dir(DirToSearch & FileTypeToFind)
        Do While aFile <> ""
            Application.Run ProcToCall, DirToSearch & aFile
            aFile = Dir()
            Loop
End Sub

Private Sub processSubFolders(ByVal DirToSearch As String, _
            ByVal ProcToCall As String, _
            ByVal FileTypeToFind As String, _
            ByVal SearchSubDir As Boolean, _
            ByVal FilesFirst As Boolean)

Dim aFolder As String, SubFolders() As String

ReDim SubFolders(0)

aFolder = Dir(DirToSearch, vbDirectory)

    Do While aFolder <> ""

        If aFolder <> "." And aFolder <> ".." Then

            If (GetAttr(DirToSearch & aFolder) And vbDirectory) _
                    = vbDirectory Then
                SubFolders(UBound(SubFolders)) = aFolder
                ReDim Preserve SubFolders(UBound(SubFolders) + 1)
                End If
                End If
            aFolder = Dir()
            Loop

        If UBound(SubFolders) <> LBound(SubFolders) Then
            Dim i As Long
            For i = LBound(SubFolders) To UBound(SubFolders) - 1
                searchForFiles _
                    DirToSearch & SubFolders(i), _
                    ProcToCall, FileTypeToFind, SearchSubDir, FilesFirst
                Next i
            End If

    End Sub

Sub searchForFiles(ByVal DirToSearch As String, ByVal ProcToCall As String, _
        Optional ByVal FileTypeToFind As String = "*.*", _
        Optional ByVal SearchSubDir As Boolean = False, _
        Optional ByVal FilesFirst As Boolean = False)
    On Error GoTo ErrXIT
    If Right(DirToSearch, 1) <> Application.PathSeparator Then _
        DirToSearch = DirToSearch & Application.PathSeparator

If FilesFirst Then processFiles DirToSearch, ProcToCall, FileTypeToFind
If SearchSubDir Then processSubFolders DirToSearch, ProcToCall, _
    FileTypeToFind, SearchSubDir, FilesFirst

    If Not FilesFirst Then _
        processFiles DirToSearch, ProcToCall, FileTypeToFind
    Exit Sub
ErrXIT:
    MsgBox "Fatal error: " & Err.Description & " (Code=" & Err.Number & ")"
    Exit Sub
End Sub

下面的脚本会将图片导入Excel。

Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range

Application.ScreenUpdating = False
fPath = "C:\your_path_here\Pictures\"
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
i = 1

For Each r In rng
    fName = Dir(fPath)
    Do While fName <> ""
        If fName = r.Value Then
            With ActiveSheet.Pictures.Insert(fPath & fName)
                .ShapeRange.LockAspectRatio = msoTrue
                Set px = .ShapeRange
                If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
                    With Cells(i, 2)
                        px.Top = .Top
                        px.Left = .Left
                        .RowHeight = px.Height
                    End With
            End With
        End If
        fName = Dir
    Loop
    i = i + 1
Next r
Application.ScreenUpdating = True
End Sub