Inventor · iLogic · 2 dni temu
Eksport (PDF, DXF, STL, CSV)
Ten makro umożliwia zapisanie pliku jednym kliknięciem w różnych formatach: PDF, STL, DXF oraz arkuszach Excel (CSV). Typy eksportowanych formatów oraz sposób działania można konfigurować w ustawieniach. Starsze pliki mogą być automatycznie przenoszone do folderu OLD.
Jak używać
Makro zawiera listę zmiennych konfiguracyjnych, które można włączać i wyłączać, aby kontrolować jego działanie.
- CfgExportPdf – eksport do PDF
- CfgExportDxf – eksport do DXF
- CfgExportStl – eksport do STL
- CfgExportExcel – eksport specyfikacji do Excela
- CfgStlAssemblyMode – metoda eksportu zestawu do STL (1 – jako pojedynczy plik, 2 – każda część osobno, 3 – oba warianty)
- CfgDxfAddThickness – dodanie grubości elementu do nazwy pliku płaskiego wzoru (DXF)
- CfgRemoveSpaces – usunięcie spacji w pliku eksportu
- CfgNotify – wyświetlenie wszystkich komunikatów lub tylko błędów
'==============================================================================
' Save.iLogicVb - Autodesk Inventor iLogic export rule (single file)
' Port of ExportTools.bas (SolidWorks VBA) to Inventor iLogic / VB.NET
'
' WHAT THIS RULE DOES
' Exports the active document next to the model file:
' PDF, DXF (sheet-metal flat / drawing), STL, CSV (drawing Parts List / BOM).
' Before overwriting an existing export, the old file is moved/copied into
' a subfolder named "old\" with a timestamp from LastWriteTime.
'
' HOW TO USE
' 1) Edit the SETTINGS functions below (True/False and mode numbers).
' 2) In Inventor: External Rules -> Add Rule -> select this .iLogicVb
' (prefer a local folder like AppData\Local\InventorRules, not W:\ / OneDrive).
' 3) The active document must already be saved on disk (needs a real path).
'
' RETURN CONTRACT (each Export* function)
' "" (empty string) = success (OK)
' any other string = failure detail shown in the summary MsgBox
'
' TYPICAL FLOW FOR ONE FORMAT
' BuildExportPath -> ArchiveToOld (if file exists) -> write new file
'
' NOTES FOR BEGINNERS
' - iLogic uses VB.NET (not VBA). Sub Main must come first in the rule.
' - Do NOT put Dim / Const / Shared fields above Main - iLogic will not compile.
' Settings are Functions that Return a value (same idea as VBA Const).
' - ThisApplication is given by iLogic (no GetObject like in SolidWorks VBA).
' - Primary write: Document.SaveAs(path, True). Fallback: TranslatorAddIn.
' - Sheet-metal DXF: FlatPattern DataIO (not a normal 3D SaveAs).
' Bend centerlines are dashed (LineType 37634). CfgDxfBendDashScale sets
' DXF header $LTSCALE so dashes are visible in CAM. Unfold uses A-Side if set.
' - Drawing DXF: one file per sheet. Names use English index only: _sht1, _sht2.
' If Inventor also writes a localized name (*_Arkusz_*), we keep only _shtN.dxf.
' - Drawing BOM: CSV (; separator, UTF-8 BOM) so Excel can open it.
' Runs only on a drawing that already has a Parts List; otherwise skipped.
' - Small helpers (IsPart, IsBlank, RequireArchive, ...) are "syntactic sugar":
' same logic, shorter and easier to read at call sites.
'==============================================================================
'===== ENTRY ==================================================================
Sub Main()
' fail: 0 = all OK so far, 1 = at least one mode failed
' msg: multi-line summary text for the final MsgBox ("PDF: OK", ...)
Dim fail As Integer = 0
Dim msg As String = ""
' Active document in Inventor (Part .ipt / Assembly .iam / Drawing .idw)
Dim oDoc As Document = ThisApplication.ActiveDocument
If oDoc Is Nothing Then
MsgErr("No active document.")
Return
End If
' Export needs a real folder on disk - unsaved docs have empty FullFileName
If Not HasSavedPath(oDoc) Then
MsgErr("Document must be saved before export.")
Return
End If
' Each mode: Cfg* = user on/off switch; CanExport* = document-type gate (silent skip)
If CfgExportPdf() Then RunMode("PDF", ExportPdf(oDoc), fail, msg)
If CfgExportDxf() AndAlso CanExportDxf(oDoc) Then RunMode("DXF", ExportDxf(oDoc), fail, msg)
If CfgExportStl() AndAlso CanExportStl(oDoc) Then RunMode("STL", ExportStl(oDoc), fail, msg)
' Excel/CSV only when drawing has Parts List (BOM) - no FAIL on Part/Assembly
If CfgExportExcel() AndAlso CanExportExcel(oDoc) Then RunMode("Excel", ExportExcel(oDoc), fail, msg)
ShowSummary(fail, msg)
End Sub
'----- SETTINGS (edit return values) ------------------------------------------
' Turn each export mode on/off. Only enabled modes run from Main().
' Change the Return value, then save the rule and run again.
' Implemented as Functions: iLogic forbids module-level Const/fields.
Function CfgExportPdf() As Boolean
' True = export PDF of the active document (Part / Assembly / Drawing).
Return True
End Function
Function CfgExportDxf() As Boolean
' True = export DXF.
' Allowed only for: sheet-metal Part (flat pattern) OR Drawing.
' Drawing with N sheets -> N DXF files (one per sheet).
Return True
End Function
Function CfgExportStl() As Boolean
' True = export STL.
' Allowed only for: Part OR Assembly (not Drawing).
Return True
End Function
Function CfgExportExcel() As Boolean
' True = dump drawing Parts List (BOM) into a .csv file (opens in Excel).
' Runs only when CanExportExcel: Drawing + at least one PartsList.
' On Part/Assembly (or drawing without BOM) the mode is skipped - no FAIL line.
Return True
End Function
Function CfgStlAssemblyMode() As Integer
' 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 leaf Part component
' naming: "<asmBase> - <compBase>.stl"
' 3 = both (1 then 2)
' Ignored for Parts (always one file).
Return 3
End Function
Function CfgDxfAddThickness() As Boolean
' True = for sheet-metal Part DXF, append thickness to the file name:
' e.g. "Bracket (S 2 mm).dxf"
' Thickness from SheetMetalComponentDefinition.Thickness (cm -> mm, *10).
Return True
End Function
Function CfgRemoveSpaces() As Boolean
' 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"
Return True
End Function
Function CfgNotify() As Integer
' 0 = show MsgBox only when something failed
' 1 = always show a summary MsgBox (OK/FAIL per mode)
Return 1
End Function
Function CfgDxfBendDashScale() As Double
' Sheet-metal DXF only: scale of dashed bend lines ($LTSCALE in DXF header).
' Inventor default dashes look tiny in many CAM viewers.
' 1 = Inventor default
' 10 = good starting value (current)
' 15..20 = even longer dashes - raise here if still too small
Return 10.0
End Function
'----- TRANSLATOR GUIDS (usually do not edit) ---------------------------------
' Official Autodesk Translator Add-In IDs used by SaveViaTranslator.
Function GuidPdf() As String
Return "{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}"
End Function
Function GuidDxf() As String
' Official Autodesk DXF Translator sample GUID (...CD80, not CD87).
Return "{C24E3AC4-122E-11D5-8E91-0010B541CD80}"
End Function
Function GuidStl() As String
Return "{533E9A98-FC3B-11D4-8E7E-0010B541CD87}"
End Function
Function DxfFlatFormat() As String
' Format string for sheet-metal flat pattern DXF via DataIO.WriteDataToFile.
'
' KEEP visible (manufacturing geometry):
' IV_OUTER_PROFILE - outer material edge (solid body for CAM)
' IV_INTERIOR_PROFILES - holes / cutouts / chamfer openings (material edges)
' IV_BEND / IV_BEND_DOWN - bend CENTERLINES only (where the brake applies)
' LineType 37634 = kDashedLineType (dashed)
' BendLayer* = legacy name; BendUp/Down = modern names
'
' HIDE (InvisibleLayers):
' IV_ARC_CENTERS - no circle/arc center marks
' IV_TANGENT - bend EXTENT / plane-boundary lines (not wanted)
' IV_FEATURE_PROFILES* - extra feature edges (incl. chamfer cosmetics)
' IV_TOOL_CENTER* - punch/tool centers
' IV_ALTREP_* - alternate representations
' IV_UNCONSUMED_SKETCH* - leftover sketches
' IV_ROLL* - roll lines
'
' AcadVersion=2007 - better linetype mapping than R12/2000.
' TrimCenterlinesAtContour=True - bend centerlines stop at the outer contour.
' After write, ScaleDxfBendDashes() sets $LTSCALE (see CfgDxfBendDashScale).
Return _
"FLAT PATTERN DXF?" & _
"AcadVersion=2007" & _
"&OuterProfileLayer=IV_OUTER_PROFILE" & _
"&InteriorProfilesLayer=IV_INTERIOR_PROFILES" & _
"&BendLayer=IV_BEND&BendLayerLineType=37634" & _
"&BendUpLayer=IV_BEND&BendUpLayerLineType=37634" & _
"&BendDownLayer=IV_BEND_DOWN&BendDownLayerLineType=37634" & _
"&TrimCenterlinesAtContour=True&SimplifySplines=True&MergeProfilesIntoPolyline=True" & _
"&InvisibleLayers=IV_ARC_CENTERS;IV_TANGENT;IV_FEATURE_PROFILES;IV_FEATURE_PROFILES_DOWN;" & _
"IV_TOOL_CENTER;IV_TOOL_CENTER_DOWN;IV_ALTREP_FRONT;IV_ALTREP_BACK;" & _
"IV_UNCONSUMED_SKETCHES;IV_UNCONSUMED_SKETCH_CONSTRUCTION;IV_ROLL;IV_ROLL_TANGENT"
End Function
'===== SYNTACTIC SUGAR ========================================================
' Tiny wrappers so call sites read like English.
' They do not change Inventor behavior - only make the code easier to scan.
Function IsBlank(s As String) As Boolean
' True when string is Nothing or "".
Return String.IsNullOrEmpty(s)
End Function
Function IsPart(oDoc As Document) As Boolean
' True for .ipt documents.
Return oDoc.DocumentType = DocumentTypeEnum.kPartDocumentObject
End Function
Function IsAssembly(oDoc As Document) As Boolean
' True for .iam documents.
Return oDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject
End Function
Function IsDrawing(oDoc As Document) As Boolean
' True for .idw / .dwg drawing documents.
Return oDoc.DocumentType = DocumentTypeEnum.kDrawingDocumentObject
End Function
Function HasSavedPath(oDoc As Document) As Boolean
' False for brand-new unsaved documents (no folder to export next to).
Return Not IsBlank(oDoc.FullFileName)
End Function
Function FileExists(path As String) As Boolean
' Short wrapper - easier to read than System.IO.File.Exists everywhere.
Return System.IO.File.Exists(path)
End Function
Function AsDrawing(oDoc As Document) As DrawingDocument
' Cast Document -> DrawingDocument (call only when IsDrawing is True).
Return CType(oDoc, DrawingDocument)
End Function
Function AsAssembly(oDoc As Document) As AssemblyDocument
' Cast Document -> AssemblyDocument (call only when IsAssembly is True).
Return CType(oDoc, AssemblyDocument)
End Function
Function AsPart(oDoc As Document) As PartDocument
' Cast Document -> PartDocument (call only when IsPart is True).
Return CType(oDoc, PartDocument)
End Function
Function IsFail(result As String) As Boolean
' True when Export* returned a non-empty string (= failure detail).
Return Not IsBlank(result)
End Function
Function ConfirmWritten(path As String, missingMsg As String) As String
' After a write attempt: "" if file exists on disk, otherwise missingMsg.
If FileExists(path) Then Return ""
Return missingMsg
End Function
Function RequireArchive(path As String) As String
' Move/copy any existing target into old\ before writing a new file.
' Returns "" on success, or a failure reason string.
If ArchiveToOld(path) Then Return ""
Return "failed to archive into old\"
End Function
Function JoinDetails(a As String, b As String) As String
' Merge two failure strings. Empty side is ignored (that step was OK).
If IsBlank(a) Then Return b
If IsBlank(b) Then Return a
Return a & "; " & b
End Function
Function Nz(value As String, fallback As String) As String
' Null/empty -> fallback (same idea as Access/VBA Nz).
If IsBlank(value) Then Return fallback
Return value
End Function
Function SafeSheetName(sh As Sheet) As String
' Sheet.Name, or "?" if the API throws.
Try
Return sh.Name
Catch
Return "?"
End Try
End Function
Function ObjCount(collection As Object) As Integer
' Safe .Count for late-bound Inventor collections (0 on error).
Try
Return CInt(collection.Count)
Catch
Return 0
End Try
End Function
'===== RESULT / UI ============================================================
Sub RunMode(label As String, result As String, ByRef fail As Integer, ByRef msg As String)
' Append one "LABEL: OK/FAIL" line and remember overall fail.
' ByRef = changes to fail/msg are visible back in Main.
If IsFail(result) Then
fail = 1
msg = msg & label & ": FAIL - " & result & vbCrLf
Else
msg = msg & label & ": OK" & vbCrLf
End If
End Sub
Sub ShowSummary(fail As Integer, msg As String)
' Nothing ran (all Cfg off, or no mode allowed for this doc type)
If IsBlank(msg) Then
msg = "No export modes enabled / available for this document type."
fail = 1
End If
' Show summary always (CfgNotify=1) or only when something failed
If CfgNotify() = 1 OrElse fail <> 0 Then
Dim icon As MsgBoxStyle = If(fail = 0, MsgBoxStyle.Information, MsgBoxStyle.Exclamation)
MsgBox(msg.Trim(), icon, "ExportTools")
End If
End Sub
Sub MsgErr(text As String)
' Simple error dialog (title matches the rule / VBA tool name).
MsgBox(text, MsgBoxStyle.Exclamation, "ExportTools")
End Sub
'===== PATH HELPERS ===========================================================
Function DocBaseName(oDoc As Document) As String
' File name without folder and without extension, e.g. "Bracket".
Return System.IO.Path.GetFileNameWithoutExtension(oDoc.FullFileName)
End Function
Function DocFolder(oDoc As Document) As String
' Folder that contains the model / drawing file.
Return System.IO.Path.GetDirectoryName(oDoc.FullFileName)
End Function
Function NormalizeFileName(fileName As String) As String
' Apply CfgRemoveSpaces rules to a file name (not a full path).
If CfgRemoveSpaces() Then Return LCase(Replace(fileName, " ", "_"))
Return fileName
End Function
Function BuildExportPath(oDoc As Document, ext As String, Optional suffix As String = "") As String
' Full path next to the document: <folder>\<normalizedBase><suffix>.<ext>
' Optional suffix example: " (S 2 mm)" for sheet-metal DXF, or "_sht1".
Return System.IO.Path.Combine(DocFolder(oDoc), NormalizeFileName(DocBaseName(oDoc) & suffix & "." & ext))
End Function
Function ComponentStlPath(asmDoc As Document, partDoc As Document) As String
' Per-component STL next to the assembly, e.g. "my_asm - bracket.stl".
Dim name As String = DocBaseName(asmDoc) & " - " & DocBaseName(partDoc) & ".stl"
Return System.IO.Path.Combine(DocFolder(asmDoc), NormalizeFileName(name))
End Function
Function EnsureDir(dirPath As String) As Boolean
' Create folder if missing. Returns False only if creation fails.
Try
If Not System.IO.Directory.Exists(dirPath) Then System.IO.Directory.CreateDirectory(dirPath)
Return True
Catch
Return False
End Try
End Function
Function WriteUtf8BomLines(path As String, lines As List(Of String)) As String
' Write text file as UTF-8 with BOM so Excel recognizes Polish characters.
Try
System.IO.File.WriteAllLines(path, lines.ToArray(), New System.Text.UTF8Encoding(True))
Return ConfirmWritten(path, "csv not written")
Catch ex As Exception
Return ex.Message
End Try
End Function
'===== RULES (when is each mode allowed?) =====================================
Function CanExportDxf(oDoc As Document) As Boolean
' Drawing -> yes. Part -> only if sheet metal. Assembly -> no.
Return IsDrawing(oDoc) OrElse (IsPart(oDoc) AndAlso IsSheetMetalPart(oDoc))
End Function
Function CanExportStl(oDoc As Document) As Boolean
' Part or Assembly only (drawings have no solid mesh to STL).
Return IsPart(oDoc) OrElse IsAssembly(oDoc)
End Function
Function CanExportExcel(oDoc As Document) As Boolean
' Must be a drawing AND at least one sheet must contain a Parts List (BOM).
If Not IsDrawing(oDoc) Then Return False
Return DrawingHasPartsList(AsDrawing(oDoc))
End Function
Function DrawingHasPartsList(drw As DrawingDocument) As Boolean
' True if any sheet has PartsLists.Count > 0.
Dim i As Integer
For i = 1 To drw.Sheets.Count
Try
If drw.Sheets.Item(i).PartsLists.Count > 0 Then Return True
Catch
End Try
Next
Return False
End Function
Function IsSheetMetalPart(oDoc As Document) As Boolean
' True when ComponentDefinition is SheetMetalComponentDefinition.
Try
If Not IsPart(oDoc) Then Return False
Return TypeOf AsPart(oDoc).ComponentDefinition Is SheetMetalComponentDefinition
Catch
Return False
End Try
End Function
Function GetSheetMetalDef(oDoc As Document) As SheetMetalComponentDefinition
' Cast helper - call only after IsSheetMetalPart is True.
Return CType(AsPart(oDoc).ComponentDefinition, SheetMetalComponentDefinition)
End Function
Function GetSheetMetalThicknessMm(oDoc As Document) As Double
' Inventor stores length in cm internally -> multiply by 10 to get mm.
Try
Return GetSheetMetalDef(oDoc).Thickness.Value * 10.0
Catch
Return 0
End Try
End Function
Function DxfThicknessSuffix(oDoc As Document) As String
' Text glued into the DXF file name when CfgDxfAddThickness is True.
If Not CfgDxfAddThickness() Then Return ""
Dim thk As Double = GetSheetMetalThicknessMm(oDoc)
If thk <= 0 Then Return ""
Return " (S " & Format(thk, "0.##") & " mm)"
End Function
'===== CORE WRITE =============================================================
' Shared pipeline for PDF / drawing DXF / STL:
' 1) RequireArchive / ArchiveToOld if the target file already exists
' 2) Document.SaveAs(path, True) - True = save a COPY, keep original open
' 3) If that fails -> TranslatorAddIn.SaveCopyAs (GUID for the format)
Function ExportViaSaveAs(oDoc As Document, ext As String, guid As String, Optional suffix As String = "") As String
' One-liner used by ExportPdf / single-file STL (not multi-sheet drawing DXF).
Return WriteExportFile(oDoc, BuildExportPath(oDoc, ext, suffix), guid)
End Function
Function WriteExportFile(oDoc As Document, path As String, guid As String) As String
' Full write pipeline with archive + SaveAs + translator fallback.
Dim arch As String = RequireArchive(path)
If IsFail(arch) Then Return arch
Dim detail As String = TrySaveAsCopy(oDoc, path)
If Not IsFail(detail) Then Return ""
' Fallback when SaveAs is not enough for this format/document
Dim trDetail As String = SaveViaTranslator(oDoc, guid, path)
If Not IsFail(trDetail) Then Return ""
Return JoinDetails(detail, trDetail)
End Function
Function TrySaveAsCopy(oDoc As Document, path As String) As String
' True = save a COPY; original document path stays unchanged.
Try
oDoc.SaveAs(path, True)
Return ConfirmWritten(path, "SaveAs did not create file")
Catch ex As Exception
Return "SaveAs: " & ex.Message
End Try
End Function
Function SaveViaTranslator(oDoc As Document, guid As String, path As String) As String
' Look up Inventor translator add-in by GUID, then SaveCopyAs to path.
Dim addIn As ApplicationAddIn = Nothing
Try
addIn = ThisApplication.ApplicationAddIns.ItemById(guid)
Catch ex As Exception
Return "translator add-in missing " & guid & " - " & ex.Message
End Try
Dim tr As TranslatorAddIn = TryCast(addIn, TranslatorAddIn)
If tr Is Nothing Then Return "add-in is not TranslatorAddIn"
If Not tr.Activated Then tr.Activate()
' TranslationContext + DataMedium = where/how to write the file
Dim ctx As TranslationContext = ThisApplication.TransientObjects.CreateTranslationContext()
ctx.Type = IOMechanismEnum.kFileBrowseIOMechanism
Dim opts As NameValueMap = ThisApplication.TransientObjects.CreateNameValueMap()
Dim data As DataMedium = ThisApplication.TransientObjects.CreateDataMedium()
data.FileName = path
' HasSaveCopyAsOptions fills default options when the translator supports them.
' In VB.NET the Boolean return must be assigned (cannot call as a bare statement).
Dim unusedOpts As Boolean = tr.HasSaveCopyAsOptions(oDoc, ctx, opts)
tr.SaveCopyAs(oDoc, ctx, opts, data)
Return ConfirmWritten(path, "Translator did not create file")
End Function
'===== EXPORT MODES ===========================================================
Function ExportPdf(oDoc As Document) As String
' PDF next to the document (any type SaveAs/Translator accepts).
Return ExportViaSaveAs(oDoc, "pdf", GuidPdf())
End Function
Function ExportDxf(oDoc As Document) As String
' Part (sheet metal) -> flat-pattern DataIO
' Drawing -> one DXF per sheet (Activate + Translator). Multi-sheet SaveAs is unreliable.
If IsPart(oDoc) Then
Return ExportSheetMetalDxf(oDoc, BuildExportPath(oDoc, "dxf", DxfThicknessSuffix(oDoc)))
End If
If IsDrawing(oDoc) Then Return ExportDrawingDxfPerSheet(oDoc)
Return "DXF: unsupported document type"
End Function
Function ExportDrawingDxfPerSheet(oDoc As Document) As String
' Each sheet -> separate DXF next to the drawing.
' Single sheet: <base>.dxf
' Multi sheet: <base>_sht1.dxf, <base>_sht2.dxf, ...
' English index only - never localized titles (Arkusz / Sheet / ...).
Dim drw As DrawingDocument = AsDrawing(oDoc)
Dim prevSheet As Sheet = Nothing
Try : prevSheet = drw.ActiveSheet : Catch : End Try
Dim multi As Boolean = (drw.Sheets.Count > 1)
Dim nOk As Integer = 0
Dim nFail As Integer = 0
Dim lastErr As String = ""
Dim i As Integer
For i = 1 To drw.Sheets.Count
Try
' Translator exports the ACTIVE sheet - activate each one in turn
drw.Sheets.Item(i).Activate()
Dim suffix As String = ""
If multi Then suffix = "_sht" & i.ToString()
Dim r As String = ExportOneDrawingSheetDxf(oDoc, BuildExportPath(oDoc, "dxf", suffix))
If IsFail(r) Then
nFail += 1
lastErr = r
Else
nOk += 1
End If
Catch ex As Exception
nFail += 1
lastErr = ex.Message
End Try
Next
' Restore previously active sheet so the user is not left on the last sheet
Try
If Not prevSheet Is Nothing Then prevSheet.Activate()
Catch
End Try
If nOk = 0 Then Return Nz(lastErr, "DXF failed for all sheets")
If nFail > 0 Then Return "exported " & nOk.ToString() & "/" & (nOk + nFail).ToString() & " sheets - " & lastErr
Return ""
End Function
Function ExportOneDrawingSheetDxf(oDoc As Document, path As String) As String
' Active sheet must already be set by caller.
' Archive -> Translator -> SaveAs fallback.
' Inventor often writes BOTH our path and an extra localized name (*_Arkusz_*).
' ResolveNewDxf keeps only expectedPath and deletes the duplicates.
Dim arch As String = RequireArchive(path)
If IsFail(arch) Then Return arch
Dim folder As String = System.IO.Path.GetDirectoryName(path)
' Snapshot *.dxf before write so we can detect Inventor's real output name
Dim before As List(Of String) = ListDxfFiles(folder)
Dim trDetail As String = SaveViaTranslator(oDoc, GuidDxf(), path)
If Not IsFail(ResolveNewDxf(folder, before, path)) Then Return ""
before = ListDxfFiles(folder)
Dim saDetail As String = TrySaveAsCopy(oDoc, path)
If Not IsFail(ResolveNewDxf(folder, before, path)) Then Return ""
Return JoinDetails(Nz(trDetail, "Translator did not create file"), _
Nz(saDetail, "SaveAs did not create file"))
End Function
Function ListDxfFiles(folder As String) As List(Of String)
' Snapshot of *.dxf paths in folder (for detecting Inventor's real output name).
Dim list As New List(Of String)
Try
If System.IO.Directory.Exists(folder) Then list.AddRange(System.IO.Directory.GetFiles(folder, "*.dxf"))
Catch
End Try
Return list
End Function
Function PathInList(list As List(Of String), path As String) As Boolean
' Case-insensitive path membership test.
Dim p As String
For Each p In list
If String.Equals(p, path, StringComparison.OrdinalIgnoreCase) Then Return True
Next
Return False
End Function
Sub TryDeleteFile(path As String)
' Best-effort delete (ignore lock / missing file).
Try
If FileExists(path) Then System.IO.File.Delete(path)
Catch
End Try
End Sub
Sub DeleteExtraDxfNewcomers(newcomers As List(Of String), keepPath As String)
' Remove Inventor duplicate outputs (e.g. *_Arkusz_1.dxf), keep only keepPath.
Dim f As String
For Each f In newcomers
If Not String.Equals(f, keepPath, StringComparison.OrdinalIgnoreCase) Then TryDeleteFile(f)
Next
End Sub
Function NewestPath(paths As List(Of String)) As String
' Path with the newest LastWriteTime (used when Inventor invents its own DXF name).
If paths Is Nothing OrElse paths.Count = 0 Then Return ""
Dim best As String = paths(0)
Dim bestTime As DateTime = System.IO.File.GetLastWriteTime(best)
Dim i As Integer
For i = 1 To paths.Count - 1
Dim t As DateTime = System.IO.File.GetLastWriteTime(paths(i))
If t > bestTime Then
bestTime = t
best = paths(i)
End If
Next
Return best
End Function
Function ListNewDxfFiles(folder As String, before As List(Of String)) As List(Of String)
' Files that appeared in folder after the "before" snapshot.
Dim newcomers As New List(Of String)
Dim f As String
For Each f In ListDxfFiles(folder)
If Not PathInList(before, f) Then newcomers.Add(f)
Next
Return newcomers
End Function
Function ResolveNewDxf(folder As String, before As List(Of String), expectedPath As String) As String
' Keep only expectedPath. Inventor may create expectedPath AND/OR a localized
' duplicate (*_Arkusz_* / *_Sheet_*). Rename if needed, then delete extras.
Dim newcomers As List(Of String) = ListNewDxfFiles(folder, before)
If FileExists(expectedPath) Then
DeleteExtraDxfNewcomers(newcomers, expectedPath)
Return ""
End If
If newcomers.Count = 0 Then Return "DXF file not found after export"
Dim best As String = NewestPath(newcomers)
If IsBlank(best) Then Return "DXF file not found after export"
Try
TryDeleteFile(expectedPath)
System.IO.File.Move(best, expectedPath)
Catch ex As Exception
If FileExists(best) Then
' Could not rename - still drop other extras, keep Inventor file as last resort
DeleteExtraDxfNewcomers(newcomers, best)
Return ""
End If
Return "DXF rename failed: " & ex.Message
End Try
' Drop any other newcomers left behind after the move
newcomers = ListNewDxfFiles(folder, before)
Dim f As String
Dim extras As New List(Of String)
For Each f In newcomers
If Not String.Equals(f, expectedPath, StringComparison.OrdinalIgnoreCase) Then extras.Add(f)
Next
DeleteExtraDxfNewcomers(extras, expectedPath)
Return ConfirmWritten(expectedPath, "DXF file not found after export")
End Function
Function ExportSheetMetalDxf(oDoc As Document, path As String) As String
' Unfold / edit flat pattern, write DXF with DataIO format string,
' then enlarge bend dash pattern for CAM viewers.
Dim arch As String = RequireArchive(path)
If IsFail(arch) Then Return arch
Dim sm As SheetMetalComponentDefinition = Nothing
Try
sm = GetSheetMetalDef(oDoc)
PrepareFlatPattern(sm)
' DataIO writes layers/linetypes from DxfFlatFormat()
sm.DataIO.WriteDataToFile(DxfFlatFormat(), path)
TryExitFlatEdit(sm)
Dim written As String = ConfirmWritten(path, "DXF flat - no file after WriteDataToFile")
If IsFail(written) Then Return written
' Inventor dashed bends are often too fine - patch DXF header $LTSCALE
ScaleDxfBendDashes(path, CfgDxfBendDashScale())
Return ""
Catch ex As Exception
TryExitFlatEdit(sm)
Return "DXF flat: " & ex.Message
End Try
End Function
Sub PrepareFlatPattern(sm As SheetMetalComponentDefinition)
' Create flat pattern if missing; otherwise enter edit for DataIO context.
' Unfold() uses the part A-Side definition when it is already set in Inventor
' (plane A facing up for manufacturing).
If Not sm.HasFlatPattern Then
sm.Unfold()
Else
sm.FlatPattern.Edit()
End If
End Sub
Sub TryExitFlatEdit(sm As SheetMetalComponentDefinition)
' Always leave flat-pattern edit mode, even after an error.
If sm Is Nothing Then Return
Try
If sm.HasFlatPattern Then sm.FlatPattern.ExitEdit()
Catch
End Try
End Sub
Sub ScaleDxfBendDashes(dxfPath As String, scale As Double)
' Set DXF header $LTSCALE so dashed bend lines render with longer dashes.
' DXF stores settings as code/value pairs (group codes). Example:
' 9
' $LTSCALE
' 40
' 10.0
' Encoding ISO-8859-1 keeps Inventor byte values (PL linetype names stay intact).
If IsBlank(dxfPath) OrElse Not FileExists(dxfPath) OrElse scale <= 0 Then Return
Dim enc As System.Text.Encoding = System.Text.Encoding.GetEncoding("ISO-8859-1")
Dim lines As New List(Of String)
lines.AddRange(System.IO.File.ReadAllLines(dxfPath, enc))
If lines.Count < 8 Then Return
Dim scaleText As String = scale.ToString(System.Globalization.CultureInfo.InvariantCulture)
Dim i As Integer
Dim found As Boolean = False
' Case 1: $LTSCALE already exists - overwrite its numeric value (group 40)
For i = 0 To lines.Count - 2
If lines(i).Trim() = "9" AndAlso lines(i + 1).Trim().ToUpperInvariant() = "$LTSCALE" Then
Dim j As Integer
Dim jMax As Integer = i + 6
If jMax > lines.Count - 2 Then jMax = lines.Count - 2
For j = i + 2 To jMax Step 2
If lines(j).Trim() = "40" Then
lines(j + 1) = scaleText
found = True
Exit For
End If
Next
Exit For
End If
Next
' Case 2: missing - insert before first ENDSEC (end of HEADER in Inventor flat DXF)
If Not found Then
For i = 0 To lines.Count - 2
If lines(i).Trim() = "0" AndAlso lines(i + 1).Trim().ToUpperInvariant() = "ENDSEC" Then
lines.Insert(i, scaleText)
lines.Insert(i, " 40")
lines.Insert(i, "$LTSCALE")
lines.Insert(i, " 9")
found = True
Exit For
End If
Next
End If
If found Then System.IO.File.WriteAllLines(dxfPath, lines.ToArray(), enc)
End Sub
Function ExportStl(oDoc As Document) As String
' Single part -> always one STL file
If IsPart(oDoc) Then Return ExportViaSaveAs(oDoc, "stl", GuidStl())
' Assembly -> depend on CfgStlAssemblyMode (1 / 2 / 3)
Dim path As String = BuildExportPath(oDoc, "stl")
Select Case CfgStlAssemblyMode()
Case 1
Return WriteExportFile(oDoc, path, GuidStl())
Case 2
Return StlAssemblyPerComponent(oDoc)
Case 3
' Run both; JoinDetails keeps OK empty and merges any errors
Return JoinDetails(WriteExportFile(oDoc, path, GuidStl()), StlAssemblyPerComponent(oDoc))
Case Else
Return "invalid CfgStlAssemblyMode"
End Select
End Function
Function StlAssemblyPerComponent(oDoc As Document) As String
' One STL per leaf Part occurrence.
' Skips suppressed components, non-Part docs, and unsaved references.
Dim nOk As Integer = 0
Dim lastErr As String = ""
Try
Dim occ As ComponentOccurrence
For Each occ In AsAssembly(oDoc).ComponentDefinition.Occurrences.AllLeafOccurrences
If occ.Suppressed Then Continue For
Dim refDoc As Document = TryGetOccurrencePart(occ)
If refDoc Is Nothing Then Continue For
Dim r As String = WriteExportFile(refDoc, ComponentStlPath(oDoc, refDoc), GuidStl())
If IsFail(r) Then
lastErr = r
Else
nOk += 1
End If
Next
If nOk = 0 AndAlso IsBlank(lastErr) Then Return "no Part components"
Return lastErr
Catch ex As Exception
Return ex.Message
End Try
End Function
Function TryGetOccurrencePart(occ As ComponentOccurrence) As Document
' Return the Part document behind an occurrence, or Nothing if not usable.
Try
Dim refDoc As Document = occ.Definition.Document
If refDoc Is Nothing OrElse Not IsPart(refDoc) OrElse Not HasSavedPath(refDoc) Then Return Nothing
Return refDoc
Catch
Return Nothing
End Try
End Function
Function ExportExcel(oDoc As Document) As String
' Dump Parts List (BOM) rows to CSV next to the drawing.
' No Excel.Application - COM SaveAs was unreliable; CSV opens in Excel.
Dim path As String = BuildExportPath(oDoc, "csv")
Dim arch As String = RequireArchive(path)
If IsFail(arch) Then Return arch
Try
Dim lines As List(Of String) = CollectBomCsvLines(AsDrawing(oDoc))
If lines.Count = 0 Then Return "no Parts List (BOM) on drawing"
Return WriteUtf8BomLines(path, lines)
Catch ex As Exception
Return ex.Message
End Try
End Function
Function CollectBomCsvLines(drw As DrawingDocument) As List(Of String)
' Walk all sheets; dump every PartsList into CSV lines.
Dim lines As New List(Of String)
Dim i As Integer
For i = 1 To drw.Sheets.Count
Try
Dim sh As Sheet = drw.Sheets.Item(i)
Dim pl As PartsList
For Each pl In sh.PartsLists
DumpPartsListCsv(pl, SafeSheetName(sh), lines)
Next
Catch
End Try
Next
Return lines
End Function
'===== CSV TABLES =============================================================
' Only Parts List (BOM). Custom / revision / hole / bend tables are ignored.
' Separator is ";" (Polish Excel default).
Function CsvEscape(value As String) As String
' Make a cell safe for semicolon-separated CSV.
If value Is Nothing Then value = ""
value = value.Replace(vbCrLf, " ").Replace(vbCr, " ").Replace(vbLf, " ")
If value.Contains(";") OrElse value.Contains(""""c) OrElse value.Contains(",") Then
Return """" & value.Replace("""", """""") & """"
End If
Return value
End Function
Function CsvJoin(cells As List(Of String)) As String
' Join one CSV row with ";" between cells.
Dim i As Integer
Dim sb As New System.Text.StringBuilder()
For i = 0 To cells.Count - 1
If i > 0 Then sb.Append(";"c)
sb.Append(CsvEscape(cells(i)))
Next
Return sb.ToString()
End Function
Function CellText(cell As Object) As String
' Prefer .Text; fall back to .Value (PartsList cells often use Value).
Try
Return CStr(cell.Text)
Catch
Try
Return CStr(cell.Value)
Catch
Return ""
End Try
End Try
End Function
Function ColumnTitles(cols As Object) As List(Of String)
' Read header titles from a PartsListColumns collection.
Dim c As Integer
Dim header As New List(Of String)
For c = 1 To ObjCount(cols)
Try
header.Add(CStr(cols.Item(c).Title))
Catch
header.Add("")
End Try
Next
Return header
End Function
Function RowCells(rowObj As Object, colCount As Integer) As List(Of String)
' Read one data row as a list of cell strings.
Dim c As Integer
Dim data As New List(Of String)
For c = 1 To colCount
Try
data.Add(CellText(rowObj.Item(c)))
Catch
data.Add("")
End Try
Next
Return data
End Function
Function RowIsHidden(rowObj As Object) As Boolean
' PartsList rows can be invisible; skip them when dumping BOM.
Try
Return rowObj.Visible = False
Catch
Return False
End Try
End Function
Sub DumpPartsListCsv(pl As PartsList, sheetLabel As String, lines As List(Of String))
' Write: title line -> header row -> data rows -> blank separator line.
' PartsList uses PartsListColumns / PartsListRows (not generic Rows/Columns).
Dim title As String = ""
Try : title = pl.Title : Catch : End Try
Dim cols As Object = pl.PartsListColumns
Dim rows As Object = pl.PartsListRows
Dim colCount As Integer = ObjCount(cols)
If colCount <= 0 Then Return
lines.Add(CsvEscape("[" & sheetLabel & "] " & Nz(title, "Parts List")))
lines.Add(CsvJoin(ColumnTitles(cols)))
Dim r As Integer
For r = 1 To ObjCount(rows)
Dim rowObj As Object = rows.Item(r)
If RowIsHidden(rowObj) Then Continue For
lines.Add(CsvJoin(RowCells(rowObj, colCount)))
Next
lines.Add("")
End Sub
'===== ARCHIVE ================================================================
' If finalPath already exists: move/copy into
' old\<base>_<yyyyMMdd.HHmmss>.<ext>
' Prefer Move; if the file is locked, try Copy (same idea as VBA ArchiveToOld).
Function ArchiveToOld(finalPath As String) As Boolean
Try
If IsBlank(finalPath) Then Return True
finalPath = System.IO.Path.GetFullPath(finalPath)
' Nothing to archive - first export of this name
If Not FileExists(finalPath) Then Return True
Dim oldDir As String = System.IO.Path.Combine(System.IO.Path.GetDirectoryName(finalPath), "old")
If Not EnsureDir(oldDir) Then
MsgErr("Failed to archive into old\:" & vbCrLf & finalPath)
Return False
End If
Dim dest As String = UniqueArchivePath(finalPath, oldDir)
If TryMoveFile(finalPath, dest) Then Return True
' Fallback when Move fails (file open elsewhere, permissions, etc.)
If TryCopyFile(finalPath, dest) Then Return True
MsgErr("Failed to archive into old\:" & vbCrLf & finalPath)
Return False
Catch
MsgErr("Failed to archive into old\:" & vbCrLf & finalPath)
Return False
End Try
End Function
Function UniqueArchivePath(finalPath As String, oldDir As String) As String
' Build old\<base>_<stamp>.ext ; add _2, _3... if that name already exists.
Dim baseName As String = System.IO.Path.GetFileNameWithoutExtension(finalPath)
Dim ext As String = System.IO.Path.GetExtension(finalPath)
If ext.StartsWith(".") Then ext = ext.Substring(1)
' Stamp from the existing file's last write time
Dim stamp As String = System.IO.File.GetLastWriteTime(finalPath).ToString("yyyyMMdd.HHmmss")
Dim dest As String = System.IO.Path.Combine(oldDir, baseName & "_" & stamp & "." & ext)
Dim n As Integer = 2
Do While FileExists(dest)
dest = System.IO.Path.Combine(oldDir, baseName & "_" & stamp & "_" & n & "." & ext)
n += 1
Loop
Return dest
End Function
Function TryMoveFile(source As String, dest As String) As Boolean
' Prefer Move so the old file does not stay in the export folder.
Try
System.IO.File.Move(source, dest)
Return FileExists(dest) AndAlso Not FileExists(source)
Catch
Return False
End Try
End Function
Function TryCopyFile(source As String, dest As String) As Boolean
' Used when Move cannot lock/replace the source file.
Try
System.IO.File.Copy(source, dest, True)
Return FileExists(dest)
Catch
Return False
End Try
End Function
'==============================================================================
' Save.iLogicVb - Autodesk Inventor iLogic export rule (single file)
' Port of ExportTools.bas (SolidWorks VBA) to Inventor iLogic / VB.NET
'
' WHAT THIS RULE DOES
' Exports the active document next to the model file:
' PDF, DXF (sheet-metal flat / drawing), STL, CSV (drawing Parts List / BOM).
' Before overwriting an existing export, the old file is moved/copied into
' a subfolder named "old\" with a timestamp from LastWriteTime.
'
' HOW TO USE
' 1) Edit the SETTINGS functions below (True/False and mode numbers).
' 2) In Inventor: External Rules -> Add Rule -> select this .iLogicVb
' (prefer a local folder like AppData\Local\InventorRules, not W:\ / OneDrive).
' 3) The active document must already be saved on disk (needs a real path).
'
' RETURN CONTRACT (each Export* function)
' "" (empty string) = success (OK)
' any other string = failure detail shown in the summary MsgBox
'
' TYPICAL FLOW FOR ONE FORMAT
' BuildExportPath -> ArchiveToOld (if file exists) -> write new file
'
' NOTES FOR BEGINNERS
' - iLogic uses VB.NET (not VBA). Sub Main must come first in the rule.
' - Do NOT put Dim / Const / Shared fields above Main - iLogic will not compile.
' Settings are Functions that Return a value (same idea as VBA Const).
' - ThisApplication is given by iLogic (no GetObject like in SolidWorks VBA).
' - Primary write: Document.SaveAs(path, True). Fallback: TranslatorAddIn.
' - Sheet-metal DXF: FlatPattern DataIO (not a normal 3D SaveAs).
' Bend centerlines are dashed (LineType 37634). CfgDxfBendDashScale sets
' DXF header $LTSCALE so dashes are visible in CAM. Unfold uses A-Side if set.
' - Drawing DXF: one file per sheet. Names use English index only: _sht1, _sht2.
' If Inventor also writes a localized name (*_Arkusz_*), we keep only _shtN.dxf.
' - Drawing BOM: CSV (; separator, UTF-8 BOM) so Excel can open it.
' Runs only on a drawing that already has a Parts List; otherwise skipped.
' - Small helpers (IsPart, IsBlank, RequireArchive, ...) are "syntactic sugar":
' same logic, shorter and easier to read at call sites.
'==============================================================================
'===== ENTRY ==================================================================
Sub Main()
' fail: 0 = all OK so far, 1 = at least one mode failed
' msg: multi-line summary text for the final MsgBox ("PDF: OK", ...)
Dim fail As Integer = 0
Dim msg As String = ""
' Active document in Inventor (Part .ipt / Assembly .iam / Drawing .idw)
Dim oDoc As Document = ThisApplication.ActiveDocument
If oDoc Is Nothing Then
MsgErr("No active document.")
Return
End If
' Export needs a real folder on disk - unsaved docs have empty FullFileName
If Not HasSavedPath(oDoc) Then
MsgErr("Document must be saved before export.")
Return
End If
' Each mode: Cfg* = user on/off switch; CanExport* = document-type gate (silent skip)
If CfgExportPdf() Then RunMode("PDF", ExportPdf(oDoc), fail, msg)
If CfgExportDxf() AndAlso CanExportDxf(oDoc) Then RunMode("DXF", ExportDxf(oDoc), fail, msg)
If CfgExportStl() AndAlso CanExportStl(oDoc) Then RunMode("STL", ExportStl(oDoc), fail, msg)
' Excel/CSV only when drawing has Parts List (BOM) - no FAIL on Part/Assembly
If CfgExportExcel() AndAlso CanExportExcel(oDoc) Then RunMode("Excel", ExportExcel(oDoc), fail, msg)
ShowSummary(fail, msg)
End Sub
'----- SETTINGS (edit return values) ------------------------------------------
' Turn each export mode on/off. Only enabled modes run from Main().
' Change the Return value, then save the rule and run again.
' Implemented as Functions: iLogic forbids module-level Const/fields.
Function CfgExportPdf() As Boolean
' True = export PDF of the active document (Part / Assembly / Drawing).
Return True
End Function
Function CfgExportDxf() As Boolean
' True = export DXF.
' Allowed only for: sheet-metal Part (flat pattern) OR Drawing.
' Drawing with N sheets -> N DXF files (one per sheet).
Return True
End Function
Function CfgExportStl() As Boolean
' True = export STL.
' Allowed only for: Part OR Assembly (not Drawing).
Return True
End Function
Function CfgExportExcel() As Boolean
' True = dump drawing Parts List (BOM) into a .csv file (opens in Excel).
' Runs only when CanExportExcel: Drawing + at least one PartsList.
' On Part/Assembly (or drawing without BOM) the mode is skipped - no FAIL line.
Return True
End Function
Function CfgStlAssemblyMode() As Integer
' 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 leaf Part component
' naming: "<asmBase> - <compBase>.stl"
' 3 = both (1 then 2)
' Ignored for Parts (always one file).
Return 3
End Function
Function CfgDxfAddThickness() As Boolean
' True = for sheet-metal Part DXF, append thickness to the file name:
' e.g. "Bracket (S 2 mm).dxf"
' Thickness from SheetMetalComponentDefinition.Thickness (cm -> mm, *10).
Return True
End Function
Function CfgRemoveSpaces() As Boolean
' 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"
Return True
End Function
Function CfgNotify() As Integer
' 0 = show MsgBox only when something failed
' 1 = always show a summary MsgBox (OK/FAIL per mode)
Return 1
End Function
Function CfgDxfBendDashScale() As Double
' Sheet-metal DXF only: scale of dashed bend lines ($LTSCALE in DXF header).
' Inventor default dashes look tiny in many CAM viewers.
' 1 = Inventor default
' 10 = good starting value (current)
' 15..20 = even longer dashes - raise here if still too small
Return 10.0
End Function
'----- TRANSLATOR GUIDS (usually do not edit) ---------------------------------
' Official Autodesk Translator Add-In IDs used by SaveViaTranslator.
Function GuidPdf() As String
Return "{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}"
End Function
Function GuidDxf() As String
' Official Autodesk DXF Translator sample GUID (...CD80, not CD87).
Return "{C24E3AC4-122E-11D5-8E91-0010B541CD80}"
End Function
Function GuidStl() As String
Return "{533E9A98-FC3B-11D4-8E7E-0010B541CD87}"
End Function
Function DxfFlatFormat() As String
' Format string for sheet-metal flat pattern DXF via DataIO.WriteDataToFile.
'
' KEEP visible (manufacturing geometry):
' IV_OUTER_PROFILE - outer material edge (solid body for CAM)
' IV_INTERIOR_PROFILES - holes / cutouts / chamfer openings (material edges)
' IV_BEND / IV_BEND_DOWN - bend CENTERLINES only (where the brake applies)
' LineType 37634 = kDashedLineType (dashed)
' BendLayer* = legacy name; BendUp/Down = modern names
'
' HIDE (InvisibleLayers):
' IV_ARC_CENTERS - no circle/arc center marks
' IV_TANGENT - bend EXTENT / plane-boundary lines (not wanted)
' IV_FEATURE_PROFILES* - extra feature edges (incl. chamfer cosmetics)
' IV_TOOL_CENTER* - punch/tool centers
' IV_ALTREP_* - alternate representations
' IV_UNCONSUMED_SKETCH* - leftover sketches
' IV_ROLL* - roll lines
'
' AcadVersion=2007 - better linetype mapping than R12/2000.
' TrimCenterlinesAtContour=True - bend centerlines stop at the outer contour.
' After write, ScaleDxfBendDashes() sets $LTSCALE (see CfgDxfBendDashScale).
Return _
"FLAT PATTERN DXF?" & _
"AcadVersion=2007" & _
"&OuterProfileLayer=IV_OUTER_PROFILE" & _
"&InteriorProfilesLayer=IV_INTERIOR_PROFILES" & _
"&BendLayer=IV_BEND&BendLayerLineType=37634" & _
"&BendUpLayer=IV_BEND&BendUpLayerLineType=37634" & _
"&BendDownLayer=IV_BEND_DOWN&BendDownLayerLineType=37634" & _
"&TrimCenterlinesAtContour=True&SimplifySplines=True&MergeProfilesIntoPolyline=True" & _
"&InvisibleLayers=IV_ARC_CENTERS;IV_TANGENT;IV_FEATURE_PROFILES;IV_FEATURE_PROFILES_DOWN;" & _
"IV_TOOL_CENTER;IV_TOOL_CENTER_DOWN;IV_ALTREP_FRONT;IV_ALTREP_BACK;" & _
"IV_UNCONSUMED_SKETCHES;IV_UNCONSUMED_SKETCH_CONSTRUCTION;IV_ROLL;IV_ROLL_TANGENT"
End Function
'===== SYNTACTIC SUGAR ========================================================
' Tiny wrappers so call sites read like English.
' They do not change Inventor behavior - only make the code easier to scan.
Function IsBlank(s As String) As Boolean
' True when string is Nothing or "".
Return String.IsNullOrEmpty(s)
End Function
Function IsPart(oDoc As Document) As Boolean
' True for .ipt documents.
Return oDoc.DocumentType = DocumentTypeEnum.kPartDocumentObject
End Function
Function IsAssembly(oDoc As Document) As Boolean
' True for .iam documents.
Return oDoc.DocumentType = DocumentTypeEnum.kAssemblyDocumentObject
End Function
Function IsDrawing(oDoc As Document) As Boolean
' True for .idw / .dwg drawing documents.
Return oDoc.DocumentType = DocumentTypeEnum.kDrawingDocumentObject
End Function
Function HasSavedPath(oDoc As Document) As Boolean
' False for brand-new unsaved documents (no folder to export next to).
Return Not IsBlank(oDoc.FullFileName)
End Function
Function FileExists(path As String) As Boolean
' Short wrapper - easier to read than System.IO.File.Exists everywhere.
Return System.IO.File.Exists(path)
End Function
Function AsDrawing(oDoc As Document) As DrawingDocument
' Cast Document -> DrawingDocument (call only when IsDrawing is True).
Return CType(oDoc, DrawingDocument)
End Function
Function AsAssembly(oDoc As Document) As AssemblyDocument
' Cast Document -> AssemblyDocument (call only when IsAssembly is True).
Return CType(oDoc, AssemblyDocument)
End Function
Function AsPart(oDoc As Document) As PartDocument
' Cast Document -> PartDocument (call only when IsPart is True).
Return CType(oDoc, PartDocument)
End Function
Function IsFail(result As String) As Boolean
' True when Export* returned a non-empty string (= failure detail).
Return Not IsBlank(result)
End Function
Function ConfirmWritten(path As String, missingMsg As String) As String
' After a write attempt: "" if file exists on disk, otherwise missingMsg.
If FileExists(path) Then Return ""
Return missingMsg
End Function
Function RequireArchive(path As String) As String
' Move/copy any existing target into old\ before writing a new file.
' Returns "" on success, or a failure reason string.
If ArchiveToOld(path) Then Return ""
Return "failed to archive into old\"
End Function
Function JoinDetails(a As String, b As String) As String
' Merge two failure strings. Empty side is ignored (that step was OK).
If IsBlank(a) Then Return b
If IsBlank(b) Then Return a
Return a & "; " & b
End Function
Function Nz(value As String, fallback As String) As String
' Null/empty -> fallback (same idea as Access/VBA Nz).
If IsBlank(value) Then Return fallback
Return value
End Function
Function SafeSheetName(sh As Sheet) As String
' Sheet.Name, or "?" if the API throws.
Try
Return sh.Name
Catch
Return "?"
End Try
End Function
Function ObjCount(collection As Object) As Integer
' Safe .Count for late-bound Inventor collections (0 on error).
Try
Return CInt(collection.Count)
Catch
Return 0
End Try
End Function
'===== RESULT / UI ============================================================
Sub RunMode(label As String, result As String, ByRef fail As Integer, ByRef msg As String)
' Append one "LABEL: OK/FAIL" line and remember overall fail.
' ByRef = changes to fail/msg are visible back in Main.
If IsFail(result) Then
fail = 1
msg = msg & label & ": FAIL - " & result & vbCrLf
Else
msg = msg & label & ": OK" & vbCrLf
End If
End Sub
Sub ShowSummary(fail As Integer, msg As String)
' Nothing ran (all Cfg off, or no mode allowed for this doc type)
If IsBlank(msg) Then
msg = "No export modes enabled / available for this document type."
fail = 1
End If
' Show summary always (CfgNotify=1) or only when something failed
If CfgNotify() = 1 OrElse fail <> 0 Then
Dim icon As MsgBoxStyle = If(fail = 0, MsgBoxStyle.Information, MsgBoxStyle.Exclamation)
MsgBox(msg.Trim(), icon, "ExportTools")
End If
End Sub
Sub MsgErr(text As String)
' Simple error dialog (title matches the rule / VBA tool name).
MsgBox(text, MsgBoxStyle.Exclamation, "ExportTools")
End Sub
'===== PATH HELPERS ===========================================================
Function DocBaseName(oDoc As Document) As String
' File name without folder and without extension, e.g. "Bracket".
Return System.IO.Path.GetFileNameWithoutExtension(oDoc.FullFileName)
End Function
Function DocFolder(oDoc As Document) As String
' Folder that contains the model / drawing file.
Return System.IO.Path.GetDirectoryName(oDoc.FullFileName)
End Function
Function NormalizeFileName(fileName As String) As String
' Apply CfgRemoveSpaces rules to a file name (not a full path).
If CfgRemoveSpaces() Then Return LCase(Replace(fileName, " ", "_"))
Return fileName
End Function
Function BuildExportPath(oDoc As Document, ext As String, Optional suffix As String = "") As String
' Full path next to the document: <folder>\<normalizedBase><suffix>.<ext>
' Optional suffix example: " (S 2 mm)" for sheet-metal DXF, or "_sht1".
Return System.IO.Path.Combine(DocFolder(oDoc), NormalizeFileName(DocBaseName(oDoc) & suffix & "." & ext))
End Function
Function ComponentStlPath(asmDoc As Document, partDoc As Document) As String
' Per-component STL next to the assembly, e.g. "my_asm - bracket.stl".
Dim name As String = DocBaseName(asmDoc) & " - " & DocBaseName(partDoc) & ".stl"
Return System.IO.Path.Combine(DocFolder(asmDoc), NormalizeFileName(name))
End Function
Function EnsureDir(dirPath As String) As Boolean
' Create folder if missing. Returns False only if creation fails.
Try
If Not System.IO.Directory.Exists(dirPath) Then System.IO.Directory.CreateDirectory(dirPath)
Return True
Catch
Return False
End Try
End Function
Function WriteUtf8BomLines(path As String, lines As List(Of String)) As String
' Write text file as UTF-8 with BOM so Excel recognizes Polish characters.
Try
System.IO.File.WriteAllLines(path, lines.ToArray(), New System.Text.UTF8Encoding(True))
Return ConfirmWritten(path, "csv not written")
Catch ex As Exception
Return ex.Message
End Try
End Function
'===== RULES (when is each mode allowed?) =====================================
Function CanExportDxf(oDoc As Document) As Boolean
' Drawing -> yes. Part -> only if sheet metal. Assembly -> no.
Return IsDrawing(oDoc) OrElse (IsPart(oDoc) AndAlso IsSheetMetalPart(oDoc))
End Function
Function CanExportStl(oDoc As Document) As Boolean
' Part or Assembly only (drawings have no solid mesh to STL).
Return IsPart(oDoc) OrElse IsAssembly(oDoc)
End Function
Function CanExportExcel(oDoc As Document) As Boolean
' Must be a drawing AND at least one sheet must contain a Parts List (BOM).
If Not IsDrawing(oDoc) Then Return False
Return DrawingHasPartsList(AsDrawing(oDoc))
End Function
Function DrawingHasPartsList(drw As DrawingDocument) As Boolean
' True if any sheet has PartsLists.Count > 0.
Dim i As Integer
For i = 1 To drw.Sheets.Count
Try
If drw.Sheets.Item(i).PartsLists.Count > 0 Then Return True
Catch
End Try
Next
Return False
End Function
Function IsSheetMetalPart(oDoc As Document) As Boolean
' True when ComponentDefinition is SheetMetalComponentDefinition.
Try
If Not IsPart(oDoc) Then Return False
Return TypeOf AsPart(oDoc).ComponentDefinition Is SheetMetalComponentDefinition
Catch
Return False
End Try
End Function
Function GetSheetMetalDef(oDoc As Document) As SheetMetalComponentDefinition
' Cast helper - call only after IsSheetMetalPart is True.
Return CType(AsPart(oDoc).ComponentDefinition, SheetMetalComponentDefinition)
End Function
Function GetSheetMetalThicknessMm(oDoc As Document) As Double
' Inventor stores length in cm internally -> multiply by 10 to get mm.
Try
Return GetSheetMetalDef(oDoc).Thickness.Value * 10.0
Catch
Return 0
End Try
End Function
Function DxfThicknessSuffix(oDoc As Document) As String
' Text glued into the DXF file name when CfgDxfAddThickness is True.
If Not CfgDxfAddThickness() Then Return ""
Dim thk As Double = GetSheetMetalThicknessMm(oDoc)
If thk <= 0 Then Return ""
Return " (S " & Format(thk, "0.##") & " mm)"
End Function
'===== CORE WRITE =============================================================
' Shared pipeline for PDF / drawing DXF / STL:
' 1) RequireArchive / ArchiveToOld if the target file already exists
' 2) Document.SaveAs(path, True) - True = save a COPY, keep original open
' 3) If that fails -> TranslatorAddIn.SaveCopyAs (GUID for the format)
Function ExportViaSaveAs(oDoc As Document, ext As String, guid As String, Optional suffix As String = "") As String
' One-liner used by ExportPdf / single-file STL (not multi-sheet drawing DXF).
Return WriteExportFile(oDoc, BuildExportPath(oDoc, ext, suffix), guid)
End Function
Function WriteExportFile(oDoc As Document, path As String, guid As String) As String
' Full write pipeline with archive + SaveAs + translator fallback.
Dim arch As String = RequireArchive(path)
If IsFail(arch) Then Return arch
Dim detail As String = TrySaveAsCopy(oDoc, path)
If Not IsFail(detail) Then Return ""
' Fallback when SaveAs is not enough for this format/document
Dim trDetail As String = SaveViaTranslator(oDoc, guid, path)
If Not IsFail(trDetail) Then Return ""
Return JoinDetails(detail, trDetail)
End Function
Function TrySaveAsCopy(oDoc As Document, path As String) As String
' True = save a COPY; original document path stays unchanged.
Try
oDoc.SaveAs(path, True)
Return ConfirmWritten(path, "SaveAs did not create file")
Catch ex As Exception
Return "SaveAs: " & ex.Message
End Try
End Function
Function SaveViaTranslator(oDoc As Document, guid As String, path As String) As String
' Look up Inventor translator add-in by GUID, then SaveCopyAs to path.
Dim addIn As ApplicationAddIn = Nothing
Try
addIn = ThisApplication.ApplicationAddIns.ItemById(guid)
Catch ex As Exception
Return "translator add-in missing " & guid & " - " & ex.Message
End Try
Dim tr As TranslatorAddIn = TryCast(addIn, TranslatorAddIn)
If tr Is Nothing Then Return "add-in is not TranslatorAddIn"
If Not tr.Activated Then tr.Activate()
' TranslationContext + DataMedium = where/how to write the file
Dim ctx As TranslationContext = ThisApplication.TransientObjects.CreateTranslationContext()
ctx.Type = IOMechanismEnum.kFileBrowseIOMechanism
Dim opts As NameValueMap = ThisApplication.TransientObjects.CreateNameValueMap()
Dim data As DataMedium = ThisApplication.TransientObjects.CreateDataMedium()
data.FileName = path
' HasSaveCopyAsOptions fills default options when the translator supports them.
' In VB.NET the Boolean return must be assigned (cannot call as a bare statement).
Dim unusedOpts As Boolean = tr.HasSaveCopyAsOptions(oDoc, ctx, opts)
tr.SaveCopyAs(oDoc, ctx, opts, data)
Return ConfirmWritten(path, "Translator did not create file")
End Function
'===== EXPORT MODES ===========================================================
Function ExportPdf(oDoc As Document) As String
' PDF next to the document (any type SaveAs/Translator accepts).
Return ExportViaSaveAs(oDoc, "pdf", GuidPdf())
End Function
Function ExportDxf(oDoc As Document) As String
' Part (sheet metal) -> flat-pattern DataIO
' Drawing -> one DXF per sheet (Activate + Translator). Multi-sheet SaveAs is unreliable.
If IsPart(oDoc) Then
Return ExportSheetMetalDxf(oDoc, BuildExportPath(oDoc, "dxf", DxfThicknessSuffix(oDoc)))
End If
If IsDrawing(oDoc) Then Return ExportDrawingDxfPerSheet(oDoc)
Return "DXF: unsupported document type"
End Function
Function ExportDrawingDxfPerSheet(oDoc As Document) As String
' Each sheet -> separate DXF next to the drawing.
' Single sheet: <base>.dxf
' Multi sheet: <base>_sht1.dxf, <base>_sht2.dxf, ...
' English index only - never localized titles (Arkusz / Sheet / ...).
Dim drw As DrawingDocument = AsDrawing(oDoc)
Dim prevSheet As Sheet = Nothing
Try : prevSheet = drw.ActiveSheet : Catch : End Try
Dim multi As Boolean = (drw.Sheets.Count > 1)
Dim nOk As Integer = 0
Dim nFail As Integer = 0
Dim lastErr As String = ""
Dim i As Integer
For i = 1 To drw.Sheets.Count
Try
' Translator exports the ACTIVE sheet - activate each one in turn
drw.Sheets.Item(i).Activate()
Dim suffix As String = ""
If multi Then suffix = "_sht" & i.ToString()
Dim r As String = ExportOneDrawingSheetDxf(oDoc, BuildExportPath(oDoc, "dxf", suffix))
If IsFail(r) Then
nFail += 1
lastErr = r
Else
nOk += 1
End If
Catch ex As Exception
nFail += 1
lastErr = ex.Message
End Try
Next
' Restore previously active sheet so the user is not left on the last sheet
Try
If Not prevSheet Is Nothing Then prevSheet.Activate()
Catch
End Try
If nOk = 0 Then Return Nz(lastErr, "DXF failed for all sheets")
If nFail > 0 Then Return "exported " & nOk.ToString() & "/" & (nOk + nFail).ToString() & " sheets - " & lastErr
Return ""
End Function
Function ExportOneDrawingSheetDxf(oDoc As Document, path As String) As String
' Active sheet must already be set by caller.
' Archive -> Translator -> SaveAs fallback.
' Inventor often writes BOTH our path and an extra localized name (*_Arkusz_*).
' ResolveNewDxf keeps only expectedPath and deletes the duplicates.
Dim arch As String = RequireArchive(path)
If IsFail(arch) Then Return arch
Dim folder As String = System.IO.Path.GetDirectoryName(path)
' Snapshot *.dxf before write so we can detect Inventor's real output name
Dim before As List(Of String) = ListDxfFiles(folder)
Dim trDetail As String = SaveViaTranslator(oDoc, GuidDxf(), path)
If Not IsFail(ResolveNewDxf(folder, before, path)) Then Return ""
before = ListDxfFiles(folder)
Dim saDetail As String = TrySaveAsCopy(oDoc, path)
If Not IsFail(ResolveNewDxf(folder, before, path)) Then Return ""
Return JoinDetails(Nz(trDetail, "Translator did not create file"), _
Nz(saDetail, "SaveAs did not create file"))
End Function
Function ListDxfFiles(folder As String) As List(Of String)
' Snapshot of *.dxf paths in folder (for detecting Inventor's real output name).
Dim list As New List(Of String)
Try
If System.IO.Directory.Exists(folder) Then list.AddRange(System.IO.Directory.GetFiles(folder, "*.dxf"))
Catch
End Try
Return list
End Function
Function PathInList(list As List(Of String), path As String) As Boolean
' Case-insensitive path membership test.
Dim p As String
For Each p In list
If String.Equals(p, path, StringComparison.OrdinalIgnoreCase) Then Return True
Next
Return False
End Function
Sub TryDeleteFile(path As String)
' Best-effort delete (ignore lock / missing file).
Try
If FileExists(path) Then System.IO.File.Delete(path)
Catch
End Try
End Sub
Sub DeleteExtraDxfNewcomers(newcomers As List(Of String), keepPath As String)
' Remove Inventor duplicate outputs (e.g. *_Arkusz_1.dxf), keep only keepPath.
Dim f As String
For Each f In newcomers
If Not String.Equals(f, keepPath, StringComparison.OrdinalIgnoreCase) Then TryDeleteFile(f)
Next
End Sub
Function NewestPath(paths As List(Of String)) As String
' Path with the newest LastWriteTime (used when Inventor invents its own DXF name).
If paths Is Nothing OrElse paths.Count = 0 Then Return ""
Dim best As String = paths(0)
Dim bestTime As DateTime = System.IO.File.GetLastWriteTime(best)
Dim i As Integer
For i = 1 To paths.Count - 1
Dim t As DateTime = System.IO.File.GetLastWriteTime(paths(i))
If t > bestTime Then
bestTime = t
best = paths(i)
End If
Next
Return best
End Function
Function ListNewDxfFiles(folder As String, before As List(Of String)) As List(Of String)
' Files that appeared in folder after the "before" snapshot.
Dim newcomers As New List(Of String)
Dim f As String
For Each f In ListDxfFiles(folder)
If Not PathInList(before, f) Then newcomers.Add(f)
Next
Return newcomers
End Function
Function ResolveNewDxf(folder As String, before As List(Of String), expectedPath As String) As String
' Keep only expectedPath. Inventor may create expectedPath AND/OR a localized
' duplicate (*_Arkusz_* / *_Sheet_*). Rename if needed, then delete extras.
Dim newcomers As List(Of String) = ListNewDxfFiles(folder, before)
If FileExists(expectedPath) Then
DeleteExtraDxfNewcomers(newcomers, expectedPath)
Return ""
End If
If newcomers.Count = 0 Then Return "DXF file not found after export"
Dim best As String = NewestPath(newcomers)
If IsBlank(best) Then Return "DXF file not found after export"
Try
TryDeleteFile(expectedPath)
System.IO.File.Move(best, expectedPath)
Catch ex As Exception
If FileExists(best) Then
' Could not rename - still drop other extras, keep Inventor file as last resort
DeleteExtraDxfNewcomers(newcomers, best)
Return ""
End If
Return "DXF rename failed: " & ex.Message
End Try
' Drop any other newcomers left behind after the move
newcomers = ListNewDxfFiles(folder, before)
Dim f As String
Dim extras As New List(Of String)
For Each f In newcomers
If Not String.Equals(f, expectedPath, StringComparison.OrdinalIgnoreCase) Then extras.Add(f)
Next
DeleteExtraDxfNewcomers(extras, expectedPath)
Return ConfirmWritten(expectedPath, "DXF file not found after export")
End Function
Function ExportSheetMetalDxf(oDoc As Document, path As String) As String
' Unfold / edit flat pattern, write DXF with DataIO format string,
' then enlarge bend dash pattern for CAM viewers.
Dim arch As String = RequireArchive(path)
If IsFail(arch) Then Return arch
Dim sm As SheetMetalComponentDefinition = Nothing
Try
sm = GetSheetMetalDef(oDoc)
PrepareFlatPattern(sm)
' DataIO writes layers/linetypes from DxfFlatFormat()
sm.DataIO.WriteDataToFile(DxfFlatFormat(), path)
TryExitFlatEdit(sm)
Dim written As String = ConfirmWritten(path, "DXF flat - no file after WriteDataToFile")
If IsFail(written) Then Return written
' Inventor dashed bends are often too fine - patch DXF header $LTSCALE
ScaleDxfBendDashes(path, CfgDxfBendDashScale())
Return ""
Catch ex As Exception
TryExitFlatEdit(sm)
Return "DXF flat: " & ex.Message
End Try
End Function
Sub PrepareFlatPattern(sm As SheetMetalComponentDefinition)
' Create flat pattern if missing; otherwise enter edit for DataIO context.
' Unfold() uses the part A-Side definition when it is already set in Inventor
' (plane A facing up for manufacturing).
If Not sm.HasFlatPattern Then
sm.Unfold()
Else
sm.FlatPattern.Edit()
End If
End Sub
Sub TryExitFlatEdit(sm As SheetMetalComponentDefinition)
' Always leave flat-pattern edit mode, even after an error.
If sm Is Nothing Then Return
Try
If sm.HasFlatPattern Then sm.FlatPattern.ExitEdit()
Catch
End Try
End Sub
Sub ScaleDxfBendDashes(dxfPath As String, scale As Double)
' Set DXF header $LTSCALE so dashed bend lines render with longer dashes.
' DXF stores settings as code/value pairs (group codes). Example:
' 9
' $LTSCALE
' 40
' 10.0
' Encoding ISO-8859-1 keeps Inventor byte values (PL linetype names stay intact).
If IsBlank(dxfPath) OrElse Not FileExists(dxfPath) OrElse scale <= 0 Then Return
Dim enc As System.Text.Encoding = System.Text.Encoding.GetEncoding("ISO-8859-1")
Dim lines As New List(Of String)
lines.AddRange(System.IO.File.ReadAllLines(dxfPath, enc))
If lines.Count < 8 Then Return
Dim scaleText As String = scale.ToString(System.Globalization.CultureInfo.InvariantCulture)
Dim i As Integer
Dim found As Boolean = False
' Case 1: $LTSCALE already exists - overwrite its numeric value (group 40)
For i = 0 To lines.Count - 2
If lines(i).Trim() = "9" AndAlso lines(i + 1).Trim().ToUpperInvariant() = "$LTSCALE" Then
Dim j As Integer
Dim jMax As Integer = i + 6
If jMax > lines.Count - 2 Then jMax = lines.Count - 2
For j = i + 2 To jMax Step 2
If lines(j).Trim() = "40" Then
lines(j + 1) = scaleText
found = True
Exit For
End If
Next
Exit For
End If
Next
' Case 2: missing - insert before first ENDSEC (end of HEADER in Inventor flat DXF)
If Not found Then
For i = 0 To lines.Count - 2
If lines(i).Trim() = "0" AndAlso lines(i + 1).Trim().ToUpperInvariant() = "ENDSEC" Then
lines.Insert(i, scaleText)
lines.Insert(i, " 40")
lines.Insert(i, "$LTSCALE")
lines.Insert(i, " 9")
found = True
Exit For
End If
Next
End If
If found Then System.IO.File.WriteAllLines(dxfPath, lines.ToArray(), enc)
End Sub
Function ExportStl(oDoc As Document) As String
' Single part -> always one STL file
If IsPart(oDoc) Then Return ExportViaSaveAs(oDoc, "stl", GuidStl())
' Assembly -> depend on CfgStlAssemblyMode (1 / 2 / 3)
Dim path As String = BuildExportPath(oDoc, "stl")
Select Case CfgStlAssemblyMode()
Case 1
Return WriteExportFile(oDoc, path, GuidStl())
Case 2
Return StlAssemblyPerComponent(oDoc)
Case 3
' Run both; JoinDetails keeps OK empty and merges any errors
Return JoinDetails(WriteExportFile(oDoc, path, GuidStl()), StlAssemblyPerComponent(oDoc))
Case Else
Return "invalid CfgStlAssemblyMode"
End Select
End Function
Function StlAssemblyPerComponent(oDoc As Document) As String
' One STL per leaf Part occurrence.
' Skips suppressed components, non-Part docs, and unsaved references.
Dim nOk As Integer = 0
Dim lastErr As String = ""
Try
Dim occ As ComponentOccurrence
For Each occ In AsAssembly(oDoc).ComponentDefinition.Occurrences.AllLeafOccurrences
If occ.Suppressed Then Continue For
Dim refDoc As Document = TryGetOccurrencePart(occ)
If refDoc Is Nothing Then Continue For
Dim r As String = WriteExportFile(refDoc, ComponentStlPath(oDoc, refDoc), GuidStl())
If IsFail(r) Then
lastErr = r
Else
nOk += 1
End If
Next
If nOk = 0 AndAlso IsBlank(lastErr) Then Return "no Part components"
Return lastErr
Catch ex As Exception
Return ex.Message
End Try
End Function
Function TryGetOccurrencePart(occ As ComponentOccurrence) As Document
' Return the Part document behind an occurrence, or Nothing if not usable.
Try
Dim refDoc As Document = occ.Definition.Document
If refDoc Is Nothing OrElse Not IsPart(refDoc) OrElse Not HasSavedPath(refDoc) Then Return Nothing
Return refDoc
Catch
Return Nothing
End Try
End Function
Function ExportExcel(oDoc As Document) As String
' Dump Parts List (BOM) rows to CSV next to the drawing.
' No Excel.Application - COM SaveAs was unreliable; CSV opens in Excel.
Dim path As String = BuildExportPath(oDoc, "csv")
Dim arch As String = RequireArchive(path)
If IsFail(arch) Then Return arch
Try
Dim lines As List(Of String) = CollectBomCsvLines(AsDrawing(oDoc))
If lines.Count = 0 Then Return "no Parts List (BOM) on drawing"
Return WriteUtf8BomLines(path, lines)
Catch ex As Exception
Return ex.Message
End Try
End Function
Function CollectBomCsvLines(drw As DrawingDocument) As List(Of String)
' Walk all sheets; dump every PartsList into CSV lines.
Dim lines As New List(Of String)
Dim i As Integer
For i = 1 To drw.Sheets.Count
Try
Dim sh As Sheet = drw.Sheets.Item(i)
Dim pl As PartsList
For Each pl In sh.PartsLists
DumpPartsListCsv(pl, SafeSheetName(sh), lines)
Next
Catch
End Try
Next
Return lines
End Function
'===== CSV TABLES =============================================================
' Only Parts List (BOM). Custom / revision / hole / bend tables are ignored.
' Separator is ";" (Polish Excel default).
Function CsvEscape(value As String) As String
' Make a cell safe for semicolon-separated CSV.
If value Is Nothing Then value = ""
value = value.Replace(vbCrLf, " ").Replace(vbCr, " ").Replace(vbLf, " ")
If value.Contains(";") OrElse value.Contains(""""c) OrElse value.Contains(",") Then
Return """" & value.Replace("""", """""") & """"
End If
Return value
End Function
Function CsvJoin(cells As List(Of String)) As String
' Join one CSV row with ";" between cells.
Dim i As Integer
Dim sb As New System.Text.StringBuilder()
For i = 0 To cells.Count - 1
If i > 0 Then sb.Append(";"c)
sb.Append(CsvEscape(cells(i)))
Next
Return sb.ToString()
End Function
Function CellText(cell As Object) As String
' Prefer .Text; fall back to .Value (PartsList cells often use Value).
Try
Return CStr(cell.Text)
Catch
Try
Return CStr(cell.Value)
Catch
Return ""
End Try
End Try
End Function
Function ColumnTitles(cols As Object) As List(Of String)
' Read header titles from a PartsListColumns collection.
Dim c As Integer
Dim header As New List(Of String)
For c = 1 To ObjCount(cols)
Try
header.Add(CStr(cols.Item(c).Title))
Catch
header.Add("")
End Try
Next
Return header
End Function
Function RowCells(rowObj As Object, colCount As Integer) As List(Of String)
' Read one data row as a list of cell strings.
Dim c As Integer
Dim data As New List(Of String)
For c = 1 To colCount
Try
data.Add(CellText(rowObj.Item(c)))
Catch
data.Add("")
End Try
Next
Return data
End Function
Function RowIsHidden(rowObj As Object) As Boolean
' PartsList rows can be invisible; skip them when dumping BOM.
Try
Return rowObj.Visible = False
Catch
Return False
End Try
End Function
Sub DumpPartsListCsv(pl As PartsList, sheetLabel As String, lines As List(Of String))
' Write: title line -> header row -> data rows -> blank separator line.
' PartsList uses PartsListColumns / PartsListRows (not generic Rows/Columns).
Dim title As String = ""
Try : title = pl.Title : Catch : End Try
Dim cols As Object = pl.PartsListColumns
Dim rows As Object = pl.PartsListRows
Dim colCount As Integer = ObjCount(cols)
If colCount <= 0 Then Return
lines.Add(CsvEscape("[" & sheetLabel & "] " & Nz(title, "Parts List")))
lines.Add(CsvJoin(ColumnTitles(cols)))
Dim r As Integer
For r = 1 To ObjCount(rows)
Dim rowObj As Object = rows.Item(r)
If RowIsHidden(rowObj) Then Continue For
lines.Add(CsvJoin(RowCells(rowObj, colCount)))
Next
lines.Add("")
End Sub
'===== ARCHIVE ================================================================
' If finalPath already exists: move/copy into
' old\<base>_<yyyyMMdd.HHmmss>.<ext>
' Prefer Move; if the file is locked, try Copy (same idea as VBA ArchiveToOld).
Function ArchiveToOld(finalPath As String) As Boolean
Try
If IsBlank(finalPath) Then Return True
finalPath = System.IO.Path.GetFullPath(finalPath)
' Nothing to archive - first export of this name
If Not FileExists(finalPath) Then Return True
Dim oldDir As String = System.IO.Path.Combine(System.IO.Path.GetDirectoryName(finalPath), "old")
If Not EnsureDir(oldDir) Then
MsgErr("Failed to archive into old\:" & vbCrLf & finalPath)
Return False
End If
Dim dest As String = UniqueArchivePath(finalPath, oldDir)
If TryMoveFile(finalPath, dest) Then Return True
' Fallback when Move fails (file open elsewhere, permissions, etc.)
If TryCopyFile(finalPath, dest) Then Return True
MsgErr("Failed to archive into old\:" & vbCrLf & finalPath)
Return False
Catch
MsgErr("Failed to archive into old\:" & vbCrLf & finalPath)
Return False
End Try
End Function
Function UniqueArchivePath(finalPath As String, oldDir As String) As String
' Build old\<base>_<stamp>.ext ; add _2, _3... if that name already exists.
Dim baseName As String = System.IO.Path.GetFileNameWithoutExtension(finalPath)
Dim ext As String = System.IO.Path.GetExtension(finalPath)
If ext.StartsWith(".") Then ext = ext.Substring(1)
' Stamp from the existing file's last write time
Dim stamp As String = System.IO.File.GetLastWriteTime(finalPath).ToString("yyyyMMdd.HHmmss")
Dim dest As String = System.IO.Path.Combine(oldDir, baseName & "_" & stamp & "." & ext)
Dim n As Integer = 2
Do While FileExists(dest)
dest = System.IO.Path.Combine(oldDir, baseName & "_" & stamp & "_" & n & "." & ext)
n += 1
Loop
Return dest
End Function
Function TryMoveFile(source As String, dest As String) As Boolean
' Prefer Move so the old file does not stay in the export folder.
Try
System.IO.File.Move(source, dest)
Return FileExists(dest) AndAlso Not FileExists(source)
Catch
Return False
End Try
End Function
Function TryCopyFile(source As String, dest As String) As Boolean
' Used when Move cannot lock/replace the source file.
Try
System.IO.File.Copy(source, dest, True)
Return FileExists(dest)
Catch
Return False
End Try
End Function