为什么code这个VBA挂？ [英] Why is the code in this VBA hanging?
本文介绍了为什么code这个VBA挂？的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我调查的一些软件编写的程序员之前，我来到船上，在我工作的公司。
他们有一些VBA code（在MS Access），该复制一些文件，写入表等，并某处在这个过程中它是挂起来。它不返回C $ CS或消息（错误处理程序，或以任何其他方式）的任何错误$。它只是挂断电话，并接入进入不响应模式，直到它被强制停止。
下面是VBA code的处理导出按钮（这是它挂）：
公用Sub cmd_export_Click（）
昏暗的WS作为新的WshShell，CLSF作为新clsNewFile，aspChemInv作为MyCstmFile，_
FSO作为新IWshRuntimeLibrary.FileSystemObject，strFileName作为字符串_
FLD作为IWshRuntimeLibrary.Folder，网络作为文件
strFileName =分段（Field0.Value，，）（0）及_cheminv
对错误转到Err_handler
昏暗TblDeltree作为字符串
昏暗的strArrTmpName
strArrTmpName =斯普利特（表单！[主菜单]！[Field0]，）
表名= strArrTmpName（0）及，＆安培; strArrTmpName（1）
如果ISNULL（表单！[主菜单]！[Field0]）= false，那么
I = 0
位数=左（表名，INSTR（1，表名，） - 1）
ShtDigits =左（数字，2）
DoCmd.TransferDatabase acExport，微软访问，_
\\ A02-DS1 \公用\客户\＆放大器; ShtDigits和放大器; \＆安培;数字＆功放; _
\ client.mdb，能够作用，表单！[主菜单]！[Field0]，表名
斯科特要求的变化（见的Email至：罗斯维森特星期三2014年4月16日上午9时26分）
数据计算
II级候选人
还原每口头变化（斯科特·沃恩）2014年5月6日上午10时09分
DoCmd.TransferDatabase acExport，微软访问，_
\\ A02-DS1 \公用\客户\＆放大器; ShtDigits和放大器; \＆安培;数字＆功放; _
\ client.mdb，能够作用，数据计算，数据计算
DoCmd.TransferDatabase acExport，微软访问，_
\\ A02-DS1 \公用\客户\＆放大器; ShtDigits和放大器; \＆安培;数字＆功放; _
\ client.mdb，能够作用，II级考生，II级考生
DoCmd.OpenReportII级考生，acView preVIEW
集RPT = Application.Reports！[II级候选人]
昏暗strReportsPath作为字符串
strReportsPath =\\ A02-DS1 \公用\客户\＆放大器; ShtDigits和放大器; \＆安培;数字＆功放; \
截图RPT
DoCmd.OutputTo acOutputReport，报告，acFormatSNP，strReportsPath和放大器; rpt.Name和放大器; .SNP，0
DoCmd.Close acReport，rpt.Name
DoCmd.OpenReport产品量清单，acView preVIEW
设置RPT = Application.Reports！[产品量清单]
modPDFCreator.RunReportAsPDF产品量清单，strReportsPath和放大器;数字＆功放; _PQL.pdf
其他
MsgBox请选择以下客户端表。，vbExclamation，状态：导出
结束如果
如果不fso.FolderExists（C：\ TEMP），然后fso.CreateFolder（C：\ TEMP）
ws.CurrentDirectory =C：\ TEMP
如果不fso.FolderExists（ws.CurrentDirectory＆安培;\ ESD_Upload），然后fso.CreateFolder ws.CurrentDirectory和放大器; \ ESD_Upload
ws.CurrentDirectory = ws.CurrentDirectory和放大器; \ ESD_Upload
昏暗xFile作为MyCstmFile
设置FLD = fso.GetFolder（\\ A02-DS1 \信封-SCI \ AutoCAD文件\发布）
昏暗strCurrentFile作为字符串
对于每一个网络fld.Files
strCurrentFile = fi.Name
fso.MoveFile fi.Path，ws.CurrentDirectory和放大器; \＆安培; strCurrentFile
下一个
昏暗tmpMSDS作为新clsChemicalInventory
fso.CopyFile\\ A02-DS1 \ applicationDatabase $ \ MSDS.mdb，ws.CurrentDirectory和放大器; \＆安培; fGetUserName _
＆放大器; 的.mdb，真
tmpMSDS.CreateMSDS数字，ws.CurrentDirectory和放大器; \＆安培; fGetUserName和放大器; 的.mdb
设置FLD = fso.GetFolder（ws.CurrentDirectory）
对于每一个网络fld.Files
如果INSTR（1，fi.Name，名.txt）= 0，INSTR（1，fi.Name的.mdb）= 0然后_
fso.CopyFile fi.Name，\\ A02-DS1 \先锋网站\ OHMMP \客户\，真
如果INSTR（1，fi.Name，layout.pdf）＆LT;＆GT; 0然后_
fso.CopyFile fi.Name，\\ A02-DS1 \ PUBLIC \ CLIENTS \布局\，真正：_
fso.CopyFile fi.Name，\\ A01-DC1 \用户$ \，真
如果INSTR（1，fi.Name，_msds_）＆LT;＆GT; 0然后_
fso.CopyFile fi.Name，\\ A01-DC1 \用户$ \，真
下一个
ws.CurrentDirectory =C：\ TEMP
fso.DeleteFolder ws.CurrentDirectory和放大器; \ ESD_Upload
设置FSO =什么
设置FLD =无
设置WS =无
MSGBOX导出已完成
Exit_Handler：
退出小组
Err_handler：
如果Err.Number的= 70然后
MSGBOX文件＆放大器; strCurrentFile和放大器; 已打开，vbOKOnly，打开文件
其他
MSGBOX为试图完成这个任务发生了一个错误。 _
＆放大器; vbCrLf＆安培; 请报告以下错误您的IT部门：_
＆放大器; vbCrLf＆安培; Err.Number的＆放大器; ：＆安培; vbCrLf＆安培; Err.Description它将，vbCritical，错误
结束如果
'恢复
简历Exit_Handler
结束小组
用VB不幸的是我没有太多的经验（我用的大多是SQL过去），虽然我一直在研究的功能，并且所有，我似乎无法找到一个方法来找出其中，或者为什么这个是挂起来的方式，它是。
有没有办法告诉这是怎么回事就在这里，或许，我应该在哪里看还是我能做些什么，找出？
修改
此外，如果有必要知道，我使用Adobe Acrobat 9.0.0（只是刚刚从DVD安装）。
新东西上
好了，我已经意识到有这里发生了3个独立的问题，但目前还不能确定如何解决这些问题。
1）我得到一个错误58（文件以下行已存在：
fso.MoveFile fi.Path，ws.CurrentDirectory和放大器; \＆安培; strCurrentFile
这是完全可以理解的，因为在VB中 MoveFile 功能不支持文件的覆盖。不知道是谁写的，但他们忽略了一个重大缺陷存在。我计划使用的CopyFile，然后删除源做来解决这一个时候，所以这里没有问题。
2）我收到（错误3043（磁盘或网络错误）在下面的行@time威廉姆斯在下面[我仍在调查发生了什么事情有意见问，但我不知道在哪里可以找到自建全局函数的位置）：
tmpMSDS.CreateMSDS数字，ws.CurrentDirectory和放大器; \＆安培; fGetUserName和放大器; 的.mdb
3），这是程序挂起：
modPDFCreator.RunReportAsPDF产品量清单，strReportsPath和放大器;数字＆功放; _PQL.pdf
这仍然是一个完整的拼图给我，因为我从来没有使用过任何这样的方法之前，任何语言。任何帮助，可以认为是缩小这一轮下来（或＃2的问题，上文）将大大AP preciated。
好吧，即使更多的东西找到
modPDFCreator：
'调用的函数是RunReportAsPDF
这需要两个参数：Access报表运行
PDF文件名
' 享受！
埃里克·普罗文
================================================= ==========
选项比较数据库
私人声明子CopyMemory的库KERNEL32_
别名RtlMoveMemory（目标为已任，_
源为已任，_
BYVAL的numBytes作为龙）
私人声明函数RegOpenKeyEx的库ADVAPI32.DLL_
别名RegOpenKeyExA（BYVAL的hKey长，_
BYVAL lpSubKey作为字符串_
BYVAL ulOptions长，_
BYVAL samDesired长，_
phkResult长）只要
私人声明函数RegCloseKey库ADVAPI32.DLL（BYVAL的hKey长）只要
私人声明函数函数RegCreateKeyEx库ADVAPI32.DLL_
别名RegCreateKeyExA（BYVAL的hKey长，_
BYVAL lpSubKey作为字符串_
BYVAL保留长，_
BYVAL lpClass作为字符串_
BYVAL dwOptions长，_
BYVAL samDesired长，_
BYVAL lpSecurityAttributes长，_
phkResult长，_
lpdwDisposition长）只要
私人声明函数的RegQueryValueEx库ADVAPI32.DLL_
别名函数RegQueryValueExA（BYVAL的hKey长，_
BYVAL lpValueName作为字符串_
BYVAL升preserved长，_
lpType长，_
lpData所为已任，_
参数lpcbData长）只要
私人声明函数函数RegSetValueEx库ADVAPI32.DLL_
别名RegSetValueExA（BYVAL的hKey长，_
BYVAL lpValueName作为字符串_
BYVAL保留长，_
BYVAL dwType长，_
lpData所为已任，_
BYVAL cbData长）只要
私人声明函数apiFindExecutable库SHELL32.DLL_
别名FindExecutableA（BYVAL参数lpFile作为字符串_
BYVAL lpDirectory作为字符串_
BYVAL升presult作为字符串）只要
常量REG_SZ = 1
常量REG_EXPAND_SZ = 2
常量REG_BINARY = 3
常量REG_DWORD = 4
常量REG_MULTI_SZ = 7
常量ERROR_MORE_DATA = 234
公共常量HKEY_CLASSES_ROOT =安培; H80000000
公共常量HKEY_CURRENT_USER =＆放大器; H80000001
公共常量HKEY_LOCAL_MACHINE =安培; H80000002
常量KEY_READ =安培; H20019（（READ_CONTROL或者KEY_QUERY_VALUE或者
KEY_ENUMERATE_SUB_KEYS或者KEY_NOTIFY）和（非
的同步））
常量KEY_WRITE =安培; H20006（（STANDARD_RIGHTS_WRITE或者KEY_SET_VALUE或者
KEY_CREATE_SUB_KEY）和（不同步））
公共功能RunReportAsPDF（prmRptName作为字符串_
prmPdfName作为字符串）作为布尔
如果已创建一个PDF文件，则返回TRUE
昏暗AdobeDevice作为字符串
昏暗strDefaultPrinter作为字符串
找到Acrobat PDF格式的装置
AdobeDevice = GetRegistryValue（HKEY_CURRENT_USER，_
软件\微软\的Windows NT \ CURRENTVERSION \设备，_
的Adobe PDF）
如果AdobeDevice =然后设备未找到
MSGBOX您必须安装Acrobat作家使用此功能之前
RunReportAsPDF =假
退出功能
结束如果
获取当前的默认打印机。
strDefaultPrinter = Application.Printer.DeviceName
设置Application.Printer = Application.Printers（的Adobe PDF）
创建注册表项，其中Acrobat中查找一个文件名
CreateNewRegistryKey HKEY_CURRENT_USER，_
SOFTWARE \的Adobe \ Acrobat Distiller中\ PrinterJobControl
将输出文件名，其中Acrobat中可以找到它
SetRegistryValue HKEY_CURRENT_USER，_
SOFTWARE \的Adobe \ Acrobat Distiller中\ PrinterJobControl，_
Find_Exe_Name（CurrentDb.Name，CurrentDb.Name），_
prmPdfName
昏暗oShell作为对象
昏暗strRegKey作为字符串
设置oShell =的CreateObject（WScript.Shell的）
对错误转到的ErrorHandler
strRegKey = oShell.RegRead（HKEY_CURRENT_USER \ SOFTWARE \的Adobe \ Acrobat Distiller中\ 10.0 \ AdobePDFOutputFolder \ 1）
如果Err.Number的= -2147024893然后
''code。如果该键不存在
MSGBOX关键不存在
' 其他
''code。如果密钥确实存在
MSGBOX关键的存在
结束如果
昏暗strRegPath作为字符串
strRegPath =SOFTWARE \的Adobe \ Acrobat Distiller中\ 9.0 \ AdobePDFOutputFolder
1：
SetRegistryValue HKEY_CURRENT_USER，strRegPath，2，左（prmPdfName，InStrRev（prmPdfName，\） - 1）
的ErrorHandler：
如果Err.Number的＆LT;＆GT; 0然后strRegPath =SOFTWARE \的Adobe \ Acrobat Distiller中\ 10.0 \ AdobePDFOutputFolder：Err.Clear：简历1
对错误转到Err_handler
昏暗strReportName作为字符串
strReportName =左（右（prmPdfName，莱恩（prmPdfName） - InStrRev（prmPdfName，\）），_
莱恩（右（prmPdfName，莱恩（prmPdfName） - InStrRev（prmPdfName，\））） - 4）
DoCmd.CopyObject，strReportName，acReport，prmRptName
DoCmd.OpenReport strReportName，acViewNormal运行报告
DoCmd.DeleteObject acReport，strReportName
虽然莱恩（迪尔（prmPdfName））= 0'等待PDF到实际存在
的DoEvents
蜿蜒
RunReportAsPDF =真正的'任务完成了！
Normal_Exit：
设置Application.Printer = Application.Printers（strDefaultPrinter）恢复默认打印机
对错误转到0
退出功能
Err_handler：
如果Err.Number的= 2501然后该报告没有正常运行（例如无数据）
RunReportAsPDF =假
简历Normal_Exit
其他
RunReportAsPDF =假该报告没有正常运行（什么都重要！）
MSGBOX意外错误＃＆放大器; Err.Number的＆放大器; - ＆安培; Err.Description它将
简历Normal_Exit
结束如果
端功能
公共功能Find_Exe_Name（prmFile作为字符串_
prmDir作为字符串）作为字符串
昏暗Return_ code以龙
昏暗RETURN_VALUE作为字符串
RETURN_VALUE =空间（260）
Return_ code = apiFindExecutable（prmFile，prmDir，RETURN_VALUE）
如果Return_ code取代; 32然后
Find_Exe_Name = RETURN_VALUE
其他
Find_Exe_Name =错误：未找到文件
结束如果
端功能
公用Sub CreateNewRegistryKey（PRM predefKey长，_
prmNewKey作为字符串）
举例1：CreateNewRegistryKey HKEY_CURRENT_USER，密押
创建HKEY_CURRENT_USER下立即打电话密押关键。
例2：CreateNewRegistryKey HKEY_LOCAL_MACHINE，密押\ SubKey1 \ SubKey2
创建马上开始下与密押三嵌套键
HKEY_LOCAL_MACHINE，SubKey1从属于密押，并SubKey3 SubKey2下。
昏暗hNewKey只要'句柄新的密钥
昏暗lRetVal作为函数RegCreateKeyEx函数龙的结果
lRetVal = RegOpenKeyEx的（PRM predefKey，prmNewKey，0，KEY_ALL_ACCESS，的hKey）
如果lRetVal＆LT;＆GT; 5然后
lRetVal =函数RegCreateKeyEx（PRM predefKey，prmNewKey，0安培;，_
vbNullString，REG_OPTION_NON_VOLATILE，_
KEY_ALL_ACCESS，0安培;, hNewKey，lRetVal）
结束如果
RegCloseKey（hNewKey）
结束小组
功能GetRegistryValue（BYVAL的hKey长，_
BYVAL KeyName是作为字符串_
BYVAL ValueName的作为字符串_
可选默认值为Variant）为Variant
昏暗的处理只要
昏暗resLong只要
昏暗resString作为字符串
昏暗resBinary（）作为字节
昏暗的长度长
昏暗retVal的长
昏暗VALUETYPE只要
读取注册表值
使用KeyName是=为默认值
如果该值不存在，则返回默认值
的说法，或者空当参数被省略
支持DWORD，REG_SZ，REG_EXPAND_SZ，REG_BINARY和REG_MULTI_SZ
REG_MULTI_SZ值的返回字符串的空分隔的流
（VB6用户可以使用SPLIT转换为字符串数组）
'prepare默认结果
GetRegistryValue = IIF（ISMISSING（默认值），空，默认值）
如果没有找到开关键，退出。
如果RegOpenKeyEx的（的hKey，注册表，0，KEY_READ，手柄）然后
退出功能
结束如果
'prepare一个1K接收resBinary
长度= 1024
REDIM resBinary（0长度 - 1）为字节
读取注册表键
retVal的=的RegQueryValueEx（手柄，ValueName的，0，VALUETYPE，resBinary（0），长度）
如果resBinary太小，再试一次
如果retVal的= ERROR_MORE_DATA然后
扩大resBinary，并重新读取的值
REDIM resBinary（0长度 - 1）为字节
retVal的=的RegQueryValueEx（手柄，ValueName的，0，值类型，resBinary（0），_
长度）
结束如果
'返回对应于该值的类型的值
选择案例VALUETYPE
案例REG_DWORD
CopyMemory的resLong，resBinary（0），4
GetRegistryValue = resLong
案例REG_SZ，REG_EXPAND_SZ
'复制一切，但结尾的空字符
resString =空间$（长度 - 1）
CopyMemory的BYVAL resString，resBinary（0），长度为 - 1
GetRegistryValue = resString
案例REG_BINARY
调整的结果resBinary
如果长度LT;＆GT; UBound函数（resBinary）+ 1然后
REDIM preserve resBinary（0长度 - 1）为字节
结束如果
GetRegistryValue = resBinary（）
案例REG_MULTI_SZ
'复制一切，但2结尾的空字符
resString =空间$（长度 - 2）
CopyMemory的BYVAL resString，resBinary（0），长度 - 2
GetRegistryValue = resString
案例否则
GetRegistryValue =
RegCloseKey手柄
Err.Raise 1001，不支持的值类型
最终选择
RegCloseKey手柄关闭注册表键
端功能
功能SetRegistryValue（BYVAL的hKey长，_
BYVAL KeyName是作为字符串_
BYVAL ValueName的作为字符串_
价值变体）作为布尔
写或者创建一个注册表值
返回True如果成功
使用KeyName是=为默认值
值可以是一个整数（REG_DWORD），一个字符串（REG_SZ）
二进制（REG_BINARY）'或阵列。否则会产生错误。
昏暗的处理只要
昏暗lngValue只要
昏暗strValue中作为字符串
昏暗binValue（）作为字节
昏暗的byteValue为字节
昏暗的长度长
昏暗retVal的长
如果没有找到开关键，退出
如果RegOpenKeyEx的（的hKey，注册表，0，KEY_WRITE，手柄）然后
Err.Raise 1
退出功能
结束如果
三种情况下，根据值的数据类型
选择案例VarType函数（值）
案例vbInteger，vbLong
lngValue =价值
retVal的=函数RegSetValueEx（手柄，ValueName的，0，REG_DWORD，lngValue，4）
案例vbString
将strValue =价值
retVal的=函数RegSetValueEx（手柄，ValueName的，0，REG_SZ，BYVAL strValue中，莱恩（strValue的））
案例的VBArray
binValue =价值
长度= UBound函数（binValue） - LBOUND（binValue）+1
retVal的=函数RegSetValueEx（手柄，ValueName的，0，REG_BINARY，binValue（LBOUND（binValue）），长度）
案例vbByte
=的byteValue价值
长度= 1
retVal的=函数RegSetValueEx（手柄，ValueName的，0，REG_BINARY，的byteValue，长度）
案例否则
RegCloseKey处理
Err.Raise 1001，不支持的值类型
最终选择
RegCloseKey手柄关闭键和信号成功
SetRegistryValue =（retVal的= 0）信号，如果该值是正确写入成功
端功能
解决方案
要尝试和调试，使以下提到的更改，然后运行测试。如果错误信息表示行号为123，则需要这个错误得到解决，以解决这个问题。如果没有线路＃指出的，误差是在别处，并且可以是固定的。我们需要知道的错误号和说明。
请尝试以下方法：
替换code以下行的功能RunReportAsPDF
SetRegistryValue HKEY_CURRENT_USER，......
的ErrorHandler：....
如果Err.Number的＆LT;＆GT; 0然后strRegPath = ....
对错误转到Err_handler
通过如下：
确保（如下行号）的123开始在第一列
123 SetRegistryValue HKEY_CURRENT_USER，strRegPath，2，左（prmPdfName，InStrRev（prmPdfName，\） - 1）
退出功能
的ErrorHandler：
显示错误信息，加上行号
MSGBOX错误=安培; Err.Number的＆放大器; vbtab和放大器; Err.Description它将和放大器; vbcrlf＆安培;在行：＆放大器; Erl的
如果Err.Number的＆LT;＆GT; 0然后strRegPath =SOFTWARE \的Adobe \ Acrobat Distiller中\ 10.0 \ AdobePDFOutputFolder：Err.Clear：简历1
对错误转到Err_handler
I am investigating some software written by a programmer before I came on-board at the company I work for.
They have some VBA code (in MS Access) that copies some files, writes to tables, etc., and somewhere in this process it is hanging up. It doesn't return any error codes or messages (in the error handler or in any other way). It just hangs up and Access goes into the "Not Responding" mode until it is forcibly stopped.
Here is the VBA code which handles the "Export" button (which is where it hangs):
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
Unfortunately I haven't had too much experience with VB (I've used mostly SQL in the past) and while I've been researching the functions, and all, I can't seem to find a way to figure out where or why this is hanging up in the way that it is.
Is there any way to tell what's going on here or, perhaps, where I should look or what I can do to find out?
EDIT
Also, if it's necessary to know, I am using Adobe Acrobat 9.0.0 (Just freshly installed from DVD).
New Things Found
Okay, I've realized there are 3 separate issues going on here, but not sure yet how to fix them.
1) I get an Error 58 (File already exists on the following line:
fso.MoveFile fi.Path, ws.CurrentDirectory & "\" & strCurrentFile
This is completely understandable since the MoveFile function in VB doesn't support the overwriting of files. Not sure who wrote that, but they overlooked a major flaw there. I plan on using CopyFile and then deleting the source when done to solve this one, so no problems here.
2) I am getting an error 3043 (Disk or Network Error) on the following line (which @Time Williams asked about in the comments below [I'm still investigating what's going on there, but I don't know where to find the location of self-built global functions]):
tmpMSDS.CreateMSDS Digits, ws.CurrentDirectory & "\" & fGetUserName & ".mdb"
3) And THIS is where the program hangs:
modPDFCreator.RunReportAsPDF "Product Quantity List", strReportsPath & Digits & "_PQL.pdf"
This is still a complete puzzle to me, because I've never used any method like this before, in any language. Any help that can be suggested as to narrowing this one down (or the problem in #2, above) will be much appreciated.
Okay, Even More Stuff Found
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
解决方案
To try and debug, make the changes mentioned below, then run your test. If the error message indicates the 'line number' is 123, then that error needs to be resolved to fix the issue. If there is no line # indicated, the error is elsewhere and can be fixed. We need to know the error number and description.
Please try the following:
Replace the following lines of code in Function RunReportAsPDF
SetRegistryValue HKEY_CURRENT_USER, ......
ErrorHandler:....
If Err.Number <> 0 Then strRegPath = ....
On Error GoTo Err_handler
With the following:
' 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
这篇关于为什么code这个VBA挂？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
