为什么此VBA中的代码会挂起？

Question

我正在调查程序员编写的一些软件，然后我才到我工作的公司工作。

他们有一些VBA代码（在MS Access中）复制一些文件，写入表等，并且在这个过程的某个地方它正在挂起。它不会返回任何错误代码或消息（在错误处理程序中或以任何其他方式）。它只是挂起而Access进入了＃34; Not Responding＆＃34;模式，直到它被强行停止。

这是处理＆＃34;导出＆＃34;的VBA代码。按钮（它挂起的地方）：

Public Sub cmd_export_Click()
    Dim ws As New WshShell, clsF As New clsNewFile, aspChemInv As MyCstmFile, _
        fso As New IWshRuntimeLibrary.FileSystemObject, strFileName As String, _
        fld As IWshRuntimeLibrary.Folder, fi As File
    strFileName = Split(Field0.Value, ",")(0) & "_cheminv"
    On Error GoTo Err_handler

    Dim TblDeltree As String
    Dim strArrTmpName
    strArrTmpName = Split(Forms![MAIN MENU]![Field0], ", ")
    TableName = strArrTmpName(0) & ", " & strArrTmpName(1)

    If IsNull(Forms![MAIN MENU]![Field0]) = False Then
        i = 0

        Digits = Left(TableName, InStr(1, TableName, ",") - 1)
        ShtDigits = Left(Digits, 2)
        DoCmd.TransferDatabase acExport, "Microsoft Access", _
            "\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
            "\client.mdb", acTable, Forms![MAIN MENU]![Field0], TableName
        'Scott request change (see email To: Ros Vicente Wed 4/16/2014 9:26 AM)
            'Data Calculations
            'TIER II CANDIDATES
        'Revert changes per verbal (Scott Vaughn) 5/6/2014 10:09 AM
        DoCmd.TransferDatabase acExport, "Microsoft Access", _
            "\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
            "\client.mdb", acTable, "Data Calculations", "Data Calculations"
        DoCmd.TransferDatabase acExport, "Microsoft Access", _
            "\\A02-ds1\Public\Clients\" & ShtDigits & "\" & Digits & _
            "\client.mdb", acTable, "TIER II CANDIDATES", "TIER II CANDIDATES"
        DoCmd.OpenReport "TIER II CANDIDATES", acViewPreview
        Set rpt = Application.Reports![TIER II CANDIDATES]

        Dim strReportsPath As String

        strReportsPath = "\\A02-DS1\Public\Clients\" & ShtDigits & "\" & Digits & "\"

        'ScreenShot rpt
        DoCmd.OutputTo acOutputReport, Report, acFormatSNP, strReportsPath & rpt.Name & ".SNP", 0

        DoCmd.Close acReport, rpt.Name

        'DoCmd.OpenReport "Product Quantity List", acViewPreview

        'Set rpt = Application.Reports![Product Quantity List]

        modPDFCreator.RunReportAsPDF "Product Quantity List", strReportsPath & Digits & "_PQL.pdf"

    Else
        MsgBox "Please select the client table below.", vbExclamation, "Status: Export"
    End If
    If Not fso.FolderExists("C:\Temp") Then fso.CreateFolder ("C:\Temp")
    ws.CurrentDirectory = "C:\Temp"
    If Not fso.FolderExists(ws.CurrentDirectory & "\ESD_Upload") Then fso.CreateFolder ws.CurrentDirectory & "\ESD_Upload"
    ws.CurrentDirectory = ws.CurrentDirectory & "\ESD_Upload"

    Dim xFile As MyCstmFile
    Set fld = fso.GetFolder("\\a02-ds1\Env-Sci\AutoCAD Files\Publish")
    Dim strCurrentFile As String
    For Each fi In fld.Files
        strCurrentFile = fi.Name
        fso.MoveFile fi.Path, ws.CurrentDirectory & "\" & strCurrentFile
    Next

    Dim tmpMSDS As New clsChemicalInventory
    fso.CopyFile "\\a02-ds1\applicationDatabase$\MSDS.mdb", ws.CurrentDirectory & "\" & fGetUserName _
        & ".mdb", True
    tmpMSDS.CreateMSDS Digits, ws.CurrentDirectory & "\" & fGetUserName & ".mdb"

    Set fld = fso.GetFolder(ws.CurrentDirectory)
    For Each fi In fld.Files
        If InStr(1, fi.Name, ".txt") = 0 And InStr(1, fi.Name, ".mdb") = 0 Then _
            fso.CopyFile fi.Name, "\\a02-ds1\Vanguard Website\OHMMP\Clients\", True
        If InStr(1, fi.Name, "layout.pdf") <> 0 Then _
            fso.CopyFile fi.Name, "\\A02-DS1\public\Clients\Layouts\", True: _
            fso.CopyFile fi.Name, "\\A01-DC1\clients$\", True
        If InStr(1, fi.Name, "_msds_") <> 0 Then _
            fso.CopyFile fi.Name, "\\A01-DC1\clients$\", True
    Next
    ws.CurrentDirectory = "C:\Temp"
    fso.DeleteFolder ws.CurrentDirectory & "\ESD_Upload"
    Set fso = Nothing
    Set fld = Nothing
    Set ws = Nothing
    MsgBox "Export Completed"

