Экспорт файла (PDF, DXF, STL, CSV)

'==============================================================================
' ExportTools.bas — SolidWorks VBA export macro (single file)
'
' WHAT THIS MACRO DOES
'   Exports the active document next to the model file:
'     PDF, DXF (sheet-metal flat / drawing), STL, Excel (drawing tables).
'   Before overwriting an existing export, the old file is moved/copied into
'   a subfolder named "old\" with a timestamp from DateLastModified.
'
' HOW TO USE
'   1) Edit the SETTINGS constants below (True/False and mode numbers).
'   2) In SolidWorks: Tools > Macro > Run > select this .bas (or assign to a button).
'   3) The active document must already be saved on disk (needs a real path).
'
' RETURN CODES (each Export* function)
'   0 = success (OK)
'   1 = failure (FAIL)
'
' TYPICAL FLOW FOR ONE FORMAT
'   BuildExportPath > ArchiveToOld (if file exists) > write new file
'
' NOTES FOR BEGINNERS
'   - "Private" = only visible inside this module; "Public" = callable from outside.
'   - "Const" = constant value you change at the top; do not change SW API constants.
'   - Late binding: we use Object + CreateObject/GetObject (no SW type library required).
'   - On Error Resume Next = ignore errors for the next statements (used around SW/Excel calls).
'==============================================================================

Option Explicit

'----- SETTINGS (edit these) --------------------------------------------------
' Turn each export mode on/off. Only enabled modes run from main().

Private Const bExportPdf As Boolean = True
' True  = export PDF of the active document (any type that SaveAs supports).

Private Const bExportDxf As Boolean = True
' True  = export DXF.
' Allowed only for: sheet-metal Part (flat pattern) OR Drawing.

Private Const bExportStl As Boolean = True
' True  = export STL.
' Allowed only for: Part OR Assembly (not Drawing).

Private Const bExportExcel As Boolean = True
' True  = dump drawing tables into an .xlsx file.
' Allowed only for: Drawing that contains at least one table.

Private Const iStlAssemblyMode As Integer = 3
' How to export STL when the active document is an Assembly:
'   1 = one combined STL file (assembly as a single mesh)
'   2 = separate STL per component (SolidWorks naming: "Asm - Comp^Asm-1.STL")
'   3 = both (1 then 2)
' Ignored for Parts (always one file).

Private Const bDxfAddThickness As Boolean = True
' True  = for sheet-metal Part DXF, append thickness to the file name:
'         e.g. "Bracket (S 2 mm).dxf"
' Thickness is read from the SheetMetal feature (meters > mm).

Private Const bRemoveSpaces As Boolean = True
' True  = normalize EVERY export file name:
'         spaces > underscore "_", and entire name to lowercase.
'         Example: "My Part (S 2 mm).dxf" > "my_part_(s_2_mm).dxf"
' Also renames per-component STL files after SolidWorks creates them.

Private Const iNotify As Integer = 1
' 0 = show MsgBox only when something failed
' 1 = always show a summary MsgBox (OK/FAIL per mode)

Private Const swDocPART As Long = 1
Private Const swDocASSEMBLY As Long = 2
Private Const swDocDRAWING As Long = 3
Private Const swSTLComponentsIntoOneFile As Long = 72

Private Const swDxfOutputNoScale As Long = 136

Private swApp As Object
Private swModel As Object
Private mBase As String
Private mFolder As String

'===== ENTRY ==================================================================

Public Sub main()
    Dim Fail As Integer, msg As String

    On Error Resume Next
    Set swApp = GetObject(, "SldWorks.Application")
    On Error GoTo 0
    If swApp Is Nothing Then MsgErr "Cannot connect to SolidWorks.": Exit Sub

    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then MsgErr "No active document.": Exit Sub

    If Len(swModel.GetPathName) = 0 Then MsgErr "Document must be saved before export.": Exit Sub

    With fso()
        mBase = .GetBaseName(swModel.GetPathName)
        mFolder = .GetParentFolderName(swModel.GetPathName)
    End With

    Fail = 0: msg = ""
    If bExportPdf Then Acc "PDF", ExportPdf(), Fail, msg
    If bExportDxf And CanExportDxf() Then Acc "DXF", ExportDxf(), Fail, msg
    If bExportStl And CanExportStl() Then Acc "STL", ExportStl(), Fail, msg
    If bExportExcel And CanExportExcel() Then Acc "Excel", ExportExcel(), Fail, msg

    If Len(msg) = 0 Then msg = "No export modes enabled.": Fail = 1
    If iNotify = 1 Or Fail <> 0 Then MsgBox Trim$(msg), IIf(Fail = 0, vbInformation, vbExclamation), "ExportTools"
End Sub

