Question

我正在编写一个宏，它会找到一个文件并将其附加到电子邮件中。

到目前为止，我所拥有的黑客攻击代码的设计如下 - 从指定目录开始 - 生成目录中的文件夹列表＆gt;导出到临时创建的工作表上的单元格 - 循环浏览此文件夹列表，搜索文件夹的存在（所有这些子文件夹都由job numbereg。/ 13456 /标记） - 当找到编号的作业文件夹时，它会再检查一个子文件夹，“图纸” - 如果文件夹标有“图纸”，则我们想要的文件将在那里。 - 如果文件夹标记“图纸”不存在，我们想要的文件将在编号的作业文件夹中。

现在我在这里被卡住了。目前，我的代码在这两个位置查找文件，搜索字词为“ FIRST .pdf”。

我还想搜索其他短语，例如“ UPPER .pdf”，“ 1st .pdf”，“ UF 。 PDF”。

执行此操作的最佳方法是引用表格中的单元格的循环，因此需要创建另一个临时表格并填充更多单元格吗？或者是否有一种棘手的方法可以使用循环代码完成而不需要它？

同样，我的代码非常粗略地被黑客攻击，就像我去学习一样。此外，宏的要求不断变化，因为人们正在努力实现它可以用它做什么，所以逻辑并没有一次性设计。：\

Sub Concrete_Order()
'code deleted from above area in question


Dim foldersearchpath As String, ctr As Integer, UFPLANNAME As String, UFPLANpdf As String

ctr = 1

Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "asdf"

Path = "K:\drafting\jobs\1DETAILING\"   'always have "\" at end

FirstDir = Dir(Path, vbDirectory)

    Do Until FirstDir = ""
        If (GetAttr(Path & FirstDir) And vbDirectory) = vbDirectory Then
            ActiveSheet.Cells(ctr, 1).Value = Path & FirstDir
            ctr = ctr + 1
        End If

        FirstDir = Dir()  
    Loop

Sheets("asdf").Select

ctr = ctr - 1 'counter correction

    Do Until ctr = 2
        foldersearchpath = Range("A" & ctr) & "\" & jobNumber & "\"

            Dim FldrCheck As String, FldrCheck2 As String, UFPlanFile As String

            FldrCheck = Dir(foldersearchpath, vbDirectory)

                 If Len(FldrCheck) > 0 Then

                        FldrCheck2 = Dir(foldersearchpath & "drawings\", vbDirectory)

                             If Len(FldrCheck2) > 0 Then

                                   foldersearchpath = foldersearchpath & "drawings\"
                                   file = Dir(foldersearchpath & "*FIRST*.pdf")


                                           If file <> "" Then
                                                  UFPlanFile = foldersearchpath & file
                                                  GoTo planfileFound
                                           Else
                                                  GoTo UFPLAN_MANUAL_attach
                                           End If


                             Else

                                  file = Dir(foldersearchpath & "*FIRST*.pdf")

                                       If file <> "" Then

                                           UFPlanFile = foldersearchpath & file
                                           GoTo planfileFound
                                       Else

                                            GoTo UFPLAN_MANUAL_attach
                                       End If



                            End If


                 Else

                 End If

        ctr = ctr - 1
    Loop

On Error GoTo 0

UFPLAN_MANUAL_attach:

Dim fd As Office.FileDialog

Set fd = Application.FileDialog(msoFileDialogFilePicker)

 With fd

      .AllowMultiSelect = False
      .Application.FileDialog(msoFileDialogOpen).InitialFileName = foldersearchpath
      .Title = "Could not find Upper Floor Plan, please locate..."
      .Filters.Clear
      .Filters.Add "Adobe PDF", "*.pdf"
      .Filters.Add "John File", "*.god"
      .Filters.Add "All Files", "*.*"

      If .Show = True Then 'user clicked ok
           UFPlanFile = .SelectedItems(1) 'replace txtFileName with your textbox
      End If

 End With


planfileFound:

Application.DisplayAlerts = False
Sheets("asdf").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True


On Error GoTo 0

'code deleted from after
 End Sub

Answer 1

大多数编程语言都有动态列表的内置类。 Vba有Collection类。您可以使用.Add添加项目并使用（i）检索项目或使用＆＃34; For Each＆＃34;遍历每个项目

Sub Concrete_Order()
    'code deleted from above area in question


    Dim foldersearchpath As String, ctr As Integer, UFPLANNAME As String, UFPLANpdf As String

    Dim foundDirectories As Collection
    Set foundDirectories = New Collection


    Path = "K:\drafting\jobs\1DETAILING\"   'always have "\" at end

    FirstDir = Dir(Path, vbDirectory)

    Do Until FirstDir = ""
        If (GetAttr(Path & FirstDir) And vbDirectory) = vbDirectory Then
            foundDirectories.Add Path & FirstDir
        End If

        FirstDir = Dir()
    Loop


    Dim possibleFileNames As Collection
    Set possibleFileNames = New Collection

    possibleFileNames.Add "*FIRST*.pdf"
    possibleFileNames.Add "UPPER.pdf"
    possibleFileNames.Add "1st.pdf"
    possibleFileNames.Add "UF.pdf"


    Dim currentDirectory

    For Each currentDirectory In foundDirectories

        foldersearchpath = currentDirectory & "\" & jobNumber & "\"

        Dim FldrCheck As String, FldrCheck2 As String, UFPlanFile As String

        FldrCheck = Dir(foldersearchpath, vbDirectory)

        If Len(FldrCheck) > 0 Then

            FldrCheck2 = Dir(foldersearchpath & "drawings\", vbDirectory)

            If Len(FldrCheck2) > 0 Then
                foldersearchpath = foldersearchpath & "drawings\"
            End If

            Dim possibleFileName

            For Each possibleFileName In possibleFileNames
                file = Dir(foldersearchpath & possibleFileName)

                If file <> "" Then

                    UFPlanFile = foldersearchpath & file

                    GoTo planfileFound

                End If
            Next

            GoTo UFPLAN_MANUAL_attach

        End If

    Next

    On Error GoTo 0

UFPLAN_MANUAL_attach:

    Dim fd As Office.FileDialog

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

     With fd

          .AllowMultiSelect = False
          .Application.FileDialog(msoFileDialogOpen).InitialFileName = foldersearchpath
          .Title = "Could not find Upper Floor Plan, please locate..."
          .Filters.Clear
          .Filters.Add "Adobe PDF", "*.pdf"
          .Filters.Add "John File", "*.god"
          .Filters.Add "All Files", "*.*"

          If .Show = True Then 'user clicked ok
               UFPlanFile = .SelectedItems(1) 'replace txtFileName with your textbox
          End If

     End With


planfileFound:



    On Error GoTo 0

'code deleted from after
End Sub

搜索具有不同关键字的文件

1 个答案: