如何批量导出钣金件展开图

liuzhanping9605

    一般要将钣金件展开图拷过数控编程，一个个另存效率很低，不知有没有批量方法？

  T& C9 C& W) |下面方法可另存pdf，却不能另存dxf
4 L8 `8 x+ q# F; V' k) jPrivate Sub cmdExportDxf_Click()
    Dim f As File
: y! {& ^7 l" L. ^% W& x. B3 T* p    Dim fo As Folder
    Dim sName As String
    Dim sExNameForOut As String
5 M8 A7 O0 t5 o  E    Dim sExNameForIn As String

    sExNameForIn = "SLDPRT"
    sExNameForOut = "dxf"
+ h9 P1 o2 x9 y, N+ N/ W: }( ~/ }% Z
    Set fo = fso.GetFolder(txtDir)

$ |" W! I/ d/ f! ?& z6 i' f. ]    If Not fso.FolderExists(fo) Then
8 [6 h' Y( \; z' |       MsgBox "目录不存在！"
       Exit Sub
    End If
& u8 a; K0 `4 ]8 O  W7 F/ {
; |& ?. X: C2 t* b! g# F& Z    Dim retVal As Boolean
    For Each f In fo.Files
/ W& l4 h" ~' h- \& q, w0 \% k       Dim sSaveName As String
+ h4 V+ M( A$ Z( q       Dim longstatus As Long
       Dim longwarnings As Long
4 h" e1 _% J& z8 Y
7 R3 k" h9 k% e2 ?0 C       If fso.GetExtensionName(f) = sExNameForIn Then
5 G9 ^& f2 O% Z* ^- X" ^( R7 f          If Not Left(fso.GetBaseName(f), 2) = "~$" Then
'             Set part = swApp.ActiveDoc
2 N  j* y  k# q1 t% U; i) D! a             Set part = swApp.OpenDoc6(f, 1, 0, "", longstatus, longwarnings)
/ s$ |; P( T& S+ X. U, y! w# s             If IsSheet(part) = True Then
                sSaveName = fso.GetParentFolderName(f) & "\" & fso.GetBaseName(f) & "." & sExNameForOut
                retVal = part.SaveAs3(sSaveName, 0, 0)
+ ~- w! |" N# c5 f* E4 K& d5 A'                retVal = part.SaveAs4(sSaveName, 0, 0, 0, 0)

             End If
          End If
0 q  u5 I& o  k       End If
- j$ a+ b: H& K( u( v: \8 ?'       part.Close
% X& B$ \/ E6 |3 I        swApp.CloseDoc (f)
    Next
End Sub
# h+ t- c$ z  \+ ^

liuzhanping9605

没有人知道吗？

liuzhanping9605

看来还是得靠自己

liuzhanping9605

自己看SDK搞定，分享一下
9 m0 D: Y- ^% R4 q1 o
'************************************************************
/ F1 i4 L' j7 M, b' _6 w# S, L4 C, w'函数名：
4 E' ?* R9 b( Y) x# x& i0 N'功能：导出当前钣金件为dxf
, H7 f8 V! U+ s2 N! I7 y3 p; @. ~Private Sub cmdExportDxfForCurrent_Click()
    Dim partDoc As SldWorks.ModelDoc2
7 E) {: R# y# }    Dim swModelDocExt As SldWorks.ModelDocExtension
    Dim boolRetVal As Boolean
    Dim sSaveName As String
    Dim f As File
. |- W5 z% Y4 Z- X    Dim path As String
" p4 C- {4 s5 `; v    Dim sExNameForOut As String
    Dim sExNameForIn As String
2 k0 y* z' U0 [; `2 M0 [1 P    Dim sSavePath As String
   
1 W# w) r# ~! ]5 n* y( @
, _" y  {- P4 }    sExNameForIn = "SLDPRT"
    sExNameForOut = "dxf"
( \; Q8 T& j& [* f9 d& w( q   
( W3 {! [% Y1 k0 R4 ]2 t; l6 B    Set partDoc = swApp.ActiveDoc
! S) z3 s9 k# L7 |9 [5 z    path = partDoc.GetPathName
    Set f = fso.GetFile(path)
, I4 K* U; @$ m" A+ z) T   
# x6 z, I- b$ v1 v5 z4 \* |/ r, `! v    If Not partDoc Is Nothing Then
9 O$ w3 _: A" o  K4 y% @       If IsSheet(partDoc) Then
           sSavePath = fso.GetParentFolderName(f) & "\" & DXF_SAVE_DIR & "\"
. q( A1 q0 g, `3 J- c           If Not fso.FolderExists(sSavePath) Then
+ z8 ?$ R$ q5 W6 i/ U              Call fso.CreateFolder(sSavePath)
8 _' R* b8 @0 S5 A! O6 h$ y           End If
           sSaveName = sSavePath & fso.GetBaseName(f) & "." & sExNameForOut
           
           Set swModelDocExt = partDoc.Extension
           boolRetVal = partDoc.ExportFlatPatternView(sSaveName, 0)
  `" a: [' P' N2 U( ~           Call swModelDocExt.SaveAs(sSaveName, 0, 0, Nothing, 0, 0)
' F" p2 ^3 }8 |- [: D       Else
           MsgBox ("当前文件不是钣金!")
+ f. Q: X( S% m, a: S( q7 g           End
       End If
0 j' D1 F# t6 o7 q    End If
End Sub
9 g$ U1 d# d1 {5 l6 I& t, N
6 ^. V  L7 [  P9 i. ]/ J) J  q1 ^

slzhrb

厉害！！！！

qiuli108028