Private Sub Acc(ByVal label As String, ByVal code As Integer, ByRef Fail As Integer, ByRef msg As String)
    Fail = Fail Or code
    msg = msg & label & ": " & IIf(code = 0, "OK", "FAIL") & vbCrLf
End Sub

'===== EXPORT MODES ===========================================================

Public Function ExportPdf() As Integer
    Dim path As String: ExportPdf = ExportSaveAs("pdf", path)
End Function

Public Function ExportDxf() As Integer
    Dim path As String, prevScale As Long, suffix As String, thk As Double
    If Not CanExportDxf() Then ExportDxf = 1: Exit Function

    If bDxfAddThickness And DocType() = swDocPART Then
        thk = GetSheetMetalThicknessMm()
        If thk > 0 Then suffix = " (S " & Format$(thk, "0.##") & " mm)"
    End If

    If Not BeginExport("dxf", path, suffix) Then ExportDxf = 1: Exit Function

    prevScale = PrefInt(swDxfOutputNoScale): SetPrefInt swDxfOutputNoScale, 1
    If DocType() = swDocPART Then
        ExportDxf = ExportSheetMetalDxf(path)
    Else
        ExportDxf = OkFail(SaveAsSilent(path))
    End If
    SetPrefInt swDxfOutputNoScale, prevScale
End Function

Public Function ExportStl() As Integer
    Dim path As String, prevOneFile As Boolean, Fail As Integer
    If Not CanExportStl() Then ExportStl = 1: Exit Function

    If DocType() = swDocPART Then ExportStl = ExportSaveAs("stl", path): Exit Function

    path = BuildExportPath("stl", "")
    prevOneFile = PrefToggle(swSTLComponentsIntoOneFile)
    Select Case iStlAssemblyMode
        Case 1: Fail = StlAssemblyPass(path, True)
        Case 2: Fail = StlAssemblyPass(path, False)
        Case 3: Fail = StlAssemblyPass(path, True) Or StlAssemblyPass(path, False)
        Case Else: Fail = 1
    End Select
    SetPrefToggle swSTLComponentsIntoOneFile, prevOneFile
    ExportStl = Fail
End Function

Public Function ExportExcel() As Integer
    Dim path As String, xl As Object, wb As Object, ws As Object
    Dim v As Object, tbls As Variant, ti As Long, tbl As Object
    Dim rr As Long, row As Long, c As Long, code As Integer
    On Error GoTo Fail
    If Not CanExportExcel() Then ExportExcel = 1: Exit Function
    If Not BeginExport("xlsx", path) Then ExportExcel = 1: Exit Function

    Set xl = CreateObject("Excel.Application"): xl.DisplayAlerts = False
    Set wb = xl.Workbooks.Add: Set ws = wb.Worksheets(1): ws.name = "Tables": row = 1

    Set v = swModel.GetFirstView
    Do While Not v Is Nothing
        If v.GetTableAnnotationCount > 0 Then
            tbls = v.GetTableAnnotations
            If IsArray(tbls) Then
                For ti = LBound(tbls) To UBound(tbls)
                    Set tbl = tbls(ti)
                    If Not tbl Is Nothing Then

                        For rr = 0 To tbl.RowCount - 1
                            For c = 0 To tbl.ColumnCount - 1
                                ws.Cells(row, c + 1).value = TableCellText(tbl, rr, c)
                            Next c
                            row = row + 1
                        Next rr
                        row = row + 1
                    End If
                Next ti
            End If
        End If
        Set v = v.GetNextView
    Loop

    If row > 1 Then wb.SaveAs path, 51: code = 0 Else code = 1
    ReleaseExcel xl, wb
    ExportExcel = code
    Exit Function
Fail:

    ReleaseExcel xl, wb
    NotifyFileLocked path
    ExportExcel = 1
End Function

'===== RULES (when is each mode allowed?) =====================================

Private Function DocType() As Long
    DocType = swModel.GetType
End Function

Private Function CanExportDxf() As Boolean
    Dim t As Long: t = DocType()
    CanExportDxf = (t = swDocDRAWING) Or (t = swDocPART And IsSheetMetalPart())
End Function

Private Function CanExportStl() As Boolean
    Dim t As Long: t = DocType()
    CanExportStl = (t = swDocPART Or t = swDocASSEMBLY)
End Function

Private Function CanExportExcel() As Boolean
    CanExportExcel = (DocType() = swDocDRAWING) And DrawingHasTables()
End Function

Private Function DrawingHasTables() As Boolean
    Dim v As Object
    On Error Resume Next
    Set v = swModel.GetFirstView
    Do While Not v Is Nothing
        If v.GetTableAnnotationCount > 0 Then DrawingHasTables = True: Exit Function
        Set v = v.GetNextView
    Loop
End Function

Private Function IsSheetMetalPart() As Boolean
    IsSheetMetalPart = Not FindFeatureInTypes("SheetMetal", "FlatPattern", "SheetMetalFolder") Is Nothing
End Function

Private Function FindFeatureInTypes(ParamArray typeNames() As Variant) As Object
    Dim feat As Object, i As Long, tn As String
    On Error Resume Next
    Set feat = swModel.FirstFeature
    Do While Not feat Is Nothing
        tn = feat.GetTypeName2
        For i = LBound(typeNames) To UBound(typeNames)
            If StrComp(tn, CStr(typeNames(i)), vbTextCompare) = 0 Then
                Set FindFeatureInTypes = feat: Exit Function
            End If
        Next i
        Set feat = feat.GetNextFeature
    Loop
End Function

Private Function GetSheetMetalThicknessMm() As Double
    Dim feat As Object
    On Error Resume Next
    Set feat = FindFeatureInTypes("SheetMetal")
    If Not feat Is Nothing Then GetSheetMetalThicknessMm = feat.GetDefinition.thickness * 1000#
End Function

Private Function TableCellText(ByVal tbl As Object, ByVal r As Long, ByVal c As Long) As String
    Dim s As String
    On Error Resume Next
    Err.Clear: s = tbl.GetEntryText(r, c)
    If Err.Number <> 0 Or Len(s) = 0 Then Err.Clear: s = tbl.text(r, c)
    If Err.Number <> 0 Then s = ""
    TableCellText = StripHtml(s)
End Function

Private Function StripHtml(ByVal s As String) As String
    Dim i As Long, ch As String, inTag As Boolean, out As String
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        If ch = "<" Then
            inTag = True
        ElseIf ch = ">" Then
            inTag = False
        ElseIf Not inTag Then
            out = out & ch
        End If
    Next i
    StripHtml = Trim$(out)
End Function

'===== PATH / WRITE HELPERS ===================================================

Private Function fso() As Object
    Static o As Object
    If o Is Nothing Then Set o = CreateObject("Scripting.FileSystemObject")
    Set fso = o
End Function

Private Function PrefInt(ByVal id As Long) As Long
    On Error Resume Next: PrefInt = swApp.GetUserPreferenceIntegerValue(id)
End Function

Private Sub SetPrefInt(ByVal id As Long, ByVal value As Long)
    On Error Resume Next: swApp.SetUserPreferenceIntegerValue id, value
End Sub

Private Function PrefToggle(ByVal id As Long) As Boolean
    On Error Resume Next: PrefToggle = swApp.GetUserPreferenceToggle(id)
End Function

Private Sub SetPrefToggle(ByVal id As Long, ByVal value As Boolean)
    On Error Resume Next: swApp.SetUserPreferenceToggle id, value
End Sub

Private Function OkFail(ByVal ok As Boolean) As Integer
    OkFail = IIf(ok, 0, 1)
End Function

Private Function BeginExport(ByVal ext As String, ByRef path As String, Optional ByVal suffix As String = "") As Boolean
    path = BuildExportPath(ext, suffix)
    BeginExport = ArchiveToOld(path)
End Function

Private Function ExportSaveAs(ByVal ext As String, ByRef path As String) As Integer
    If BeginExport(ext, path) Then ExportSaveAs = OkFail(SaveAsSilent(path)) Else ExportSaveAs = 1
End Function

Private Function StlAssemblyPass(ByVal path As String, ByVal oneFile As Boolean) As Integer
    Dim archived As Boolean
    SetPrefToggle swSTLComponentsIntoOneFile, oneFile
    If oneFile Then archived = ArchiveToOld(path) Else archived = ArchiveAssemblyComponentStls()
    If Not archived Then StlAssemblyPass = 1: Exit Function
    StlAssemblyPass = OkFail(SaveAsSilent(path))

    If StlAssemblyPass = 0 And Not oneFile And bRemoveSpaces Then NormalizeComponentStlNames
End Function

Private Function SaveAsSilent(ByVal path As String) As Boolean
    Dim errn As Long, warn As Long, exportData As Object, ok As Boolean, existed As Boolean
    existed = fso().FileExists(path)

    On Error Resume Next
    Err.Clear
    ok = swModel.Extension.SaveAs(path, 0, 3, exportData, errn, warn)
    If Not ok Then Err.Clear: ok = swModel.Extension.SaveAs(path, 0, 1, exportData, errn, warn)

    If Not ok And LCase$(fso().GetExtensionName(path)) = "stl" Then
        Err.Clear: errn = swModel.SaveAs3(path, 0, 1): ok = (errn = 0)
    End If

    SaveAsSilent = (Err.Number = 0 And ok)
    If Not SaveAsSilent Then Err.Clear: ReportExportFail path, existed
End Function

Private Function ExportSheetMetalDxf(ByVal path As String) As Integer
    Dim ok As Boolean, existed As Boolean
    existed = fso().FileExists(path)
    On Error Resume Next
    Err.Clear
    ok = swModel.ExportToDWG2(path, CStr(swModel.GetPathName), 1, True, Empty, False, False, 5, Empty)
    If Err.Number <> 0 Or Not ok Then
        Err.Clear: ReportExportFail path, existed: ExportSheetMetalDxf = 1
    Else
        ExportSheetMetalDxf = 0
    End If
End Function

Private Function BuildExportPath(ByVal ext As String, ByVal suffix As String) As String
    BuildExportPath = fso().BuildPath(mFolder, NormalizeFileName(mBase & suffix & "." & ext))
End Function

Private Function NormalizeFileName(ByVal fileName As String) As String
    NormalizeFileName = IIf(bRemoveSpaces, LCase$(Replace(fileName, " ", "_")), fileName)
End Function

Private Function IsComponentStlName(ByVal fileName As String) As Boolean
    Dim nm As String: nm = LCase$(fso().GetBaseName(fileName))
    IsComponentStlName = (nm Like LCase$(mBase) & " - *") Or (nm Like LCase$(Replace(mBase, " ", "_")) & "_-_*")
End Function

Private Function ComponentStlFiles() As Collection
    Dim f As Object, col As New Collection
    For Each f In fso().GetFolder(mFolder).Files
        If LCase$(fso().GetExtensionName(f.name)) = "stl" And IsComponentStlName(f.name) Then col.Add f
    Next f
    Set ComponentStlFiles = col
End Function

Private Function ArchiveAssemblyComponentStls() As Boolean
    Dim f As Object
    For Each f In ComponentStlFiles()
        If Not ArchiveToOld(f.path) Then ArchiveAssemblyComponentStls = False: Exit Function
    Next f
    ArchiveAssemblyComponentStls = True
End Function

Private Sub NormalizeComponentStlNames()
    Dim f As Object, newName As String, newPath As String
    If Not bRemoveSpaces Then Exit Sub
    For Each f In ComponentStlFiles()
        newName = NormalizeFileName(f.name)
        If StrComp(newName, f.name, vbBinaryCompare) <> 0 Then
            newPath = fso().BuildPath(mFolder, newName)
            On Error Resume Next
            If fso().FileExists(newPath) Then fso().DeleteFile newPath, True
            f.name = newName: Err.Clear: On Error GoTo 0
        End If
    Next f
End Sub

Private Sub ReleaseExcel(ByRef xl As Object, ByRef wb As Object)
    On Error Resume Next
    If Not wb Is Nothing Then wb.Close False: Set wb = Nothing
    If Not xl Is Nothing Then xl.Quit: Set xl = Nothing
End Sub

Private Sub ReportExportFail(ByVal path As String, ByVal existed As Boolean)
    If existed Then NotifyFileLocked path Else MsgErr "Export failed:" & vbCrLf & path
End Sub

Private Sub MsgErr(ByVal text As String)
    MsgBox text, vbExclamation, "ExportTools"
End Sub

Private Sub NotifyFileLocked(ByVal targetPath As String)
    MsgErr "Close the file (it may be open in another program):" & vbCrLf & targetPath
End Sub

'===== ARCHIVE ================================================================

Private Function ArchiveToOld(ByVal finalPath As String) As Boolean
    Dim oldDir As String, base As String, ext As String
    Dim stamp As String, dest As String, n As Long

    On Error GoTo Fail
    If Len(finalPath) = 0 Then ArchiveToOld = True: Exit Function
    With fso()
        finalPath = .GetAbsolutePathName(finalPath)

        If Not .FileExists(finalPath) Then ArchiveToOld = True: Exit Function

        oldDir = .BuildPath(.GetParentFolderName(finalPath), "old")
        If Not .FolderExists(oldDir) Then .CreateFolder oldDir

        base = .GetBaseName(finalPath)
        ext = .GetExtensionName(finalPath)
        stamp = Format$(.GetFile(finalPath).DateLastModified, "yyyymmdd.hhnnss")
        dest = .BuildPath(oldDir, base & "_" & stamp & "." & ext)

        n = 2
        Do While .FileExists(dest)
            dest = .BuildPath(oldDir, base & "_" & stamp & "_" & n & "." & ext)
            n = n + 1
        Loop

        On Error Resume Next
        Err.Clear: .MoveFile finalPath, dest
        If Err.Number = 0 And .FileExists(dest) And Not .FileExists(finalPath) Then ArchiveToOld = True: Exit Function

        Err.Clear: .CopyFile finalPath, dest, True
        If Err.Number = 0 And .FileExists(dest) Then ArchiveToOld = True: Exit Function
    End With

Fail:
    MsgErr "Failed to archive into old\:" & vbCrLf & finalPath
    ArchiveToOld = False
End Function