[求助]用vb批量处理文件的通用程序

citykunan

咳，我对vb不懂，老板还是要我做真是急死人。还请版主们救救我啊。

tiger8888

1. 我想我给你贴的代码你没有看吧，我再贴一次好了，你在我指出的地方sendcommand加载你的lisp，请试一下，看行不行。

复制代码

2. Private Type BrowseInfo
3.          hWndOwner As Long
4.          pIDLRoot As Long
5.          pszDisplayName As Long
6.          lpszTitle As Long
7.          ulFlags As Long
8.          lpfnCallback As Long
9.          lParam As Long
10.          iImage As Long
11. End TypePrivate Const BIF_RETURNONLYFSDIRS = 1
12. Private Const MAX_PATH = 260
13. 'Public Declare function GetVersion Lib "Kernel32" () As Integer
14. Private Declare function GetCommandLine Lib "Kernel32" Alias "GetCommandLineA" () As String
15. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
16. Private Declare function lstrcat Lib "Kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
17. Private Declare function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
18. Private Declare function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As LongPublic Sub qdtubl()
19. Dim inDir As String
20. Dim elem
21. Dim filenom As String
22. Dim WholeFile As String
23. Dim newHeight As Double
24. Dim tufu As String
25. Dim neirong33 As String
26. inDir = ""
27. inDir = ThisDrawing.BrowseForFolder("请选择目录：")
28. If inDir = "" Then Exit Sub
29. If Right(inDir, 1) = "" Then inDir = Left(inDir, Len(inDir) - 1)
30. filenom = Dir$(inDir & "\*.dwg")
31. 'On Error GoTo errorcontrol
33. Do While filenom <> ""
34.       
35.        WholeFile = inDir & "" & filenom
36.        ThisDrawing.Application.Documents.Open WholeFile在这里加入你的sendcommand代码
37.                ThisDrawing.Application.ActiveDocument.Close         filenom = Dir$
39. Loop
40. Exit Suberrorcontrol:
41. MsgBox "错误，程序退出！"
42. End SubPublic function BrowseForFolder(sPrompt As String) As String
43. 'Public function BrowseForFolder(hWndOwner As Long, sPrompt As String) As StringDim iNull As Integer
44. Dim lpIDList As Long
45. Dim lResult As Long
46. Dim sPath As String
47. Dim udtBI As BrowseInfo
48.        With udtBI
49.    '           .hWndOwner = hWndOwner
50.                .lpszTitle = lstrcat(sPrompt, "")
51.                .ulFlags = BIF_RETURNONLYFSDIRS
52.        End With       lpIDList = SHBrowseForFolder(udtBI)       If lpIDList Then
53.                sPath = String$(MAX_PATH, 0)
54.              lResult = SHGetPathFromIDList(lpIDList, sPath)
55.                Call CoTaskMemFree(lpIDList)
56.                iNull = InStr(sPath, vbNullChar)               If iNull Then
57.                        sPath = Left$(sPath, iNull - 1)
58.                End If       End If       BrowseForFolder = sPath
59. End Function

Private Type BrowseInfo          hWndOwner As Long          pIDLRoot As Long          pszDisplayName As Long          lpszTitle As Long          ulFlags As Long          lpfnCallback As Long          lParam As Long          iImage As Long End TypePrivate Const BIF_RETURNONLYFSDIRS = 1 Private Const MAX_PATH = 260 'Public Declare function GetVersion Lib "Kernel32" () As Integer Private Declare function GetCommandLine Lib "Kernel32" Alias "GetCommandLineA" () As String Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Private Declare function lstrcat Lib "Kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Private Declare function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Private Declare function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As LongPublic Sub qdtubl() Dim inDir As String Dim elem Dim filenom As String Dim WholeFile As String Dim newHeight As Double Dim tufu As String Dim neirong33 As String inDir = "" inDir = ThisDrawing.BrowseForFolder("请选择目录：") If inDir = "" Then Exit Sub If Right(inDir, 1) = "" Then inDir = Left(inDir, Len(inDir) - 1) filenom = Dir$(inDir & "\*.dwg") 'On Error GoTo errorcontrol Do While filenom <> ""               WholeFile = inDir & "" & filenom        ThisDrawing.Application.Documents.Open WholeFile在这里加入你的sendcommand代码                ThisDrawing.Application.ActiveDocument.Close         filenom = Dir$ Loop Exit Suberrorcontrol: MsgBox "错误，程序退出！" End SubPublic function BrowseForFolder(sPrompt As String) As String 'Public function BrowseForFolder(hWndOwner As Long, sPrompt As String) As StringDim iNull As Integer Dim lpIDList As Long Dim lResult As Long Dim sPath As String Dim udtBI As BrowseInfo        With udtBI    '           .hWndOwner = hWndOwner                .lpszTitle = lstrcat(sPrompt, "")                .ulFlags = BIF_RETURNONLYFSDIRS        End With       lpIDList = SHBrowseForFolder(udtBI)       If lpIDList Then                sPath = String$(MAX_PATH, 0)              lResult = SHGetPathFromIDList(lpIDList, sPath)                Call CoTaskMemFree(lpIDList)                iNull = InStr(sPath, vbNullChar)               If iNull Then                        sPath = Left$(sPath, iNull - 1)                End If       End If       BrowseForFolder = sPath End Function

