[分享]特此上传*DWG减肥工具所有部分

gzy

为答谢明总及EFAN2000版主的指点，特将此减肥工具的所有上传。
  注意：减肥后的文件保存在D盘的jianfei文件夹下，名称没有变

mccad

呵呵，终于出成果了，恭喜

gzy

谈不上什么成果，没有您老的意见，可能也没有办法做出来。呵呵！
冒昧地说一句：干脆够点意思，给个积分吧？呵呵

thankyou

你这个程序没法用哦，我用的是CAD2004。

topirol

很好很好

gzy

4楼朋友能不能具体说清楚，我那是个用VB做的，不是2004的VBA环境

zeng29

此程序需要改进.
不知你是否打开过"减肥"过后的图形,是空白图形.
由于On Error Resume Next
和缺少On Error GoTo 0语句,后续错误将被忽略.

2. 
   
3. Private Sub cmddo_click()
   
4.    Size = 0
   
5.    On Error Resume Next
   
6.    Set acadapp = GetObject(, "AutoCAD.application")
   
7.    If Err Then
   
8.      Err.Clear
   
9.      Set acadapp = CreateObject("AutoCAD.application")
   
10.         If Err Then
    
11.            MsgBox Err.Description
    
12.            Exit Sub
    
13.         End If
    
14.    End If
    
15. Set acaddoc = acadapp.activedocument
    
16. For i = 0 To File1.ListCount - 1 Step 1
    
17.   If File1.Selected(i) Then '对列表文件进行处理
    
18.     a = Path + File1.List(i)
    
19.     File1.Selected(i) = False
    
20.     acaddoc.apen a '拼写错误,acaddoc.open也会导致错误,但都被忽略
    
21.     acaddoc.activeviewport.zoomall
    
22.     acaddoc.purgeall
    
23.     acaddoc.purgeall
    
24.     acaddoc.purgeall
    
25.     acaddoc.purgeall
    
26.     acaddoc.purgeall
    
27.     MkDir "d:\jianfei" '如果存在,将会产生错误
    
28.     acaddoc.saveas "d:\jianfei" & File1.List(i) & ".dwg"'保存的不一定是a
    
29.     Size = Size + FileLen("d:\jianfei" & File1.List(i) & ".dwg")
    
30.   End If
    
31. Next i
    
32. Text2.Text = Str(Size)
    
33.   acadapp.quit'如果是用户正在使用,也将提示退出.
    
34. End Sub
    

<br /> Private Sub cmddo_click()<br />    Size = 0<br />    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<br />            MsgBox Err.Description<br />            Exit Sub<br />         End If<br />    End If<br /> Set acaddoc = acadapp.activedocument<br /> For i = 0 To File1.ListCount - 1 Step 1<br />   If File1.Selected(i) Then '对列表文件进行处理<br />     a = Path + File1.List(i)<br />     File1.Selected(i) = False<br />     acaddoc.apen a '拼写错误,acaddoc.open也会导致错误,但都被忽略<br />     acaddoc.activeviewport.zoomall<br />     acaddoc.purgeall<br />     acaddoc.purgeall<br />     acaddoc.purgeall<br />     acaddoc.purgeall<br />     acaddoc.purgeall<br />     MkDir "d:\jianfei" '如果存在,将会产生错误<br />     acaddoc.saveas "d:\jianfei" & File1.List(i) & ".dwg"'保存的不一定是a<br />     Size = Size + FileLen("d:\jianfei" & File1.List(i) & ".dwg")<br />   End If<br /> Next i<br /> Text2.Text = Str(Size)<br />   acadapp.quit'如果是用户正在使用,也将提示退出.<br /> End Sub<br />

以下是改写后的代码:

2. 
   
3. Private Sub cmddo_click()
   
4.     Size = 0
   
5.     On Error Resume Next
   
6.     Set AcadApp = GetObject(, "AutoCAD.application")
   
7.     If Err Then
   
8.         NewApp = True
   
9.         Err.Clear
   
10.         Set AcadApp = CreateObject("AutoCAD.application")
    
11.         If Err Then
    
12.             MsgBox Err.Description
    
13.             Exit Sub
    
14.         End If
    
15.     End If
    
16.     On Error GoTo 0 '关闭错误陷井,以便调试后续语句.
    
17.     For i = 0 To File1.ListCount - 1 Step 1
    
18.         If File1.Selected(i) Then '对列表文件进行处理
    
19.             a = Path + File1.List(i)
    
20.             File1.Selected(i) = False
    
21.             AcadApp.documents.open a
    
22.             For Each CurDoc In AcadApp.documents
    
23.                 If CurDoc.FullName = a Then
    
24.                     AcadApp.zoomall
    
25.                     CurDoc.PurgeAll
    
26.                     CurDoc.PurgeAll
    
27.                     CurDoc.PurgeAll
    
28.                     CurDoc.PurgeAll
    
29.                     CurDoc.SaveAs Dir1.Path & "S_" & File1.List(i)
    
30.                     CurDoc.Close
    
31.                     Size = Size + FileLen(Dir1.Path & "S_" & File1.List(i))
    
32.                 End If
    
33.             Next CurDoc
    
34.         End If
    
35.     Next i
    
36.     Text2.Text = Str(Size)
    
37.     If NewApp = True Then AcadApp.quit
    
38.     Set AcadApp = Nothing
    
39. End Sub
    

