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

citykunan

Private Sub Form_Click()

Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then End
End If
acadApp.Visible = True
Set acadDoc = acadApp.ActiveDocument
acadDoc.SendCommand ("filedia") & Chr(13) & ("0") & Chr(13)
acadDoc.SendCommand "(Load ""C:/Lhy_Leo/plot.lsp"")" & vbCr
acadDoc.SendCommand ("filedia") & Chr(13) & ("1") & Chr(13)
End Sub
以上程序是我用vb编的一个打开cad并加载一个lisp程序的命令，现在只能对一个文件操作，我想有没有那位高手能实现一个用vb作的批处理的程序，它能选择一个目录下的所有dwg文件，分别打开，加载某个lisp程序，存盘关闭，这样就可做出一个批处理用vb打开dwg文件调用lisp的通用程序，我想这个很有用的，不知那位高手可以帮助我，小弟对vb不是很熟，有急用，谢谢了。

雪山飞狐_lzh

调用Lisp文件有顺序么？

雪山飞狐_lzh

以下是一段测试，你自己按这个格式改写一下吧 Private Sub Form_Load()
sFilename = Dir(Replace(App.Path & "\*.lsp", "\\", "\"))
Do While sFilename <> ""
sLspName = "(Load " & Replace("""" & Replace(App.Path, "\", "/") & "/" & sFilename & """", "//", "/") & ")"
MsgBox sLspName
sFilename = Dir
Loop
End Sub

mccad

这种做法本身就有问题，这也是AutoCAD的BUG造成的。
注意SendCommand方法容易出现不同步，也就是说当你使用SendCommand方法后，在命令还没有执行完时，VBA会继续执行剩下的语句。所以对程序的执行会造成混乱。
解决的方法就是想办法把LISP程序改装成VBA或VB程序。

雪山飞狐_lzh

有想过这个问题，：） 不过citykunan是玩Lisp的，可能对VBA不怎么熟，可以试试生成一个临时的Lisp文件，把要执行的Lisp一次全部写进去，再SendCommand

mccad

那就需要把打开文件和保存文件这些操作都放到LSP文件中。只SendCommand一次。

tiger8888

试了一下，sendcommand是容易引起程序运行混乱，不知道vlax是不是可以解决这个问题？以下一个程序是我以前编写的，用于统计某个目录下的所有图纸信息的，贴出来供citykunan参考。

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 intfilename As Integer
25. Dim extmin1 As Double
26. Dim extmax1 As Double
27. Dim extmin2 As Double
28. Dim extmax2 As Double
29. Dim scale1 As Double
30. Dim tufu As String
31. Dim neirong33 As String
32. intfilename = FreeFile()
33. inDir = ""
34. inDir = ThisDrawing.BrowseForFolder("请选择目录：")
35. If inDir = "" Then Exit Sub
36. If Right(inDir, 1) = "" Then inDir = Left(inDir, Len(inDir) - 1)
37. filenom = Dir$(inDir & "\*.dwg")
38. Dim tzlbzz As String
39. tzlbzz = inDir & "\图纸幅面及比例.txt"'On Error GoTo errorcontrol
40. Open tzlbzz For Output As intfilename
41. Print #intfilename, inDir
42. Print #intfilename, "---------------"
43. Do While filenom <> ""
44.       
45.        WholeFile = inDir & "" & filenom
46.        ThisDrawing.Application.Documents.Open WholeFile
47.        extmin1 = ThisDrawing.Application.ActiveDocument.GetVariable("extmax")(0) - ThisDrawing.Application.ActiveDocument.GetVariable("extmin")(0)
48.        extmax1 = ThisDrawing.Application.ActiveDocument.GetVariable("extmax")(1) - ThisDrawing.Application.ActiveDocument.GetVariable("extmin")(1)
49.        scale1 = ThisDrawing.Application.ActiveDocument.GetVariable("dimscale")
50.        If scale1 = 0 Then scale1 = 1
51.        extmin2 = extmin1 / scale1
52.        extmax2 = extmax1 / scale1
53.        If extmin2 > extmax2 Then
54.                Select Case ThisDrawing.Round(extmin2, 0)
55.                Case 1189
56.                        tufu = "图幅A0"
57.                Case 841
58.                        tufu = "图幅A1"
59.                Case 594
60.                        tufu = "图幅A2"
61.                Case 420
62.                        tufu = "图幅A3"
63.                Case 297
64.                        tufu = "图幅A4"
65.                Case Else
66.                        tufu = "图幅未知"
67.                End Select
68.                Else
69.                Select Case ThisDrawing.Round(extmin2, 0)
70.                Case 841
71.                        tufu = "图幅A0"
72.                Case 594
73.                        tufu = "图幅A1"
74.                Case 420
75.                        tufu = "图幅A2"
76.                Case 297
77.                        tufu = "图幅A3"
78.                Case 210
79.                        tufu = "图幅A4"
80.                Case Else
81.                        tufu = "图幅未知"
82.                End Select
83.        End If
84.        neirong33 = filenom & Chr(9) & tufu & "(" & CStr(extmin2) & "," & CStr(extmax2) & ")" & Chr(9) & "比例(1:" & CStr(scale1) & ")"
85.        Print #intfilename, neirong33
86.        'MsgBox ThisDrawing.GetVariable("extmax")
87.        ThisDrawing.Application.ActiveDocument.Close False
88.        filenom = Dir$
89.        ThisDrawing.Utility.Prompt vbCrLf
90. Loop
91. Close intfilename
92. 'MsgBox tzlbzz
93. Dim runtemp As String
94. runtemp = "NOTEPAD.EXE " & tzlbzz
95. Shell runtemp, vbNormalFocus
96. Exit Suberrorcontrol:
97. Close intfilename
98. MsgBox "错误，程序退出！"
99. End SubPublic Function Round(ByVal nValue, Optional nPlaces As Integer = 2) As Double       Dim tmp As Integer
100.        On Error GoTo errorcontrol
101.       
102.        nValue = CDbl(nValue)
103.        tmp = Fix(nValue)
104.        nValue = CInt((nValue - tmp) * 10 ^ nPlaces)
105.        Round = tmp + nValue / 10 ^ nPlaces
106.        Exit Function
107.       
108. errorcontrol:
109.        Round = 0
110. End FunctionPublic Function BrowseForFolder(sPrompt As String) As String
111. 'Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As StringDim iNull As Integer
112. Dim lpIDList As Long
113. Dim lResult As Long
114. Dim sPath As String
115. Dim udtBI As BrowseInfo
116.        With udtBI
117.    '           .hWndOwner = hWndOwner
118.                .lpszTitle = lstrcat(sPrompt, "")
119.                .ulFlags = BIF_RETURNONLYFSDIRS
120.        End With       lpIDList = SHBrowseForFolder(udtBI)       If lpIDList Then
121.                sPath = String$(MAX_PATH, 0)
122.              lResult = SHGetPathFromIDList(lpIDList, sPath)
123.                Call CoTaskMemFree(lpIDList)
124.                iNull = InStr(sPath, vbNullChar)               If iNull Then
125.                        sPath = Left$(sPath, iNull - 1)
126.                End If       End If       BrowseForFolder = sPath
127. 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 intfilename As Integer Dim extmin1 As Double Dim extmax1 As Double Dim extmin2 As Double Dim extmax2 As Double Dim scale1 As Double Dim tufu As String Dim neirong33 As String intfilename = FreeFile() inDir = "" inDir = ThisDrawing.BrowseForFolder("请选择目录：") If inDir = "" Then Exit Sub If Right(inDir, 1) = "" Then inDir = Left(inDir, Len(inDir) - 1) filenom = Dir$(inDir & "\*.dwg") Dim tzlbzz As String tzlbzz = inDir & "\图纸幅面及比例.txt"'On Error GoTo errorcontrol Open tzlbzz For Output As intfilename Print #intfilename, inDir Print #intfilename, "---------------" Do While filenom <> ""               WholeFile = inDir & "" & filenom        ThisDrawing.Application.Documents.Open WholeFile        extmin1 = ThisDrawing.Application.ActiveDocument.GetVariable("extmax")(0) - ThisDrawing.Application.ActiveDocument.GetVariable("extmin")(0)        extmax1 = ThisDrawing.Application.ActiveDocument.GetVariable("extmax")(1) - ThisDrawing.Application.ActiveDocument.GetVariable("extmin")(1)        scale1 = ThisDrawing.Application.ActiveDocument.GetVariable("dimscale")        If scale1 = 0 Then scale1 = 1        extmin2 = extmin1 / scale1        extmax2 = extmax1 / scale1        If extmin2 > extmax2 Then                Select Case ThisDrawing.Round(extmin2, 0)                Case 1189                        tufu = "图幅A0"                Case 841                        tufu = "图幅A1"                Case 594                        tufu = "图幅A2"                Case 420                        tufu = "图幅A3"                Case 297                        tufu = "图幅A4"                Case Else                        tufu = "图幅未知"                End Select                Else                Select Case ThisDrawing.Round(extmin2, 0)                Case 841                        tufu = "图幅A0"                Case 594                        tufu = "图幅A1"                Case 420                        tufu = "图幅A2"                Case 297                        tufu = "图幅A3"                Case 210                        tufu = "图幅A4"                Case Else                        tufu = "图幅未知"                End Select        End If        neirong33 = filenom & Chr(9) & tufu & "(" & CStr(extmin2) & "," & CStr(extmax2) & ")" & Chr(9) & "比例(1:" & CStr(scale1) & ")"        Print #intfilename, neirong33        'MsgBox ThisDrawing.GetVariable("extmax")        ThisDrawing.Application.ActiveDocument.Close False        filenom = Dir$        ThisDrawing.Utility.Prompt vbCrLf Loop Close intfilename 'MsgBox tzlbzz Dim runtemp As String runtemp = "NOTEPAD.EXE " & tzlbzz Shell runtemp, vbNormalFocus Exit Suberrorcontrol: Close intfilename MsgBox "错误，程序退出！" End SubPublic Function Round(ByVal nValue, Optional nPlaces As Integer = 2) As Double       Dim tmp As Integer        On Error GoTo errorcontrol               nValue = CDbl(nValue)        tmp = Fix(nValue)        nValue = CInt((nValue - tmp) * 10 ^ nPlaces)        Round = tmp + nValue / 10 ^ nPlaces        Exit Function        errorcontrol:        Round = 0 End FunctionPublic 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

to mccad: 那就需要把打开文件和保存文件这些操作都放到LSP文件中。只SendCommand一次。

明总有没有什么例子，其实我是想用vb做一个.exe文件，双击此文件，可以打开cad,批量处理一批图纸，而这个处理的过程，可能是用lisp，如果能做到而没有bug的话，就可以实现一个通用的用lisp处理dwg文件的程序，这个就能把像我这样略懂vb但是平时主要是用lisp编成的人结合起来，会很有帮助的。谢谢。

雪山飞狐_lzh

下面是写临时文档的代码，SendCommand你自己加吧 要引用Scripting RunTime运行库 Private Sub Form_Load()
Dim sLispCode As String
sFilename = Dir(Replace(App.Path & "\*.lsp", "\\", "\"))
Do While sFilename <> ""
sLispCode = sLispCode & "(Load " & Replace("""" & Replace(App.Path, "\", "/") & "/" & sFilename & """", "//", "/") & ")" & vbCrLf
sFilename = Dir
Loop
Dim fso As New FileSystemObject
Dim tr As TextStream
Set tr = fso.CreateTextFile("mytemp.lsp")
tr.Write sLispCode
tr.Close
End Sub

mccad

不知能否利用IsQuiescent 属性检查AutoCAD状态来实现。
只是想法，但没有多试。