社区 › VBA/VB/ActiveX/API 编程技术 › [分享]特此上传*DWG减肥工具所有部分

gzy 发表于 2003-10-11 12:09:00

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

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

mccad 发表于 2003-10-11 18:43:00

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

gzy 发表于 2003-10-11 19:00:00

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

thankyou 发表于 2003-10-13 09:36:00

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

topirol 发表于 2003-10-13 10:14:00

本帖最后由 作者 于 2003-10-13 11:00:55 编辑

很好很好

gzy 发表于 2003-10-13 14:39:00

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

zeng29 发表于 2003-10-13 19:36:00

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

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


以下是改写后的代码:

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

gzy 发表于 2003-10-13 19:55:00

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

zeng29 发表于 2003-10-13 20:09:00

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

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

gzy 发表于 2003-10-13 20:22:00

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

查看完整版本: [分享]特此上传*DWG减肥工具所有部分