citykunan

好像不行。我上传了lisp，好像程序不能运行。再帮我看看，谢谢。

tiger8888

可以运行阿，我用你的lisp把cad/sample下的dwg全部打印成了dwf文件了，运行的很好，vba和lisp结合的很好，也没有命令顺序混乱的现象，现在我把所有的代码全都贴一次，你再试试，我这里一点问题都没有（我是2004） 下面这个是你那个lisp，我只修改了filedia的设置和dwf打印机的名称下面这个是vba的代码，你把它复制下来，粘贴在thisdrawing的code区

3. Private Type BrowseInfo
4.          hWndOwner As Long
5.          pIDLRoot As Long
6.          pszDisplayName As Long
7.          lpszTitle As Long
8.          ulFlags As Long
9.          lpfnCallback As Long
10.          lParam As Long
11.          iImage As Long
12. End TypePrivate Const BIF_RETURNONLYFSDIRS = 1
13. Private Const MAX_PATH = 260
14. 'Public Declare function GetVersion Lib "Kernel32" () As Integer
15. Private Declare Function GetCommandLine Lib "Kernel32" Alias "GetCommandLineA" () As String
16. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
17. Private Declare Function lstrcat Lib "Kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
18. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
19. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As LongPublic Sub qdtubl()
20. Dim inDir As String
21. Dim elem
22. Dim filenom As String
23. Dim WholeFile As String
24. Dim newHeight As Double
25. Dim tufu As String
26. Dim neirong33 As String
27. inDir = ""
28. inDir = ThisDrawing.BrowseForFolder("请选择目录：")
29. If inDir = "" Then Exit Sub
30. If Right(inDir, 1) = "" Then inDir = Left(inDir, Len(inDir) - 1)
31. filenom = Dir$(inDir & "\*.dwg")
32. On Error GoTo errorcontrolDo While filenom <> ""
33.       
34.        WholeFile = inDir & "" & filenom
35.        ThisDrawing.Application.Documents.Open WholeFile'在这里加入你的sendcommand代码
36. '输出dwf文件（运行plo.lisp文件）ThisDrawing.SendCommand "(load " & Chr(34) & "plo.lsp" & Chr(34) & ")" & vbCr               ThisDrawing.Application.ActiveDocument.Close false       filenom = Dir$Loop
37. Exit Suberrorcontrol:
38. MsgBox "错误，程序退出！"
39. End SubPublic Function BrowseForFolder(sPrompt As String) As String
40. 'Public function BrowseForFolder(hWndOwner As Long, sPrompt As String) As StringDim iNull As Integer
41. Dim lpIDList As Long
42. Dim lResult As Long
43. Dim sPath As String
44. Dim udtBI As BrowseInfo
45.        With udtBI
46.    '           .hWndOwner = hWndOwner
47.                .lpszTitle = lstrcat(sPrompt, "")
48.                .ulFlags = BIF_RETURNONLYFSDIRS
49.        End With       lpIDList = SHBrowseForFolder(udtBI)       If lpIDList Then
50.                sPath = String$(MAX_PATH, 0)
51.              lResult = SHGetPathFromIDList(lpIDList, sPath)
52.                Call CoTaskMemFree(lpIDList)
53.                iNull = InStr(sPath, vbNullChar)               If iNull Then
54.                        sPath = Left$(sPath, iNull - 1)
55.                End If       End If       BrowseForFolder = sPath
56. End Function

