社区 › VBA/VB/ActiveX/API 编程技术 › [求助]用vb批量处理文件的通用程序

citykunan 发表于 2004-12-6 21:00:00

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

Private Sub Form_Click()<BR>        <BR>Dim acadApp As AcadApplication<BR>Dim acadDoc As AcadDocument


On Error Resume Next<BR>Set acadApp = GetObject(, "AutoCAD.Application")<BR>If Err Then<BR>Err.Clear<BR>Set acadApp = CreateObject("AutoCAD.Application")<BR>If Err Then End<BR>End If<BR>acadApp.Visible = True<BR>Set acadDoc = acadApp.ActiveDocument<BR>acadDoc.SendCommand ("filedia") &amp; Chr(13) &amp; ("0") &amp; Chr(13)<BR>acadDoc.SendCommand "(Load ""C:/Lhy_Leo/plot.lsp"")" &amp; vbCr<BR>acadDoc.SendCommand ("filedia") &amp; Chr(13) &amp; ("1") &amp; Chr(13)<BR>End Sub<BR>





以上程序是我用vb编的一个打开cad并加载一个lisp程序的命令，现在只能对一个文件操作，我想有没有那位高手能实现一个用vb作的批处理的程序，它能选择一个目录下的所有dwg文件，分别打开，加载某个lisp程序，存盘关闭，这样就可做出一个批处理用vb打开dwg文件调用lisp的通用程序，我想这个很有用的，不知那位高手可以帮助我，小弟对vb不是很熟，有急用，谢谢了。

雪山飞狐_lzh 发表于 2004-12-6 21:25:00

调用Lisp文件有顺序么？

雪山飞狐_lzh 发表于 2004-12-6 21:37:00

以下是一段测试，你自己按这个格式改写一下吧


Private Sub Form_Load()<BR>sFilename = Dir(Replace(App.Path &amp; "\*.lsp", "\\", "\"))<BR>Do While sFilename &lt;&gt; ""<BR>                       sLspName = "(Load " &amp; Replace("""" &amp; Replace(App.Path, "\", "/") &amp; "/" &amp; sFilename &amp; """", "//", "/") &amp; ")"<BR>                       MsgBox sLspName<BR>                       sFilename = Dir<BR>Loop<BR>End Sub<BR>

mccad 发表于 2004-12-6 21:43:00

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

雪山飞狐_lzh 发表于 2004-12-6 22:02:00

有想过这个问题，：）


不过<A name=74186><FONT color=#000066><B>citykunan</B></FONT></A>是玩Lisp的，可能对VBA不怎么熟，可以试试生成一个临时的Lisp文件，把要执行的Lisp一次全部写进去，再SendCommand

mccad 发表于 2004-12-6 22:05:00

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

tiger8888 发表于 2004-12-6 23:03:00

试了一下，sendcommand是容易引起程序运行混乱，不知道vlax是不是可以解决这个问题？以下一个程序是我以前编写的，用于统计某个目录下的所有图纸信息的，贴出来供citykunan参考。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 发表于 2004-12-7 09:06:00

to mccad:


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


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

雪山飞狐_lzh 发表于 2004-12-7 11:35:00

下面是写临时文档的代码，SendCommand你自己加吧


要引用Scripting RunTime运行库





Private Sub Form_Load()<BR>Dim sLispCode As String<BR>sFilename = Dir(Replace(App.Path &amp; "\*.lsp", "\\", "\"))<BR>Do While sFilename &lt;&gt; ""<BR>                       sLispCode = sLispCode &amp; "(Load " &amp; Replace("""" &amp; Replace(App.Path, "\", "/") &amp; "/" &amp; sFilename &amp; """", "//", "/") &amp; ")" &amp; vbCrLf<BR>                       sFilename = Dir<BR>Loop<BR>Dim fso As New FileSystemObject<BR>Dim tr As TextStream<BR>Set tr = fso.CreateTextFile("mytemp.lsp")<BR>tr.Write sLispCode<BR>tr.Close<BR>End Sub<BR>

mccad 发表于 2004-12-7 21:58:00

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

查看完整版本: [求助]用vb批量处理文件的通用程序