Exit_Handler:
    Exit Sub

Err_handler:
    If Err.Number = 70 Then
        MsgBox "File " & strCurrentFile & " is Open.", vbOKOnly, "Open File"
    Else
        MsgBox "An Error as occured while trying to complete this task." _
            & vbCrLf & "Please report the following error to your IT department: " _
            & vbCrLf & Err.Number & ":" & vbCrLf & Err.Description, vbCritical, "Error"
    End If
    'Resume
    Resume Exit_Handler
End Sub

不幸的是，我没有太多使用VB的经验（我过去主要使用过SQL），虽然我一直在研究这些功能，但是我无法做到这一点。似乎找到了一种方法来弄清楚它在哪里或为什么会以它的方式挂起。

有什么方法可以告诉我们这里发生了什么，或者，或许，我应该在哪里看，或者我可以做些什么来找出？

修改

另外，如果有必要知道，我使用的是Adobe Acrobat 9.0.0（刚从DVD上新安装）。

找到新事物

好的，我已经意识到这里有3个不同的问题，但还不确定如何修复它们。

1）我收到错误58（文件已存在于以下行：

fso.MoveFile fi.Path, ws.CurrentDirectory & "\" & strCurrentFile

这是完全可以理解的，因为VB中的MoveFile函数不支持覆盖文件。不确定是谁写的，但他们忽视了那里的一个重大缺陷。我打算使用CopyFile，然后在完成时删除源代码来解决这个问题，所以这里没有问题。

2）我在下一行收到错误3043（磁盘或网络错误）（@Time Williams在下面的评论中询问了这一点[我还在调查什么＆＃39在那里继续，但我不知道在哪里可以找到自建全局函数的位置]）：

tmpMSDS.CreateMSDS Digits, ws.CurrentDirectory & "\" & fGetUserName & ".mdb"

3）这就是程序挂起的地方：

modPDFCreator.RunReportAsPDF "Product Quantity List", strReportsPath & Digits & "_PQL.pdf"

这对我来说仍然是一个完整的难题，因为我之前从未使用任何语言的任何方法。我们非常感谢任何可以建议缩小此范围的帮助（或上面＃2中的问题）。

好的，发现更多东西

modPDFCreator：

' The function to call is RunReportAsPDF
'
' It requires 2 parameters:  the Access Report to run
'                            the PDF file name
'
' Enjoy!
'
' Eric Provencher
'===========================================================

Option Compare Database