Private Type BrowseInfo          hWndOwner As Long          pIDLRoot As Long          pszDisplayName As Long          lpszTitle As Long          ulFlags As Long          lpfnCallback As Long          lParam As Long          iImage As Long End TypePrivate Const BIF_RETURNONLYFSDIRS = 1 Private Const MAX_PATH = 260 'Public Declare function GetVersion Lib "Kernel32" () As Integer Private Declare Function GetCommandLine Lib "Kernel32" Alias "GetCommandLineA" () As String Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Private Declare Function lstrcat Lib "Kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As LongPublic Sub qdtubl() Dim inDir As String Dim elem Dim filenom As String Dim WholeFile As String Dim newHeight As Double Dim tufu As String Dim neirong33 As String inDir = "" inDir = ThisDrawing.BrowseForFolder("请选择目录：") If inDir = "" Then Exit Sub If Right(inDir, 1) = "" Then inDir = Left(inDir, Len(inDir) - 1) filenom = Dir$(inDir & "\*.dwg") On Error GoTo errorcontrolDo While filenom <> ""               WholeFile = inDir & "" & filenom        ThisDrawing.Application.Documents.Open WholeFile'在这里加入你的sendcommand代码 '输出dwf文件（运行plo.lisp文件）ThisDrawing.SendCommand "(load " & Chr(34) & "plo.lsp" & Chr(34) & ")" & vbCr               ThisDrawing.Application.ActiveDocument.Close false       filenom = Dir$Loop Exit Suberrorcontrol: MsgBox "错误，程序退出！" End SubPublic Function BrowseForFolder(sPrompt As String) As String 'Public function BrowseForFolder(hWndOwner As Long, sPrompt As String) As StringDim iNull As Integer Dim lpIDList As Long Dim lResult As Long Dim sPath As String Dim udtBI As BrowseInfo        With udtBI    '           .hWndOwner = hWndOwner                .lpszTitle = lstrcat(sPrompt, "")                .ulFlags = BIF_RETURNONLYFSDIRS        End With       lpIDList = SHBrowseForFolder(udtBI)       If lpIDList Then                sPath = String$(MAX_PATH, 0)              lResult = SHGetPathFromIDList(lpIDList, sPath)                Call CoTaskMemFree(lpIDList)                iNull = InStr(sPath, vbNullChar)               If iNull Then                        sPath = Left$(sPath, iNull - 1)                End If       End If       BrowseForFolder = sPath End Function

tiger8888

刚才又试了几次，还是可能会出现命令混乱的现象，主要表现在cad一张张打开图的时候，我同时点了几下鼠标，就可能出现命令混乱。明主说这是cad的bug，我想那就是很难解决的了，不过对你这个lisp来说，我想如果都改写为vba的话，应该不是很难的事。不过citykunan是作lisp，我想干脆plo.lsp文件就一句话一条命令好了： (command "-plot" "no" "model" "" "DWF6 ePlot.pc3"
(strcat "c:\\lhy_leo" "\\" (vl-filename-base (getvar "dwgname"))) "n" "y") 这样我试了试，点击鼠标试图干扰cad，没什么作用，程序顺利运行。 另外：好像filedia对lisp不起什么作用，上一个帖子我把你注释掉的改成语句是画蛇添足了。

citykunan

你这是vba，我是想用vb，在cad外做一个*.exe文件，双击此文件，能选择目录，选取dwg 文件，在打开cad，分别加载lisp程序，不知可以否？

雪山飞狐_lzh

可以这样试试：


用Lisp做一个反应器，触发条件为Users1值为“VB－Cad”，Users2的值改变


触发处理就是调用对应路径（Users2的值）的Lisp文件，Lisp文件全部用VL改写


VB端改变Users1、Users2的值

tiger8888

to citykunan其实把vba程序改成vb程序不是很难的。按你的要求，我已经把vba改写成了vb，程序代码如下，窗体上加个按钮（command1），点击按钮就可以打开cad，把选定的目录文件打印成dwf了。别忘记在reference中添加cad的引用。

2. Option Explicit
3. Private Type BrowseInfo
4.          hWndOwner As Long
5.          pIDLRoot As Long
6.          pszDisplayName As Long
7.          lpszTitle As Long
8.          ulFlags As Long
9.          lpfnCallback As Long
10.          lParam As Long
11.          iImage As Long
12. End TypePrivate Const BIF_RETURNONLYFSDIRS = 1
13. Private Const MAX_PATH = 260
14. 'Public Declare function GetVersion Lib "Kernel32" () As Integer
15. Private Declare Function GetCommandLine Lib "Kernel32" Alias "GetCommandLineA" () As String
16. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
17. Private Declare Function lstrcat Lib "Kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
18. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
19. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
20. Public Function BrowseForFolder(sPrompt As String) As String
21. 'Public function BrowseForFolder(hWndOwner As Long, sPrompt As String) As StringDim iNull As Integer
22. Dim lpIDList As Long
23. Dim lResult As Long
24. Dim sPath As String
25. Dim udtBI As BrowseInfo
26.        With udtBI
27.    '           .hWndOwner = hWndOwner
28.                .lpszTitle = lstrcat(sPrompt, "")
29.                .ulFlags = BIF_RETURNONLYFSDIRS
30.        End With       lpIDList = SHBrowseForFolder(udtBI)       If lpIDList Then
31.                sPath = String$(MAX_PATH, 0)
32.              lResult = SHGetPathFromIDList(lpIDList, sPath)
33.                Call CoTaskMemFree(lpIDList)
34.                iNull = InStr(sPath, vbNullChar)               If iNull Then
35.                        sPath = Left$(sPath, iNull - 1)
36.                End If       End If       BrowseForFolder = sPath
37. End FunctionPrivate Sub Command1_Click()
38. Dim inDir As String
39. Dim elem
40. Dim filenom As String
41. Dim WholeFile As String
42. Dim newHeight As Double
43. Dim tufu As String
44. Dim neirong33 As String
45. inDir = ""
46. inDir = BrowseForFolder("请选择目录：")
47. If inDir = "" Then Exit Sub
48. If Right(inDir, 1) = "" Then inDir = Left(inDir, Len(inDir) - 1)
49. filenom = Dir$(inDir & "\*.dwg")Dim acadApp As AcadApplication
50. Set acadApp = CreateObject("AutoCAD.Application")On Error GoTo errorcontrol
51. Do While filenom <> ""
52.       
53.        WholeFile = inDir & "" & filenom
54.        acadApp.Documents.Open WholeFile'在这里加入你的sendcommand代码
55. '输出dwf文件（运行plo.lisp文件）
56. acadApp.ActiveDocument.SendCommand "(load " & Chr(34) & "plo.lsp" & Chr(34) & ")" & vbCr
57. acadApp.ActiveDocument.Close False
58.        filenom = Dir$Loop
59. acadApp.Quit
60. Exit Suberrorcontrol:
61. MsgBox "错误，程序退出！"
62. End Sub  

Option Explicit Private Type BrowseInfo          hWndOwner As Long          pIDLRoot As Long          pszDisplayName As Long          lpszTitle As Long          ulFlags As Long          lpfnCallback As Long          lParam As Long          iImage As Long End TypePrivate Const BIF_RETURNONLYFSDIRS = 1 Private Const MAX_PATH = 260 'Public Declare function GetVersion Lib "Kernel32" () As Integer Private Declare Function GetCommandLine Lib "Kernel32" Alias "GetCommandLineA" () As String Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long) Private Declare Function lstrcat Lib "Kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Public Function BrowseForFolder(sPrompt As String) As String 'Public function BrowseForFolder(hWndOwner As Long, sPrompt As String) As StringDim iNull As Integer Dim lpIDList As Long Dim lResult As Long Dim sPath As String Dim udtBI As BrowseInfo        With udtBI    '           .hWndOwner = hWndOwner                .lpszTitle = lstrcat(sPrompt, "")                .ulFlags = BIF_RETURNONLYFSDIRS        End With       lpIDList = SHBrowseForFolder(udtBI)       If lpIDList Then                sPath = String$(MAX_PATH, 0)              lResult = SHGetPathFromIDList(lpIDList, sPath)                Call CoTaskMemFree(lpIDList)                iNull = InStr(sPath, vbNullChar)               If iNull Then                        sPath = Left$(sPath, iNull - 1)                End If       End If       BrowseForFolder = sPath End FunctionPrivate Sub Command1_Click() Dim inDir As String Dim elem Dim filenom As String Dim WholeFile As String Dim newHeight As Double Dim tufu As String Dim neirong33 As String inDir = "" inDir = BrowseForFolder("请选择目录：") If inDir = "" Then Exit Sub If Right(inDir, 1) = "" Then inDir = Left(inDir, Len(inDir) - 1) filenom = Dir$(inDir & "\*.dwg")Dim acadApp As AcadApplication Set acadApp = CreateObject("AutoCAD.Application")On Error GoTo errorcontrol Do While filenom <> ""               WholeFile = inDir & "" & filenom        acadApp.Documents.Open WholeFile'在这里加入你的sendcommand代码 '输出dwf文件（运行plo.lisp文件） acadApp.ActiveDocument.SendCommand "(load " & Chr(34) & "plo.lsp" & Chr(34) & ")" & vbCr acadApp.ActiveDocument.Close False        filenom = Dir$Loop acadApp.Quit Exit Suberrorcontrol: MsgBox "错误，程序退出！" End Sub  

citykunan

谢谢各位热心人，可以了。但是如果dwg文件很大的话，是不是会出现混乱的现象？不知道有没有办法解决。再次感谢。

citykunan

在前一楼的程序中acadApp.ActiveDocument.SendCommand "(load " &amp; Chr(34) &amp; "plo.lsp" &amp; Chr(34) &amp; ")"         中要将*.lsp的路径写上，有没有办法，让vb自己找到自身的*.exe的所在目录，自动加载同一目录下的*.lsp程序呢？（*.lsp程序总与*.exe程序在同一目录），这样程序复制到不同的目录就不要改程序了。谢谢。