Question

我是VBA领域的新手，我使用excel电子表格运行每月客户报告，对于每个客户，我要添加一张不同的图片。所有图片均以相同的名称保存，但保存在每个客户文件夹中，这意味着我的路径将针对每个报告而更改。因此，我正在使用下面的代码从我在报告的单元格M6中设置的路径导入图片，但是我遇到了“ -2147319765（8002802b）自动化错误”。

!spam Denard 1 spam spam spam
!spam @Denard 1 spam spam spam
!spam 1234 1 spam spam spam

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

使用VBA从路径导入图片

1 个答案: