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

zeng29

没有问题

这是原代码

gzy

多谢整理啊，如果CAD开着，那么CAD将打开所有处理的文件。但是关了就没有什么问题了,还有我始终找不到处理的文件，所以显示处理后为0，收索整个硬盘也找不到处理的文件，
再次多谢！

zeng29

AutoCAD有时将盘符大写.
加了Lcase函数应该可以:

2. Private Sub cmddo_click()
   
3.     On Error Resume Next
   
4.     Size = 0
   
5.     If File1.ListCount = 0 Then Exit Sub
   
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.     If Right(Dir1.Path, 1) <> "" Then
    
17.         Path = Dir1.Path & ""
    
18.     Else
    
19.         Path = Dir1.Path
    
20.     End If
    
21.     For i = 0 To File1.ListCount - 1 Step 1
    
22.         If File1.Selected(i) Then '对列表文件进行处理
    
23.             a = Path + File1.List(i)
    
24.             File1.Selected(i) = False
    
25.             AcadApp.documents.open a
    
26.             If Err Then
    
27.                 Err.Clear
    
28.                 MsgBox Err.Description
    
29.             End If
    
30.             On Error GoTo 0 '关闭错误陷井,以便调试后续语句.
    
31.             For Each CurDoc In AcadApp.documents
    
32.                 If LCase(CurDoc.FullName) = LCase(a) Then
    
33.                     CurDoc.PurgeAll
    
34.                     CurDoc.PurgeAll
    
35.                     CurDoc.PurgeAll
    
36.                     CurDoc.PurgeAll
    
37.                     OutFileName = Path & "S_" & File1.List(i)
    
38.                     If Dir(OutFileName) = "" Then
    
39.                         CurDoc.SaveAs OutFileName
    
40.                     ElseIf MsgBox("文件已经存在:" & vbCrLf & OutFileName & vbCrLf & "要替换它吗?", vbYesNo) = vbYes Then
    
41.                         CurDoc.SaveAs OutFileName
    
42.                     End If
    
43.                     CurDoc.Close
    
44.                     Size = Size + FileLen(OutFileName)
    
45.                     Exit For
    
46.                 End If
    
47.             Next CurDoc
    
48.         End If
    
49.     Next i
    
50.     Text2.Text = Str(Size)
    
51.     If NewApp = True Then AcadApp.quit
    
52.     File1.Refresh
    
53.     Set AcadApp = Nothing
    
54. End Sub

Private Sub cmddo_click()<br />     On Error Resume Next<br />     Size = 0<br />     If File1.ListCount = 0 Then Exit Sub<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 />     If Right(Dir1.Path, 1) <> "" Then<br />         Path = Dir1.Path & ""<br />     Else<br />         Path = Dir1.Path<br />     End If<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 />             If Err Then<br />                 Err.Clear<br />                 MsgBox Err.Description<br />             End If<br />             On Error GoTo 0 '关闭错误陷井,以便调试后续语句.<br />             For Each CurDoc In AcadApp.documents<br />                 If LCase(CurDoc.FullName) = LCase(a) Then<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     CurDoc.PurgeAll<br />                     OutFileName = Path & "S_" & File1.List(i)<br />                     If Dir(OutFileName) = "" Then<br />                         CurDoc.SaveAs OutFileName<br />                     ElseIf MsgBox("文件已经存在:" & vbCrLf & OutFileName & vbCrLf & "要替换它吗?", vbYesNo) = vbYes Then<br />                         CurDoc.SaveAs OutFileName<br />                     End If<br />                     CurDoc.Close<br />                     Size = Size + FileLen(OutFileName)<br />                     Exit For<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 />     File1.Refresh<br />     Set AcadApp = Nothing<br /> End Sub

zeng29

这个是编译后的文件5K)

myfreemind

不错！

zchuier

CurDoc.SaveAs Dir1.Path & "\S_" & File1.List(i)
这条语句少了一个“\”加上就好了，似乎确实是起到了“减肥”的作用。

zeng29

zchuier发表于2003-10-17 10:34:00CurDoc.SaveAs Dir1.Path & &quot;\S_&quot; & File1.List(i)
这条语句少了一个“\”加上就好了，似乎确实是起到了“减肥”的作用。

如果这样的话,文件名就是错误的!!!
你没有仔细查看前面的代码:
    If Right(Dir1.Path, 1) <> "\" Then
        Path = Dir1.Path & "\"
    Else
        Path = Dir1.Path
    End If
之所以这样是因为根目录下Path具有"\"(如"C:\"),而子目录下没有"\"(如"C:\Winnt").

zgyxn

好像还是空文件

zeng29

不会吧,有听说过AutoCAD的"清理"命令将文件"清理"大的吗?
这个VB程序原理上只是调用了AutoCAD的"清理"而已.