Почему код в этом VBA висит?

Question

Я изучаю программное обеспечение, написанное программистом, прежде чем я вышел на борт компании, в которой я работаю.

У них есть код VBA (в MS Access), который копирует некоторые файлы, записывает в таблицы и т. Д., И где-то в этом процессе он висит. Он не возвращает никаких кодов ошибок или сообщений (в обработчике ошибок или каким-либо другим способом). Он просто зависает, и Access переходит в режим «Не реагировать», пока он не будет принудительно остановлен.

Вот код 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 в прошлом), и пока я изучаю функции и все, я не могу найти способ выяснить, где и почему это висит так, как оно есть.

Есть ли способ рассказать, что здесь происходит или, может быть, где я должен искать или что я могу сделать, чтобы узнать?

EDIT

Кроме того, если это необходимо знать, я использую Adobe Acrobat 9.0.0 (Только свежеустановленную с DVD).

Новые вещи Найдено

Хорошо, я понял, что есть 3 отдельные проблемы, происходящие здесь, но пока не уверен, как исправить их.

1) Я получаю сообщение об ошибке 58 (Файл уже существует на следующей строке:.

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

Это вполне понятно, так как MoveFile функция в VB не поддерживает перезапись файлов Не уверен, который писал, что, но они упустили из виду главный недостаток есть. Я не планирую использовать CopyFile и затем удалить источник, когда сделано, чтобы решить эту, так что никаких проблем здесь.

2) Я получаю сообщение об ошибке 3043 (Disk или сетевой ошибки) o n следующая строка (о которой @Time Williams спрашивает в комментариях ниже [Я все еще исследую, что там происходит, но я не знаю, где найти местоположение встроенных глобальных функций]):

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

Чтобы попробовать и отладки, внесите изменения, указанные ниже, а затем запустить тест. Если сообщение об ошибке указывает, что номер строки равен 123, эта ошибка должна быть устранена, чтобы исправить проблему. Если указана строка #, ошибка находится в другом месте и может быть исправлена. Нам нужно знать номер ошибки и описание.

Пожалуйста, попробуйте следующее:

Замените следующие строки кода в функции 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