Ms access 为什么VBA中的代码挂起？
我正在调查一个程序员写的一些软件，在我进入我工作的公司之前 他们有一些VBA代码（在MS Access中）可以复制一些文件、写入表等，在这个过程中，它会挂断。它不会返回任何错误代码或消息（在错误处理程序中或以任何其他方式）。它只是挂断，访问进入“无响应”模式，直到被强制停止 下面是处理“导出”按钮（挂起位置）的VBA代码：Ms access 为什么VBA中的代码挂起？,ms-access,vba,ms-access-2003,Ms Access,Vba,Ms Access 2003,我正在调查一个程序员写的一些软件，在我进入我工作的公司之前 他们有一些VBA代码（在MS Access中）可以复制一些文件、写入表等，在这个过程中，它会挂断。它不会返回任何错误代码或消息（在错误处理程序中或以任何其他方式）。它只是挂断，访问进入“无响应”模式，直到被强制停止 下面是处理“导出”按钮（挂起位置）的VBA代码： Public Sub cmd_export_Click() Dim ws As New WshShell, clsF As New clsNewFile, aspCh
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
' 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
MoveFilemodPDFCreator.RunReportAsPDF "Product Quantity List", strReportsPath & Digits & "_PQL.pdf"
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
' 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
”要调用的函数是RunReportAsPDF
'
'它需要两个参数：运行Access报告
'PDF文件名
'
“享受吧！
'
“埃里克·普罗文彻
'===========================================================
选项比较数据库
私有声明子CopyMemory库“kernel32”_
别名“rtlmovemory”（dest如有_
任何来源_
ByVal（长度为字节）
私有声明函数RegOpenKeyEx Lib“advapi32.dll”_
别名“RegOpenKeyExA”（ByVal hKey，简称_
ByVal lpSubKey作为字符串_
顺便说一句，只要有选择_
拜瓦尔·萨姆林，只要_
phkResult As Long）As Long
私有声明函数RegCloseKey Lib“advapi32.dll”（ByVal hKey作为Long）作为Long
私有声明函数RegCreateKeyEx Lib“advapi32.dll”_
别名“RegCreateKeyExA”（ByVal hKey，简称_
ByVal lpSubKey作为字符串_
拜瓦尔保留了很久_
ByVal lpClass作为字符串_
只要_
拜瓦尔·萨姆林，只要_
ByVal lpSecurityAttributes，只要_
phkResult只要_
LPDW配置为长）为长
私有声明函数RegQueryValueEx Lib“advapi32.dll”_
别名“RegQueryValueExA”（ByVal hKey，简称_
ByVal lpValueName作为字符串_
拜瓦尔：只要_
只要_
如有任何数据_
lpcbData As Long）As Long
私有声明函数RegSetValueEx Lib“advapi32.dll”_
别名“RegSetValueExA”（ByVal hKey，简称_
ByVal lpValueName作为字符串_
拜瓦尔保留了很久_
ByVal dwType，只要_
如有任何数据_
ByVal cbData As Long）As Long
私有声明函数apiFindExecutable Lib“shell32.dll”_
别名“FindExecutableA”（ByVal lpFile作为字符串_
ByVal lpDirectory作为字符串_
ByVal lpResult（作为字符串）的长度
常数REG_SZ=1
常数REG_扩展_SZ=2
常量寄存器二进制=3
常数REG_DWORD=4
常数REG_MULTI_SZ=7
常量错误\u更多\u数据=234
公共工程HKEY\U类\U根=&H8000000
公用工程HKEY\U当前用户=&H80000001
公共工程HKEY\U本地\U机器=&H8000002
常量键读取=&H20019'（（读取控件或键查询值或
'键(枚举)子键(或键)通知)和(非)
“同步”）
常量键写入=&H20006'（（标准权限写入或键设置值或
'键（创建子键）和（不同步））
公共函数RunReportAsPDF（prmRptName作为字符串_
prmPdfName（作为字符串）作为布尔值
'如果已创建PDF文件，则返回TRUE
暗淡的AdobeDevice作为字符串
Dim STRDEFAULT打印机作为字符串
'查找Acrobat PDF设备
AdobeDevice=GetRegistryValue（HKEY\u当前用户_
“软件\Microsoft\WIndows NT\CurrentVersion\Devices”_
“Adobe PDF”）
如果AdobeDevice=“”，则“未找到该设备”
MsgBox“使用此功能前必须安装Acrobat Writer”
RunReportAsPDF=False
退出功能
如果结束
'获取当前默认打印机。
strDefaultPrinter=Application.Printer.DeviceName
设置Application.Printer=Application.Printers（“Adobe PDF”）
'创建Acrobat查找文件名的注册表项
CreateNewRegistryKey HKEY_当前用户_
“软件
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