Private Declare Sub CopyMemory Lib "kernel32" _
              Alias "RtlMoveMemory" (dest As Any, _
                                     source As Any, _
                                     ByVal numBytes As Long)

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
                  Alias "RegOpenKeyExA" (ByVal hKey As Long, _
                                         ByVal lpSubKey As String, _
                                         ByVal ulOptions As Long, _
                                         ByVal samDesired As Long, _
                                         phkResult As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
                   Alias "RegCreateKeyExA" (ByVal hKey As Long, _
                                            ByVal lpSubKey As String, _
                                            ByVal Reserved As Long, _
                                            ByVal lpClass As String, _
                                            ByVal dwOptions As Long, _
                                            ByVal samDesired As Long, _
                                            ByVal lpSecurityAttributes As Long, _
                                            phkResult As Long, _
                                            lpdwDisposition As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
                   Alias "RegQueryValueExA" (ByVal hKey As Long, _
                                             ByVal lpValueName As String, _
                                             ByVal lpReserved As Long, _
                                             lpType As Long, _
                                             lpData As Any, _
                                             lpcbData As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" _
                   Alias "RegSetValueExA" (ByVal hKey As Long, _
                                           ByVal lpValueName As String, _
                                           ByVal Reserved As Long, _
                                           ByVal dwType As Long, _
                                           lpData As Any, _
                                           ByVal cbData As Long) As Long

Private Declare Function apiFindExecutable Lib "shell32.dll" _
                  Alias "FindExecutableA" (ByVal lpFile As String, _
                                           ByVal lpDirectory As String, _
                                           ByVal lpResult As String) As Long

Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const ERROR_MORE_DATA = 234

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002

Const KEY_READ = &H20019  ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
                          ' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not
                          ' SYNCHRONIZE))

Const KEY_WRITE = &H20006  '((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or
                           ' KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))

Public Function RunReportAsPDF(prmRptName As String, _
                               prmPdfName As String) As Boolean

    ' Returns TRUE if a PDF file has been created

    Dim AdobeDevice As String
    Dim strDefaultPrinter As String

    'Find the Acrobat PDF device

    AdobeDevice = GetRegistryValue(HKEY_CURRENT_USER, _
                                   "Software\Microsoft\WIndows NT\CurrentVersion\Devices", _
                                   "Adobe PDF")

    If AdobeDevice = "" Then    ' The device was not found
        MsgBox "You must install Acrobat Writer before using this feature"
        RunReportAsPDF = False
        Exit Function
    End If

    ' get current default printer.
    strDefaultPrinter = Application.Printer.DeviceName

    Set Application.Printer = Application.Printers("Adobe PDF")

    'Create the Registry Key where Acrobat looks for a file name
    CreateNewRegistryKey HKEY_CURRENT_USER, _
                         "Software\Adobe\Acrobat Distiller\PrinterJobControl"

    'Put the output filename where Acrobat could find it
    'SetRegistryValue HKEY_CURRENT_USER, _
                     "Software\Adobe\Acrobat Distiller\PrinterJobControl", _
                     Find_Exe_Name(CurrentDb.Name, CurrentDb.Name), _
                     prmPdfName

    Dim oShell As Object
    Dim strRegKey As String
    Set oShell = CreateObject("WScript.Shell")
    On Error GoTo ErrorHandler
'    strRegKey = oShell.RegRead("HKEY_CURRENT_USER\Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder\1")
'    If Err.Number = -2147024893 Then
'    ' Code for if the key doesn't exist
'    MsgBox "The key does not exist"
'    Else
'    ' Code for if the key does exist
'    MsgBox "The key exists"
'    End If

    Dim strRegPath As String
    strRegPath = "Software\Adobe\Acrobat Distiller\9.0\AdobePDFOutputFolder"
1:
    SetRegistryValue HKEY_CURRENT_USER, strRegPath, "2", Left(prmPdfName, InStrRev(prmPdfName, "\") - 1)

ErrorHandler:
    If Err.Number <> 0 Then strRegPath = "Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder": Err.Clear: Resume 1

    On Error GoTo Err_handler
    Dim strReportName As String
    strReportName = Left(Right(prmPdfName, Len(prmPdfName) - InStrRev(prmPdfName, "\")), _
        Len(Right(prmPdfName, Len(prmPdfName) - InStrRev(prmPdfName, "\"))) - 4)

    DoCmd.CopyObject , strReportName, acReport, prmRptName

    DoCmd.OpenReport strReportName, acViewNormal   'Run the report

    DoCmd.DeleteObject acReport, strReportName

'    While Len(Dir(prmPdfName)) = 0              ' Wait for the PDF to actually exist
'        DoEvents
'    Wend

    RunReportAsPDF = True       ' Mission accomplished!

Normal_Exit:

    Set Application.Printer = Application.Printers(strDefaultPrinter)   ' Restore default printer

    On Error GoTo 0

    Exit Function

Err_handler:

    If Err.Number = 2501 Then       ' The report did not run properly (ex NO DATA)
        RunReportAsPDF = False
        Resume Normal_Exit
    Else
        RunReportAsPDF = False      ' The report did not run properly (anything else!)
        MsgBox "Unexpected error #" & Err.Number & " - " & Err.Description
        Resume Normal_Exit
    End If

End Function

Public Function Find_Exe_Name(prmFile As String, _
                              prmDir As String) As String

    Dim Return_Code As Long
    Dim Return_Value As String

    Return_Value = Space(260)
    Return_Code = apiFindExecutable(prmFile, prmDir, Return_Value)

    If Return_Code > 32 Then
        Find_Exe_Name = Return_Value
    Else
        Find_Exe_Name = "Error: File Not Found"
    End If

End Function

Public Sub CreateNewRegistryKey(prmPredefKey As Long, _
                                prmNewKey As String)

    ' Example #1:  CreateNewRegistryKey HKEY_CURRENT_USER, "TestKey"
    '
    '              Create a key called TestKey immediately under HKEY_CURRENT_USER.
    '
    ' Example #2:  CreateNewRegistryKey HKEY_LOCAL_MACHINE, "TestKey\SubKey1\SubKey2"
    '
    '              Creates three-nested keys beginning with TestKey immediately under
    '              HKEY_LOCAL_MACHINE, SubKey1 subordinate to TestKey, and SubKey3 under SubKey2.
    '
    Dim hNewKey As Long         'handle to the new key
    Dim lRetVal As Long         'result of the RegCreateKeyEx function

    lRetVal = RegOpenKeyEx(prmPredefKey, prmNewKey, 0, KEY_ALL_ACCESS, hKey)

    If lRetVal <> 5 Then
        lRetVal = RegCreateKeyEx(prmPredefKey, prmNewKey, 0&, _
                                 vbNullString, REG_OPTION_NON_VOLATILE, _
                                 KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    End If

    RegCloseKey (hNewKey)

End Sub

Function GetRegistryValue(ByVal hKey As Long, _
                          ByVal KeyName As String, _
                          ByVal ValueName As String, _
                          Optional DefaultValue As Variant) As Variant

    Dim handle As Long
    Dim resLong As Long
    Dim resString As String
    Dim resBinary() As Byte
    Dim length As Long
    Dim retVal As Long
    Dim valueType As Long

    ' Read a Registry value
    '
    ' Use KeyName = "" for the default value
    ' If the value isn't there, it returns the DefaultValue
    ' argument, or Empty if the argument has been omitted
    '
    ' Supports DWORD, REG_SZ, REG_EXPAND_SZ, REG_BINARY and REG_MULTI_SZ
    ' REG_MULTI_SZ values are returned as a null-delimited stream of strings
    ' (VB6 users can use SPlit to convert to an array of string)


    ' Prepare the default result
    GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)

    ' Open the key, exit if not found.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
        Exit Function
    End If

    ' prepare a 1K receiving resBinary
    length = 1024
    ReDim resBinary(0 To length - 1) As Byte

    ' read the registry key
    retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)

    ' if resBinary was too small, try again
    If retVal = ERROR_MORE_DATA Then
        ' enlarge the resBinary, and read the value again
        ReDim resBinary(0 To length - 1) As Byte
        retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
            length)
    End If

    ' return a value corresponding to the value type
    Select Case valueType
        Case REG_DWORD
            CopyMemory resLong, resBinary(0), 4
            GetRegistryValue = resLong
        Case REG_SZ, REG_EXPAND_SZ
            ' copy everything but the trailing null char
            resString = Space$(length - 1)
            CopyMemory ByVal resString, resBinary(0), length - 1
            GetRegistryValue = resString
        Case REG_BINARY
            ' resize the result resBinary
            If length <> UBound(resBinary) + 1 Then
                ReDim Preserve resBinary(0 To length - 1) As Byte
            End If
            GetRegistryValue = resBinary()
        Case REG_MULTI_SZ
            ' copy everything but the 2 trailing null chars
            resString = Space$(length - 2)
            CopyMemory ByVal resString, resBinary(0), length - 2
            GetRegistryValue = resString
        Case Else
            GetRegistryValue = ""
    '        RegCloseKey handle
    '        Err.Raise 1001, , "Unsupported value type"
    End Select

    RegCloseKey handle  ' close the registry key

End Function

Function SetRegistryValue(ByVal hKey As Long, _
                          ByVal KeyName As String, _
                          ByVal ValueName As String, _
                          Value As Variant) As Boolean

    ' Write or Create a Registry value
    ' returns True if successful
    '
    ' Use KeyName = "" for the default value
    '
    ' Value can be an integer value (REG_DWORD), a string (REG_SZ)
    ' or an array of binary (REG_BINARY). Raises an error otherwise.

    Dim handle As Long
    Dim lngValue As Long
    Dim strValue As String
    Dim binValue() As Byte
    Dim byteValue As Byte
    Dim length As Long
    Dim retVal As Long

    ' Open the key, exit if not found
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then
        Err.Raise 1
        Exit Function
    End If

    ' three cases, according to the data type in Value
    Select Case VarType(Value)
        Case vbInteger, vbLong
            lngValue = Value
            retVal = RegSetValueEx(handle, ValueName, 0, REG_DWORD, lngValue, 4)
        Case vbString
            strValue = Value
            retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, Len(strValue))
        Case vbArray
            binValue = Value
            length = UBound(binValue) - LBound(binValue) + 1
            retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, binValue(LBound(binValue)), length)
        Case vbByte
            byteValue = Value
            length = 1
            retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, byteValue, length)
        Case Else
            RegCloseKey handle
            Err.Raise 1001, , "Unsupported value type"
    End Select

    RegCloseKey handle  ' Close the key and signal success

    SetRegistryValue = (retVal = 0)     ' signal success if the value was written correctly

End Function

Answer 1

要尝试调试，请进行下面提到的更改，然后运行测试。如果错误消息指示＆＃39;行号＆＃39;是123，然后需要解决该错误以解决问题。如果没有指示＃行，则错误在其他地方并且可以修复。我们需要知道错误编号和描述。

请尝试以下方法：

替换Function RunReportAsPDF

中的以下代码行

    SetRegistryValue HKEY_CURRENT_USER, ......

    ErrorHandler:....

    If Err.Number <> 0 Then strRegPath = .... 
    On Error GoTo Err_handler

以下内容：

    ' Make sure the 123 (line number below) starts in the first column
    123    SetRegistryValue HKEY_CURRENT_USER, strRegPath, "2", Left(prmPdfName, InStrRev(prmPdfName, "\") - 1)
    Exit Function
    ErrorHandler:
    ' Display the Error info, plus Line number
      Msgbox "Error = & Err.Number & vbtab & Err.Description & vbcrlf & "At Line: " & Erl
      If Err.Number <> 0 Then strRegPath = "Software\Adobe\Acrobat Distiller\10.0\AdobePDFOutputFolder": Err.Clear: Resume 1

    On Error GoTo Err_handler