<br /> Private Sub cmddo_click()<br />     Size = 0<br />     On Error Resume Next<br />     Set AcadApp = GetObject(, "AutoCAD.application")<br />     If Err Then<br />         NewApp = True<br />         Err.Clear<br />         Set AcadApp = CreateObject("AutoCAD.application")<br />         If Err Then<br />             MsgBox Err.Description<br />             Exit Sub<br />         End If<br />     End If<br />     On Error GoTo 0 '关闭错误陷井,以便调试后续语句.<br />     For i = 0 To File1.ListCount - 1 Step 1<br />         If File1.Selected(i) Then '对列表文件进行处理<br />             a = Path + File1.List(i)<br />             File1.Selected(i) = False<br />             AcadApp.documents.open a<br />             For Each CurDoc In AcadApp.documents<br />                 If CurDoc.FullName = a Then<br />                     AcadApp.zoomall<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     CurDoc.SaveAs Dir1.Path & "S_" & File1.List(i)<br />                     CurDoc.Close<br />                     Size = Size + FileLen(Dir1.Path & "S_" & File1.List(i))<br />                 End If<br />             Next CurDoc<br />         End If<br />     Next i<br />     Text2.Text = Str(Size)<br />     If NewApp = True Then AcadApp.quit<br />     Set AcadApp = Nothing<br /> End Sub<br />

gzy

呵呵，实在不好意思了，连我自己都没有发现，我只看了一下那个文件大小有变化就以为大功告成了。
不过你改动的程序也不行，那个处理后文件大小显示为零，然后找不到处理后的文件。

zeng29

处理后的文件存在原文件所在目录,文件名在原文件名加上前缀"S_",不可能每个人运行是都建个目录,没D盘咋办.
由于我在根目录下调试的,没考虑到非根目录的情况,以下是改正后的程序:

2. 
   
3. Private Sub cmddo_click()
   
4.     Size = 0
   
5.     On Error Resume Next
   
6.     Set AcadApp = GetObject(, "AutoCAD.application")
   
7.     If Err Then
   
8.         NewApp = True
   
9.         Err.Clear
   
10.         Set AcadApp = CreateObject("AutoCAD.application")
    
11.         If Err Then
    
12.             MsgBox Err.Description
    
13.             Exit Sub
    
14.         End If
    
15.     End If
    
16.     On Error GoTo 0 '关闭错误陷井,以便调试后续语句.
    
17.     For i = 0 To File1.ListCount - 1 Step 1
    
18.         If File1.Selected(i) Then '对列表文件进行处理
    
19.             a = Path + File1.List(i)
    
20.             File1.Selected(i) = False
    
21.             AcadApp.documents.open a
    
22.             For Each CurDoc In AcadApp.documents
    
23.                 If CurDoc.FullName = a Then
    
24.                     AcadApp.zoomall
    
25.                     CurDoc.PurgeAll
    
26.                     CurDoc.PurgeAll
    
27.                     CurDoc.PurgeAll
    
28.                     CurDoc.PurgeAll
    
29.                     If Right(Dir1.Path, 1) <> "" Then
    
30.                         Temp = Dir1.Path & ""
    
31.                     Else
    
32.                         Temp = Dir1.Path
    
33.                     End If
    
34.                     CurDoc.SaveAs Temp & "S_" & File1.List(i)
    
35.                     CurDoc.Close
    
36.                     Size = Size + FileLen(Temp & "S_" & File1.List(i))
    
37.                 End If
    
38.             Next CurDoc
    
39.         End If
    
40.     Next i
    
41.     Text2.Text = Str(Size)
    
42.     If NewApp = True Then AcadApp.quit
    
43.     Set AcadApp = Nothing
    
44. End Sub
    
45. Private Sub cmdexit_Click()
    
46. Unload Me
    
47. End Sub
    

<br /> Private Sub cmddo_click()<br />     Size = 0<br />     On Error Resume Next<br />     Set AcadApp = GetObject(, "AutoCAD.application")<br />     If Err Then<br />         NewApp = True<br />         Err.Clear<br />         Set AcadApp = CreateObject("AutoCAD.application")<br />         If Err Then<br />             MsgBox Err.Description<br />             Exit Sub<br />         End If<br />     End If<br />     On Error GoTo 0 '关闭错误陷井,以便调试后续语句.<br />     For i = 0 To File1.ListCount - 1 Step 1<br />         If File1.Selected(i) Then '对列表文件进行处理<br />             a = Path + File1.List(i)<br />             File1.Selected(i) = False<br />             AcadApp.documents.open a<br />             For Each CurDoc In AcadApp.documents<br />                 If CurDoc.FullName = a Then<br />                     AcadApp.zoomall<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     If Right(Dir1.Path, 1) <> "" Then<br />                         Temp = Dir1.Path & ""<br />                     Else<br />                         Temp = Dir1.Path<br />                     End If<br />                     CurDoc.SaveAs Temp & "S_" & File1.List(i)<br />                     CurDoc.Close<br />                     Size = Size + FileLen(Temp & "S_" & File1.List(i))<br />                 End If<br />             Next CurDoc<br />         End If<br />     Next i<br />     Text2.Text = Str(Size)<br />     If NewApp = True Then AcadApp.quit<br />     Set AcadApp = Nothing<br /> End Sub<br /> Private Sub cmdexit_Click()<br /> Unload Me<br /> End Sub<br />

gzy

依旧没有发现处理后的文件，再有就是处理后CAD打开了所有图形，应该退出CAD的。处理结果仍然显示为0