DXF & fabrication · R12
Sheet-Metal DXF Export by Material and Thickness
A SolidWorks VBA branch for native flat-pattern export with material/thickness grouping and configuration selection.
ENGINEERING CONTRIBUTION
Extended the export workflow through R12 with native sheet-metal flat-pattern handling.
Prerequisites
- SolidWorks VBA; saved CAD with appropriate manufacturing properties and sheet-metal features for native flat-pattern export.
- Configure local templates; confirm the selected DXF/nesting configuration and material classification.
- Writable output folder and downstream software compatible with generated quantity JSON and inch thickness buckets.
Additional setup
- Match the material properties, configuration naming and local template paths to your CAD environment.
SOURCE WALKTHROUGH
How the workflow fits together.
- 01
Resolve the manufacturing configuration
The module scores candidate DXF/nesting configuration names, evaluates properties and chooses part/assembly/drawing-view processing.
- 02
Classify stock
Material and thickness resolution combines metadata and geometric extent along the export normal. Thickness folder values are normalized to inch buckets.
- 03
Choose a valid export route
Native sheet-metal flat-pattern export is enabled with single-body safety rules. Ordinary bodies use the geometry-aware temporary-part route and orientation postprocessing.
- 04
Write a traceable run
Default output uses timestamped run folders under DXF FOR WATERJET CUT and per-folder QTY.json. CLEAR_DXF_ROOT_BEFORE_RUN defaults to False.
Output & model changes
- Writes DXF files, quantity JSON and run logs; creates temporary documents.
- Can switch configurations and alter temporary model/view state.
- Contains optional cleanup behavior; defaults retain the output root and write a timestamped run folder.
CODE & ENTRY POINTS
Read the implementation.
Find a procedure, follow an API call or download the module for your SolidWorks setup.
SheetMetalDxfExport.bas
Material/thickness export classification, nesting configuration selection, native sheet-metal flat-pattern handling, quantity sidecars and geometry-based fallback export.
VBA · 9,996 lines
Entry points
API & integration calls
Option Explicit
'=========================================================================================
' SAVE_ALL_DXF_ACCORDING_TO_MATERIAL_THICKNESS_MACRO
'
' REVISION: CRASH_SAFE_R12_NATIVE_SHEET_METAL_FLAT_PATTERN_EXPORT
'
' PURPOSE
' Production-oriented macro for weldment DXF export:
'
' PART MODE
' - Runs on the active part
' - If the part has real cut-list folders, it is treated as weldment / cut-list mode
' - Reads evaluated cut-list property "DXF"
' - For single-body parts, if cut-list DXF is blank, falls back to part property DXF (then legacy DXY)
' - Exports only qualifying cut-list items where the effective DXF flag resolves to YES
' - If the part is a regular part (no real cut-list folders), checks part property "DXF" first, then legacy "DXY" as fallback
' - Exports the whole part only when the part-level export flag resolves to YES
'
' ASSEMBLY MODE
' - Runs on the active assembly
' - Recursively traverses all components / subassemblies
' - Processes each unique PART + CONFIGURATION once
' - Exports eligible cut-list items or regular parts from each qualifying part
'
' EXPORT RULES
' - Uses native SolidWorks sheet-metal flat-pattern DXF export for eligible single-body sheet-metal parts
' - Uses largest planar face as export normal for weldment/plate/generic fallback exports
' - DXF nesting configuration selection is ON by default
' - Configuration names are scanned for DXF / WATERJET / CUTTING / NESTING intent
' - Examples recognized: DXF, WATERJET, DXF CUT, WATERJET CUT,
' FOR WATERJET CUTTING, DXF FOR WATERJET CUTTING, DXF_WATERJET,
' WATERJET_CUTTING_DXF, and similar names
' - Exact WATERJET_CUT behavior is preserved as a legacy fallback
' - Otherwise uses the referenced / active configuration as normal
' - Sheet-metal native export uses the default SolidWorks flat pattern/unbend state; it does not require a flat configuration
' - Multi-body sheet-metal/cut-list items intentionally remain on the existing per-body fallback path unless safely single-body
' - Uses the two longest perpendicular straight edges that share a corner when available
' - If a longer non-intersecting perpendicular pair exists, it overrides the shared-corner pair to ignore chamfers
' - Orients that shared or virtual corner as the bottom-left export corner
' - If no shared-corner perpendicular pair exists, uses the two longest perpendicular straight edges even when separated by chamfers/gaps
' - Falls back to longest straight edge horizontal when no suitable perpendicular pair exists
' - Writes DXFs into <active model folder>\DXF\<MATERIAL>\<GEOMETRIC_THICKNESS>
' - Multi-body uses PART NUMBER.dxf; single-body parts use saved part file name directly
' - Thickness folders are derived from body extent along the nesting normal, rounded to three decimals
' - Single-body parts export directly from the source part using the oriented current view
' - Multi-body / isolated cut-list bodies still use direct temp-part DXF export by named view
' - Hides sketches before DXF export to avoid stray sketch geometry
' - DRAWING MODE: if the active doc is a drawing and a drawing view is selected,
' the macro uses that view orientation for DXF export and uses the view's
' referenced part/configuration as the source model state
'
' NOTES
' - Duplicate output names are auto-resolved with _01, _02, etc.
' - If a component part is used multiple times in the assembly with the same
' referenced configuration, it is only processed once.
' - If the same part is used in multiple different configurations, each unique
' configuration is processed once.
'
'=========================================================================================
'------------------------------------------
' SolidWorks app/document globals
'------------------------------------------
Private swApp As SldWorks.SldWorks
Private swModel As SldWorks.ModelDoc2
Private swPart As SldWorks.PartDoc
Private swExt As SldWorks.ModelDocExtension
Private swMathUtil As SldWorks.MathUtility
'------------------------------------------
' Settings
'------------------------------------------
Private Const OUT_FOLDER_NAME As String = "DXF FOR WATERJET CUT"
Private Const USE_DXF_NESTING_CONFIGURATION As Boolean = True
Private Const DXF_NESTING_CONFIG_MIN_SCORE As Long = 5000
Private Const LEGACY_WATERJET_CONFIG_NAME As String = "WATERJET_CUT"
Private Const PROP_DXF As String = "DXF"
Private Const PROP_DXY As String = "DXY"
Private Const PROP_PARTNO As String = "PART NUMBER"
Private Const PROP_MATERIAL As String = "MATERIAL"
Private Const PROP_THICKNESS As String = "THICKNESS"
Private Const PROP_CANDIDATES_MATERIAL As String = "MATERIAL|Material|SW-Material|Material Description|MATERIAL DESCRIPTION|DESCRIPTION MATERIAL|Stock Material|STOCK MATERIAL"
Private Const PROP_CANDIDATES_THICKNESS As String = "THICKNESS|Thickness|PLATE THICKNESS|Plate Thickness|MATERIAL THICKNESS|Material Thickness|STOCK THICKNESS|Stock Thickness|SW-Thickness|Sheet Metal Thickness|SW-Sheet Metal Thickness|SheetMetalThickness|Sheet Metal Gauge"
Private Const JSON_FILE_NAME As String = "QTY.json"
Private Const JSON_SIMPLE_FILE_NAME As String = "QTY_SIMPLE.json"
Private Const UNKNOWN_MATERIAL_FOLDER As String = "_UNCLASSIFIED_MATERIAL"
Private Const UNKNOWN_THICKNESS_FOLDER As String = "_THICKNESS_RESOLUTION_FAILED"
Private Const PROP_TRUE_VALUE As String = "YES"
Private Const EPS As Double = 0.0000001
Private Const PT_TOL As Double = 0.000001
Private Const PERP_DOT_TOL As Double = 0.001
Private Const SHEET_MARGIN_M As Double = 0.05
Private Const MIN_SHEET_W_M As Double = 0.3
Private Const MIN_SHEET_H_M As Double = 0.2
Private Const TEMP_PREFIX As String = "WJDXF_"
Private Const TEMP_VIEW_NAME As String = "WATERJET_EXPORT_VIEW"
Private Const PI_VAL As Double = 3.14159265358979
Private Const CUSTOM_DRAWING_TEMPLATE As String = "C:\Public\Templates\Blank.drwdot"
'------------------------------------------
' Output / nesting-batch behavior
'------------------------------------------
' When True, the macro clears the DXF root folder at the start of the run.
' This prevents stale DXFs from previous runs being picked up by nesting software.
' Safety check: cleanup only runs when the leaf folder name equals OUT_FOLDER_NAME.
Private Const CLEAR_DXF_ROOT_BEFORE_RUN As Boolean = False
' Production network-safe mode:
' - The macro never deletes the root output folder.
' - Each run writes into DXF FOR WATERJET CUT\RUN_YYYYMMDD_HHMMSS.
' - This avoids Windows/network permission errors caused by deleting/recreating folders
' while Explorer or nesting software is watching the folder.
Private Const USE_TIMESTAMPED_RUN_FOLDER As Boolean = True
Private Const RUN_FOLDER_PREFIX As String = "RUN_"
' QTY.json is intentionally production-minimal for nesting software.
' It contains only file name and quantity records. QTY_SIMPLE.json is disabled by default.
Private Const WRITE_SIMPLE_QTY_JSON As Boolean = False
' Thickness folders are normalized to inch buckets, for example 0.250_IN.
' Raw MM values with MM in the property are converted to inches.
Private Const NORMALIZE_THICKNESS_TO_INCH_FOLDERS As Boolean = True
' For waterjet nesting, thickness must come from the same orientation used for DXF export.
' This uses the body extent along the export normal (faceN) and formats the folder to three decimals.
Private Const GEOMETRIC_THICKNESS_FOR_NESTING_FOLDER As Boolean = True
Private Const FAIL_ITEM_WHEN_GEOMETRIC_THICKNESS_FAILS As Boolean = True
Private Const THICKNESS_FOLDER_INCLUDE_UNITS As Boolean = True
Private Const METER_TO_INCH As Double = 39.3700787401575
' Write QTY.json/QTY_SIMPLE.json after every successful item/qty update.
' This prevents losing the qty files if SolidWorks crashes later during document cleanup or view events.
Private Const WRITE_QTY_JSON_INCREMENTALLY As Boolean = True
' Persistent event logging writes every macro event to files in the DXF root folder.
' This is intentionally file-based because SolidWorks/VBE can crash before the Immediate Window is useful.
Private Const ENABLE_PERSISTENT_EVENT_LOGGER As Boolean = False
Private Const EVENT_LOG_ECHO_TO_IMMEDIATE As Boolean = False
Private Const EVENT_LOG_FILE_NAME As String = "_SAVE_ALL_DXF_EVENT_LOG.txt"
Private Const EVENT_LAST_FILE_NAME As String = "_SAVE_ALL_DXF_LAST_EVENT.txt"
Private Const EVENT_STATE_FILE_NAME As String = "_SAVE_ALL_DXF_RUN_STATE.json"
Private Const EVENT_LOG_MAX_BUFFER_BEFORE_INIT As Long = 20000
Private Const WRITE_RUN_COMPLETE_FILE As Boolean = False
' SolidWorks 2023 crash report showed a VBE access violation during view/zoom events.
' Orientation still gets set, but batch mode avoids ViewZoomtofit2 to reduce UI-event instability.
Private Const AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH As Boolean = True
' Material aliases reduce accidental split folders from common shop naming variants.
Private Const USE_MATERIAL_ALIAS_NORMALIZATION As Boolean = True
'------------------------------------------
' Production DXF orientation post-processing
'------------------------------------------
' Field result from R8:
' - Tab-aware candidate selection worked.
' - Isolated temp-part export was stable.
' - SolidWorks *Current view export still did not reliably honor in-plane roll.
'
' R10 keeps the stable SolidWorks export path, then normalizes the finished DXF coordinates:
' 1) Reads the exported 2D DXF.
' 2) Prefers a shared-corner perpendicular leg pair so right-triangle/gusset legs win over hypotenuse.
' 3) Places the selected adjacent/opposite edge on the bottom when possible.
' 4) Falls back to longest linear edge only when no right-angle leg pair exists.
' 5) Translates geometry to positive XY for cleaner nesting import.
Private Const POSTPROCESS_DXF_ORIENTATION_TO_HORIZONTAL As Boolean = True
Private Const DXF_POSTPROCESS_PREFER_RIGHT_ANGLE_LEG_PAIR As Boolean = True
Private Const DXF_POSTPROCESS_PREFER_LONGER_RIGHT_ANGLE_LEG_HORIZONTAL As Boolean = True
Private Const DXF_POSTPROCESS_FORCE_WIDE_ENVELOPE As Boolean = True
Private Const DXF_POSTPROCESS_FORCE_WIDE_ONLY_FOR_FALLBACK As Boolean = True
Private Const DXF_POSTPROCESS_TRANSLATE_TO_POSITIVE_XY As Boolean = True
Private Const DXF_POSTPROCESS_MIN_SEGMENT_LENGTH As Double = 0.001
Private Const DXF_POSTPROCESS_POINT_TOL As Double = 0.001
Private Const DXF_POSTPROCESS_PERP_DOT_TOL As Double = 0.02
Private Const DXF_POSTPROCESS_BOTTOM_EDGE_TOL As Double = 0.01
Private Const DXF_POSTPROCESS_OUTPUT_DECIMALS As Long = 6
Private Const DXF_POSTPROCESS_KEEP_BACKUP_FILE As Boolean = False
'------------------------------------------
' Tab-aware gusset orientation toggles
'------------------------------------------
' This block is intentionally ported from WATERJET_DXF_BATCH_EXPORT_V6_CLEANED.
' It affects only orientation candidate selection. Export path, folder logic, JSON,
' quantity aggregation, and crash-safe temp-part-only workflow are preserved.
Private Const ENABLE_TAB_AWARE_GUSSET_MODE As Boolean = True
Private Const TAB_AWARE_USER_TAB_MAX_M As Double = 0.0254 ' 1.00 in
Private Const TAB_AWARE_ALLOWANCE_M As Double = 0.03175 ' 1.25 in
Private Const TAB_AWARE_AXIS_STRIP_HALF_WIDTH_M As Double = 0.03175 ' 1.25 in
Private Const TAB_AWARE_MIN_EFFECTIVE_LEG_M As Double = 0.0508 ' 2.00 in
Private Const TAB_AWARE_MIN_LEG_TO_TAB_RATIO As Double = 2#
Private Const TAB_AWARE_PREFER_LONGER_LEG_HORIZONTAL As Boolean = True
'------------------------------------------
' Direct temp-part DXF export toggles
'------------------------------------------
Private Const USE_FAST_MODE As Boolean = True
Private Const FAST_MODE_PRESERVE_LEGACY_OUTPUT As Boolean = False
Private Const FAST_MODE_SINGLE_TEMP_PART_SAVE As Boolean = True
Private Const FAST_MODE_SKIP_TEMP_DRAWING_SAVE As Boolean = True
Private Const FAST_MODE_MINIMIZE_EXTRA_REDRAWS As Boolean = True
Private Const USE_EXPERIMENTAL_FAST_DIRECT_DXF As Boolean = True
Private Const EXPERIMENTAL_DIRECT_FALLBACK_TO_DRAWING As Boolean = False
Private Const EXPERIMENTAL_DIRECT_ALLOW_CURRENT_VIEW_FALLBACK As Boolean = False
Private Const DIRECT_TEMP_PART_FORCE_INCH_UNITS As Boolean = True
'------------------------------------------
' Native sheet-metal flat-pattern export toggles
'------------------------------------------
' ON by default:
' If the active/export configuration is a normal single-body sheet-metal part with a
' SolidWorks Flat-Pattern feature, the macro exports the native flat pattern using
' PartDoc.ExportToDWG2 with sheet-metal options before trying the generic oriented body path.
'
' Safety rule:
' Multi-body sheet-metal parts/cut-list items stay on the existing isolated-body workflow.
' This prevents a per-cut-list item export from accidentally outputting every flat pattern
' from the source part into one DXF file.
Private Const USE_NATIVE_SHEET_METAL_FLAT_PATTERN_EXPORT As Boolean = True
Private Const SHEET_METAL_NATIVE_SINGLE_BODY_ONLY As Boolean = True
Private Const SHEET_METAL_NATIVE_SKIP_WHEN_DRAWING_VIEW_ORIENTATION_OVERRIDE As Boolean = True
Private Const SHEET_METAL_NATIVE_TEMPORARILY_FORCE_INCH_UNITS As Boolean = True
' Waterjet/nesting default: export flat pattern profile only, no bend lines/sketches.
Private Const SHEET_METAL_EXPORT_BEND_LINES As Boolean = False
Private Const SHEET_METAL_EXPORT_SKETCHES As Boolean = False
Private Const SHEET_METAL_EXPORT_HIDDEN_EDGES As Boolean = False
Private Const SHEET_METAL_EXPORT_MERGE_COPLANAR_FACES As Boolean = True
Private Const SHEET_METAL_EXPORT_LIBRARY_FEATURES As Boolean = False
Private Const SHEET_METAL_EXPORT_FORMING_TOOLS As Boolean = False
Private Const SHEET_METAL_EXPORT_BOUNDING_BOX As Boolean = False
' R5 rotation fix:
' Use the V15-proven *Current view export logic on the isolated temp part.
' Named annotation views can preserve the face normal but lose/ignore in-plane roll on some sheet-metal bodies.
' This keeps the crash-safe temp-part workflow while matching V15's current-view rotation behavior.
Private Const TEMP_PART_EXPORT_USE_CURRENT_VIEW_V15_ROTATION As Boolean = True
Private Const TEMP_PART_NAMED_VIEW_EXPORT_FALLBACK As Boolean = False
' R7 stability correction:
' R6 attempted Body.ApplyTransform on copied sheet/weldment bodies. Field logs showed
' Body.ApplyTransform returned False for all eligible parts, resulting in 0 DXFs.
' Keep this OFF by default and use the proven isolated temp-part + current-view export path.
' The source model is still never modified.
Private Const PHYSICALLY_FLATTEN_TEMP_BODY_FOR_DXF As Boolean = False
' If a future test turns physical flatten back ON, this prevents a no-output run by
' falling back to the stable view-oriented isolated temp-part export when ApplyTransform fails.
Private Const FALL_BACK_TO_VIEW_EXPORT_IF_BODY_FLATTEN_FAILS As Boolean = True
' Stability toggles added after field failure investigation.
' Drawing fallback is kept in the code but disabled by default because the provided crash report
' shows document open/close activity around drawing/template usage immediately before a VBE access violation.
' Re-enable only after testing on a small assembly if direct temp-part export cannot handle a specific case.
Private Const HIDE_SKETCHES_BEFORE_DXF_EXPORT As Boolean = False
Private Const DISABLE_SOURCE_PART_DIRECT_EXPORT_FOR_STABILITY As Boolean = True
Private Const STRIP_THICKNESS_TEXT_FROM_MATERIAL_FOLDER As Boolean = True
Private Const CLOSE_COMPONENT_DOCS_OPENED_BY_MACRO As Boolean = False
' ExportToDWG2 action value (compile-safe)
Private Const SW_EXPORT_TO_DWG_ANNOTATION_VIEWS As Long = 3
Private Const SW_EXPORT_TO_DWG_SHEET_METAL As Long = 1
'Sheet-metal DXF option bitmask values used by ExportToDWG2.
Private Const SM_DXF_OPT_FLAT_PATTERN_GEOMETRY As Long = 1
Private Const SM_DXF_OPT_HIDDEN_EDGES As Long = 2
Private Const SM_DXF_OPT_BEND_LINES As Long = 4
Private Const SM_DXF_OPT_SKETCHES As Long = 8
Private Const SM_DXF_OPT_MERGE_COPLANAR_FACES As Long = 16
Private Const SM_DXF_OPT_LIBRARY_FEATURES As Long = 32
Private Const SM_DXF_OPT_FORMING_TOOLS As Long = 64
Private Const SM_DXF_OPT_BOUNDING_BOX As Long = 2048
'------------------------------------------
' Body type constants (compile-safe)
'------------------------------------------
Private Const BODYTYPE_SOLID As Long = 0
Private Const BODYTYPE_SHEET As Long = 1
Private Const BODYTYPE_WIRE As Long = 2
Private Const BODYTYPE_MINIMUM As Long = 3
Private Const BODYTYPE_GENERAL As Long = 4
Private Const BODYTYPE_EMPTY As Long = 5
'------------------------------------------
' Summary counters
'------------------------------------------
Private gTotalChecked As Long
Private gTotalEligible As Long
Private gTotalExported As Long
Private gTotalSkipped As Long
Private gTotalFailed As Long
Private gTotalComponentInstances As Long
Private gTotalUniquePartConfigs As Long
Private gTotalPartDocsProcessed As Long
Private gTotalAssemblyNodes As Long
Private gTotalVirtualSkipped As Long
Private gTotalSuppressedSkipped As Long
Private gTotalQtyAccumulated As Long
Private gTotalJsonFilesWritten As Long
Private gTotalJsonRecordsWritten As Long
Private gTotalSimpleJsonFilesWritten As Long
Private gTotalClassifiedFolders As Long
Private gTotalMissingMaterial As Long
Private gTotalMissingThickness As Long
Private gTotalGeometricThicknessUsed As Long
Private gTotalGeometricThicknessFailed As Long
Private gTotalImmediateJsonFlushes As Long
Private gTotalNativeSheetMetalFlatPatternExported As Long
Private gTotalNativeSheetMetalFlatPatternFallbacks As Long
Private gTotalNativeSheetMetalFlatPatternSkipped As Long
'------------------------------------------
' Run-state / quantity aggregation
'------------------------------------------
Private gPartTemplateByKey As Object
Private gItemMetadataByKey As Object
Private gItemQtyByKey As Object
Private gFolderItemsByPath As Object
'------------------------------------------
' Persistent event logger state
'------------------------------------------
Private gEventLogReady As Boolean
Private gEventLogPath As String
Private gEventLastPath As String
Private gEventStatePath As String
Private gEventRootFolder As String
Private gEventSeq As Long
Private gEventPendingLines As Collection
Private gEventLastLine As String
Private gEventRunLabel As String
Private gEventLastStage As String
Private gCurrentPartTemplateKey As String
Private gCurrentPartInstanceMultiplier As Long
Private gCurrentPartDoExport As Boolean
'------------------------------------------
' Run-state / orientation override
'------------------------------------------
Private gHasOrientationOverride As Boolean
Private gOrientationOverrideX(2) As Double
Private gOrientationOverrideZ(2) As Double
Private gOrientationOverrideLabel As String
Private gForceRequestedConfig As Boolean
Private gDrawingSelectedViewMode As Boolean
Private gDrawingSelectedViewName As String
Private gDrawingSelectedViewConfig As String
Private gDrawingSelectedViewModelPath As String
'=========================================================================================
' ENTRY POINT
'=========================================================================================
Public Sub main()
On Error GoTo EH
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swMathUtil = swApp.GetMathUtility
ResetEventLoggerState
LogEventRaw String(110, "=")
LogEvent " | START | SAVE_ALL_DXF_ACCORDING_TO_MATERIAL_THICKNESS_MACRO"
LogEvent " | INFO | Root output folder name = " & OUT_FOLDER_NAME
LogEvent " | INFO | Clear DXF root before run = " & CStr(CLEAR_DXF_ROOT_BEFORE_RUN)
LogEvent " | INFO | Timestamped run folder enabled = " & CStr(USE_TIMESTAMPED_RUN_FOLDER)
LogEvent " | INFO | Per-folder QTY.json = YES | QTY_SIMPLE.json = " & CStr(WRITE_SIMPLE_QTY_JSON)
LogEvent " | INFO | Source-part direct export disabled for stability = " & CStr(DISABLE_SOURCE_PART_DIRECT_EXPORT_FOR_STABILITY)
LogEvent " | INFO | Temp-part current-view export = " & CStr(TEMP_PART_EXPORT_USE_CURRENT_VIEW_V15_ROTATION)
LogEvent " | INFO | Physical temp-body flatten for DXF orientation = " & CStr(PHYSICALLY_FLATTEN_TEMP_BODY_FOR_DXF) & " (stable default OFF)"
LogEvent " | INFO | Tab-aware gusset orientation candidate logic = " & CStr(ENABLE_TAB_AWARE_GUSSET_MODE)
LogEvent " | INFO | DXF post-process horizontal normalization = " & CStr(POSTPROCESS_DXF_ORIENTATION_TO_HORIZONTAL)
LogEvent " | INFO | Native sheet-metal flat-pattern export = " & CStr(USE_NATIVE_SHEET_METAL_FLAT_PATTERN_EXPORT)
LogEvent " | INFO | Native sheet-metal export single-body safety = " & CStr(SHEET_METAL_NATIVE_SINGLE_BODY_ONLY)
LogEvent " | INFO | Native sheet-metal options bitmask = " & CStr(BuildNativeSheetMetalDxfOptions())
LogEvent " | INFO | DXF/waterjet nesting configuration auto-select = " & CStr(USE_DXF_NESTING_CONFIGURATION)
ResetCounters
If Not ValidateActiveModel(swModel) Then Exit Sub
Dim summaryDocType As Long
summaryDocType = swModel.GetType
Select Case swModel.GetType
Case swDocPART
Set swExt = swModel.Extension
Set swPart = swModel
Dim partModelPath As String
Dim partModelDir As String
Dim partOutDir As String
partModelPath = swModel.GetPathName
partModelDir = GetFolderFromPath(partModelPath)
partOutDir = PrepareRootOutputFolder(partModelDir, OUT_FOLDER_NAME)
If Len(partOutDir) = 0 Then
MsgBox "Failed to create or access output folder:" & vbCrLf & partModelDir & "\" & OUT_FOLDER_NAME, vbCritical
Exit Sub
End If
InitializeEventLogger partOutDir, "PART"
LogEvent " | INFO | Event log file = " & gEventLogPath
LogEvent " | INFO | Output folder = " & partOutDir
LogEvent " | INFO | Running in PART mode"
LogEvent " | CHECK | About to process active part document"
Call ProcessPartDocument(swModel, partOutDir, GetActiveConfigurationName(swModel), swModel.GetPathName, swModel.GetTitle)
LogEvent " | CHECK | Returned from active part document processing"
Case swDocASSEMBLY
Set swExt = swModel.Extension
Dim assyModelPath As String
Dim assyModelDir As String
Dim assyOutDir As String
assyModelPath = swModel.GetPathName
assyModelDir = GetFolderFromPath(assyModelPath)
assyOutDir = PrepareRootOutputFolder(assyModelDir, OUT_FOLDER_NAME)
If Len(assyOutDir) = 0 Then
MsgBox "Failed to create or access output folder:" & vbCrLf & assyModelDir & "\" & OUT_FOLDER_NAME, vbCritical
Exit Sub
End If
InitializeEventLogger assyOutDir, "ASSEMBLY"
LogEvent " | INFO | Event log file = " & gEventLogPath
LogEvent " | INFO | Output folder = " & assyOutDir
LogEvent " | INFO | Running in ASSEMBLY mode"
LogEvent " | CHECK | About to process assembly document"
Call ProcessAssemblyDocument(swModel, assyOutDir)
LogEvent " | CHECK | Returned from assembly document processing"
Case swDocDRAWING
LogEvent " | INFO | Running in DRAWING selected-view mode"
If Not ProcessSelectedDrawingViewMode(swModel) Then Exit Sub
Case Else
MsgBox "Unsupported active document type.", vbExclamation
Exit Sub
End Select
LogEvent " | CHECK | About to run final WriteAllQtyJsonFiles"
If Not WriteAllQtyJsonFiles() Then
LogEvent " | WARN | WriteAllQtyJsonFiles returned False"
End If
LogEvent " | CHECK | Returned from final WriteAllQtyJsonFiles"
Dim summary As String
summary = BuildSummaryText(summaryDocType)
WriteRunCompleteFile summary
LogEvent " | DONE | " & Replace(summary, vbCrLf, " | ")
LogEventRaw String(110, "=")
LogEvent " | CHECK | About to show final summary message box"
MsgBox summary, vbInformation, "Waterjet DXF Export Summary"
LogEvent " | CHECK | Final summary message box closed"
Exit Sub
EH:
LogEvent " | ERROR | Unhandled main error: " & Err.Number & " - " & Err.Description
MsgBox "Macro terminated with an unexpected error:" & vbCrLf & Err.Number & " - " & Err.Description, vbCritical
End Sub
Private Function BuildSummaryText(ByVal docType As Long) As String
Dim s As String
s = "DXF export + quantity JSON complete." & vbCrLf & vbCrLf
If docType = swDocASSEMBLY Then
s = s & _
"Assembly component instances seen: " & gTotalComponentInstances & vbCrLf & _
"Assembly/subassembly nodes visited: " & gTotalAssemblyNodes & vbCrLf & _
"Unique part+config processed: " & gTotalUniquePartConfigs & vbCrLf & _
"Part docs processed: " & gTotalPartDocsProcessed & vbCrLf & _
"Suppressed components skipped: " & gTotalSuppressedSkipped & vbCrLf & _
"Virtual/unloadable components skipped: " & gTotalVirtualSkipped & vbCrLf & vbCrLf
ElseIf docType = swDocDRAWING Then
s = s & _
"Drawing selected-view mode: YES" & vbCrLf & _
"Selected drawing view: " & NzStr(gDrawingSelectedViewName) & vbCrLf & _
"Selected view configuration: " & NzStr(gDrawingSelectedViewConfig) & vbCrLf & _
"Selected view model path: " & NzStr(gDrawingSelectedViewModelPath) & vbCrLf & _
"Part docs processed: " & gTotalPartDocsProcessed & vbCrLf & vbCrLf
Else
s = s & _
"Part docs processed: " & gTotalPartDocsProcessed & vbCrLf & vbCrLf
End If
s = s & _
"Export candidates checked: " & gTotalChecked & vbCrLf & _
"Eligible (DXF/DXY=YES): " & gTotalEligible & vbCrLf & _
"Exported: " & gTotalExported & vbCrLf & _
"Skipped: " & gTotalSkipped & vbCrLf & _
"Failed: " & gTotalFailed & vbCrLf & vbCrLf & _
"Classified folders: " & gTotalClassifiedFolders & vbCrLf & _
"JSON files written: " & gTotalJsonFilesWritten & vbCrLf & _
"QTY_SIMPLE.json files written: " & gTotalSimpleJsonFilesWritten & vbCrLf & _
"Detailed JSON item records written: " & gTotalJsonRecordsWritten & vbCrLf & _
"Total accumulated qty: " & gTotalQtyAccumulated & vbCrLf & _
"Items missing material: " & gTotalMissingMaterial & vbCrLf & _
"Items missing thickness: " & gTotalMissingThickness & vbCrLf & _
"Geometric thickness folders used: " & gTotalGeometricThicknessUsed & vbCrLf & _
"Geometric thickness failures: " & gTotalGeometricThicknessFailed & vbCrLf & _
"Native sheet-metal flat-pattern exports: " & gTotalNativeSheetMetalFlatPatternExported & vbCrLf & _
"Native sheet-metal fallback attempts: " & gTotalNativeSheetMetalFlatPatternFallbacks & vbCrLf & _
"Native sheet-metal skipped by safety checks: " & gTotalNativeSheetMetalFlatPatternSkipped & vbCrLf & _
"Immediate JSON flushes: " & gTotalImmediateJsonFlushes
BuildSummaryText = s
End Function
'=========================================================================================
' VALIDATION / SETUP
'=========================================================================================
Private Function ValidateActiveModel(ByVal mdl As SldWorks.ModelDoc2) As Boolean
On Error GoTo EH
ValidateActiveModel = False
If mdl Is Nothing Then
MsgBox "No active SolidWorks document found.", vbExclamation
Exit Function
End If
If mdl.GetType <> swDocPART And mdl.GetType <> swDocASSEMBLY And mdl.GetType <> swDocDRAWING Then
MsgBox "Active document must be a saved PART, ASSEMBLY, or a DRAWING with a selected drawing view.", vbExclamation
Exit Function
End If
If mdl.GetType <> swDocDRAWING Then
If Len(Trim$(mdl.GetPathName)) = 0 Then
MsgBox "The active document must be saved before running this macro.", vbExclamation
Exit Function
End If
End If
LogEvent " | INFO | Active model = " & mdl.GetTitle
LogEvent " | INFO | Path = " & mdl.GetPathName
LogEvent " | INFO | Type = " & DocTypeName(mdl.GetType)
ValidateActiveModel = True
Exit Function
EH:
LogEvent " | ERROR | ValidateActiveModel: " & Err.Number & " - " & Err.Description
End Function
Private Function DocTypeName(ByVal docType As Long) As String
Select Case docType
Case swDocPART: DocTypeName = "PART"
Case swDocASSEMBLY: DocTypeName = "ASSEMBLY"
Case swDocDRAWING: DocTypeName = "DRAWING"
Case Else: DocTypeName = "UNKNOWN"
End Select
End Function
Private Sub ResetCounters()
gTotalChecked = 0
gTotalEligible = 0
gTotalExported = 0
gTotalSkipped = 0
gTotalFailed = 0
gTotalComponentInstances = 0
gTotalUniquePartConfigs = 0
gTotalPartDocsProcessed = 0
gTotalAssemblyNodes = 0
gTotalVirtualSkipped = 0
gTotalSuppressedSkipped = 0
gTotalQtyAccumulated = 0
gTotalJsonFilesWritten = 0
gTotalJsonRecordsWritten = 0
gTotalSimpleJsonFilesWritten = 0
gTotalClassifiedFolders = 0
gTotalMissingMaterial = 0
gTotalMissingThickness = 0
gTotalGeometricThicknessUsed = 0
gTotalGeometricThicknessFailed = 0
gTotalImmediateJsonFlushes = 0
gTotalNativeSheetMetalFlatPatternExported = 0
gTotalNativeSheetMetalFlatPatternFallbacks = 0
gTotalNativeSheetMetalFlatPatternSkipped = 0
Set gPartTemplateByKey = CreateObject("Scripting.Dictionary")
gPartTemplateByKey.CompareMode = vbTextCompare
Set gItemMetadataByKey = CreateObject("Scripting.Dictionary")
gItemMetadataByKey.CompareMode = vbTextCompare
Set gItemQtyByKey = CreateObject("Scripting.Dictionary")
gItemQtyByKey.CompareMode = vbTextCompare
Set gFolderItemsByPath = CreateObject("Scripting.Dictionary")
gFolderItemsByPath.CompareMode = vbTextCompare
gCurrentPartTemplateKey = ""
gCurrentPartInstanceMultiplier = 1
gCurrentPartDoExport = True
ResetOrientationOverrideState
End Sub
Private Sub ResetOrientationOverrideState()
gHasOrientationOverride = False
gOrientationOverrideX(0) = 0#: gOrientationOverrideX(1) = 0#: gOrientationOverrideX(2) = 0#
gOrientationOverrideZ(0) = 0#: gOrientationOverrideZ(1) = 0#: gOrientationOverrideZ(2) = 0#
gOrientationOverrideLabel = ""
gForceRequestedConfig = False
gDrawingSelectedViewMode = False
gDrawingSelectedViewName = ""
gDrawingSelectedViewConfig = ""
gDrawingSelectedViewModelPath = ""
End Sub
Private Function ProcessSelectedDrawingViewMode(ByVal drwMdl As SldWorks.ModelDoc2) As Boolean
On Error GoTo EH
ProcessSelectedDrawingViewMode = False
If drwMdl Is Nothing Then Exit Function
If drwMdl.GetType <> swDocDRAWING Then Exit Function
Dim drawingTitle As String
drawingTitle = drwMdl.GetTitle
Dim selView As SldWorks.View
Set selView = GetSelectedDrawingViewFromActiveDrawing(drwMdl)
If selView Is Nothing Then
MsgBox "Drawing mode requires one selected drawing view." & vbCrLf & _
"Click the drawing view border or select an object that belongs to the target view and run again.", _
vbExclamation, "Waterjet DXF Export"
LogEvent " | FAIL | No selected drawing view could be resolved"
Exit Function
End If
gDrawingSelectedViewMode = True
gDrawingSelectedViewName = NzStr(selView.Name)
LogEventRaw String(100, "-")
LogEvent " | INFO | DRAWING SELECTED-VIEW MODE"
LogEvent " | INFO | Drawing title | " & drawingTitle
LogEvent " | INFO | Selected view | " & NzStr(selView.Name)
Dim refView As SldWorks.View
Set refView = ResolveDrawingViewForReferencedDocument(selView)
If refView Is Nothing Then
Set refView = selView
End If
Dim openedByUs As Boolean
Dim partMdl As SldWorks.ModelDoc2
Set partMdl = GetDrawingViewReferencedPartDocument(refView, openedByUs)
If partMdl Is Nothing Then
MsgBox "The selected drawing view does not resolve to a saved part document." & vbCrLf & _
"Use a part drawing view, not the sheet, and make sure the referenced model is available.", _
vbExclamation, "Waterjet DXF Export"
LogEvent " | FAIL | Selected drawing view did not resolve to a PART document"
GoTo CleanupAndExit
End If
gDrawingSelectedViewModelPath = partMdl.GetPathName
gDrawingSelectedViewConfig = GetDrawingViewReferencedConfiguration(refView)
If Len(Trim$(gDrawingSelectedViewConfig)) = 0 Then
gDrawingSelectedViewConfig = GetActiveConfigurationName(partMdl)
End If
LogEvent " | INFO | Referenced part | " & partMdl.GetTitle
LogEvent " | INFO | Part path | " & gDrawingSelectedViewModelPath
LogEvent " | INFO | View config | " & gDrawingSelectedViewConfig
If Len(Trim$(gDrawingSelectedViewModelPath)) = 0 Then
MsgBox "The selected drawing view references an unsaved part." & vbCrLf & _
"Save the part first and run again.", vbExclamation, "Waterjet DXF Export"
LogEvent " | FAIL | Referenced part path is blank"
GoTo CleanupAndExit
End If
Dim outDir As String
outDir = PrepareRootOutputFolder(GetFolderFromPath(gDrawingSelectedViewModelPath), OUT_FOLDER_NAME)
If Len(outDir) = 0 Then
MsgBox "Failed to create or access output folder:" & vbCrLf & _
GetFolderFromPath(gDrawingSelectedViewModelPath) & "\" & OUT_FOLDER_NAME, vbCritical
LogEvent " | FAIL | Could not create output folder for drawing-selected-view mode"
GoTo CleanupAndExit
End If
InitializeEventLogger outDir, "DRAWING_SELECTED_VIEW"
LogEvent " | INFO | Event log file = " & gEventLogPath
LogEvent " | INFO | Output folder | " & outDir
If Not SetOrientationOverrideFromDrawingView(selView) Then
MsgBox "Could not read orientation from the selected drawing view.", vbCritical, "Waterjet DXF Export"
LogEvent " | FAIL | Could not set drawing-view orientation override"
GoTo CleanupAndExit
End If
gForceRequestedConfig = True
Set swExt = partMdl.Extension
Set swPart = partMdl
Call ProcessPartDocument(partMdl, outDir, gDrawingSelectedViewConfig, gDrawingSelectedViewModelPath, _
"DRAWING VIEW | " & NzStr(selView.Name))
ProcessSelectedDrawingViewMode = True
CleanupAndExit:
gForceRequestedConfig = False
gHasOrientationOverride = False
If openedByUs Then
LogEvent " | INFO | Closing drawing-opened referenced part: " & gDrawingSelectedViewModelPath
CloseDocIfOpen gDrawingSelectedViewModelPath
End If
If Len(Trim$(drawingTitle)) > 0 Then
Call ActivateDocumentByTitle(drawingTitle)
End If
Exit Function
EH:
LogEvent " | ERROR | ProcessSelectedDrawingViewMode: " & Err.Number & " - " & Err.Description
Resume CleanupAndExit
End Function
Private Function GetSelectedDrawingViewFromActiveDrawing(ByVal drwMdl As SldWorks.ModelDoc2) As SldWorks.View
On Error GoTo EH
If drwMdl Is Nothing Then Exit Function
If drwMdl.GetType <> swDocDRAWING Then Exit Function
Dim selMgr As SldWorks.SelectionMgr
Set selMgr = drwMdl.SelectionManager
If selMgr Is Nothing Then
LogEvent " | WARN | Drawing SelectionManager is Nothing"
Exit Function
End If
Dim selCount As Long
selCount = selMgr.GetSelectedObjectCount2(-1)
LogEvent " | INFO | Drawing selection count = " & CStr(selCount)
If selCount < 1 Then Exit Function
Dim selObj As Object
Set selObj = selMgr.GetSelectedObject6(1, -1)
If Not selObj Is Nothing Then
LogEvent " | INFO | First selected object type = " & typeName(selObj)
If typeName(selObj) = "View" Then
Set GetSelectedDrawingViewFromActiveDrawing = selObj
Exit Function
End If
End If
Dim objView As Object
Set objView = Nothing
On Error Resume Next
Set objView = CallByName(selMgr, "GetSelectedObjectsDrawingView2", VbMethod, 1, -1)
If objView Is Nothing Or Err.Number <> 0 Then
Err.Clear
Set objView = CallByName(selMgr, "GetSelectedObjectsDrawingView", VbMethod, 1)
End If
On Error GoTo EH
If Not objView Is Nothing Then
LogEvent " | INFO | Resolved drawing view from selected object context"
Set GetSelectedDrawingViewFromActiveDrawing = objView
Exit Function
End If
LogEvent " | WARN | Could not resolve selected drawing view"
Exit Function
EH:
LogEvent " | ERROR | GetSelectedDrawingViewFromActiveDrawing: " & Err.Number & " - " & Err.Description
End Function
Private Function ResolveDrawingViewForReferencedDocument(ByVal srcView As SldWorks.View) As SldWorks.View
On Error GoTo EH
Set ResolveDrawingViewForReferencedDocument = srcView
Dim curView As SldWorks.View
Set curView = srcView
Dim depth As Long
For depth = 1 To 20
If curView Is Nothing Then Exit For
Dim mdl As SldWorks.ModelDoc2
Set mdl = curView.ReferencedDocument
If Not mdl Is Nothing Then
Set ResolveDrawingViewForReferencedDocument = curView
Exit Function
End If
Dim baseView As SldWorks.View
Set baseView = curView.GetBaseView
If baseView Is Nothing Then Exit For
LogEvent " | INFO | ReferencedDocument unavailable on view [" & NzStr(curView.Name) & "] -> trying base view [" & NzStr(baseView.Name) & "]"
Set curView = baseView
Next depth
Exit Function
EH:
LogEvent " | ERROR | ResolveDrawingViewForReferencedDocument: " & Err.Number & " - " & Err.Description
End Function
Private Function GetDrawingViewReferencedConfiguration(ByVal refView As SldWorks.View) As String
On Error GoTo EH
GetDrawingViewReferencedConfiguration = ""
If refView Is Nothing Then Exit Function
On Error Resume Next
GetDrawingViewReferencedConfiguration = Trim$(refView.ReferencedConfiguration)
If Err.Number <> 0 Then
LogEvent " | WARN | Could not read ReferencedConfiguration from drawing view [" & NzStr(refView.Name) & "]: " & Err.Number & " - " & Err.Description
Err.Clear
End If
On Error GoTo EH
Exit Function
EH:
LogEvent " | ERROR | GetDrawingViewReferencedConfiguration: " & Err.Number & " - " & Err.Description
End Function
Private Function GetDrawingViewReferencedPartDocument(ByVal refView As SldWorks.View, _
ByRef openedByUs As Boolean) As SldWorks.ModelDoc2
On Error GoTo EH
openedByUs = False
If refView Is Nothing Then Exit Function
Dim mdl As SldWorks.ModelDoc2
Set mdl = refView.ReferencedDocument
If Not mdl Is Nothing Then
LogEvent " | INFO | ReferencedDocument returned loaded model [" & mdl.GetTitle & "] type=" & DocTypeName(mdl.GetType)
If mdl.GetType = swDocPART Then
Set GetDrawingViewReferencedPartDocument = mdl
Else
LogEvent " | FAIL | Selected drawing view references non-part model type " & DocTypeName(mdl.GetType)
End If
Exit Function
End If
Dim refModelName As String
refModelName = ""
On Error Resume Next
refModelName = Trim$(refView.GetReferencedModelName)
If Err.Number <> 0 Then
LogEvent " | WARN | GetReferencedModelName failed on drawing view [" & NzStr(refView.Name) & "]: " & Err.Number & " - " & Err.Description
Err.Clear
End If
On Error GoTo EH
LogEvent " | INFO | Referenced model name/path from drawing view = " & refModelName
If Len(refModelName) = 0 Then Exit Function
Dim docType As Long
docType = GetDocTypeFromPath(refModelName)
If docType <> swDocPART Then
LogEvent " | FAIL | Selected drawing view referenced file is not a part: " & refModelName
Exit Function
End If
Dim alreadyOpen As Boolean
alreadyOpen = Not (swApp.GetOpenDocumentByName(refModelName) Is Nothing)
Dim errs As Long
Dim warns As Long
errs = 0
warns = 0
LogEvent " | INFO | Opening drawing-referenced part silently: " & refModelName
Set mdl = swApp.OpenDoc6(refModelName, swDocPART, swOpenDocOptions_Silent Or swOpenDocOptions_ReadOnly, "", errs, warns)
If mdl Is Nothing Then
LogEvent " | FAIL | OpenDoc6 failed for drawing-referenced part. errs=" & errs & " warns=" & warns
Exit Function
End If
If Not alreadyOpen Then openedByUs = True
Set GetDrawingViewReferencedPartDocument = mdl
Exit Function
EH:
LogEvent " | ERROR | GetDrawingViewReferencedPartDocument: " & Err.Number & " - " & Err.Description
End Function
Private Function SetOrientationOverrideFromDrawingView(ByVal srcView As SldWorks.View) As Boolean
On Error GoTo EH
SetOrientationOverrideFromDrawingView = False
If srcView Is Nothing Then Exit Function
Dim xDir(2) As Double
Dim zDir(2) As Double
If Not GetOrientationAxesFromDrawingView(srcView, xDir, zDir) Then
LogEvent " | FAIL | Could not derive orientation axes from drawing view [" & NzStr(srcView.Name) & "]"
Exit Function
End If
gHasOrientationOverride = True
gOrientationOverrideX(0) = xDir(0)
gOrientationOverrideX(1) = xDir(1)
gOrientationOverrideX(2) = xDir(2)
gOrientationOverrideZ(0) = zDir(0)
gOrientationOverrideZ(1) = zDir(1)
gOrientationOverrideZ(2) = zDir(2)
gOrientationOverrideLabel = "DRAWING VIEW [" & NzStr(srcView.Name) & "]"
LogEvent " | INFO | Drawing-view orientation override enabled"
LogEvent " | INFO | X override = (" & Dbl3ToStr(gOrientationOverrideX) & ")"
LogEvent " | INFO | Z override = (" & Dbl3ToStr(gOrientationOverrideZ) & ")"
SetOrientationOverrideFromDrawingView = True
Exit Function
EH:
LogEvent " | ERROR | SetOrientationOverrideFromDrawingView: " & Err.Number & " - " & Err.Description
End Function
Private Function GetOrientationAxesFromDrawingView(ByVal srcView As SldWorks.View, _
ByRef xDir() As Double, _
ByRef zDir() As Double) As Boolean
On Error GoTo EH
GetOrientationAxesFromDrawingView = False
If srcView Is Nothing Then Exit Function
Dim mtv As SldWorks.MathTransform
Set mtv = srcView.ModelToViewTransform
If mtv Is Nothing Then
LogEvent " | FAIL | Drawing view ModelToViewTransform is Nothing"
Exit Function
End If
Dim arr As Variant
arr = mtv.ArrayData
If Not VariantHasAtLeast9Numbers(arr) Then
LogEvent " | FAIL | Drawing view transform array did not contain at least 9 numbers"
Exit Function
End If
xDir(0) = CDbl(arr(0))
xDir(1) = CDbl(arr(1))
xDir(2) = CDbl(arr(2))
Dim yDir(2) As Double
yDir(0) = CDbl(arr(3))
yDir(1) = CDbl(arr(4))
yDir(2) = CDbl(arr(5))
zDir(0) = CDbl(arr(6))
zDir(1) = CDbl(arr(7))
zDir(2) = CDbl(arr(8))
LogEvent " | INFO | Drawing view raw transform rows:"
LogEvent " | INFO | RowX = (" & Dbl3ToStr(xDir) & ")"
LogEvent " | INFO | RowY = (" & Dbl3ToStr(yDir) & ")"
LogEvent " | INFO | RowZ = (" & Dbl3ToStr(zDir) & ")"
If VecLength(xDir) <= EPS Or VecLength(zDir) <= EPS Then
LogEvent " | FAIL | Drawing view transform produced zero-length orientation vectors"
Exit Function
End If
NormalizeVec xDir
NormalizeVec yDir
NormalizeVec zDir
Dim crossZ(2) As Double
CrossProduct xDir, yDir, crossZ
If VecLength(crossZ) > EPS Then
NormalizeVec crossZ
If DotProduct(crossZ, zDir) < 0# Then
FlipVec zDir
End If
End If
If Abs(DotProduct(xDir, zDir)) > 0.9999 Then
LogEvent " | FAIL | Drawing view transform produced near-parallel X/Z vectors"
Exit Function
End If
LogEvent " | INFO | Drawing view normalized orientation axes:"
LogEvent " | INFO | X = (" & Dbl3ToStr(xDir) & ")"
LogEvent " | INFO | Z = (" & Dbl3ToStr(zDir) & ")"
GetOrientationAxesFromDrawingView = True
Exit Function
EH:
LogEvent " | ERROR | GetOrientationAxesFromDrawingView: " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' PART / ASSEMBLY DISPATCH
'=========================================================================================
Private Sub ProcessPartDocument(ByVal partMdl As SldWorks.ModelDoc2, _
ByVal outDir As String, _
ByVal targetConfig As String, _
ByVal sourcePath As String, _
ByVal sourceLabel As String)
On Error GoTo EH
If partMdl Is Nothing Then Exit Sub
If partMdl.GetType <> swDocPART Then Exit Sub
gTotalPartDocsProcessed = gTotalPartDocsProcessed + 1
Dim oldCfg As String
Dim switchedCfg As Boolean
Dim effectiveConfig As String
Dim hasRealCutList As Boolean
oldCfg = GetActiveConfigurationName(partMdl)
switchedCfg = False
If gForceRequestedConfig Then
effectiveConfig = Trim$(targetConfig)
If Len(effectiveConfig) = 0 Then effectiveConfig = oldCfg
LogEvent " | INFO | Drawing-selected-view mode forcing requested configuration [" & effectiveConfig & "]"
Else
effectiveConfig = ResolveNestingConfiguration(partMdl, targetConfig, True)
End If
If Len(Trim$(effectiveConfig)) > 0 Then
If StrComp(oldCfg, effectiveConfig, vbTextCompare) <> 0 Then
LogEvent " | INFO | Switching part config from [" & oldCfg & "] to [" & effectiveConfig & "] for " & sourceLabel
If ActivateModelConfiguration(partMdl, effectiveConfig) Then
switchedCfg = True
Else
LogEvent " | WARN | Could not switch to configuration [" & effectiveConfig & "] for " & sourceLabel & ". Continuing with active config [" & oldCfg & "]"
End If
End If
End If
partMdl.ForceRebuild3 True
gCurrentPartTemplateKey = BuildPartTemplateKey(sourcePath, GetActiveConfigurationName(partMdl))
gCurrentPartInstanceMultiplier = 1
gCurrentPartDoExport = True
EnsurePartTemplateExists gCurrentPartTemplateKey
LogEventRaw String(100, "-")
LogEvent " | INFO | PROCESS PART | " & sourceLabel
LogEvent " | INFO | Source path | " & sourcePath
LogEvent " | INFO | Requested cfg| " & targetConfig
LogEvent " | INFO | Nesting cfg | " & effectiveConfig
LogEvent " | INFO | Active cfg | " & GetActiveConfigurationName(partMdl)
LogEvent " | INFO | Part template key | " & gCurrentPartTemplateKey
If gHasOrientationOverride Then
LogEvent " | INFO | Orientation | OVERRIDE ACTIVE -> " & gOrientationOverrideLabel
End If
If Not UpdateAllCutLists(partMdl) Then
LogEvent " | WARN | Cut-list update returned False / partial"
End If
hasRealCutList = PartHasRealCutList(partMdl)
LogEvent " | INFO | Real cut-list detected = " & CStr(hasRealCutList)
If hasRealCutList Then
ProcessCutLists partMdl, outDir
Else
ProcessRegularPart partMdl, outDir
End If
Cleanup:
If switchedCfg Then
LogEvent " | INFO | Restoring original part config [" & oldCfg & "] for " & sourceLabel
Call ActivateModelConfiguration(partMdl, oldCfg)
partMdl.ForceRebuild3 True
End If
gCurrentPartTemplateKey = ""
gCurrentPartInstanceMultiplier = 1
gCurrentPartDoExport = True
Exit Sub
EH:
LogEvent " | ERROR | ProcessPartDocument(" & sourceLabel & "): " & Err.Number & " - " & Err.Description
Resume Cleanup
End Sub
Private Sub ProcessAssemblyDocument(ByVal assyMdl As SldWorks.ModelDoc2, ByVal outDir As String)
On Error GoTo EH
If assyMdl Is Nothing Then Exit Sub
If assyMdl.GetType <> swDocASSEMBLY Then Exit Sub
Dim assy As SldWorks.AssemblyDoc
Set assy = assyMdl
ResolveAssemblyLightweight assyMdl
Dim rootComp As SldWorks.Component2
Set rootComp = GetAssemblyRootComponent(assyMdl)
If rootComp Is Nothing Then
LogEvent " | FAIL | Could not obtain root component from active assembly"
Exit Sub
End If
Dim dictPartCfg As Object
Dim dictAsmCfg As Object
Set dictPartCfg = CreateObject("Scripting.Dictionary")
Set dictAsmCfg = CreateObject("Scripting.Dictionary")
LogEvent " | INFO | Beginning recursive assembly traversal from root: " & rootComp.Name2
WalkAssemblyTree rootComp, outDir, dictPartCfg, dictAsmCfg
Exit Sub
EH:
LogEvent " | ERROR | ProcessAssemblyDocument: " & Err.Number & " - " & Err.Description
End Sub
Private Sub ResolveAssemblyLightweight(ByVal assyMdl As SldWorks.ModelDoc2)
On Error GoTo EH
Dim assy As SldWorks.AssemblyDoc
Set assy = assyMdl
LogEvent " | INFO | Attempting to resolve lightweight assembly components"
On Error Resume Next
assy.ResolveAllLightWeightComponents True
Err.Clear
On Error GoTo EH
assyMdl.ForceRebuild3 True
Exit Sub
EH:
LogEvent " | WARN | ResolveAssemblyLightweight: " & Err.Number & " - " & Err.Description
End Sub
Private Function GetAssemblyRootComponent(ByVal assyMdl As SldWorks.ModelDoc2) As SldWorks.Component2
On Error GoTo EH
Dim cfg As SldWorks.Configuration
Set cfg = assyMdl.ConfigurationManager.ActiveConfiguration
If cfg Is Nothing Then Exit Function
Set GetAssemblyRootComponent = cfg.GetRootComponent3(True)
Exit Function
EH:
LogEvent " | ERROR | GetAssemblyRootComponent: " & Err.Number & " - " & Err.Description
End Function
Private Sub WalkAssemblyTree(ByVal parentComp As SldWorks.Component2, _
ByVal outDir As String, _
ByVal dictPartCfg As Object, _
ByVal dictAsmCfg As Object)
On Error GoTo EH
If parentComp Is Nothing Then Exit Sub
gTotalAssemblyNodes = gTotalAssemblyNodes + 1
Dim vChildren As Variant
vChildren = parentComp.GetChildren
If IsEmpty(vChildren) Then Exit Sub
If Not IsArray(vChildren) Then Exit Sub
Dim i As Long
For i = LBound(vChildren) To UBound(vChildren)
Dim child As SldWorks.Component2
Set child = vChildren(i)
gTotalComponentInstances = gTotalComponentInstances + 1
If child Is Nothing Then
LogEvent " | WARN | Child component is Nothing"
GoTo NextChild
End If
If IsComponentSuppressedSafe(child) Then
gTotalSuppressedSkipped = gTotalSuppressedSkipped + 1
LogEvent " | SKIP | Suppressed component: " & child.Name2
GoTo NextChild
End If
Dim openedByUs As Boolean
Dim compMdl As SldWorks.ModelDoc2
Set compMdl = EnsureComponentModelLoaded(child, openedByUs)
If compMdl Is Nothing Then
gTotalVirtualSkipped = gTotalVirtualSkipped + 1
LogEvent " | SKIP | Could not load component model: " & child.Name2
GoTo NextChild
End If
Dim compPath As String
Dim compCfg As String
Dim effectivePartCfg As String
Dim uniqueKey As String
compPath = GetComponentBestPath(child, compMdl)
compCfg = Trim$(child.ReferencedConfiguration)
If Len(compCfg) = 0 Then compCfg = GetActiveConfigurationName(compMdl)
If compMdl.GetType = swDocPART Then
effectivePartCfg = ResolveNestingConfiguration(compMdl, compCfg, False)
uniqueKey = BuildPartTemplateKey(compPath, effectivePartCfg)
If Not dictPartCfg.Exists(uniqueKey) Then
dictPartCfg.Add uniqueKey, True
gTotalUniquePartConfigs = gTotalUniquePartConfigs + 1
LogEventRaw String(90, "-")
LogEvent " | INFO | UNIQUE PART+CFG | " & child.Name2
LogEvent " | INFO | Part path | " & compPath
LogEvent " | INFO | Ref config | " & compCfg
LogEvent " | INFO | Nesting config | " & effectivePartCfg
ProcessPartDocument compMdl, outDir, effectivePartCfg, compPath, child.Name2
Else
LogEvent " | INFO | Duplicate part+cfg encountered again; qty will be accumulated from template: " & child.Name2 & " | " & compPath & " | " & effectivePartCfg
AddQtyFromExistingPartTemplate uniqueKey, 1, child.Name2
End If
ElseIf compMdl.GetType = swDocASSEMBLY Then
uniqueKey = UCase$(compPath) & "|" & UCase$(compCfg)
If Not dictAsmCfg.Exists(uniqueKey) Then
dictAsmCfg.Add uniqueKey, True
LogEventRaw String(90, "-")
LogEvent " | INFO | ENTER SUBASM FIRST OCCURRENCE | " & child.Name2
LogEvent " | INFO | Asm path | " & compPath
LogEvent " | INFO | Ref config | " & compCfg
Else
LogEventRaw String(90, "-")
LogEvent " | INFO | ENTER SUBASM DUPLICATE OCCURRENCE FOR QTY | " & child.Name2
LogEvent " | INFO | Asm path | " & compPath
LogEvent " | INFO | Ref config | " & compCfg
LogEvent " | INFO | Duplicate subassembly is still traversed so nested part quantities are counted."
End If
'Important for nesting quantity accuracy:
'Do NOT skip duplicate subassemblies. DXF export is deduplicated at the part+config level,
'but every subassembly occurrence must still be traversed so repeated nested parts add qty.
WalkAssemblyTree child, outDir, dictPartCfg, dictAsmCfg
Else
LogEvent " | SKIP | Unsupported component doc type: " & child.Name2 & " | " & DocTypeName(compMdl.GetType)
End If
If openedByUs Then
If CLOSE_COMPONENT_DOCS_OPENED_BY_MACRO Then
LogEvent " | INFO | Closing component document opened by macro: " & compPath
CloseDocIfOpen compPath
Else
LogEvent " | INFO | Leaving component document open for SolidWorks stability: " & compPath
End If
End If
NextChild:
Next i
Exit Sub
EH:
LogEvent " | ERROR | WalkAssemblyTree(" & parentComp.Name2 & "): " & Err.Number & " - " & Err.Description
End Sub
Private Function EnsureComponentModelLoaded(ByVal comp As SldWorks.Component2, ByRef openedByUs As Boolean) As SldWorks.ModelDoc2
On Error GoTo EH
openedByUs = False
If comp Is Nothing Then Exit Function
Dim mdl As SldWorks.ModelDoc2
Set mdl = comp.GetModelDoc2
If Not mdl Is Nothing Then
Set EnsureComponentModelLoaded = mdl
Exit Function
End If
Dim path As String
path = Trim$(comp.GetPathName)
If Len(path) = 0 Then
LogEvent " | WARN | Component path is blank (likely virtual/unresolved): " & comp.Name2
Exit Function
End If
Dim alreadyOpen As Boolean
alreadyOpen = Not (swApp.GetOpenDocumentByName(path) Is Nothing)
Dim docType As Long
docType = GetDocTypeFromPath(path)
If docType = 0 Then
LogEvent " | WARN | Unsupported component file type: " & path
Exit Function
End If
Dim errs As Long, warns As Long
errs = 0: warns = 0
LogEvent " | INFO | Opening component silently: " & path
Set mdl = swApp.OpenDoc6(path, docType, swOpenDocOptions_Silent Or swOpenDocOptions_ReadOnly, "", errs, warns)
If mdl Is Nothing Then
LogEvent " | FAIL | OpenDoc6 failed. errs=" & errs & " warns=" & warns & " | " & path
Exit Function
End If
If Not alreadyOpen Then openedByUs = True
Set EnsureComponentModelLoaded = mdl
Exit Function
EH:
LogEvent " | ERROR | EnsureComponentModelLoaded(" & comp.Name2 & "): " & Err.Number & " - " & Err.Description
End Function
Private Function GetDocTypeFromPath(ByVal filePath As String) As Long
Dim ext As String
ext = LCase$(GetExtensionFromPath(filePath))
Select Case ext
Case "sldprt": GetDocTypeFromPath = swDocPART
Case "sldasm": GetDocTypeFromPath = swDocASSEMBLY
Case "slddrw": GetDocTypeFromPath = swDocDRAWING
Case Else: GetDocTypeFromPath = 0
End Select
End Function
Private Function GetExtensionFromPath(ByVal filePath As String) As String
Dim p As Long
p = InStrRev(filePath, ".")
If p > 0 Then
GetExtensionFromPath = Mid$(filePath, p + 1)
Else
GetExtensionFromPath = ""
End If
End Function
Private Function GetComponentBestPath(ByVal comp As SldWorks.Component2, ByVal mdl As SldWorks.ModelDoc2) As String
On Error GoTo EH
Dim s As String
s = Trim$(comp.GetPathName)
If Len(s) > 0 Then
GetComponentBestPath = s
Exit Function
End If
If Not mdl Is Nothing Then
s = Trim$(mdl.GetPathName)
If Len(s) > 0 Then
GetComponentBestPath = s
Exit Function
End If
GetComponentBestPath = "[VIRTUAL] " & mdl.GetTitle
Exit Function
End If
GetComponentBestPath = "[UNKNOWN_COMPONENT]"
Exit Function
EH:
GetComponentBestPath = "[UNKNOWN_COMPONENT]"
End Function
Private Function IsComponentSuppressedSafe(ByVal comp As SldWorks.Component2) As Boolean
On Error GoTo EH
IsComponentSuppressedSafe = False
If comp Is Nothing Then Exit Function
On Error Resume Next
IsComponentSuppressedSafe = CBool(comp.IsSuppressed)
If Err.Number <> 0 Then
Err.Clear
IsComponentSuppressedSafe = False
End If
On Error GoTo EH
Exit Function
EH:
IsComponentSuppressedSafe = False
End Function
Private Function GetActiveConfigurationName(ByVal mdl As SldWorks.ModelDoc2) As String
On Error GoTo EH
GetActiveConfigurationName = ""
If mdl Is Nothing Then Exit Function
If mdl.ConfigurationManager Is Nothing Then Exit Function
If mdl.ConfigurationManager.ActiveConfiguration Is Nothing Then Exit Function
GetActiveConfigurationName = Trim$(mdl.ConfigurationManager.ActiveConfiguration.Name)
Exit Function
EH:
LogEvent " | ERROR | GetActiveConfigurationName: " & Err.Number & " - " & Err.Description
End Function
Private Function FindPreferredWaterjetConfiguration(ByVal mdl As SldWorks.ModelDoc2, _
Optional ByVal writeLog As Boolean = False) As String
On Error GoTo EH
FindPreferredWaterjetConfiguration = ""
If mdl Is Nothing Then Exit Function
If writeLog Then
LogEvent " | INFO | DXF/waterjet nesting config search enabled = " & CStr(USE_DXF_NESTING_CONFIGURATION)
End If
'R11 behavior:
' When enabled, score all configuration names for DXF / waterjet / cutting / nesting intent.
' This is intentionally more flexible than the old exact WATERJET_CUT check, but still deterministic.
If USE_DXF_NESTING_CONFIGURATION Then
FindPreferredWaterjetConfiguration = FindBestDxfNestingConfiguration(mdl, writeLog)
If Len(Trim$(FindPreferredWaterjetConfiguration)) > 0 Then Exit Function
Else
If writeLog Then
LogEvent " | INFO | DXF/waterjet keyword config search disabled by setting. Legacy exact " & LEGACY_WATERJET_CONFIG_NAME & " search still allowed."
End If
End If
'Legacy fallback preserved from previous macro behavior.
FindPreferredWaterjetConfiguration = FindExactConfigurationByName(mdl, LEGACY_WATERJET_CONFIG_NAME)
If Len(Trim$(FindPreferredWaterjetConfiguration)) > 0 Then
If writeLog Then
LogEvent " | INFO | Legacy nesting config override detected: [" & FindPreferredWaterjetConfiguration & "]"
End If
End If
Exit Function
EH:
LogEvent " | ERROR | FindPreferredWaterjetConfiguration: " & Err.Number & " - " & Err.Description
End Function
Private Function FindBestDxfNestingConfiguration(ByVal mdl As SldWorks.ModelDoc2, _
Optional ByVal writeLog As Boolean = False) As String
On Error GoTo EH
FindBestDxfNestingConfiguration = ""
If mdl Is Nothing Then Exit Function
Dim vCfgNames As Variant
vCfgNames = mdl.GetConfigurationNames
If IsEmpty(vCfgNames) Then
If writeLog Then LogEvent " | WARN | DXF nesting config search: model returned no configuration names"
Exit Function
End If
If Not IsArray(vCfgNames) Then
If writeLog Then LogEvent " | WARN | DXF nesting config search: configuration name list is not an array"
Exit Function
End If
Dim i As Long
Dim cfgName As String
Dim normName As String
Dim score As Long
Dim bestScore As Long
Dim bestIndex As Long
Dim bestName As String
bestScore = 0
bestIndex = 2147483647
bestName = ""
For i = LBound(vCfgNames) To UBound(vCfgNames)
cfgName = Trim$(CStr(vCfgNames(i)))
If Len(cfgName) > 0 Then
normName = NormalizeConfigurationSearchText(cfgName)
score = ScoreDxfNestingConfigurationName(cfgName)
If writeLog Then
If score > 0 Then
LogEvent " | INFO | DXF nesting config candidate | cfg=[" & cfgName & "] | normalized=[" & normName & "] | score=" & CStr(score)
Else
LogEvent " | INFO | DXF nesting config ignored | cfg=[" & cfgName & "] | normalized=[" & normName & "] | score=0"
End If
End If
If score >= DXF_NESTING_CONFIG_MIN_SCORE Then
If score > bestScore Then
bestScore = score
bestIndex = i
bestName = cfgName
ElseIf score = bestScore Then
'Tie-breaker: prefer the shorter, clearer configuration name.
'If still tied, keep the earliest SolidWorks configuration order.
If Len(bestName) = 0 Or Len(cfgName) < Len(bestName) Then
bestIndex = i
bestName = cfgName
End If
End If
End If
End If
Next i
If Len(bestName) > 0 Then
FindBestDxfNestingConfiguration = bestName
If writeLog Then
LogEvent " | INFO | Selected DXF/waterjet nesting config [" & bestName & "] | score=" & CStr(bestScore) & " | index=" & CStr(bestIndex)
End If
Else
If writeLog Then
LogEvent " | INFO | No DXF/waterjet nesting config met minimum score " & CStr(DXF_NESTING_CONFIG_MIN_SCORE)
End If
End If
Exit Function
EH:
LogEvent " | ERROR | FindBestDxfNestingConfiguration: " & Err.Number & " - " & Err.Description
End Function
Private Function FindExactConfigurationByName(ByVal mdl As SldWorks.ModelDoc2, _
ByVal desiredConfigName As String) As String
On Error GoTo EH
FindExactConfigurationByName = ""
If mdl Is Nothing Then Exit Function
If Len(Trim$(desiredConfigName)) = 0 Then Exit Function
Dim vCfgNames As Variant
vCfgNames = mdl.GetConfigurationNames
If IsEmpty(vCfgNames) Then Exit Function
If Not IsArray(vCfgNames) Then Exit Function
Dim i As Long
Dim cfgName As String
For i = LBound(vCfgNames) To UBound(vCfgNames)
cfgName = Trim$(CStr(vCfgNames(i)))
If Len(cfgName) > 0 Then
If StrComp(cfgName, desiredConfigName, vbTextCompare) = 0 Then
FindExactConfigurationByName = CStr(vCfgNames(i))
Exit Function
End If
End If
Next i
Exit Function
EH:
LogEvent " | ERROR | FindExactConfigurationByName(" & desiredConfigName & "): " & Err.Number & " - " & Err.Description
End Function
Private Function ScoreDxfNestingConfigurationName(ByVal cfgName As String) As Long
On Error GoTo EH
ScoreDxfNestingConfigurationName = 0
Dim normName As String
Dim compactName As String
normName = NormalizeConfigurationSearchText(cfgName)
compactName = Replace(normName, " ", "")
If Len(normName) = 0 Then Exit Function
'Avoid obvious negative/control configurations.
If ConfigurationNameHasNegativeDxfIntent(normName) Then Exit Function
'Exact / near-exact high-confidence names.
Select Case normName
Case "DXF FOR WATERJET CUTTING"
ScoreDxfNestingConfigurationName = 10000
Exit Function
Case "DXF WATERJET CUTTING", "DXF WATERJET CUT", "WATERJET CUTTING DXF", "WATERJET CUT DXF", "WATERJET DXF CUTTING", "WATERJET DXF CUT"
ScoreDxfNestingConfigurationName = 9900
Exit Function
Case "DXF WATERJET", "WATERJET DXF"
ScoreDxfNestingConfigurationName = 9700
Exit Function
Case "FOR WATERJET CUTTING", "WATERJET CUTTING", "WATERJET CUT", "WATERJET CUT CONFIG", "WATERJET CUTTING CONFIG"
ScoreDxfNestingConfigurationName = 9500
Exit Function
Case LEGACY_WATERJET_CONFIG_NAME
ScoreDxfNestingConfigurationName = 9400
Exit Function
Case "DXF CUT", "DXF CUTTING", "CUT DXF", "CUTTING DXF"
ScoreDxfNestingConfigurationName = 9300
Exit Function
Case "DXF"
ScoreDxfNestingConfigurationName = 9000
Exit Function
Case "WATERJET"
ScoreDxfNestingConfigurationName = 8800
Exit Function
End Select
'Compact check catches names where separators were unusual.
Select Case compactName
Case "DXFFORWATERJETCUTTING"
ScoreDxfNestingConfigurationName = 10000
Exit Function
Case "DXFWATERJETCUTTING", "DXFWATERJETCUT", "WATERJETCUTTINGDXF", "WATERJETCUTDXF", "WATERJETDXFCUTTING", "WATERJETDXFCUT"
ScoreDxfNestingConfigurationName = 9900
Exit Function
Case "DXFWATERJET", "WATERJETDXF"
ScoreDxfNestingConfigurationName = 9700
Exit Function
Case "FORWATERJETCUTTING", "WATERJETCUTTING", "WATERJETCUT", "WATERJETCUTCONFIG", "WATERJETCUTTINGCONFIG"
ScoreDxfNestingConfigurationName = 9500
Exit Function
Case "DXFCUT", "DXFCUTTING", "CUTDXF", "CUTTINGDXF"
ScoreDxfNestingConfigurationName = 9300
Exit Function
End Select
Dim hasDxf As Boolean
Dim hasWaterjet As Boolean
Dim hasWj As Boolean
Dim hasCut As Boolean
Dim hasNest As Boolean
Dim hasExport As Boolean
Dim hasFlat As Boolean
hasDxf = ConfigTokenExists(normName, "DXF")
hasWaterjet = ConfigTokenExists(normName, "WATERJET")
hasWj = ConfigTokenExists(normName, "WJ")
hasCut = ConfigTokenExists(normName, "CUT") Or ConfigTokenExists(normName, "CUTTING")
hasNest = ConfigTokenExists(normName, "NEST") Or ConfigTokenExists(normName, "NESTING")
hasExport = ConfigTokenExists(normName, "EXPORT")
hasFlat = ConfigTokenExists(normName, "FLAT") Or ConfigTokenExists(normName, "FLATTEN") Or ConfigTokenExists(normName, "FLATTENED")
If hasDxf And hasWaterjet And hasCut Then
ScoreDxfNestingConfigurationName = 8500
ElseIf hasDxf And hasWaterjet Then
ScoreDxfNestingConfigurationName = 8200
ElseIf hasWaterjet And hasCut Then
ScoreDxfNestingConfigurationName = 7800
ElseIf hasDxf And hasCut Then
ScoreDxfNestingConfigurationName = 7600
ElseIf hasDxf And hasNest Then
ScoreDxfNestingConfigurationName = 7400
ElseIf hasWaterjet And hasNest Then
ScoreDxfNestingConfigurationName = 7200
ElseIf hasDxf And hasExport Then
ScoreDxfNestingConfigurationName = 7000
ElseIf hasWaterjet And hasExport Then
ScoreDxfNestingConfigurationName = 6900
ElseIf hasDxf And hasFlat Then
ScoreDxfNestingConfigurationName = 6600
ElseIf hasWaterjet And hasFlat Then
ScoreDxfNestingConfigurationName = 6500
ElseIf hasDxf Then
ScoreDxfNestingConfigurationName = 6200
ElseIf hasWaterjet Then
ScoreDxfNestingConfigurationName = 6000
ElseIf hasWj And (hasDxf Or hasCut Or hasNest Or hasExport Or hasFlat) Then
ScoreDxfNestingConfigurationName = 5800
End If
Exit Function
EH:
LogEvent " | ERROR | ScoreDxfNestingConfigurationName(" & cfgName & "): " & Err.Number & " - " & Err.Description
ScoreDxfNestingConfigurationName = 0
End Function
Private Function ConfigurationNameHasNegativeDxfIntent(ByVal normName As String) As Boolean
On Error GoTo EH
ConfigurationNameHasNegativeDxfIntent = False
If Len(Trim$(normName)) = 0 Then Exit Function
'Only block obvious negative phrases. Do not block words like OLD/REV/TEST because
'some shops intentionally use test configs during setup.
If InStr(1, " " & normName & " ", " NO DXF ", vbTextCompare) > 0 Then
ConfigurationNameHasNegativeDxfIntent = True
Exit Function
End If
If InStr(1, " " & normName & " ", " NOT DXF ", vbTextCompare) > 0 Then
ConfigurationNameHasNegativeDxfIntent = True
Exit Function
End If
If InStr(1, " " & normName & " ", " NON DXF ", vbTextCompare) > 0 Then
ConfigurationNameHasNegativeDxfIntent = True
Exit Function
End If
If InStr(1, " " & normName & " ", " WITHOUT DXF ", vbTextCompare) > 0 Then
ConfigurationNameHasNegativeDxfIntent = True
Exit Function
End If
If InStr(1, " " & normName & " ", " DXF DISABLED ", vbTextCompare) > 0 Then
ConfigurationNameHasNegativeDxfIntent = True
Exit Function
End If
If InStr(1, " " & normName & " ", " DISABLE DXF ", vbTextCompare) > 0 Then
ConfigurationNameHasNegativeDxfIntent = True
Exit Function
End If
Exit Function
EH:
ConfigurationNameHasNegativeDxfIntent = False
End Function
Private Function ConfigTokenExists(ByVal normName As String, ByVal token As String) As Boolean
On Error GoTo EH
ConfigTokenExists = False
If Len(Trim$(normName)) = 0 Then Exit Function
If Len(Trim$(token)) = 0 Then Exit Function
ConfigTokenExists = (InStr(1, " " & normName & " ", " " & UCase$(Trim$(token)) & " ", vbTextCompare) > 0)
Exit Function
EH:
ConfigTokenExists = False
End Function
Private Function NormalizeConfigurationSearchText(ByVal rawText As String) As String
On Error GoTo EH
Dim s As String
Dim i As Long
Dim ch As String
Dim code As Long
Dim outText As String
s = UCase$(Trim$(rawText))
outText = ""
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
code = Asc(ch)
If (code >= 65 And code <= 90) Or (code >= 48 And code <= 57) Then
outText = outText & ch
Else
outText = outText & " "
End If
Next i
Do While InStr(1, outText, " ", vbBinaryCompare) > 0
outText = Replace(outText, " ", " ")
Loop
NormalizeConfigurationSearchText = Trim$(outText)
Exit Function
EH:
NormalizeConfigurationSearchText = UCase$(Trim$(rawText))
End Function
Private Function ResolveNestingConfiguration(ByVal mdl As SldWorks.ModelDoc2, _
ByVal requestedConfig As String, _
Optional ByVal writeLog As Boolean = False) As String
On Error GoTo EH
ResolveNestingConfiguration = ""
If mdl Is Nothing Then Exit Function
Dim preferredCfg As String
Dim fallbackCfg As String
preferredCfg = Trim$(FindPreferredWaterjetConfiguration(mdl, writeLog))
fallbackCfg = Trim$(requestedConfig)
If Len(fallbackCfg) = 0 Then
fallbackCfg = GetActiveConfigurationName(mdl)
End If
If Len(preferredCfg) > 0 Then
ResolveNestingConfiguration = preferredCfg
If writeLog Then
LogEvent " | INFO | Nesting config override selected: using [" & preferredCfg & "] instead of requested/active [" & fallbackCfg & "]"
End If
Else
ResolveNestingConfiguration = fallbackCfg
If writeLog Then
LogEvent " | INFO | No DXF/waterjet nesting config found. Using requested/active config [" & ResolveNestingConfiguration & "]"
End If
End If
Exit Function
EH:
LogEvent " | ERROR | ResolveNestingConfiguration: " & Err.Number & " - " & Err.Description
End Function
Private Function ActivateModelConfiguration(ByVal mdl As SldWorks.ModelDoc2, ByVal cfgName As String) As Boolean
On Error GoTo EH
ActivateModelConfiguration = False
If mdl Is Nothing Then Exit Function
If Len(Trim$(cfgName)) = 0 Then Exit Function
Dim ok As Boolean
ok = mdl.ShowConfiguration2(cfgName)
If ok Then
mdl.ForceRebuild3 True
mdl.GraphicsRedraw2
ActivateModelConfiguration = True
End If
Exit Function
EH:
LogEvent " | ERROR | ActivateModelConfiguration(" & cfgName & "): " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' CUT-LIST TRAVERSAL
'=========================================================================================
Private Sub ProcessCutLists(ByVal mdl As SldWorks.ModelDoc2, ByVal outDir As String)
On Error GoTo EH
Dim feat As SldWorks.Feature
Set feat = mdl.FirstFeature
Dim foundAnyCutList As Boolean
foundAnyCutList = False
LogEvent " | INFO | ProcessCutLists pass 1: top-level features"
Do While Not feat Is Nothing
If IsRealCutListFolderFeature(feat) Then
foundAnyCutList = True
ProcessSingleCutList mdl, feat, outDir
End If
Set feat = feat.GetNextFeature
Loop
If Not foundAnyCutList Then
LogEvent " | WARN | No top-level cut-list folders found; starting recursive subfeature fallback"
Set feat = mdl.FirstFeature
Do While Not feat Is Nothing
ProcessCutListFeatureRecursive mdl, feat, outDir, foundAnyCutList
Set feat = feat.GetNextFeature
Loop
End If
If Not foundAnyCutList Then
LogEvent " | WARN | No real cut-list folders found in part after recursive fallback: " & mdl.GetTitle
End If
Exit Sub
EH:
LogEvent " | ERROR | ProcessCutLists: " & Err.Number & " - " & Err.Description
End Sub
Private Function PartHasRealCutList(ByVal mdl As SldWorks.ModelDoc2) As Boolean
On Error GoTo EH
PartHasRealCutList = False
If mdl Is Nothing Then Exit Function
Dim feat As SldWorks.Feature
Set feat = mdl.FirstFeature
Do While Not feat Is Nothing
If IsRealCutListFolderFeature(feat) Then
PartHasRealCutList = True
Exit Function
End If
Set feat = feat.GetNextFeature
Loop
'Fallback for parts where SolidWorks exposes cut-list items as subfeatures only.
Set feat = mdl.FirstFeature
Do While Not feat Is Nothing
If FeatureTreeHasRealCutList(feat) Then
PartHasRealCutList = True
Exit Function
End If
Set feat = feat.GetNextFeature
Loop
Exit Function
EH:
LogEvent " | ERROR | PartHasRealCutList: " & Err.Number & " - " & Err.Description
End Function
Private Sub ProcessRegularPart(ByVal mdl As SldWorks.ModelDoc2, ByVal outDir As String)
On Error GoTo EH
gTotalChecked = gTotalChecked + 1
LogEventRaw String(80, "-")
LogEvent " | INFO | Processing regular part (non-weldment): " & mdl.GetTitle
Dim exportPropName As String
Dim exportRaw As String
Dim exportResolved As String
Dim partNoRaw As String
Dim partNoResolved As String
Dim bodyCount As Long
Dim materialResolved As String
Dim thicknessResolved As String
Dim materialSource As String
Dim thicknessSource As String
Dim classifiedOutDir As String
Dim perInstanceQty As Long
Dim itemKey As String
Dim finalPartNo As String
exportResolved = GetEffectivePartLevelDxfFlag(mdl, exportPropName, exportRaw)
partNoResolved = GetEvaluatedModelProperty(mdl, PROP_PARTNO, partNoRaw)
bodyCount = CountUsableBodiesInPart(mdl)
LogEvent " | INFO | Effective regular-part export property = [" & exportPropName & "] raw=[" & exportRaw & "] eval=[" & exportResolved & "]"
LogEvent " | INFO | PART PROP " & PROP_PARTNO & " raw=[" & partNoRaw & "] eval=[" & partNoResolved & "]"
LogEvent " | INFO | Regular part usable body count = " & CStr(bodyCount)
If UCase$(Trim$(exportResolved)) <> PROP_TRUE_VALUE Then
gTotalSkipped = gTotalSkipped + 1
LogEvent " | SKIP | Regular part effective export property is not YES"
Exit Sub
End If
gTotalEligible = gTotalEligible + 1
Dim repBody As SldWorks.Body2
Set repBody = GetRepresentativeBodyFromPart(mdl)
If repBody Is Nothing Then
gTotalFailed = gTotalFailed + 1
LogEvent " | FAIL | No valid representative body found for regular part"
Exit Sub
End If
Dim faceN(2) As Double
Dim xDir(2) As Double
Dim usedFallbackEdge As Boolean
Dim usedPerpCorner As Boolean
If Not GetExportOrientationForBody(repBody, "regular part [" & mdl.GetTitle & "]", faceN, xDir, usedFallbackEdge, usedPerpCorner) Then
gTotalFailed = gTotalFailed + 1
Exit Sub
End If
If gHasOrientationOverride Then
LogEvent " | INFO | Regular part orientation mode = selected drawing view override"
ElseIf usedPerpCorner Then
LogEvent " | INFO | Regular part orientation mode = perpendicular edge pair -> shared or virtual corner driven bottom-left"
ElseIf usedFallbackEdge Then
LogEvent " | WARN | Regular part orientation mode = fallback axis (no usable linear edge found)"
Else
LogEvent " | INFO | Regular part orientation mode = longest single linear edge horizontal fallback"
End If
Dim baseName As String
baseName = ResolveDxfBaseNameForPart(mdl, partNoResolved, bodyCount, "regular part")
finalPartNo = Trim$(partNoResolved)
If Len(finalPartNo) = 0 Then finalPartNo = baseName
materialResolved = ResolveBestModelPropertyByCandidates(mdl, PROP_CANDIDATES_MATERIAL, materialSource)
thicknessResolved = ResolveBestModelPropertyByCandidates(mdl, PROP_CANDIDATES_THICKNESS, thicknessSource)
thicknessResolved = ResolveNestingThicknessForBody(repBody, faceN, thicknessResolved, thicknessSource, "regular part [" & mdl.GetTitle & "]")
If Len(Trim$(thicknessResolved)) = 0 Then
gTotalFailed = gTotalFailed + 1
LogEvent " | FAIL | Could not resolve geometric nesting thickness for regular part [" & mdl.GetTitle & "]; export skipped to prevent unclassified thickness folder"
Exit Sub
End If
classifiedOutDir = ResolveClassifiedOutputFolder(outDir, materialResolved, thicknessResolved)
LogEvent " | INFO | Regular part material source = " & materialSource & " | value=[" & materialResolved & "]"
LogEvent " | INFO | Regular part thickness source = " & thicknessSource & " | value=[" & thicknessResolved & "]"
LogEvent " | INFO | Classified output folder = " & classifiedOutDir
Dim finalDxfPath As String
finalDxfPath = GetUniqueOutputPath(classifiedOutDir, baseName, "dxf")
If bodyCount > 1 Then
LogEvent " | WARN | Regular part has multiple usable bodies but no real cut-list. Existing logic exports representative body only."
End If
If ShouldAttemptNativeSheetMetalFlatPatternExport(mdl, bodyCount, "regular part [" & mdl.GetTitle & "]") Then
LogEvent " | INFO | Export path = NATIVE_SHEET_METAL_FLAT_PATTERN | regular part [" & mdl.GetTitle & "]"
If ExportNativeSheetMetalFlatPatternDxf(mdl, finalDxfPath, "regular part [" & mdl.GetTitle & "]") Then
gTotalExported = gTotalExported + 1
gTotalNativeSheetMetalFlatPatternExported = gTotalNativeSheetMetalFlatPatternExported + 1
LogEvent " | OK | Regular part exported native sheet-metal flat pattern => " & finalDxfPath
GoTo RegisterRegularPartOutput
Else
gTotalNativeSheetMetalFlatPatternFallbacks = gTotalNativeSheetMetalFlatPatternFallbacks + 1
LogEvent " | WARN | Regular part native sheet-metal flat-pattern export failed; falling back to existing oriented body workflow => " & finalDxfPath
End If
End If
If bodyCount = 1 And Not DISABLE_SOURCE_PART_DIRECT_EXPORT_FOR_STABILITY Then
LogEvent " | INFO | Export path = DIRECT_SOURCE_SINGLE_BODY"
If ExportSingleBodyPartAsOrientedDxfFromSource(mdl, faceN, xDir, finalDxfPath, mdl.GetTitle, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
LogEvent " | OK | Regular part exported directly from source => " & finalDxfPath
Else
LogEvent " | WARN | Regular part direct-from-source export failed; trying isolated temp-part export => " & finalDxfPath
If ExportBodyAsOrientedDxf(repBody, faceN, xDir, finalDxfPath, mdl.GetTitle, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
LogEvent " | OK | Regular part exported by isolated temp-part fallback => " & finalDxfPath
Else
gTotalFailed = gTotalFailed + 1
LogEvent " | FAIL | Regular part direct and isolated fallback export both failed => " & finalDxfPath
Exit Sub
End If
End If
Else
If bodyCount = 1 Then
LogEvent " | INFO | Export path = TEMP_PART_ISOLATED_BODY | source-part direct export disabled for crash stability"
Else
LogEvent " | INFO | Export path = TEMP_PART_ISOLATED_BODY"
End If
If ExportBodyAsOrientedDxf(repBody, faceN, xDir, finalDxfPath, mdl.GetTitle, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
LogEvent " | OK | Regular part exported by isolated temp-part workflow => " & finalDxfPath
Else
gTotalFailed = gTotalFailed + 1
LogEvent " | FAIL | Regular part isolated temp-part export failed => " & finalDxfPath
Exit Sub
End If
End If
RegisterRegularPartOutput:
LogEvent " | CHECK | About to register regular-part output metadata/qty/json after successful export"
perInstanceQty = 1
itemKey = RegisterOutputItem(finalDxfPath, classifiedOutDir, finalPartNo, materialResolved, thicknessResolved, mdl.GetPathName, GetActiveConfigurationName(mdl), mdl.GetTitle, False)
RegisterPartTemplateItem gCurrentPartTemplateKey, itemKey, perInstanceQty
AddQtyForItem itemKey, CLng(perInstanceQty) * CLng(gCurrentPartInstanceMultiplier)
If WRITE_QTY_JSON_INCREMENTALLY Then
FlushItemFolderQtyJson itemKey, "regular part immediate qty write"
End If
Exit Sub
EH:
gTotalFailed = gTotalFailed + 1
LogEvent " | ERROR | ProcessRegularPart(" & mdl.GetTitle & "): " & Err.Number & " - " & Err.Description
End Sub
Private Function UpdateAllCutLists(ByVal mdl As SldWorks.ModelDoc2) As Boolean
On Error GoTo EH
UpdateAllCutLists = False
LogEvent " | INFO | Rebuilding model before cut-list update"
mdl.ForceRebuild3 True
Dim feat As SldWorks.Feature
Set feat = mdl.FirstFeature
Dim updatedAny As Boolean
updatedAny = False
Do While Not feat Is Nothing
Dim typeName As String
typeName = feat.GetTypeName2
If StrComp(typeName, "SolidBodyFolder", vbTextCompare) = 0 _
Or StrComp(typeName, "CutListFolder", vbTextCompare) = 0 _
Or StrComp(typeName, "SubWeldFolder", vbTextCompare) = 0 Then
Dim bf As Object
Set bf = Nothing
On Error Resume Next
Set bf = feat.GetSpecificFeature2
On Error GoTo EH
If Not bf Is Nothing Then
Dim vRet As Variant
On Error Resume Next
vRet = bf.UpdateCutList
On Error GoTo EH
LogEvent " | INFO | UpdateCutList on feature [" & feat.Name & "] => " & CStr(vRet)
If Not IsEmpty(vRet) Then
If CBool(vRet) Then updatedAny = True
End If
End If
End If
Set feat = feat.GetNextFeature
Loop
mdl.ForceRebuild3 True
UpdateAllCutLists = True
If Not updatedAny Then
LogEvent " | WARN | No body folders explicitly updated; rebuild still performed"
End If
Exit Function
EH:
LogEvent " | ERROR | UpdateAllCutLists: " & Err.Number & " - " & Err.Description
End Function
Private Function IsRealCutListFolderFeature(ByVal feat As SldWorks.Feature) As Boolean
On Error GoTo EH
IsRealCutListFolderFeature = False
If feat Is Nothing Then Exit Function
If StrComp(feat.GetTypeName2, "CutListFolder", vbTextCompare) <> 0 Then Exit Function
Dim bf As Object
Set bf = feat.GetSpecificFeature2
If bf Is Nothing Then Exit Function
Dim bodyCount As Long
bodyCount = 0
On Error Resume Next
bodyCount = CLng(bf.GetBodyCount)
On Error GoTo EH
LogEvent " | INFO | Cut-list [" & feat.Name & "] body count = " & bodyCount
If bodyCount > 0 Then
IsRealCutListFolderFeature = True
End If
Exit Function
EH:
LogEvent " | ERROR | IsRealCutListFolderFeature(" & feat.Name & "): " & Err.Number & " - " & Err.Description
End Function
Private Sub ProcessSingleCutList(ByVal mdl As SldWorks.ModelDoc2, ByVal cutFeat As SldWorks.Feature, ByVal outDir As String)
On Error GoTo EH
gTotalChecked = gTotalChecked + 1
LogEventRaw String(80, "-")
LogEvent " | INFO | Processing cut-list feature: " & cutFeat.Name
Dim cpMgr As SldWorks.CustomPropertyManager
Set cpMgr = cutFeat.CustomPropertyManager
Dim dxfRaw As String
Dim dxfResolved As String
Dim effectiveDxfRaw As String
Dim effectiveDxfResolved As String
Dim effectiveDxfSource As String
Dim partNoRaw As String
Dim partNoResolved As String
Dim bodyCount As Long
Dim materialResolved As String
Dim thicknessResolved As String
Dim materialSource As String
Dim thicknessSource As String
Dim classifiedOutDir As String
Dim itemBodyQty As Long
Dim itemKey As String
Dim finalPartNo As String
dxfResolved = GetEvaluatedCutListProperty(cpMgr, PROP_DXF, dxfRaw)
effectiveDxfRaw = dxfRaw
effectiveDxfResolved = dxfResolved
effectiveDxfSource = "CUTLIST." & PROP_DXF
partNoResolved = GetEvaluatedCutListProperty(cpMgr, PROP_PARTNO, partNoRaw)
bodyCount = CountUsableBodiesInPart(mdl)
LogEvent " | INFO | PROP " & PROP_DXF & " raw=[" & dxfRaw & "] eval=[" & dxfResolved & "]"
LogEvent " | INFO | PROP " & PROP_PARTNO & " raw=[" & partNoRaw & "] eval=[" & partNoResolved & "]"
LogEvent " | INFO | Part usable body count = " & CStr(bodyCount)
If Len(Trim$(effectiveDxfResolved)) = 0 Then
If bodyCount = 1 Then
Dim partExportPropName As String
effectiveDxfResolved = GetEffectivePartLevelDxfFlag(mdl, partExportPropName, effectiveDxfRaw)
effectiveDxfSource = "PART." & partExportPropName
LogEvent " | INFO | Single-body cut-list fallback to part property [" & partExportPropName & "] raw=[" & effectiveDxfRaw & "] eval=[" & effectiveDxfResolved & "]"
Else
LogEvent " | INFO | Cut-list DXF blank and part is not single-body; no part-level fallback used"
End If
End If
LogEvent " | INFO | Effective DXF source = " & effectiveDxfSource & " raw=[" & effectiveDxfRaw & "] eval=[" & effectiveDxfResolved & "]"
If UCase$(Trim$(effectiveDxfResolved)) <> PROP_TRUE_VALUE Then
gTotalSkipped = gTotalSkipped + 1
LogEvent " | SKIP | Effective DXF property is not YES"
Exit Sub
End If
gTotalEligible = gTotalEligible + 1
Dim repBody As SldWorks.Body2
Set repBody = GetRepresentativeBodyFromCutList(cutFeat)
If repBody Is Nothing Then
gTotalFailed = gTotalFailed + 1
LogEvent " | FAIL | No representative body found for cut-list [" & cutFeat.Name & "]"
Exit Sub
End If
Dim faceN(2) As Double
Dim xDir(2) As Double
Dim usedFallbackEdge As Boolean
Dim usedPerpCorner As Boolean
If Not GetExportOrientationForBody(repBody, "cut-list [" & cutFeat.Name & "]", faceN, xDir, usedFallbackEdge, usedPerpCorner) Then
gTotalFailed = gTotalFailed + 1
Exit Sub
End If
If gHasOrientationOverride Then
LogEvent " | INFO | Cut-list orientation mode = selected drawing view override"
ElseIf usedPerpCorner Then
LogEvent " | INFO | Cut-list orientation mode = perpendicular edge pair -> shared or virtual corner driven bottom-left"
ElseIf usedFallbackEdge Then
LogEvent " | WARN | Cut-list orientation mode = fallback axis (no usable linear edge found)"
Else
LogEvent " | INFO | Cut-list orientation mode = longest single linear edge horizontal fallback"
End If
Dim baseName As String
baseName = ResolveDxfBaseNameForPart(mdl, partNoResolved, bodyCount, "cut-list [" & cutFeat.Name & "]")
finalPartNo = Trim$(partNoResolved)
If Len(finalPartNo) = 0 Then finalPartNo = baseName
materialResolved = ResolveBestCutListOrModelProperty(cutFeat, mdl, PROP_CANDIDATES_MATERIAL, materialSource)
thicknessResolved = ResolveBestCutListOrModelProperty(cutFeat, mdl, PROP_CANDIDATES_THICKNESS, thicknessSource)
thicknessResolved = ResolveNestingThicknessForBody(repBody, faceN, thicknessResolved, thicknessSource, "cut-list [" & cutFeat.Name & "]")
If Len(Trim$(thicknessResolved)) = 0 Then
gTotalFailed = gTotalFailed + 1
LogEvent " | FAIL | Could not resolve geometric nesting thickness for cut-list [" & cutFeat.Name & "]; export skipped to prevent unclassified thickness folder"
Exit Sub
End If
classifiedOutDir = ResolveClassifiedOutputFolder(outDir, materialResolved, thicknessResolved)
LogEvent " | INFO | Cut-list material source = " & materialSource & " | value=[" & materialResolved & "]"
LogEvent " | INFO | Cut-list thickness source = " & thicknessSource & " | value=[" & thicknessResolved & "]"
LogEvent " | INFO | Classified output folder = " & classifiedOutDir
Dim outputPath As String
outputPath = GetUniqueOutputPath(classifiedOutDir, baseName, "dxf")
If ShouldAttemptNativeSheetMetalFlatPatternExport(mdl, bodyCount, "cut-list [" & cutFeat.Name & "]") Then
LogEvent " | INFO | Export path = NATIVE_SHEET_METAL_FLAT_PATTERN | cut-list [" & cutFeat.Name & "]"
If ExportNativeSheetMetalFlatPatternDxf(mdl, outputPath, "cut-list [" & cutFeat.Name & "]") Then
gTotalExported = gTotalExported + 1
gTotalNativeSheetMetalFlatPatternExported = gTotalNativeSheetMetalFlatPatternExported + 1
LogEvent " | OK | Exported native sheet-metal flat pattern => " & outputPath
GoTo RegisterCutListOutput
Else
gTotalNativeSheetMetalFlatPatternFallbacks = gTotalNativeSheetMetalFlatPatternFallbacks + 1
LogEvent " | WARN | Native sheet-metal flat-pattern export failed; falling back to existing oriented body workflow => " & outputPath
End If
End If
If bodyCount = 1 And Not DISABLE_SOURCE_PART_DIRECT_EXPORT_FOR_STABILITY Then
LogEvent " | INFO | Export path = DIRECT_SOURCE_SINGLE_BODY"
If ExportSingleBodyPartAsOrientedDxfFromSource(mdl, faceN, xDir, outputPath, cutFeat.Name, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
LogEvent " | OK | Exported directly from source => " & outputPath
Else
LogEvent " | WARN | Direct-from-source export failed; trying isolated temp-part export => " & outputPath
If ExportBodyAsOrientedDxf(repBody, faceN, xDir, outputPath, cutFeat.Name, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
LogEvent " | OK | Exported by isolated temp-part fallback => " & outputPath
Else
gTotalFailed = gTotalFailed + 1
LogEvent " | FAIL | Direct and isolated fallback export both failed => " & outputPath
Exit Sub
End If
End If
Else
If bodyCount = 1 Then
LogEvent " | INFO | Export path = TEMP_PART_ISOLATED_BODY | source-part direct export disabled for crash stability"
Else
LogEvent " | INFO | Export path = TEMP_PART_ISOLATED_BODY"
End If
If ExportBodyAsOrientedDxf(repBody, faceN, xDir, outputPath, cutFeat.Name, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
LogEvent " | OK | Exported by isolated temp-part workflow => " & outputPath
Else
gTotalFailed = gTotalFailed + 1
LogEvent " | FAIL | Isolated temp-part export failed => " & outputPath
Exit Sub
End If
End If
RegisterCutListOutput:
LogEvent " | CHECK | About to register cut-list output metadata/qty/json after successful export"
itemBodyQty = GetCutListFolderBodyCountSafe(cutFeat)
If itemBodyQty < 1 Then itemBodyQty = 1
itemKey = RegisterOutputItem(outputPath, classifiedOutDir, finalPartNo, materialResolved, thicknessResolved, mdl.GetPathName, GetActiveConfigurationName(mdl), cutFeat.Name, True)
RegisterPartTemplateItem gCurrentPartTemplateKey, itemKey, itemBodyQty
AddQtyForItem itemKey, CLng(itemBodyQty) * CLng(gCurrentPartInstanceMultiplier)
If WRITE_QTY_JSON_INCREMENTALLY Then
FlushItemFolderQtyJson itemKey, "cut-list immediate qty write"
End If
Exit Sub
EH:
gTotalFailed = gTotalFailed + 1
LogEvent " | ERROR | ProcessSingleCutList(" & cutFeat.Name & "): " & Err.Number & " - " & Err.Description
End Sub
Private Function ResolveDxfBaseNameForPart(ByVal mdl As SldWorks.ModelDoc2, _
ByVal preferredPartNo As String, _
ByVal bodyCount As Long, _
ByVal contextLabel As String) As String
On Error GoTo EH
Dim baseName As String
baseName = ""
If bodyCount = 1 Then
baseName = GetFileStemFromPath(mdl.GetPathName)
LogEvent " | INFO | Single-body " & contextLabel & " uses saved part file name directly for DXF base name => [" & baseName & "]"
Else
baseName = Trim$(preferredPartNo)
If Len(baseName) > 0 Then
LogEvent " | INFO | Multi-body " & contextLabel & " uses PART NUMBER for DXF base name => [" & baseName & "]"
Else
baseName = GetFileStemFromPath(mdl.GetPathName)
LogEvent " | WARN | PART NUMBER missing/blank on " & contextLabel & ", using file name fallback => [" & baseName & "]"
End If
End If
baseName = SanitizeFileName(baseName)
If Len(baseName) = 0 Then
baseName = "PART"
LogEvent " | WARN | Sanitized DXF base name became blank for " & contextLabel & "; using [PART]"
End If
ResolveDxfBaseNameForPart = baseName
Exit Function
EH:
LogEvent " | ERROR | ResolveDxfBaseNameForPart(" & contextLabel & "): " & Err.Number & " - " & Err.Description
ResolveDxfBaseNameForPart = "PART"
End Function
Private Function GetRepresentativeBodyFromCutList(ByVal cutFeat As SldWorks.Feature) As SldWorks.Body2
On Error GoTo EH
Dim bf As Object
Set bf = cutFeat.GetSpecificFeature2
If bf Is Nothing Then
LogEvent " | FAIL | GetSpecificFeature2 returned Nothing for cut-list [" & cutFeat.Name & "]"
Exit Function
End If
Dim bodyCount As Long
bodyCount = 0
On Error Resume Next
bodyCount = CLng(bf.GetBodyCount)
On Error GoTo EH
LogEvent " | INFO | [" & cutFeat.Name & "] GetBodyCount = " & bodyCount
If bodyCount <= 0 Then
LogEvent " | FAIL | [" & cutFeat.Name & "] has no bodies"
Exit Function
End If
Dim vBodies As Variant
vBodies = bf.GetBodies
If IsEmpty(vBodies) Then
LogEvent " | FAIL | [" & cutFeat.Name & "] GetBodies returned Empty"
Exit Function
End If
If Not IsArray(vBodies) Then
LogEvent " | FAIL | [" & cutFeat.Name & "] GetBodies did not return an array"
Exit Function
End If
Dim i As Long
Dim b As SldWorks.Body2
Dim bt As Long
For i = LBound(vBodies) To UBound(vBodies)
Set b = Nothing
On Error Resume Next
Set b = vBodies(i)
On Error GoTo EH
If Not b Is Nothing Then
bt = SafeGetBodyType(b)
LogEvent " | INFO | [" & cutFeat.Name & "] Body(" & i & ") type = " & bt & " [" & BodyTypeName(bt) & "]"
If bt = BODYTYPE_SOLID Then
Set GetRepresentativeBodyFromCutList = b
LogEvent " | INFO | [" & cutFeat.Name & "] representative = SOLID body index " & i
Exit Function
End If
Else
LogEvent " | WARN | [" & cutFeat.Name & "] Body(" & i & ") is Nothing"
End If
Next i
For i = LBound(vBodies) To UBound(vBodies)
Set b = Nothing
On Error Resume Next
Set b = vBodies(i)
On Error GoTo EH
If Not b Is Nothing Then
bt = SafeGetBodyType(b)
If bt = BODYTYPE_SHEET Or bt = BODYTYPE_GENERAL Then
Set GetRepresentativeBodyFromCutList = b
LogEvent " | INFO | [" & cutFeat.Name & "] representative = fallback body index " & i & " [" & BodyTypeName(bt) & "]"
Exit Function
End If
End If
Next i
LogEvent " | FAIL | [" & cutFeat.Name & "] no usable representative body found"
Exit Function
EH:
LogEvent " | ERROR | GetRepresentativeBodyFromCutList(" & cutFeat.Name & "): " & Err.Number & " - " & Err.Description
End Function
Private Function GetRepresentativeBodyFromPart(ByVal mdl As SldWorks.ModelDoc2) As SldWorks.Body2
On Error GoTo EH
If mdl Is Nothing Then Exit Function
If mdl.GetType <> swDocPART Then Exit Function
Dim p As SldWorks.PartDoc
Set p = mdl
Dim vBodies As Variant
vBodies = p.GetBodies2(swSolidBody, True)
If IsEmpty(vBodies) Then
LogEvent " | WARN | No solid bodies found. Trying all bodies for regular part."
vBodies = p.GetBodies2(swAllBodies, True)
End If
If IsEmpty(vBodies) Then
LogEvent " | FAIL | GetBodies2 returned Empty for regular part"
Exit Function
End If
If Not IsArray(vBodies) Then
LogEvent " | FAIL | GetBodies2 did not return an array for regular part"
Exit Function
End If
Dim i As Long
Dim b As SldWorks.Body2
Dim bt As Long
For i = LBound(vBodies) To UBound(vBodies)
Set b = Nothing
On Error Resume Next
Set b = vBodies(i)
On Error GoTo EH
If Not b Is Nothing Then
bt = SafeGetBodyType(b)
LogEvent " | INFO | Regular part Body(" & i & ") type = " & bt & " [" & BodyTypeName(bt) & "]"
If bt = BODYTYPE_SOLID Then
Set GetRepresentativeBodyFromPart = b
LogEvent " | INFO | Regular part representative = SOLID body index " & i
Exit Function
End If
Else
LogEvent " | WARN | Regular part Body(" & i & ") is Nothing"
End If
Next i
For i = LBound(vBodies) To UBound(vBodies)
Set b = Nothing
On Error Resume Next
Set b = vBodies(i)
On Error GoTo EH
If Not b Is Nothing Then
bt = SafeGetBodyType(b)
If bt = BODYTYPE_SHEET Or bt = BODYTYPE_GENERAL Then
Set GetRepresentativeBodyFromPart = b
LogEvent " | INFO | Regular part representative = fallback body index " & i & " [" & BodyTypeName(bt) & "]"
Exit Function
End If
End If
Next i
LogEvent " | FAIL | No usable representative body found for regular part"
Exit Function
EH:
LogEvent " | ERROR | GetRepresentativeBodyFromPart(" & mdl.GetTitle & "): " & Err.Number & " - " & Err.Description
End Function
Private Function SafeGetBodyType(ByVal body As SldWorks.Body2) As Long
On Error GoTo EH
SafeGetBodyType = body.GetType
Exit Function
EH:
LogEvent " | ERROR | SafeGetBodyType: " & Err.Number & " - " & Err.Description
SafeGetBodyType = -999
End Function
Private Function BodyTypeName(ByVal bodyType As Long) As String
Select Case bodyType
Case BODYTYPE_SOLID: BodyTypeName = "SOLID"
Case BODYTYPE_SHEET: BodyTypeName = "SHEET"
Case BODYTYPE_WIRE: BodyTypeName = "WIRE"
Case BODYTYPE_MINIMUM: BodyTypeName = "MINIMUM"
Case BODYTYPE_GENERAL: BodyTypeName = "GENERAL"
Case BODYTYPE_EMPTY: BodyTypeName = "EMPTY"
Case Else: BodyTypeName = "UNKNOWN"
End Select
End Function
Private Function CountUsableBodiesInPart(ByVal mdl As SldWorks.ModelDoc2) As Long
On Error GoTo EH
CountUsableBodiesInPart = 0
If mdl Is Nothing Then Exit Function
If mdl.GetType <> swDocPART Then Exit Function
Dim p As SldWorks.PartDoc
Set p = mdl
Dim vBodies As Variant
vBodies = p.GetBodies2(swAllBodies, True)
If IsEmpty(vBodies) Then
LogEvent " | WARN | CountUsableBodiesInPart: GetBodies2 returned Empty"
Exit Function
End If
If Not IsArray(vBodies) Then
LogEvent " | WARN | CountUsableBodiesInPart: GetBodies2 did not return an array"
Exit Function
End If
Dim i As Long
Dim b As SldWorks.Body2
Dim bt As Long
For i = LBound(vBodies) To UBound(vBodies)
Set b = Nothing
On Error Resume Next
Set b = vBodies(i)
On Error GoTo EH
If Not b Is Nothing Then
bt = SafeGetBodyType(b)
If bt = BODYTYPE_SOLID Or bt = BODYTYPE_SHEET Or bt = BODYTYPE_GENERAL Then
CountUsableBodiesInPart = CountUsableBodiesInPart + 1
End If
End If
Next i
LogEvent " | INFO | CountUsableBodiesInPart = " & CStr(CountUsableBodiesInPart)
Exit Function
EH:
LogEvent " | ERROR | CountUsableBodiesInPart(" & mdl.GetTitle & "): " & Err.Number & " - " & Err.Description
End Function
Private Function GetEffectivePartLevelDxfFlag(ByVal mdl As SldWorks.ModelDoc2, _
ByRef sourcePropName As String, _
ByRef rawValOut As String) As String
On Error GoTo EH
Dim rawPrimary As String
Dim rawLegacy As String
Dim evalPrimary As String
Dim evalLegacy As String
sourcePropName = PROP_DXF
rawValOut = ""
GetEffectivePartLevelDxfFlag = ""
evalPrimary = GetEvaluatedModelProperty(mdl, PROP_DXF, rawPrimary)
LogEvent " | INFO | Effective part export lookup primary [" & PROP_DXF & "] raw=[" & rawPrimary & "] eval=[" & evalPrimary & "]"
If Len(Trim$(evalPrimary)) > 0 Or Len(Trim$(rawPrimary)) > 0 Then
sourcePropName = PROP_DXF
rawValOut = rawPrimary
GetEffectivePartLevelDxfFlag = evalPrimary
Exit Function
End If
evalLegacy = GetEvaluatedModelProperty(mdl, PROP_DXY, rawLegacy)
LogEvent " | INFO | Effective part export lookup legacy [" & PROP_DXY & "] raw=[" & rawLegacy & "] eval=[" & evalLegacy & "]"
sourcePropName = PROP_DXY
rawValOut = rawLegacy
GetEffectivePartLevelDxfFlag = evalLegacy
Exit Function
EH:
LogEvent " | ERROR | GetEffectivePartLevelDxfFlag: " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' PROPERTY HELPERS
'=========================================================================================
Private Function GetEvaluatedCutListProperty(ByVal cpMgr As SldWorks.CustomPropertyManager, _
ByVal propName As String, _
ByRef rawValOut As String) As String
On Error GoTo EH
rawValOut = ""
If cpMgr Is Nothing Then Exit Function
Dim rawVal As String
Dim evalVal As String
Dim wasResolved As Boolean
Dim isLinked As Boolean
Dim ret As Long
rawVal = ""
evalVal = ""
wasResolved = False
isLinked = False
ret = cpMgr.Get6(propName, False, rawVal, evalVal, wasResolved, isLinked)
rawValOut = NzStr(rawVal)
If Len(Trim$(evalVal)) > 0 Then
GetEvaluatedCutListProperty = Trim$(evalVal)
Else
GetEvaluatedCutListProperty = Trim$(rawVal)
End If
Exit Function
EH:
LogEvent " | ERROR | GetEvaluatedCutListProperty(" & propName & "): " & Err.Number & " - " & Err.Description
End Function
Private Function GetEvaluatedModelProperty(ByVal mdl As SldWorks.ModelDoc2, _
ByVal propName As String, _
ByRef rawValOut As String) As String
On Error GoTo EH
rawValOut = ""
GetEvaluatedModelProperty = ""
If mdl Is Nothing Then Exit Function
Dim cfgName As String
Dim cpMgr As SldWorks.CustomPropertyManager
Dim tempRaw As String
Dim tempEval As String
cfgName = GetActiveConfigurationName(mdl)
If Len(cfgName) > 0 Then
Set cpMgr = mdl.Extension.CustomPropertyManager(cfgName)
If Not cpMgr Is Nothing Then
tempEval = GetEvaluatedPropertyValue(cpMgr, propName, tempRaw)
LogEvent " | INFO | Config property lookup [" & cfgName & "] " & propName & " raw=[" & tempRaw & "] eval=[" & tempEval & "]"
If Len(Trim$(tempEval)) > 0 Or Len(Trim$(tempRaw)) > 0 Then
rawValOut = tempRaw
GetEvaluatedModelProperty = tempEval
Exit Function
End If
End If
End If
Set cpMgr = mdl.Extension.CustomPropertyManager("")
If Not cpMgr Is Nothing Then
tempEval = GetEvaluatedPropertyValue(cpMgr, propName, tempRaw)
LogEvent " | INFO | File property lookup " & propName & " raw=[" & tempRaw & "] eval=[" & tempEval & "]"
rawValOut = tempRaw
GetEvaluatedModelProperty = tempEval
End If
Exit Function
EH:
LogEvent " | ERROR | GetEvaluatedModelProperty(" & propName & "): " & Err.Number & " - " & Err.Description
End Function
Private Function ResolveBestCutListOrModelProperty(ByVal cutFeat As SldWorks.Feature, _
ByVal mdl As SldWorks.ModelDoc2, _
ByVal candidateList As String, _
ByRef sourceOut As String) As String
On Error GoTo EH
Dim cpMgr As SldWorks.CustomPropertyManager
Dim propNames As Variant
Dim i As Long
Dim propName As String
Dim rawVal As String
Dim evalVal As String
sourceOut = ""
If Not cutFeat Is Nothing Then
Set cpMgr = cutFeat.CustomPropertyManager
End If
propNames = Split(candidateList, "|")
If Not cpMgr Is Nothing Then
For i = LBound(propNames) To UBound(propNames)
propName = Trim$(CStr(propNames(i)))
If Len(propName) > 0 Then
evalVal = GetEvaluatedCutListProperty(cpMgr, propName, rawVal)
LogEvent " | INFO | Cut-list property lookup [" & propName & "] raw=[" & rawVal & "] eval=[" & evalVal & "]"
If Len(Trim$(evalVal)) > 0 Or Len(Trim$(rawVal)) > 0 Then
sourceOut = "CUTLIST." & propName
ResolveBestCutListOrModelProperty = evalVal
Exit Function
End If
End If
Next i
End If
ResolveBestCutListOrModelProperty = ResolveBestModelPropertyByCandidates(mdl, candidateList, sourceOut)
Exit Function
EH:
LogEvent " | ERROR | ResolveBestCutListOrModelProperty: " & Err.Number & " - " & Err.Description
End Function
Private Function ResolveBestModelPropertyByCandidates(ByVal mdl As SldWorks.ModelDoc2, _
ByVal candidateList As String, _
ByRef sourceOut As String) As String
On Error GoTo EH
Dim propNames As Variant
Dim i As Long
Dim propName As String
Dim rawVal As String
Dim evalVal As String
sourceOut = ""
propNames = Split(candidateList, "|")
For i = LBound(propNames) To UBound(propNames)
propName = Trim$(CStr(propNames(i)))
If Len(propName) > 0 Then
evalVal = GetEvaluatedModelProperty(mdl, propName, rawVal)
LogEvent " | INFO | Model property candidate [" & propName & "] raw=[" & rawVal & "] eval=[" & evalVal & "]"
If Len(Trim$(evalVal)) > 0 Or Len(Trim$(rawVal)) > 0 Then
sourceOut = "MODEL." & propName
ResolveBestModelPropertyByCandidates = evalVal
Exit Function
End If
End If
Next i
Exit Function
EH:
LogEvent " | ERROR | ResolveBestModelPropertyByCandidates: " & Err.Number & " - " & Err.Description
End Function
Private Function ResolveClassifiedOutputFolder(ByVal rootOutDir As String, _
ByVal materialVal As String, _
ByVal thicknessVal As String) As String
On Error GoTo EH
Dim materialFolder As String
Dim thicknessFolder As String
Dim fullPath As String
materialFolder = NormalizeMaterialFolderName(materialVal)
thicknessFolder = NormalizeThicknessFolderName(thicknessVal)
fullPath = EnsureFolderExists(rootOutDir & "\" & materialFolder)
If Len(fullPath) = 0 Then Exit Function
fullPath = EnsureFolderExists(fullPath & "\" & thicknessFolder)
ResolveClassifiedOutputFolder = fullPath
Exit Function
EH:
LogEvent " | ERROR | ResolveClassifiedOutputFolder: " & Err.Number & " - " & Err.Description
End Function
Private Function NormalizeMaterialFolderName(ByVal rawVal As String) As String
Dim s As String
Dim aliasName As String
s = Trim$(rawVal)
If Len(s) = 0 Then
gTotalMissingMaterial = gTotalMissingMaterial + 1
NormalizeMaterialFolderName = UNKNOWN_MATERIAL_FOLDER
Exit Function
End If
s = UCase$(s)
If STRIP_THICKNESS_TEXT_FROM_MATERIAL_FOLDER Then
s = StripThicknessTextFromMaterialName(s)
End If
s = Replace$(s, Chr$(34), " IN ")
s = Replace$(s, vbTab, " ")
s = Replace$(s, "-", " ")
s = Replace$(s, "_", " ")
s = Replace$(s, "/", " ")
s = Replace$(s, "\", " ")
s = Replace$(s, ".", " ")
s = CollapseSpaces(s)
If USE_MATERIAL_ALIAS_NORMALIZATION Then
aliasName = MaterialAliasFolderName(s)
If Len(aliasName) > 0 Then
NormalizeMaterialFolderName = aliasName
Exit Function
End If
End If
s = UCase$(SanitizeFileName(s))
s = Replace$(s, " ", "_")
s = CollapseUnderscores(s)
If Len(s) = 0 Then s = UNKNOWN_MATERIAL_FOLDER
NormalizeMaterialFolderName = s
End Function
Private Function ResolveNestingThicknessForBody(ByVal srcBody As SldWorks.Body2, _
ByRef faceNormal() As Double, _
ByVal propertyThicknessVal As String, _
ByRef thicknessSource As String, _
ByVal contextLabel As String) As String
On Error GoTo EH
ResolveNestingThicknessForBody = ""
Dim geomInches As Double
Dim propInches As Double
Dim hasPropInches As Boolean
hasPropInches = TryParseThicknessToInches(propertyThicknessVal, propInches)
If GEOMETRIC_THICKNESS_FOR_NESTING_FOLDER Then
If GetBodyThicknessInchesAlongNormal(srcBody, faceNormal, geomInches, contextLabel) Then
ResolveNestingThicknessForBody = FormatThicknessInchesValue(geomInches)
thicknessSource = "GEOMETRY.NORMAL_EXTENT_INCHES"
gTotalGeometricThicknessUsed = gTotalGeometricThicknessUsed + 1
LogEvent " | INFO | Geometric nesting thickness selected for " & contextLabel & _
" | inches=" & Format$(geomInches, "0.000000") & _
" | folderValue=" & ResolveNestingThicknessForBody
If hasPropInches Then
If Abs(propInches - geomInches) > 0.003 Then
LogEvent " | WARN | Property thickness differs from geometric nesting thickness for " & contextLabel & _
" | property=[" & propertyThicknessVal & "] => " & Format$(propInches, "0.000000") & _
" | geometry=" & Format$(geomInches, "0.000000") & _
" | using GEOMETRY"
Else
LogEvent " | INFO | Property thickness agrees with geometric nesting thickness for " & contextLabel & _
" | property=[" & propertyThicknessVal & "]"
End If
ElseIf Len(Trim$(propertyThicknessVal)) > 0 Then
LogEvent " | WARN | Thickness property existed but could not be parsed for comparison on " & contextLabel & _
" | property=[" & propertyThicknessVal & "] | using GEOMETRY"
Else
LogEvent " | INFO | No usable thickness property found for " & contextLabel & "; using GEOMETRY"
End If
Exit Function
End If
gTotalGeometricThicknessFailed = gTotalGeometricThicknessFailed + 1
LogEvent " | FAIL | Geometric nesting thickness failed for " & contextLabel
If FAIL_ITEM_WHEN_GEOMETRIC_THICKNESS_FAILS Then
ResolveNestingThicknessForBody = ""
Exit Function
End If
End If
If hasPropInches Then
ResolveNestingThicknessForBody = FormatThicknessInchesValue(propInches)
If Len(Trim$(thicknessSource)) = 0 Then thicknessSource = "PROPERTY.PARSED_FALLBACK"
LogEvent " | WARN | Falling back to parsed property thickness for " & contextLabel & _
" | property=[" & propertyThicknessVal & "] | folderValue=" & ResolveNestingThicknessForBody
Exit Function
End If
gTotalMissingThickness = gTotalMissingThickness + 1
LogEvent " | FAIL | No geometric or property thickness could be resolved for " & contextLabel
ResolveNestingThicknessForBody = ""
Exit Function
EH:
gTotalGeometricThicknessFailed = gTotalGeometricThicknessFailed + 1
LogEvent " | ERROR | ResolveNestingThicknessForBody(" & contextLabel & "): " & Err.Number & " - " & Err.Description
ResolveNestingThicknessForBody = ""
End Function
Private Function GetBodyThicknessInchesAlongNormal(ByVal srcBody As SldWorks.Body2, _
ByRef faceNormal() As Double, _
ByRef thicknessInchesOut As Double, _
ByVal contextLabel As String) As Boolean
On Error GoTo EH
GetBodyThicknessInchesAlongNormal = False
thicknessInchesOut = 0#
If srcBody Is Nothing Then
LogEvent " | FAIL | GetBodyThicknessInchesAlongNormal: srcBody is Nothing for " & contextLabel
Exit Function
End If
If Not ArrayHasThreeVectorValues(faceNormal) Then
LogEvent " | FAIL | GetBodyThicknessInchesAlongNormal: faceNormal is not usable for " & contextLabel
Exit Function
End If
Dim n(2) As Double
n(0) = CDbl(faceNormal(0))
n(1) = CDbl(faceNormal(1))
n(2) = CDbl(faceNormal(2))
NormalizeVec n
If VecLength(n) <= EPS Then
LogEvent " | FAIL | GetBodyThicknessInchesAlongNormal: normalized normal length is zero for " & contextLabel
Exit Function
End If
Dim pxMax As Double, pyMax As Double, pzMax As Double
Dim pxMin As Double, pyMin As Double, pzMin As Double
Dim okMax As Boolean, okMin As Boolean
okMax = srcBody.GetExtremePoint(n(0), n(1), n(2), pxMax, pyMax, pzMax)
okMin = srcBody.GetExtremePoint(-n(0), -n(1), -n(2), pxMin, pyMin, pzMin)
LogEvent " | INFO | Thickness extreme-point status for " & contextLabel & _
" | okMax=" & CStr(okMax) & " | okMin=" & CStr(okMin)
If Not okMax Or Not okMin Then
LogEvent " | FAIL | Body2.GetExtremePoint failed while calculating nesting thickness for " & contextLabel
Exit Function
End If
Dim dx As Double, dy As Double, dz As Double
Dim distM As Double
dx = pxMax - pxMin
dy = pyMax - pyMin
dz = pzMax - pzMin
distM = Abs(dx * n(0) + dy * n(1) + dz * n(2))
LogEvent " | INFO | Thickness points for " & contextLabel & _
" | Pmax=(" & Format$(pxMax, "0.00000000") & ", " & Format$(pyMax, "0.00000000") & ", " & Format$(pzMax, "0.00000000") & ")" & _
" | Pmin=(" & Format$(pxMin, "0.00000000") & ", " & Format$(pyMin, "0.00000000") & ", " & Format$(pzMin, "0.00000000") & ")" & _
" | distM=" & Format$(distM, "0.00000000")
If distM <= EPS Then
LogEvent " | FAIL | Calculated nesting thickness distance is zero/too small for " & contextLabel
Exit Function
End If
thicknessInchesOut = distM * METER_TO_INCH
If thicknessInchesOut <= 0# Then
LogEvent " | FAIL | Calculated nesting thickness inches is invalid for " & contextLabel
Exit Function
End If
LogEvent " | INFO | Geometric nesting thickness for " & contextLabel & _
" = " & Format$(thicknessInchesOut, "0.000000") & " in -> folder " & FormatThicknessInchesFolder(thicknessInchesOut)
GetBodyThicknessInchesAlongNormal = True
Exit Function
EH:
LogEvent " | ERROR | GetBodyThicknessInchesAlongNormal(" & contextLabel & "): " & Err.Number & " - " & Err.Description
GetBodyThicknessInchesAlongNormal = False
End Function
Private Function ArrayHasThreeVectorValues(ByRef arr() As Double) As Boolean
On Error GoTo EH
Dim lb As Long
Dim ub As Long
lb = LBound(arr)
ub = UBound(arr)
If (ub - lb + 1) < 3 Then Exit Function
ArrayHasThreeVectorValues = True
Exit Function
EH:
ArrayHasThreeVectorValues = False
End Function
Private Function NormalizeThicknessFolderName(ByVal rawVal As String) As String
Dim s As String
Dim inches As Double
s = Trim$(rawVal)
If Len(s) = 0 Then
gTotalMissingThickness = gTotalMissingThickness + 1
NormalizeThicknessFolderName = UNKNOWN_THICKNESS_FOLDER
Exit Function
End If
If NORMALIZE_THICKNESS_TO_INCH_FOLDERS Then
If TryParseThicknessToInches(s, inches) Then
If inches > 0# Then
NormalizeThicknessFolderName = FormatThicknessInchesFolder(inches)
Exit Function
End If
End If
End If
s = Replace$(s, Chr$(34), " IN ")
s = Replace$(s, vbTab, " ")
s = CollapseSpaces(s)
s = UCase$(SanitizeFileName(s))
s = Replace$(s, " ", "_")
s = CollapseUnderscores(s)
If Len(s) = 0 Then s = UNKNOWN_THICKNESS_FOLDER
NormalizeThicknessFolderName = s
End Function
Private Function GetCutListFolderBodyCountSafe(ByVal cutFeat As SldWorks.Feature) As Long
On Error GoTo EH
GetCutListFolderBodyCountSafe = 0
If cutFeat Is Nothing Then Exit Function
Dim bf As Object
Set bf = cutFeat.GetSpecificFeature2
If bf Is Nothing Then Exit Function
On Error Resume Next
GetCutListFolderBodyCountSafe = CLng(bf.GetBodyCount)
If Err.Number <> 0 Then
Err.Clear
GetCutListFolderBodyCountSafe = 0
End If
On Error GoTo EH
Exit Function
EH:
LogEvent " | ERROR | GetCutListFolderBodyCountSafe: " & Err.Number & " - " & Err.Description
End Function
Private Function BuildPartTemplateKey(ByVal modelPath As String, ByVal cfgName As String) As String
BuildPartTemplateKey = UCase$(Trim$(modelPath)) & "|" & UCase$(Trim$(cfgName))
End Function
Private Sub EnsurePartTemplateExists(ByVal partKey As String)
On Error GoTo EH
If Len(Trim$(partKey)) = 0 Then Exit Sub
If gPartTemplateByKey Is Nothing Then Exit Sub
If Not gPartTemplateByKey.Exists(partKey) Then
Dim dictTemplate As Object
Set dictTemplate = CreateObject("Scripting.Dictionary")
dictTemplate.CompareMode = vbTextCompare
gPartTemplateByKey.Add partKey, dictTemplate
LogEvent " | INFO | Created part qty template bucket => " & partKey
End If
Exit Sub
EH:
LogEvent " | ERROR | EnsurePartTemplateExists: " & Err.Number & " - " & Err.Description
End Sub
Private Sub RegisterPartTemplateItem(ByVal partKey As String, ByVal itemKey As String, ByVal qtyPerInstance As Long)
On Error GoTo EH
If Len(Trim$(partKey)) = 0 Then Exit Sub
If Len(Trim$(itemKey)) = 0 Then Exit Sub
EnsurePartTemplateExists partKey
Dim dictTemplate As Object
Set dictTemplate = gPartTemplateByKey(partKey)
If dictTemplate.Exists(itemKey) Then
dictTemplate(itemKey) = CLng(dictTemplate(itemKey)) + CLng(qtyPerInstance)
Else
dictTemplate.Add itemKey, CLng(qtyPerInstance)
End If
LogEvent " | INFO | Template item registered | partKey=" & partKey & " | itemKey=" & itemKey & " | qtyPerInstance=" & CStr(qtyPerInstance)
Exit Sub
EH:
LogEvent " | ERROR | RegisterPartTemplateItem: " & Err.Number & " - " & Err.Description
End Sub
Private Sub AddQtyFromExistingPartTemplate(ByVal partKey As String, ByVal instanceMultiplier As Long, ByVal sourceLabel As String)
On Error GoTo EH
If Len(Trim$(partKey)) = 0 Then Exit Sub
If instanceMultiplier < 1 Then instanceMultiplier = 1
If gPartTemplateByKey Is Nothing Then Exit Sub
If Not gPartTemplateByKey.Exists(partKey) Then
LogEvent " | WARN | No qty template exists for duplicate part occurrence: " & sourceLabel & " | partKey=" & partKey
Exit Sub
End If
Dim dictTemplate As Object
Dim k As Variant
Set dictTemplate = gPartTemplateByKey(partKey)
If dictTemplate Is Nothing Then Exit Sub
For Each k In dictTemplate.Keys
AddQtyForItem CStr(k), CLng(dictTemplate(k)) * CLng(instanceMultiplier)
If WRITE_QTY_JSON_INCREMENTALLY Then
FlushItemFolderQtyJson CStr(k), "duplicate part occurrence immediate qty write"
End If
Next k
LogEvent " | INFO | Added qty from existing template | source=" & sourceLabel & " | partKey=" & partKey & " | multiplier=" & CStr(instanceMultiplier)
Exit Sub
EH:
LogEvent " | ERROR | AddQtyFromExistingPartTemplate: " & Err.Number & " - " & Err.Description
End Sub
Private Function RegisterOutputItem(ByVal finalDxfPath As String, _
ByVal folderPath As String, _
ByVal partNumber As String, _
ByVal materialVal As String, _
ByVal thicknessVal As String, _
ByVal sourceModelPath As String, _
ByVal sourceConfig As String, _
ByVal sourceItemLabel As String, _
ByVal isCutList As Boolean) As String
On Error GoTo EH
Dim itemKey As String
itemKey = UCase$(Trim$(finalDxfPath))
If Len(itemKey) = 0 Then Exit Function
If Not gItemMetadataByKey.Exists(itemKey) Then
Dim rec As Object
Set rec = CreateObject("Scripting.Dictionary")
rec.CompareMode = vbTextCompare
rec.Add "file", GetFileNameFromPath(finalDxfPath)
rec.Add "partNumber", NzStr(partNumber)
rec.Add "material", NzStr(materialVal)
rec.Add "thickness", NzStr(thicknessVal)
rec.Add "folderPath", folderPath
rec.Add "sourceModelPath", sourceModelPath
rec.Add "configuration", sourceConfig
rec.Add "sourceItem", sourceItemLabel
rec.Add "sourceType", IIf(isCutList, "CUTLIST", "PART")
gItemMetadataByKey.Add itemKey, rec
LogEvent " | INFO | Registered output item => " & finalDxfPath
End If
AddItemKeyToFolderBucket folderPath, itemKey
RegisterOutputItem = itemKey
Exit Function
EH:
LogEvent " | ERROR | RegisterOutputItem: " & Err.Number & " - " & Err.Description
End Function
Private Sub AddItemKeyToFolderBucket(ByVal folderPath As String, ByVal itemKey As String)
On Error GoTo EH
If Len(Trim$(folderPath)) = 0 Then Exit Sub
If Len(Trim$(itemKey)) = 0 Then Exit Sub
Dim bucket As Object
If Not gFolderItemsByPath.Exists(folderPath) Then
Set bucket = CreateObject("Scripting.Dictionary")
bucket.CompareMode = vbTextCompare
gFolderItemsByPath.Add folderPath, bucket
gTotalClassifiedFolders = gTotalClassifiedFolders + 1
LogEvent " | INFO | New classified folder bucket registered => " & folderPath
Else
Set bucket = gFolderItemsByPath(folderPath)
End If
If Not bucket.Exists(itemKey) Then
bucket.Add itemKey, True
End If
Exit Sub
EH:
LogEvent " | ERROR | AddItemKeyToFolderBucket: " & Err.Number & " - " & Err.Description
End Sub
Private Sub AddQtyForItem(ByVal itemKey As String, ByVal qtyToAdd As Long)
On Error GoTo EH
If Len(Trim$(itemKey)) = 0 Then Exit Sub
If qtyToAdd <= 0 Then Exit Sub
If gItemQtyByKey.Exists(itemKey) Then
gItemQtyByKey(itemKey) = CLng(gItemQtyByKey(itemKey)) + CLng(qtyToAdd)
Else
gItemQtyByKey.Add itemKey, CLng(qtyToAdd)
End If
gTotalQtyAccumulated = gTotalQtyAccumulated + CLng(qtyToAdd)
LogEvent " | INFO | Qty added | itemKey=" & itemKey & " | add=" & CStr(qtyToAdd) & " | total=" & CStr(gItemQtyByKey(itemKey))
Exit Sub
EH:
LogEvent " | ERROR | AddQtyForItem: " & Err.Number & " - " & Err.Description
End Sub
Private Function WriteAllQtyJsonFiles() As Boolean
On Error GoTo EH
WriteAllQtyJsonFiles = False
If gFolderItemsByPath Is Nothing Then
WriteAllQtyJsonFiles = True
Exit Function
End If
Dim folderPath As Variant
For Each folderPath In gFolderItemsByPath.Keys
If WriteQtyJsonForFolder(CStr(folderPath), True, "final batch write") Then
LogEvent " | INFO | Final QTY JSON write complete for folder => " & CStr(folderPath)
Else
LogEvent " | WARN | Final QTY JSON write failed for folder => " & CStr(folderPath)
End If
Next folderPath
WriteAllQtyJsonFiles = True
Exit Function
EH:
LogEvent " | ERROR | WriteAllQtyJsonFiles: " & Err.Number & " - " & Err.Description
End Function
Private Function WriteQtyJsonForFolder(ByVal folderPath As String, ByVal countAsFinalWrite As Boolean, ByVal reason As String) As Boolean
On Error GoTo EH
WriteQtyJsonForFolder = False
If Len(Trim$(folderPath)) = 0 Then Exit Function
If Not FolderExistsSafe(folderPath) Then
LogEvent " | WARN | WriteQtyJsonForFolder target folder does not exist: " & folderPath
Exit Function
End If
Dim jsonText As String
Dim simpleJsonText As String
Dim recordCount As Long
Dim simpleRecordCount As Long
Dim jsonPath As String
Dim simpleJsonPath As String
jsonText = BuildFolderQtyJson(folderPath, recordCount)
jsonPath = folderPath & "\" & JSON_FILE_NAME
If WriteTextFile(jsonPath, jsonText) Then
If countAsFinalWrite Then
gTotalJsonFilesWritten = gTotalJsonFilesWritten + 1
gTotalJsonRecordsWritten = gTotalJsonRecordsWritten + recordCount
End If
LogEvent " | INFO | Wrote QTY.json => " & jsonPath & " | records=" & CStr(recordCount) & " | reason=" & reason
Else
LogEvent " | WARN | Failed to write QTY.json => " & jsonPath & " | reason=" & reason
Exit Function
End If
If WRITE_SIMPLE_QTY_JSON Then
simpleJsonText = BuildFolderSimpleQtyJson(folderPath, simpleRecordCount)
simpleJsonPath = folderPath & "\" & JSON_SIMPLE_FILE_NAME
If WriteTextFile(simpleJsonPath, simpleJsonText) Then
If countAsFinalWrite Then
gTotalJsonFilesWritten = gTotalJsonFilesWritten + 1
gTotalSimpleJsonFilesWritten = gTotalSimpleJsonFilesWritten + 1
End If
LogEvent " | INFO | Wrote QTY_SIMPLE.json => " & simpleJsonPath & " | records=" & CStr(simpleRecordCount) & " | reason=" & reason
Else
LogEvent " | WARN | Failed to write QTY_SIMPLE.json => " & simpleJsonPath & " | reason=" & reason
Exit Function
End If
End If
If Not countAsFinalWrite Then
gTotalImmediateJsonFlushes = gTotalImmediateJsonFlushes + 1
End If
WriteQtyJsonForFolder = True
Exit Function
EH:
LogEvent " | ERROR | WriteQtyJsonForFolder(" & folderPath & "): " & Err.Number & " - " & Err.Description
End Function
Private Sub FlushItemFolderQtyJson(ByVal itemKey As String, ByVal reason As String)
On Error GoTo EH
If Len(Trim$(itemKey)) = 0 Then Exit Sub
If gItemMetadataByKey Is Nothing Then Exit Sub
If Not gItemMetadataByKey.Exists(itemKey) Then Exit Sub
Dim rec As Object
Set rec = gItemMetadataByKey(itemKey)
If rec Is Nothing Then Exit Sub
If Not rec.Exists("folderPath") Then Exit Sub
Dim folderPath As String
folderPath = CStr(rec("folderPath"))
If Len(Trim$(folderPath)) = 0 Then Exit Sub
If Not WriteQtyJsonForFolder(folderPath, False, reason) Then
LogEvent " | WARN | Immediate QTY JSON flush failed for itemKey=" & itemKey & " | folder=" & folderPath
End If
Exit Sub
EH:
LogEvent " | ERROR | FlushItemFolderQtyJson: " & Err.Number & " - " & Err.Description
End Sub
Private Function BuildFolderQtyJson(ByVal folderPath As String, ByRef recordCountOut As Long) As String
On Error GoTo EH
'Production nesting import format:
'[
' { "file": "PART-001.dxf", "qty": 4 },
' { "file": "PART-002.dxf", "qty": 2 }
']
'
'All traceability metadata remains internal to the macro dictionaries during the run.
'The JSON file intentionally contains only what the nesting software needs.
Dim bucket As Object
Dim itemKeys() As String
Dim i As Long
Dim k As Variant
Dim rec As Object
Dim itemKey As String
Dim s As String
recordCountOut = 0
s = "["
If gFolderItemsByPath Is Nothing Then
BuildFolderQtyJson = "[]"
Exit Function
End If
If Not gFolderItemsByPath.Exists(folderPath) Then
BuildFolderQtyJson = "[]"
Exit Function
End If
Set bucket = gFolderItemsByPath(folderPath)
If bucket Is Nothing Then
BuildFolderQtyJson = "[]"
Exit Function
End If
If bucket.Count > 0 Then
ReDim itemKeys(0 To bucket.Count - 1) As String
i = 0
For Each k In bucket.Keys
itemKeys(i) = CStr(k)
i = i + 1
Next k
SortStringArray itemKeys
For i = LBound(itemKeys) To UBound(itemKeys)
itemKey = itemKeys(i)
If gItemMetadataByKey.Exists(itemKey) Then
Set rec = gItemMetadataByKey(itemKey)
If recordCountOut > 0 Then s = s & ","
s = s & vbCrLf & " {" & _
vbCrLf & " ""file"": """ & JsonEscape(CStr(rec("file"))) & """," & _
vbCrLf & " ""qty"": " & CStr(GetItemQtySafe(itemKey)) & _
vbCrLf & " }"
recordCountOut = recordCountOut + 1
End If
Next i
End If
If recordCountOut > 0 Then
s = s & vbCrLf
End If
s = s & "]"
BuildFolderQtyJson = s
Exit Function
EH:
LogEvent " | ERROR | BuildFolderQtyJson: " & Err.Number & " - " & Err.Description
BuildFolderQtyJson = "[]"
End Function
Private Function GetItemQtySafe(ByVal itemKey As String) As Long
If gItemQtyByKey Is Nothing Then Exit Function
If gItemQtyByKey.Exists(itemKey) Then GetItemQtySafe = CLng(gItemQtyByKey(itemKey))
End Function
Private Function WriteTextFile(ByVal filePath As String, ByVal textOut As String) As Boolean
On Error GoTo EH
WriteTextFile = False
'UTF-8 output is safer for external nesting software and non-ASCII paths/properties.
Dim stm As Object
Set stm = CreateObject("ADODB.Stream")
stm.Type = 2 'adTypeText
stm.Charset = "utf-8"
stm.Open
stm.WriteText textOut
stm.SaveToFile filePath, 2 'adSaveCreateOverWrite
stm.Close
WriteTextFile = True
Exit Function
EH:
LogEvent " | WARN | UTF-8 WriteTextFile failed; trying VBA text fallback. Path=" & filePath & " | Err=" & Err.Number & " - " & Err.Description
On Error Resume Next
If Not stm Is Nothing Then
If stm.State <> 0 Then stm.Close
End If
On Error GoTo EH2
Dim ff As Integer
ff = FreeFile
Open filePath For Output As #ff
Print #ff, textOut
Close #ff
WriteTextFile = True
Exit Function
EH2:
On Error Resume Next
If ff <> 0 Then Close #ff
On Error GoTo 0
LogEvent " | ERROR | WriteTextFile(" & filePath & "): " & Err.Number & " - " & Err.Description
End Function
Private Function JsonEscape(ByVal s As String) As String
'JSON escape helper.
'Important: VBA does not use backslash as a string escape character.
'The replacement strings below are JSON escape sequences made from real backslash characters.
s = Replace$(s, "\", "\\")
s = Replace$(s, Chr$(34), "\" & Chr$(34))
s = Replace$(s, vbBack, "\b")
s = Replace$(s, vbFormFeed, "\f")
s = Replace$(s, vbTab, "\t")
s = Replace$(s, vbCrLf, "\n")
s = Replace$(s, vbCr, "\n")
s = Replace$(s, vbLf, "\n")
JsonEscape = s
End Function
Private Function BuildFolderSimpleQtyJson(ByVal folderPath As String, ByRef recordCountOut As Long) As String
On Error GoTo EH
Dim bucket As Object
Dim itemKeys() As String
Dim i As Long
Dim k As Variant
Dim rec As Object
Dim itemKey As String
Dim s As String
recordCountOut = 0
s = "{"
If gFolderItemsByPath Is Nothing Then
BuildFolderSimpleQtyJson = "{}"
Exit Function
End If
If Not gFolderItemsByPath.Exists(folderPath) Then
BuildFolderSimpleQtyJson = "{}"
Exit Function
End If
Set bucket = gFolderItemsByPath(folderPath)
If bucket Is Nothing Then
BuildFolderSimpleQtyJson = "{}"
Exit Function
End If
If bucket.Count > 0 Then
ReDim itemKeys(0 To bucket.Count - 1) As String
i = 0
For Each k In bucket.Keys
itemKeys(i) = CStr(k)
i = i + 1
Next k
SortStringArray itemKeys
For i = LBound(itemKeys) To UBound(itemKeys)
itemKey = itemKeys(i)
If gItemMetadataByKey.Exists(itemKey) Then
Set rec = gItemMetadataByKey(itemKey)
If recordCountOut > 0 Then s = s & ","
s = s & vbCrLf & " """ & JsonEscape(CStr(rec("file"))) & """: " & CStr(GetItemQtySafe(itemKey))
recordCountOut = recordCountOut + 1
End If
Next i
End If
If recordCountOut > 0 Then s = s & vbCrLf
s = s & "}"
BuildFolderSimpleQtyJson = s
Exit Function
EH:
LogEvent " | ERROR | BuildFolderSimpleQtyJson: " & Err.Number & " - " & Err.Description
BuildFolderSimpleQtyJson = "{}"
End Function
Private Function StripThicknessTextFromMaterialName(ByVal rawMaterial As String) As String
On Error GoTo EH
Dim s As String
Dim p As Long
Dim leftPart As String
Dim rightPart As String
s = UCase$(Trim$(rawMaterial))
If Len(s) = 0 Then
StripThicknessTextFromMaterialName = ""
Exit Function
End If
'If material is stored as "44W, 0.25"" THK", keep only the material side.
p = InStr(1, s, ",", vbTextCompare)
If p > 0 Then
leftPart = Trim$(Left$(s, p - 1))
rightPart = Trim$(Mid$(s, p + 1))
If LooksLikeThicknessDescription(rightPart) Then
StripThicknessTextFromMaterialName = leftPart
Exit Function
End If
End If
'If material is stored as "44W 0.25"" THK", remove from the first explicit thickness marker.
p = FirstThicknessMarkerPosition(s)
If p > 1 Then
leftPart = Trim$(Left$(s, p - 1))
If Len(leftPart) > 0 Then
StripThicknessTextFromMaterialName = leftPart
Exit Function
End If
End If
StripThicknessTextFromMaterialName = s
Exit Function
EH:
StripThicknessTextFromMaterialName = rawMaterial
End Function
Private Function LooksLikeThicknessDescription(ByVal textVal As String) As Boolean
Dim s As String
s = " " & UCase$(Trim$(textVal)) & " "
LooksLikeThicknessDescription = False
If InStr(1, s, " THK ", vbTextCompare) > 0 Then LooksLikeThicknessDescription = True
If InStr(1, s, " THICK ", vbTextCompare) > 0 Then LooksLikeThicknessDescription = True
If InStr(1, s, " THICKNESS ", vbTextCompare) > 0 Then LooksLikeThicknessDescription = True
If InStr(1, s, Chr$(34), vbTextCompare) > 0 Then LooksLikeThicknessDescription = True
If InStr(1, s, " IN ", vbTextCompare) > 0 Then LooksLikeThicknessDescription = True
If InStr(1, s, " MM ", vbTextCompare) > 0 Then LooksLikeThicknessDescription = True
If InStr(1, s, " GA ", vbTextCompare) > 0 Then LooksLikeThicknessDescription = True
If InStr(1, s, " GAUGE ", vbTextCompare) > 0 Then LooksLikeThicknessDescription = True
If Not LooksLikeThicknessDescription Then
Dim numericCount As Long
numericCount = CountNumericCharacters(s)
If numericCount > 0 And (InStr(1, s, ".", vbTextCompare) > 0 Or InStr(1, s, "/", vbTextCompare) > 0) Then
LooksLikeThicknessDescription = True
End If
End If
End Function
Private Function FirstThicknessMarkerPosition(ByVal textVal As String) As Long
Dim s As String
Dim candidates As Variant
Dim i As Long
Dim p As Long
Dim best As Long
s = UCase$(textVal)
candidates = Array(" THK", " THICK", " THICKNESS", Chr$(34) & " THK", " MM THK", " IN THK")
best = 0
For i = LBound(candidates) To UBound(candidates)
p = InStr(1, s, CStr(candidates(i)), vbTextCompare)
If p > 0 Then
If best = 0 Or p < best Then best = p
End If
Next i
FirstThicknessMarkerPosition = best
End Function
Private Function CountNumericCharacters(ByVal textVal As String) As Long
Dim i As Long
Dim ch As String
CountNumericCharacters = 0
For i = 1 To Len(textVal)
ch = Mid$(textVal, i, 1)
If ch >= "0" And ch <= "9" Then CountNumericCharacters = CountNumericCharacters + 1
Next i
End Function
Private Function MaterialAliasFolderName(ByVal normalizedMaterialText As String) As String
Dim s As String
s = " " & UCase$(CollapseSpaces(normalizedMaterialText)) & " "
'Common steel aliases.
If InStr(1, s, " A36 ", vbTextCompare) > 0 Or _
InStr(1, s, " ASTM A36 ", vbTextCompare) > 0 Then
MaterialAliasFolderName = "A36_STEEL"
Exit Function
End If
If InStr(1, s, " MILD STEEL ", vbTextCompare) > 0 Or _
InStr(1, s, " CARBON STEEL ", vbTextCompare) > 0 Or _
InStr(1, s, " HRPO ", vbTextCompare) > 0 Or _
InStr(1, s, " HRS ", vbTextCompare) > 0 Then
MaterialAliasFolderName = "MILD_STEEL"
Exit Function
End If
If InStr(1, s, " AR400 ", vbTextCompare) > 0 Then
MaterialAliasFolderName = "AR400"
Exit Function
End If
If InStr(1, s, " AR500 ", vbTextCompare) > 0 Then
MaterialAliasFolderName = "AR500"
Exit Function
End If
'Common stainless aliases.
If InStr(1, s, " 304 ", vbTextCompare) > 0 And _
(InStr(1, s, " SS ", vbTextCompare) > 0 Or InStr(1, s, " STAINLESS ", vbTextCompare) > 0) Then
MaterialAliasFolderName = "304_STAINLESS"
Exit Function
End If
If InStr(1, s, " 316 ", vbTextCompare) > 0 And _
(InStr(1, s, " SS ", vbTextCompare) > 0 Or InStr(1, s, " STAINLESS ", vbTextCompare) > 0) Then
MaterialAliasFolderName = "316_STAINLESS"
Exit Function
End If
'Common aluminum aliases.
If InStr(1, s, " 5052 ", vbTextCompare) > 0 And _
(InStr(1, s, " AL ", vbTextCompare) > 0 Or InStr(1, s, " ALUMINUM ", vbTextCompare) > 0 Or InStr(1, s, " ALUMINIUM ", vbTextCompare) > 0) Then
MaterialAliasFolderName = "5052_ALUMINUM"
Exit Function
End If
If InStr(1, s, " 6061 ", vbTextCompare) > 0 And _
(InStr(1, s, " AL ", vbTextCompare) > 0 Or InStr(1, s, " ALUMINUM ", vbTextCompare) > 0 Or InStr(1, s, " ALUMINIUM ", vbTextCompare) > 0) Then
MaterialAliasFolderName = "6061_ALUMINUM"
Exit Function
End If
MaterialAliasFolderName = ""
End Function
Private Function TryParseThicknessToInches(ByVal rawVal As String, ByRef inchesOut As Double) As Boolean
On Error GoTo EH
Dim s As String
Dim tokens As Variant
Dim i As Long
Dim totalVal As Double
Dim parsedAny As Boolean
Dim isMM As Boolean
TryParseThicknessToInches = False
inchesOut = 0#
s = UCase$(Trim$(rawVal))
If Len(s) = 0 Then Exit Function
isMM = (InStr(1, s, "MM", vbTextCompare) > 0) Or _
(InStr(1, s, "MILLIMETER", vbTextCompare) > 0) Or _
(InStr(1, s, "MILLIMETRE", vbTextCompare) > 0)
s = Replace$(s, Chr$(34), " IN ")
s = Replace$(s, "INCHES", " IN ")
s = Replace$(s, "INCH", " IN ")
s = Replace$(s, "MILLIMETERS", " MM ")
s = Replace$(s, "MILLIMETRES", " MM ")
s = Replace$(s, "MILLIMETER", " MM ")
s = Replace$(s, "MILLIMETRE", " MM ")
s = Replace$(s, "MM", " MM ")
s = Replace$(s, "IN", " IN ")
s = Replace$(s, "(", " ")
s = Replace$(s, ")", " ")
s = Replace$(s, "[", " ")
s = Replace$(s, "]", " ")
s = Replace$(s, "X", " ")
s = Replace$(s, "*", " ")
s = Replace$(s, ",", ".")
s = CollapseSpaces(s)
tokens = Split(s, " ")
For i = LBound(tokens) To UBound(tokens)
Dim tok As String
Dim v As Double
tok = Trim$(CStr(tokens(i)))
If Len(tok) = 0 Then GoTo NextToken
If TryParseThicknessToken(tok, v) Then
totalVal = totalVal + v
parsedAny = True
'Support mixed fractions like "1 1/2 IN" by summing adjacent numeric tokens.
'For normal values like "0.250 IN", there is only one numeric token.
End If
NextToken:
Next i
If Not parsedAny Then Exit Function
If isMM Then
inchesOut = totalVal / 25.4
Else
inchesOut = totalVal
End If
If inchesOut <= 0# Then Exit Function
TryParseThicknessToInches = True
Exit Function
EH:
LogEvent " | WARN | TryParseThicknessToInches failed for [" & rawVal & "]: " & Err.Number & " - " & Err.Description
TryParseThicknessToInches = False
End Function
Private Function TryParseThicknessToken(ByVal tokenText As String, ByRef valueOut As Double) As Boolean
On Error GoTo EH
Dim p As Long
Dim n As Double
Dim d As Double
Dim leftPart As String
Dim rightPart As String
TryParseThicknessToken = False
valueOut = 0#
tokenText = Trim$(tokenText)
If Len(tokenText) = 0 Then Exit Function
p = InStr(1, tokenText, "/", vbTextCompare)
If p > 0 Then
leftPart = Trim$(Left$(tokenText, p - 1))
rightPart = Trim$(Mid$(tokenText, p + 1))
If IsThicknessNumericToken(leftPart) And IsThicknessNumericToken(rightPart) Then
n = Val(leftPart)
d = Val(rightPart)
If d <> 0# Then
valueOut = n / d
TryParseThicknessToken = True
End If
End If
Exit Function
End If
If IsThicknessNumericToken(tokenText) Then
valueOut = Val(tokenText)
TryParseThicknessToken = True
End If
Exit Function
EH:
TryParseThicknessToken = False
End Function
Private Function IsThicknessNumericToken(ByVal tokenText As String) As Boolean
Dim c As String
tokenText = Trim$(tokenText)
If Len(tokenText) = 0 Then Exit Function
c = Left$(tokenText, 1)
If (c >= "0" And c <= "9") Or c = "." Then
IsThicknessNumericToken = (Val(tokenText) <> 0# Or tokenText = "0" Or tokenText = "0.0" Or tokenText = ".0")
End If
End Function
Private Function FormatThicknessInchesFolder(ByVal inchesVal As Double) As String
Dim roundedVal As Double
'Three decimal places are required for nesting folder grouping.
'Use normal three-place rounding after converting SolidWorks meters to inches.
roundedVal = Round(inchesVal, 3)
If THICKNESS_FOLDER_INCLUDE_UNITS Then
FormatThicknessInchesFolder = Format$(roundedVal, "0.000") & "_IN"
Else
FormatThicknessInchesFolder = Format$(roundedVal, "0.000")
End If
End Function
Private Function FormatThicknessInchesValue(ByVal inchesVal As Double) As String
FormatThicknessInchesValue = Format$(Round(inchesVal, 3), "0.000")
End Function
Private Function CollapseSpaces(ByVal s As String) As String
s = Trim$(s)
Do While InStr(1, s, " ", vbBinaryCompare) > 0
s = Replace$(s, " ", " ")
Loop
CollapseSpaces = s
End Function
Private Function CollapseUnderscores(ByVal s As String) As String
s = Trim$(s)
Do While InStr(1, s, "__", vbBinaryCompare) > 0
s = Replace$(s, "__", "_")
Loop
Do While Left$(s, 1) = "_"
s = Mid$(s, 2)
Loop
Do While Right$(s, 1) = "_"
s = Left$(s, Len(s) - 1)
Loop
CollapseUnderscores = s
End Function
Private Function FeatureTreeHasRealCutList(ByVal feat As SldWorks.Feature) As Boolean
On Error GoTo EH
FeatureTreeHasRealCutList = False
If feat Is Nothing Then Exit Function
If IsRealCutListFolderFeature(feat) Then
FeatureTreeHasRealCutList = True
Exit Function
End If
Dim subFeat As SldWorks.Feature
Set subFeat = feat.GetFirstSubFeature
Do While Not subFeat Is Nothing
If FeatureTreeHasRealCutList(subFeat) Then
FeatureTreeHasRealCutList = True
Exit Function
End If
Set subFeat = subFeat.GetNextSubFeature
Loop
Exit Function
EH:
LogEvent " | ERROR | FeatureTreeHasRealCutList(" & SafeFeatureName(feat) & "): " & Err.Number & " - " & Err.Description
End Function
Private Sub ProcessCutListFeatureRecursive(ByVal mdl As SldWorks.ModelDoc2, _
ByVal feat As SldWorks.Feature, _
ByVal outDir As String, _
ByRef foundAnyCutList As Boolean)
On Error GoTo EH
If feat Is Nothing Then Exit Sub
If IsRealCutListFolderFeature(feat) Then
foundAnyCutList = True
ProcessSingleCutList mdl, feat, outDir
End If
Dim subFeat As SldWorks.Feature
Set subFeat = feat.GetFirstSubFeature
Do While Not subFeat Is Nothing
ProcessCutListFeatureRecursive mdl, subFeat, outDir, foundAnyCutList
Set subFeat = subFeat.GetNextSubFeature
Loop
Exit Sub
EH:
LogEvent " | ERROR | ProcessCutListFeatureRecursive(" & SafeFeatureName(feat) & "): " & Err.Number & " - " & Err.Description
End Sub
Private Function SafeFeatureName(ByVal feat As SldWorks.Feature) As String
On Error Resume Next
If feat Is Nothing Then
SafeFeatureName = "(Nothing)"
Else
SafeFeatureName = feat.Name
End If
End Function
Private Sub SortStringArray(ByRef arr() As String)
On Error GoTo EH
Dim i As Long
Dim j As Long
Dim tmp As String
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If StrComp(arr(j), arr(i), vbTextCompare) < 0 Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next j
Next i
Exit Sub
EH:
LogEvent " | ERROR | SortStringArray: " & Err.Number & " - " & Err.Description
End Sub
Private Function GetEvaluatedPropertyValue(ByVal cpMgr As SldWorks.CustomPropertyManager, _
ByVal propName As String, _
ByRef rawValOut As String) As String
On Error GoTo EH
rawValOut = ""
If cpMgr Is Nothing Then Exit Function
Dim rawVal As String
Dim evalVal As String
Dim wasResolved As Boolean
Dim isLinked As Boolean
Dim ret As Long
rawVal = ""
evalVal = ""
wasResolved = False
isLinked = False
ret = cpMgr.Get6(propName, False, rawVal, evalVal, wasResolved, isLinked)
rawValOut = NzStr(rawVal)
If Len(Trim$(evalVal)) > 0 Then
GetEvaluatedPropertyValue = Trim$(evalVal)
Else
GetEvaluatedPropertyValue = Trim$(rawVal)
End If
Exit Function
EH:
LogEvent " | ERROR | GetEvaluatedPropertyValue(" & propName & "): " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' NATIVE SHEET-METAL FLAT-PATTERN EXPORT HELPERS
'=========================================================================================
Private Function ShouldAttemptNativeSheetMetalFlatPatternExport(ByVal mdl As SldWorks.ModelDoc2, _
ByVal usableBodyCount As Long, _
ByVal contextLabel As String) As Boolean
On Error GoTo EH
ShouldAttemptNativeSheetMetalFlatPatternExport = False
If Not USE_NATIVE_SHEET_METAL_FLAT_PATTERN_EXPORT Then
LogEvent " | INFO | Native sheet-metal flat-pattern export disabled by setting | context=" & contextLabel
Exit Function
End If
If mdl Is Nothing Then
gTotalNativeSheetMetalFlatPatternSkipped = gTotalNativeSheetMetalFlatPatternSkipped + 1
LogEvent " | WARN | Native sheet-metal skipped: model is Nothing | context=" & contextLabel
Exit Function
End If
If mdl.GetType <> swDocPART Then
gTotalNativeSheetMetalFlatPatternSkipped = gTotalNativeSheetMetalFlatPatternSkipped + 1
LogEvent " | WARN | Native sheet-metal skipped: source document is not a part | context=" & contextLabel
Exit Function
End If
If Len(Trim$(mdl.GetPathName)) = 0 Then
gTotalNativeSheetMetalFlatPatternSkipped = gTotalNativeSheetMetalFlatPatternSkipped + 1
LogEvent " | WARN | Native sheet-metal skipped: part is unsaved | context=" & contextLabel
Exit Function
End If
If SHEET_METAL_NATIVE_SKIP_WHEN_DRAWING_VIEW_ORIENTATION_OVERRIDE And gHasOrientationOverride Then
gTotalNativeSheetMetalFlatPatternSkipped = gTotalNativeSheetMetalFlatPatternSkipped + 1
LogEvent " | INFO | Native sheet-metal skipped to preserve selected drawing-view orientation override | context=" & contextLabel
Exit Function
End If
If SHEET_METAL_NATIVE_SINGLE_BODY_ONLY Then
If usableBodyCount <> 1 Then
gTotalNativeSheetMetalFlatPatternSkipped = gTotalNativeSheetMetalFlatPatternSkipped + 1
LogEvent " | INFO | Native sheet-metal skipped by single-body safety rule | context=" & contextLabel & _
" | usableBodyCount=" & CStr(usableBodyCount) & _
" | fallback=existing isolated per-body export"
Exit Function
End If
End If
Dim flatPatternInfo As String
flatPatternInfo = ""
If Not PartHasSheetMetalFlatPatternSignal(mdl, flatPatternInfo) Then
gTotalNativeSheetMetalFlatPatternSkipped = gTotalNativeSheetMetalFlatPatternSkipped + 1
LogEvent " | INFO | Native sheet-metal not used: no Flat-Pattern feature signal found | context=" & contextLabel
Exit Function
End If
LogEvent " | INFO | Native sheet-metal flat-pattern candidate accepted | context=" & contextLabel & _
" | flatPatternSignal=" & flatPatternInfo
ShouldAttemptNativeSheetMetalFlatPatternExport = True
Exit Function
EH:
gTotalNativeSheetMetalFlatPatternSkipped = gTotalNativeSheetMetalFlatPatternSkipped + 1
LogEvent " | ERROR | ShouldAttemptNativeSheetMetalFlatPatternExport(" & contextLabel & "): " & Err.Number & " - " & Err.Description
End Function
Private Function ExportNativeSheetMetalFlatPatternDxf(ByVal mdl As SldWorks.ModelDoc2, _
ByVal finalDxfPath As String, _
ByVal contextLabel As String) As Boolean
On Error GoTo EH
ExportNativeSheetMetalFlatPatternDxf = False
If mdl Is Nothing Then
LogEvent " | FAIL | Native sheet-metal export: model is Nothing | context=" & contextLabel
Exit Function
End If
If mdl.GetType <> swDocPART Then
LogEvent " | FAIL | Native sheet-metal export requires PART doc, got " & DocTypeName(mdl.GetType) & " | context=" & contextLabel
Exit Function
End If
If Len(Trim$(finalDxfPath)) = 0 Then
LogEvent " | FAIL | Native sheet-metal export: output path is blank | context=" & contextLabel
Exit Function
End If
Dim modelPath As String
modelPath = Trim$(mdl.GetPathName)
If Len(modelPath) = 0 Then
LogEvent " | FAIL | Native sheet-metal export requires saved part path | context=" & contextLabel
Exit Function
End If
If Not FileExists(modelPath) Then
LogEvent " | FAIL | Native sheet-metal export source file not found: " & modelPath & " | context=" & contextLabel
Exit Function
End If
Dim swSrcPart As SldWorks.PartDoc
Set swSrcPart = mdl
Dim options As Long
options = BuildNativeSheetMetalDxfOptions()
Dim emptyAlignment As Variant
Dim emptyViews As Variant
Dim resultVar As Variant
Dim ok As Boolean
Dim oldUnits As Long
Dim haveOldUnits As Boolean
haveOldUnits = False
oldUnits = 0
LogEvent " | INFO | Native sheet-metal ExportToDWG2 start"
LogEvent " | INFO | context = " & contextLabel
LogEvent " | INFO | modelPath = " & modelPath
LogEvent " | INFO | finalDxfPath = " & finalDxfPath
LogEvent " | INFO | action = SHEET_METAL(" & CStr(SW_EXPORT_TO_DWG_SHEET_METAL) & ")"
LogEvent " | INFO | options = " & CStr(options) & " | " & DescribeNativeSheetMetalDxfOptions(options)
If Not ActivateDocumentByTitle(mdl.GetTitle) Then
LogEvent " | WARN | Native sheet-metal export could not explicitly activate source part | context=" & contextLabel
End If
mdl.ForceRebuild3 True
If SHEET_METAL_NATIVE_TEMPORARILY_FORCE_INCH_UNITS Then
On Error Resume Next
oldUnits = mdl.GetUserPreferenceIntegerValue(swUnitsLinear)
If Err.Number = 0 Then
haveOldUnits = True
LogEvent " | INFO | Native sheet-metal source linear units before temporary export change = " & CStr(oldUnits)
mdl.SetUserPreferenceIntegerValue swUnitsLinear, swINCHES
LogEvent " | INFO | Native sheet-metal source linear units temporarily set to INCHES for DXF export"
Else
LogEvent " | WARN | Native sheet-metal could not read/set linear units before export: " & Err.Number & " - " & Err.Description
Err.Clear
End If
On Error GoTo EH
End If
DeleteFileIfExists finalDxfPath
On Error Resume Next
resultVar = CallByName(swSrcPart, "ExportToDWG2", VbMethod, _
finalDxfPath, _
modelPath, _
SW_EXPORT_TO_DWG_SHEET_METAL, _
True, _
emptyAlignment, _
False, _
False, _
options, _
emptyViews)
If Err.Number <> 0 Then
LogEvent " | WARN | Native sheet-metal CallByName ExportToDWG2 failed: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
GoTo CleanupAndExit
End If
On Error GoTo EH
ok = False
On Error Resume Next
ok = CBool(resultVar)
If Err.Number <> 0 Then
LogEvent " | WARN | Native sheet-metal ExportToDWG2 result could not be converted to Boolean: " & Err.Number & " - " & Err.Description
Err.Clear
ok = False
End If
On Error GoTo EH
LogEvent " | INFO | Native sheet-metal ExportToDWG2 result = " & CStr(ok)
If Not ok Then GoTo CleanupAndExit
If Not FileExists(finalDxfPath) Then
LogEvent " | WARN | Native sheet-metal ExportToDWG2 returned True but output file was not found: " & finalDxfPath
GoTo CleanupAndExit
End If
If GetFileSizeSafe(finalDxfPath) <= 0 Then
LogEvent " | WARN | Native sheet-metal ExportToDWG2 created zero-byte DXF: " & finalDxfPath
GoTo CleanupAndExit
End If
LogEvent " | INFO | Native sheet-metal ExportToDWG2 created DXF. File size = " & CStr(GetFileSizeSafe(finalDxfPath))
Call FinalizeWaterjetDxfAfterExport(finalDxfPath, contextLabel & " | native sheet-metal flat pattern", True)
If FileExists(finalDxfPath) And GetFileSizeSafe(finalDxfPath) > 0 Then
ExportNativeSheetMetalFlatPatternDxf = True
Else
LogEvent " | WARN | Native sheet-metal DXF missing/empty after finalization: " & finalDxfPath
End If
CleanupAndExit:
If haveOldUnits Then
On Error Resume Next
mdl.SetUserPreferenceIntegerValue swUnitsLinear, oldUnits
If Err.Number = 0 Then
LogEvent " | INFO | Native sheet-metal source linear units restored to " & CStr(oldUnits)
Else
LogEvent " | WARN | Native sheet-metal failed to restore original linear units: " & Err.Number & " - " & Err.Description
Err.Clear
End If
On Error GoTo EH
End If
Exit Function
EH:
LogEvent " | ERROR | ExportNativeSheetMetalFlatPatternDxf(" & contextLabel & "): " & Err.Number & " - " & Err.Description
Resume CleanupAndExit
End Function
Private Function BuildNativeSheetMetalDxfOptions() As Long
On Error GoTo EH
Dim options As Long
options = SM_DXF_OPT_FLAT_PATTERN_GEOMETRY
If SHEET_METAL_EXPORT_HIDDEN_EDGES Then options = options Or SM_DXF_OPT_HIDDEN_EDGES
If SHEET_METAL_EXPORT_BEND_LINES Then options = options Or SM_DXF_OPT_BEND_LINES
If SHEET_METAL_EXPORT_SKETCHES Then options = options Or SM_DXF_OPT_SKETCHES
If SHEET_METAL_EXPORT_MERGE_COPLANAR_FACES Then options = options Or SM_DXF_OPT_MERGE_COPLANAR_FACES
If SHEET_METAL_EXPORT_LIBRARY_FEATURES Then options = options Or SM_DXF_OPT_LIBRARY_FEATURES
If SHEET_METAL_EXPORT_FORMING_TOOLS Then options = options Or SM_DXF_OPT_FORMING_TOOLS
If SHEET_METAL_EXPORT_BOUNDING_BOX Then options = options Or SM_DXF_OPT_BOUNDING_BOX
BuildNativeSheetMetalDxfOptions = options
Exit Function
EH:
LogEvent " | ERROR | BuildNativeSheetMetalDxfOptions: " & Err.Number & " - " & Err.Description
BuildNativeSheetMetalDxfOptions = SM_DXF_OPT_FLAT_PATTERN_GEOMETRY
End Function
Private Function DescribeNativeSheetMetalDxfOptions(ByVal options As Long) As String
On Error GoTo EH
Dim s As String
s = ""
If (options And SM_DXF_OPT_FLAT_PATTERN_GEOMETRY) <> 0 Then s = AppendDelimitedText(s, "FlatPatternGeometry", ", ")
If (options And SM_DXF_OPT_HIDDEN_EDGES) <> 0 Then s = AppendDelimitedText(s, "HiddenEdges", ", ")
If (options And SM_DXF_OPT_BEND_LINES) <> 0 Then s = AppendDelimitedText(s, "BendLines", ", ")
If (options And SM_DXF_OPT_SKETCHES) <> 0 Then s = AppendDelimitedText(s, "Sketches", ", ")
If (options And SM_DXF_OPT_MERGE_COPLANAR_FACES) <> 0 Then s = AppendDelimitedText(s, "MergeCoplanarFaces", ", ")
If (options And SM_DXF_OPT_LIBRARY_FEATURES) <> 0 Then s = AppendDelimitedText(s, "LibraryFeatures", ", ")
If (options And SM_DXF_OPT_FORMING_TOOLS) <> 0 Then s = AppendDelimitedText(s, "FormingTools", ", ")
If (options And SM_DXF_OPT_BOUNDING_BOX) <> 0 Then s = AppendDelimitedText(s, "BoundingBox", ", ")
If Len(s) = 0 Then s = "(none)"
DescribeNativeSheetMetalDxfOptions = s
Exit Function
EH:
DescribeNativeSheetMetalDxfOptions = "(option description failed)"
End Function
Private Function PartHasSheetMetalFlatPatternSignal(ByVal mdl As SldWorks.ModelDoc2, _
ByRef flatPatternInfoOut As String) As Boolean
On Error GoTo EH
PartHasSheetMetalFlatPatternSignal = False
flatPatternInfoOut = ""
If mdl Is Nothing Then Exit Function
If mdl.GetType <> swDocPART Then Exit Function
Dim topFeat As SldWorks.Feature
Set topFeat = mdl.FirstFeature
Do While Not topFeat Is Nothing
If FeatureNodeOrSubFeaturesHasFlatPatternSignal(topFeat, flatPatternInfoOut, 0) Then
PartHasSheetMetalFlatPatternSignal = True
Exit Function
End If
Set topFeat = topFeat.GetNextFeature
Loop
Exit Function
EH:
LogEvent " | ERROR | PartHasSheetMetalFlatPatternSignal(" & mdl.GetTitle & "): " & Err.Number & " - " & Err.Description
End Function
Private Function FeatureNodeOrSubFeaturesHasFlatPatternSignal(ByVal feat As SldWorks.Feature, _
ByRef flatPatternInfoOut As String, _
ByVal depth As Long) As Boolean
On Error GoTo EH
FeatureNodeOrSubFeaturesHasFlatPatternSignal = False
If feat Is Nothing Then Exit Function
If depth > 200 Then
LogEvent " | WARN | Flat-pattern feature scan depth limit reached at feature [" & feat.Name & "]"
Exit Function
End If
If FeatureLooksLikeSheetMetalFlatPattern(feat) Then
flatPatternInfoOut = "FeatureName=[" & NzStr(feat.Name) & "] Type=[" & NzStr(feat.GetTypeName2) & "] Suppressed=" & CStr(IsFeatureSuppressedSafe(feat))
FeatureNodeOrSubFeaturesHasFlatPatternSignal = True
Exit Function
End If
Dim subFeat As SldWorks.Feature
Set subFeat = feat.GetFirstSubFeature
Do While Not subFeat Is Nothing
If FeatureNodeOrSubFeaturesHasFlatPatternSignal(subFeat, flatPatternInfoOut, depth + 1) Then
FeatureNodeOrSubFeaturesHasFlatPatternSignal = True
Exit Function
End If
Set subFeat = subFeat.GetNextSubFeature
Loop
Exit Function
EH:
LogEvent " | ERROR | FeatureNodeOrSubFeaturesHasFlatPatternSignal: " & Err.Number & " - " & Err.Description
End Function
Private Function FeatureLooksLikeSheetMetalFlatPattern(ByVal feat As SldWorks.Feature) As Boolean
On Error GoTo EH
FeatureLooksLikeSheetMetalFlatPattern = False
If feat Is Nothing Then Exit Function
Dim typeText As String
Dim nameText As String
Dim compact As String
Dim normalized As String
typeText = NzStr(feat.GetTypeName2)
nameText = NzStr(feat.Name)
compact = UCase$(typeText & " " & nameText)
compact = Replace(compact, " ", "")
compact = Replace(compact, "-", "")
compact = Replace(compact, "_", "")
compact = Replace(compact, ".", "")
normalized = NormalizeConfigurationSearchText(typeText & " " & nameText)
If InStr(1, compact, "FLATPATTERN", vbTextCompare) > 0 Then
FeatureLooksLikeSheetMetalFlatPattern = True
Exit Function
End If
If ConfigTokenExists(normalized, "FLAT") And ConfigTokenExists(normalized, "PATTERN") Then
FeatureLooksLikeSheetMetalFlatPattern = True
Exit Function
End If
FeatureLooksLikeSheetMetalFlatPattern = False
Exit Function
EH:
FeatureLooksLikeSheetMetalFlatPattern = False
End Function
Private Function IsFeatureSuppressedSafe(ByVal feat As SldWorks.Feature) As Boolean
On Error GoTo EH
IsFeatureSuppressedSafe = False
If feat Is Nothing Then Exit Function
Dim resultVar As Variant
Dim state As Boolean
state = False
'Use late-bound calls here because Feature.IsSuppressed signatures have varied across API versions.
On Error Resume Next
resultVar = CallByName(feat, "IsSuppressed", VbMethod)
If Err.Number <> 0 Then
Err.Clear
resultVar = CallByName(feat, "IsSuppressed", VbGet)
End If
If Err.Number = 0 Then
state = CBool(resultVar)
Else
Err.Clear
state = False
End If
On Error GoTo EH
IsFeatureSuppressedSafe = state
Exit Function
EH:
IsFeatureSuppressedSafe = False
End Function
Private Function AppendDelimitedText(ByVal existingText As String, _
ByVal textToAppend As String, _
ByVal delimiter As String) As String
If Len(existingText) = 0 Then
AppendDelimitedText = textToAppend
Else
AppendDelimitedText = existingText & delimiter & textToAppend
End If
End Function
Private Function GetExportOrientationForBody(ByVal srcBody As SldWorks.Body2, _
ByVal contextLabel As String, _
ByRef faceN() As Double, _
ByRef xDir() As Double, _
ByRef usedFallbackEdge As Boolean, _
ByRef usedPerpCorner As Boolean) As Boolean
On Error GoTo EH
GetExportOrientationForBody = False
usedFallbackEdge = False
usedPerpCorner = False
If srcBody Is Nothing Then
LogEvent " | FAIL | GetExportOrientationForBody: srcBody is Nothing for " & contextLabel
Exit Function
End If
If gHasOrientationOverride Then
faceN(0) = gOrientationOverrideZ(0)
faceN(1) = gOrientationOverrideZ(1)
faceN(2) = gOrientationOverrideZ(2)
xDir(0) = gOrientationOverrideX(0)
xDir(1) = gOrientationOverrideX(1)
xDir(2) = gOrientationOverrideX(2)
LogEvent " | INFO | Orientation mode = DRAWING_SELECTED_VIEW override"
LogEvent " | INFO | Override label = " & gOrientationOverrideLabel
LogEvent " | INFO | Override X = (" & Dbl3ToStr(xDir) & ")"
LogEvent " | INFO | Override Z = (" & Dbl3ToStr(faceN) & ")"
GetExportOrientationForBody = True
Exit Function
End If
Dim refFace As SldWorks.Face2
Set refFace = FindLargestPlanarFace(srcBody)
If refFace Is Nothing Then
LogEvent " | FAIL | No planar face found on representative body for " & contextLabel
Exit Function
End If
If Not GetStableFaceNormal(refFace, faceN) Then
LogEvent " | FAIL | Could not obtain face normal for " & contextLabel
Exit Function
End If
If Not FindHorizontalDirectionFromFace(refFace, faceN, xDir, usedFallbackEdge, usedPerpCorner) Then
LogEvent " | FAIL | Could not determine horizontal direction for " & contextLabel
Exit Function
End If
GetExportOrientationForBody = True
Exit Function
EH:
LogEvent " | ERROR | GetExportOrientationForBody(" & contextLabel & "): " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' GEOMETRY / ORIENTATION
'=========================================================================================
Private Function FindLargestPlanarFace(ByVal body As SldWorks.Body2) As SldWorks.Face2
On Error GoTo EH
Dim vFaces As Variant
vFaces = body.GetFaces
If IsEmpty(vFaces) Then Exit Function
If Not IsArray(vFaces) Then Exit Function
Dim i As Long
Dim bestArea As Double
bestArea = -1#
For i = LBound(vFaces) To UBound(vFaces)
Dim f As SldWorks.Face2
Set f = vFaces(i)
If Not f Is Nothing Then
Dim surf As SldWorks.Surface
Set surf = f.GetSurface
If Not surf Is Nothing Then
If surf.IsPlane Then
Dim a As Double
a = 0#
On Error Resume Next
a = f.GetArea
On Error GoTo EH
If a > bestArea Then
bestArea = a
Set FindLargestPlanarFace = f
End If
End If
End If
End If
Next i
LogEvent " | INFO | Largest planar face area = " & FormatNumber(bestArea, 8)
Exit Function
EH:
LogEvent " | ERROR | FindLargestPlanarFace: " & Err.Number & " - " & Err.Description
End Function
Private Function GetStableFaceNormal(ByVal face As SldWorks.Face2, ByRef n() As Double) As Boolean
On Error GoTo EH
GetStableFaceNormal = False
LogEvent " | INFO | GetStableFaceNormal: start"
If face Is Nothing Then
LogEvent " | FAIL | GetStableFaceNormal: face is Nothing"
Exit Function
End If
If TryGetNormalFromFaceVertices(face, n) Then
NormalizeVec n
If VecLength(n) > EPS Then
StabilizeVectorSign n
LogEvent " | INFO | Face normal from face vertices = (" & Dbl3ToStr(n) & ")"
GetStableFaceNormal = True
Exit Function
End If
End If
LogEvent " | WARN | Face vertex normal method failed, trying Face2.Normal"
Dim vNorm As Variant
On Error Resume Next
vNorm = face.Normal
On Error GoTo EH
If VariantHas3Numbers(vNorm) Then
n(0) = CDbl(vNorm(0))
n(1) = CDbl(vNorm(1))
n(2) = CDbl(vNorm(2))
NormalizeVec n
If VecLength(n) > EPS Then
StabilizeVectorSign n
LogEvent " | INFO | Face normal from Face2.Normal = (" & Dbl3ToStr(n) & ")"
GetStableFaceNormal = True
Exit Function
End If
Else
LogEvent " | WARN | Face2.Normal did not return usable data"
End If
LogEvent " | WARN | Face2.Normal failed, trying Surface.PlaneParams"
Dim surf As SldWorks.Surface
Set surf = face.GetSurface
If Not surf Is Nothing Then
Dim planeProps As Variant
On Error Resume Next
planeProps = surf.PlaneParams
On Error GoTo EH
If VariantHasAtLeast6Numbers(planeProps) Then
n(0) = CDbl(planeProps(3))
n(1) = CDbl(planeProps(4))
n(2) = CDbl(planeProps(5))
NormalizeVec n
If VecLength(n) > EPS Then
StabilizeVectorSign n
LogEvent " | INFO | Face normal from Surface.PlaneParams = (" & Dbl3ToStr(n) & ")"
GetStableFaceNormal = True
Exit Function
End If
Else
LogEvent " | WARN | Surface.PlaneParams did not return usable data"
End If
Else
LogEvent " | WARN | face.GetSurface returned Nothing inside GetStableFaceNormal"
End If
LogEvent " | FAIL | GetStableFaceNormal exhausted all methods"
Exit Function
EH:
LogEvent " | ERROR | GetStableFaceNormal: " & Err.Number & " - " & Err.Description
End Function
Private Function TryGetNormalFromFaceVertices(ByVal face As SldWorks.Face2, ByRef n() As Double) As Boolean
On Error GoTo EH
TryGetNormalFromFaceVertices = False
Dim vEdges As Variant
vEdges = face.GetEdges
If IsEmpty(vEdges) Then
LogEvent " | WARN | TryGetNormalFromFaceVertices: face.GetEdges returned Empty"
Exit Function
End If
If Not IsArray(vEdges) Then
LogEvent " | WARN | TryGetNormalFromFaceVertices: face.GetEdges did not return array"
Exit Function
End If
Dim pts() As Double
Dim ptCount As Long
ptCount = 0
Dim i As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim ed As SldWorks.Edge
Set ed = vEdges(i)
If Not ed Is Nothing Then
Dim p0(2) As Double, p1(2) As Double
If GetEdgeEndPoints(ed, p0, p1) Then
AddUniquePoint3 pts, ptCount, p0
AddUniquePoint3 pts, ptCount, p1
End If
End If
Next i
LogEvent " | INFO | TryGetNormalFromFaceVertices: unique point count = " & ptCount
If ptCount < 3 Then
LogEvent " | WARN | TryGetNormalFromFaceVertices: fewer than 3 unique points"
Exit Function
End If
Dim i0 As Long, i1 As Long, i2 As Long
For i0 = 0 To ptCount - 3
For i1 = i0 + 1 To ptCount - 2
For i2 = i1 + 1 To ptCount - 1
Dim a(2) As Double, b(2) As Double, cr(2) As Double
a(0) = pts(0, i1) - pts(0, i0)
a(1) = pts(1, i1) - pts(1, i0)
a(2) = pts(2, i1) - pts(2, i0)
b(0) = pts(0, i2) - pts(0, i0)
b(1) = pts(1, i2) - pts(1, i0)
b(2) = pts(2, i2) - pts(2, i0)
CrossProduct a, b, cr
If VecLength(cr) > EPS Then
NormalizeVec cr
n(0) = cr(0)
n(1) = cr(1)
n(2) = cr(2)
LogEvent " | INFO | TryGetNormalFromFaceVertices: using point indices " & i0 & "," & i1 & "," & i2
TryGetNormalFromFaceVertices = True
Exit Function
End If
Next i2
Next i1
Next i0
LogEvent " | WARN | TryGetNormalFromFaceVertices: no non-collinear triplet found"
Exit Function
EH:
LogEvent " | ERROR | TryGetNormalFromFaceVertices: " & Err.Number & " - " & Err.Description
End Function
Private Sub AddUniquePoint3(ByRef pts() As Double, ByRef ptCount As Long, ByRef p() As Double)
Dim i As Long
For i = 0 To ptCount - 1
If Abs(pts(0, i) - p(0)) <= PT_TOL _
And Abs(pts(1, i) - p(1)) <= PT_TOL _
And Abs(pts(2, i) - p(2)) <= PT_TOL Then
Exit Sub
End If
Next i
If ptCount = 0 Then
ReDim pts(0 To 2, 0 To 0)
Else
ReDim Preserve pts(0 To 2, 0 To ptCount)
End If
pts(0, ptCount) = p(0)
pts(1, ptCount) = p(1)
pts(2, ptCount) = p(2)
ptCount = ptCount + 1
End Sub
Private Function VariantHas3Numbers(ByVal v As Variant) As Boolean
On Error GoTo EH
VariantHas3Numbers = False
If IsEmpty(v) Then Exit Function
If Not IsArray(v) Then Exit Function
Dim lb As Long, ub As Long
lb = LBound(v)
ub = UBound(v)
If (ub - lb + 1) < 3 Then Exit Function
Dim t0 As Double, t1 As Double, t2 As Double
t0 = CDbl(v(lb + 0))
t1 = CDbl(v(lb + 1))
t2 = CDbl(v(lb + 2))
VariantHas3Numbers = True
Exit Function
EH:
VariantHas3Numbers = False
End Function
Private Function VariantHasAtLeast6Numbers(ByVal v As Variant) As Boolean
On Error GoTo EH
VariantHasAtLeast6Numbers = False
If IsEmpty(v) Then Exit Function
If Not IsArray(v) Then Exit Function
Dim lb As Long, ub As Long
lb = LBound(v)
ub = UBound(v)
If (ub - lb + 1) < 6 Then Exit Function
Dim i As Long, tmp As Double
For i = 0 To 5
tmp = CDbl(v(lb + i))
Next i
VariantHasAtLeast6Numbers = True
Exit Function
EH:
VariantHasAtLeast6Numbers = False
End Function
Private Function GetBestTabAwareGussetOrientationCandidate(ByVal face As SldWorks.Face2, _
ByRef faceNormal() As Double, _
ByRef bestPrimaryLen As Double, _
ByRef bestSecondaryLen As Double, _
ByRef bestX() As Double, _
ByRef bestY() As Double, _
ByRef bestCorner() As Double) As Boolean
On Error GoTo EH
GetBestTabAwareGussetOrientationCandidate = False
If face Is Nothing Then Exit Function
Dim pts() As Double
Dim ptCount As Long
ptCount = 0
If Not CollectUniqueFaceBoundaryPoints(face, pts, ptCount) Then
LogEvent " | INFO | Tab-aware gusset scan: no usable boundary points"
Exit Function
End If
LogEvent " | INFO | Tab-aware gusset scan: boundary point count = " & ptCount
Dim vEdges As Variant
vEdges = face.GetEdges
If IsEmpty(vEdges) Then Exit Function
If Not IsArray(vEdges) Then Exit Function
bestPrimaryLen = -1#
bestSecondaryLen = -1#
Dim bestArea As Double
Dim bestNegMax As Double
bestArea = -1#
bestNegMax = 1E+30
Dim i As Long
Dim j As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim ed1 As SldWorks.Edge
Set ed1 = vEdges(i)
If Not ed1 Is Nothing Then
If EdgeIsLinear(ed1) Then
Dim e1p0(2) As Double, e1p1(2) As Double
If GetEdgeEndPoints(ed1, e1p0, e1p1) Then
For j = i + 1 To UBound(vEdges)
Dim ed2 As SldWorks.Edge
Set ed2 = vEdges(j)
If Not ed2 Is Nothing Then
If EdgeIsLinear(ed2) Then
Dim e2p0(2) As Double, e2p1(2) As Double
If GetEdgeEndPoints(ed2, e2p0, e2p1) Then
Dim corner(2) As Double
Dim e1Far(2) As Double
Dim e2Far(2) As Double
If TryGetSharedCornerFromEdgeEndpoints(e1p0, e1p1, e2p0, e2p1, corner, e1Far, e2Far) Then
Dim dir1(2) As Double
Dim dir2(2) As Double
Dim len1 As Double
Dim len2 As Double
dir1(0) = e1Far(0) - corner(0)
dir1(1) = e1Far(1) - corner(1)
dir1(2) = e1Far(2) - corner(2)
dir2(0) = e2Far(0) - corner(0)
dir2(1) = e2Far(1) - corner(1)
dir2(2) = e2Far(2) - corner(2)
ProjectVectorOntoPlane dir1, faceNormal, dir1
ProjectVectorOntoPlane dir2, faceNormal, dir2
len1 = VecLength(dir1)
len2 = VecLength(dir2)
If len1 > EPS And len2 > EPS Then
NormalizeVec dir1
NormalizeVec dir2
Dim perpDot As Double
perpDot = Abs(DotProduct(dir1, dir2))
If perpDot <= PERP_DOT_TOL Then
Dim candPrimaryLen As Double
Dim candSecondaryLen As Double
Dim candX(2) As Double
Dim candY(2) As Double
Dim candNegMax As Double
Dim candArea As Double
If EvaluateTabAwareCornerCandidate(pts, ptCount, corner, dir1, dir2, candPrimaryLen, candSecondaryLen, candX, candY, candNegMax, candArea) Then
LogEvent " | INFO | Tab-aware candidate accepted | EdgeIdx=" & i & "/" & j & _
" | corner=(" & Dbl3ToStr(corner) & ")" & _
" | primary=" & FormatNumber(candPrimaryLen, 8) & _
" | secondary=" & FormatNumber(candSecondaryLen, 8) & _
" | negMax=" & FormatNumber(candNegMax, 8) & _
" | area=" & FormatNumber(candArea, 8)
If IsTabAwareCandidateBetter(candPrimaryLen, candSecondaryLen, candArea, candNegMax, candX, _
bestPrimaryLen, bestSecondaryLen, bestArea, bestNegMax, bestX) Then
bestPrimaryLen = candPrimaryLen
bestSecondaryLen = candSecondaryLen
bestArea = candArea
bestNegMax = candNegMax
bestX(0) = candX(0): bestX(1) = candX(1): bestX(2) = candX(2)
bestY(0) = candY(0): bestY(1) = candY(1): bestY(2) = candY(2)
bestCorner(0) = corner(0): bestCorner(1) = corner(1): bestCorner(2) = corner(2)
GetBestTabAwareGussetOrientationCandidate = True
End If
Else
LogEvent " | INFO | Tab-aware candidate rejected | EdgeIdx=" & i & "/" & j & _
" | corner=(" & Dbl3ToStr(corner) & ")"
End If
End If
End If
End If
End If
End If
End If
Next j
End If
End If
End If
Next i
Exit Function
EH:
LogEvent " | ERROR | GetBestTabAwareGussetOrientationCandidate: " & Err.Number & " - " & Err.Description
End Function
Private Function CollectUniqueFaceBoundaryPoints(ByVal face As SldWorks.Face2, _
ByRef pts() As Double, _
ByRef ptCount As Long) As Boolean
On Error GoTo EH
CollectUniqueFaceBoundaryPoints = False
ptCount = 0
If face Is Nothing Then Exit Function
Dim vEdges As Variant
vEdges = face.GetEdges
If IsEmpty(vEdges) Then Exit Function
If Not IsArray(vEdges) Then Exit Function
Dim i As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim ed As SldWorks.Edge
Set ed = vEdges(i)
If Not ed Is Nothing Then
Dim p0(2) As Double, p1(2) As Double
If GetEdgeEndPoints(ed, p0, p1) Then
AddUniquePoint3 pts, ptCount, p0
AddUniquePoint3 pts, ptCount, p1
End If
End If
Next i
CollectUniqueFaceBoundaryPoints = (ptCount >= 3)
Exit Function
EH:
LogEvent " | ERROR | CollectUniqueFaceBoundaryPoints: " & Err.Number & " - " & Err.Description
End Function
Private Function EvaluateTabAwareCornerCandidate(ByRef pts() As Double, _
ByVal ptCount As Long, _
ByRef corner() As Double, _
ByRef dir1() As Double, _
ByRef dir2() As Double, _
ByRef bestPrimaryLen As Double, _
ByRef bestSecondaryLen As Double, _
ByRef bestX() As Double, _
ByRef bestY() As Double, _
ByRef bestNegMax As Double, _
ByRef bestArea As Double) As Boolean
On Error GoTo EH
EvaluateTabAwareCornerCandidate = False
If ptCount < 3 Then Exit Function
Dim requiredLeg As Double
requiredLeg = TAB_AWARE_MIN_EFFECTIVE_LEG_M
Dim ratioLeg As Double
ratioLeg = TAB_AWARE_USER_TAB_MAX_M * TAB_AWARE_MIN_LEG_TO_TAB_RATIO
If ratioLeg > requiredLeg Then requiredLeg = ratioLeg
bestPrimaryLen = -1#
bestSecondaryLen = -1#
bestNegMax = 1E+30
bestArea = -1#
Dim sx As Long
Dim sy As Long
For sx = -1 To 1 Step 2
For sy = -1 To 1 Step 2
Dim candX(2) As Double
Dim candY(2) As Double
candX(0) = sx * dir1(0)
candX(1) = sx * dir1(1)
candX(2) = sx * dir1(2)
candY(0) = sy * dir2(0)
candY(1) = sy * dir2(1)
candY(2) = sy * dir2(2)
NormalizeVec candX
NormalizeVec candY
Dim maxNegX As Double
Dim maxNegY As Double
Dim effX As Double
Dim effY As Double
maxNegX = 0#
maxNegY = 0#
effX = 0#
effY = 0#
Dim i As Long
For i = 0 To ptCount - 1
Dim rel(2) As Double
rel(0) = pts(0, i) - corner(0)
rel(1) = pts(1, i) - corner(1)
rel(2) = pts(2, i) - corner(2)
Dim u As Double
Dim v As Double
u = DotProduct(rel, candX)
v = DotProduct(rel, candY)
If u < 0# Then
If -u > maxNegX Then maxNegX = -u
Else
If Abs(v) <= TAB_AWARE_AXIS_STRIP_HALF_WIDTH_M + EPS Then
If u > effX Then effX = u
End If
End If
If v < 0# Then
If -v > maxNegY Then maxNegY = -v
Else
If Abs(u) <= TAB_AWARE_AXIS_STRIP_HALF_WIDTH_M + EPS Then
If v > effY Then effY = v
End If
End If
Next i
Dim candNegMax As Double
candNegMax = maxNegX
If maxNegY > candNegMax Then candNegMax = maxNegY
Dim candPrimary As Double
Dim candSecondary As Double
Dim candArea As Double
Dim finalX(2) As Double
Dim finalY(2) As Double
If TAB_AWARE_PREFER_LONGER_LEG_HORIZONTAL Then
If effY > effX + EPS Then
candPrimary = effY
candSecondary = effX
finalX(0) = candY(0): finalX(1) = candY(1): finalX(2) = candY(2)
finalY(0) = candX(0): finalY(1) = candX(1): finalY(2) = candX(2)
Else
candPrimary = effX
candSecondary = effY
finalX(0) = candX(0): finalX(1) = candX(1): finalX(2) = candX(2)
finalY(0) = candY(0): finalY(1) = candY(1): finalY(2) = candY(2)
End If
Else
candPrimary = effX
candSecondary = effY
finalX(0) = candX(0): finalX(1) = candX(1): finalX(2) = candX(2)
finalY(0) = candY(0): finalY(1) = candY(1): finalY(2) = candY(2)
End If
candArea = candPrimary * candSecondary
LogEvent " | INFO | Tab-aware sign combo | sx=" & sx & " sy=" & sy & _
" | negX=" & FormatNumber(maxNegX, 8) & _
" | negY=" & FormatNumber(maxNegY, 8) & _
" | effX=" & FormatNumber(effX, 8) & _
" | effY=" & FormatNumber(effY, 8) & _
" | chosenPrimary=" & FormatNumber(candPrimary, 8) & _
" | chosenSecondary=" & FormatNumber(candSecondary, 8)
If candNegMax <= TAB_AWARE_ALLOWANCE_M + EPS Then
If candPrimary >= requiredLeg - EPS And candSecondary >= requiredLeg - EPS Then
If IsTabAwareCandidateBetter(candPrimary, candSecondary, candArea, candNegMax, finalX, _
bestPrimaryLen, bestSecondaryLen, bestArea, bestNegMax, bestX) Then
bestPrimaryLen = candPrimary
bestSecondaryLen = candSecondary
bestNegMax = candNegMax
bestArea = candArea
bestX(0) = finalX(0): bestX(1) = finalX(1): bestX(2) = finalX(2)
bestY(0) = finalY(0): bestY(1) = finalY(1): bestY(2) = finalY(2)
EvaluateTabAwareCornerCandidate = True
End If
Else
LogEvent " | INFO | Tab-aware sign combo rejected by minimum effective leg requirement = " & FormatNumber(requiredLeg, 8)
End If
Else
LogEvent " | INFO | Tab-aware sign combo rejected by negative extent allowance = " & FormatNumber(candNegMax, 8)
End If
Next sy
Next sx
Exit Function
EH:
LogEvent " | ERROR | EvaluateTabAwareCornerCandidate: " & Err.Number & " - " & Err.Description
End Function
Private Function IsTabAwareCandidateBetter(ByVal candPrimary As Double, _
ByVal candSecondary As Double, _
ByVal candArea As Double, _
ByVal candNegMax As Double, _
ByRef candX() As Double, _
ByVal bestPrimary As Double, _
ByVal bestSecondary As Double, _
ByVal bestArea As Double, _
ByVal bestNegMax As Double, _
ByRef bestX() As Double) As Boolean
IsTabAwareCandidateBetter = False
If candSecondary > bestSecondary + EPS Then
IsTabAwareCandidateBetter = True
Exit Function
End If
If Abs(candSecondary - bestSecondary) <= EPS Then
If candArea > bestArea + EPS Then
IsTabAwareCandidateBetter = True
Exit Function
End If
If Abs(candArea - bestArea) <= EPS Then
If candPrimary > bestPrimary + EPS Then
IsTabAwareCandidateBetter = True
Exit Function
End If
If Abs(candPrimary - bestPrimary) <= EPS Then
If candNegMax < bestNegMax - EPS Then
IsTabAwareCandidateBetter = True
Exit Function
End If
If Abs(candNegMax - bestNegMax) <= EPS Then
If CompareVectorLex(candX, bestX) > 0 Then
IsTabAwareCandidateBetter = True
Exit Function
End If
End If
End If
End If
End If
End Function
Private Function FindHorizontalDirectionFromFace(ByVal face As SldWorks.Face2, _
ByRef faceNormal() As Double, _
ByRef xDir() As Double, _
ByRef usedFallback As Boolean, _
ByRef usedPerpCorner As Boolean) As Boolean
On Error GoTo EH
FindHorizontalDirectionFromFace = False
usedFallback = False
usedPerpCorner = False
Dim tabAwareFound As Boolean
Dim sharedFound As Boolean
Dim virtualFound As Boolean
Dim tabPrimaryLen As Double
Dim tabSecondaryLen As Double
Dim tabX(2) As Double
Dim tabY(2) As Double
Dim tabCorner(2) As Double
Dim sharedPrimaryLen As Double
Dim sharedSecondaryLen As Double
Dim sharedX(2) As Double
Dim sharedY(2) As Double
Dim sharedCorner(2) As Double
Dim virtualPrimaryLen As Double
Dim virtualSecondaryLen As Double
Dim virtualX(2) As Double
Dim virtualY(2) As Double
Dim virtualCorner(2) As Double
If ENABLE_TAB_AWARE_GUSSET_MODE Then
LogEvent " | INFO | Tab-aware gusset orientation scan: start"
tabAwareFound = GetBestTabAwareGussetOrientationCandidate(face, faceNormal, tabPrimaryLen, tabSecondaryLen, tabX, tabY, tabCorner)
If tabAwareFound Then
LogEvent " | INFO | Tab-aware gusset orientation candidate accepted before legacy pair-length logic"
If ApplyBottomLeftOrientationCandidate(faceNormal, xDir, tabX, tabY, tabCorner, tabPrimaryLen, tabSecondaryLen, "Tab-aware gusset orientation", "Manufacturing corner") Then
usedPerpCorner = True
FindHorizontalDirectionFromFace = True
Exit Function
Else
LogEvent " | WARN | Tab-aware gusset candidate was found but could not be applied"
End If
Else
LogEvent " | INFO | Tab-aware gusset orientation scan found no qualifying manufacturing corner"
End If
End If
sharedFound = GetBestSharedCornerOrientationCandidate(face, faceNormal, sharedPrimaryLen, sharedSecondaryLen, sharedX, sharedY, sharedCorner)
If sharedFound Then
LogEvent " | INFO | Shared-corner perpendicular pair found; checking non-intersecting perpendicular pairs for chamfer override"
virtualFound = GetBestVirtualCornerOrientationCandidate(face, faceNormal, virtualPrimaryLen, virtualSecondaryLen, virtualX, virtualY, virtualCorner)
If virtualFound Then
LogEvent " | INFO | Best shared-corner pair lengths = " & FormatNumber(sharedPrimaryLen, 8) & " / " & FormatNumber(sharedSecondaryLen, 8)
LogEvent " | INFO | Best non-intersecting pair lengths = " & FormatNumber(virtualPrimaryLen, 8) & " / " & FormatNumber(virtualSecondaryLen, 8)
If IsPairLengthBetter(virtualPrimaryLen, virtualSecondaryLen, sharedPrimaryLen, sharedSecondaryLen) Then
LogEvent " | INFO | Non-intersecting perpendicular pair is longer than shared-corner pair; using chamfer-ignore virtual corner orientation"
If ApplyBottomLeftOrientationCandidate(faceNormal, xDir, virtualX, virtualY, virtualCorner, virtualPrimaryLen, virtualSecondaryLen, "Virtual corner orientation", "Virtual corner") Then
usedPerpCorner = True
FindHorizontalDirectionFromFace = True
Exit Function
End If
Else
LogEvent " | INFO | Shared-corner pair remains preferred because non-intersecting pair is not longer"
If ApplyBottomLeftOrientationCandidate(faceNormal, xDir, sharedX, sharedY, sharedCorner, sharedPrimaryLen, sharedSecondaryLen, "Corner orientation", "Shared corner") Then
usedPerpCorner = True
FindHorizontalDirectionFromFace = True
Exit Function
End If
End If
Else
LogEvent " | INFO | No qualifying non-intersecting perpendicular pair found; using shared-corner pair"
If ApplyBottomLeftOrientationCandidate(faceNormal, xDir, sharedX, sharedY, sharedCorner, sharedPrimaryLen, sharedSecondaryLen, "Corner orientation", "Shared corner") Then
usedPerpCorner = True
FindHorizontalDirectionFromFace = True
Exit Function
End If
End If
Else
LogEvent " | INFO | No valid perpendicular shared-corner pair found; trying non-intersecting perpendicular pair fallback"
virtualFound = GetBestVirtualCornerOrientationCandidate(face, faceNormal, virtualPrimaryLen, virtualSecondaryLen, virtualX, virtualY, virtualCorner)
If virtualFound Then
If ApplyBottomLeftOrientationCandidate(faceNormal, xDir, virtualX, virtualY, virtualCorner, virtualPrimaryLen, virtualSecondaryLen, "Virtual corner orientation", "Virtual corner") Then
usedPerpCorner = True
FindHorizontalDirectionFromFace = True
Exit Function
End If
End If
End If
LogEvent " | INFO | No usable perpendicular edge pair found; trying longest single edge fallback"
Dim vEdges As Variant
vEdges = face.GetEdges
Dim bestLen As Double
bestLen = -1#
Dim bestVec(2) As Double
Dim foundLine As Boolean
foundLine = False
If Not IsEmpty(vEdges) Then
If IsArray(vEdges) Then
Dim i As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim ed As SldWorks.Edge
Set ed = vEdges(i)
If Not ed Is Nothing Then
If EdgeIsLinear(ed) Then
Dim p0(2) As Double, p1(2) As Double
If GetEdgeEndPoints(ed, p0, p1) Then
Dim v(2) As Double
v(0) = p1(0) - p0(0)
v(1) = p1(1) - p0(1)
v(2) = p1(2) - p0(2)
ProjectVectorOntoPlane v, faceNormal, v
Dim L As Double
L = VecLength(v)
If L > EPS Then
NormalizeVec v
StabilizeVectorSign v
Dim trueLen As Double
trueLen = Distance3(p0, p1)
If (trueLen > bestLen + EPS) Or _
(Abs(trueLen - bestLen) <= EPS And CompareVectorLex(v, bestVec) > 0) Then
bestLen = trueLen
bestVec(0) = v(0)
bestVec(1) = v(1)
bestVec(2) = v(2)
foundLine = True
End If
End If
End If
End If
End If
Next i
End If
End If
If foundLine Then
xDir(0) = bestVec(0)
xDir(1) = bestVec(1)
xDir(2) = bestVec(2)
NormalizeVec xDir
LogEvent " | INFO | Longest edge dir fallback = (" & Dbl3ToStr(xDir) & "), length = " & FormatNumber(bestLen, 8)
FindHorizontalDirectionFromFace = True
Exit Function
End If
LogEvent " | WARN | No valid linear edge found on face; using fallback orientation axis"
ChooseFallbackXAxis faceNormal, xDir
usedFallback = True
FindHorizontalDirectionFromFace = True
Exit Function
EH:
LogEvent " | ERROR | FindHorizontalDirectionFromFace: " & Err.Number & " - " & Err.Description
End Function
Private Function EdgeIsLinear(ByVal ed As SldWorks.Edge) As Boolean
On Error GoTo EH
EdgeIsLinear = False
Dim crv As SldWorks.Curve
Set crv = ed.GetCurve
If crv Is Nothing Then Exit Function
EdgeIsLinear = crv.IsLine
Exit Function
EH:
LogEvent " | ERROR | EdgeIsLinear: " & Err.Number & " - " & Err.Description
End Function
Private Function GetEdgeEndPoints(ByVal ed As SldWorks.Edge, ByRef p0() As Double, ByRef p1() As Double) As Boolean
On Error GoTo EH
GetEdgeEndPoints = False
Dim vStart As SldWorks.Vertex
Dim vEnd As SldWorks.Vertex
Set vStart = ed.GetStartVertex
Set vEnd = ed.GetEndVertex
If vStart Is Nothing Or vEnd Is Nothing Then Exit Function
Dim a As Variant, b As Variant
a = vStart.GetPoint
b = vEnd.GetPoint
If IsEmpty(a) Or IsEmpty(b) Then Exit Function
p0(0) = CDbl(a(0)): p0(1) = CDbl(a(1)): p0(2) = CDbl(a(2))
p1(0) = CDbl(b(0)): p1(1) = CDbl(b(1)): p1(2) = CDbl(b(2))
GetEdgeEndPoints = True
Exit Function
EH:
LogEvent " | ERROR | GetEdgeEndPoints: " & Err.Number & " - " & Err.Description
End Function
Private Function TryGetBottomLeftCornerOrientation(ByVal face As SldWorks.Face2, _
ByRef faceNormal() As Double, _
ByRef xDir() As Double) As Boolean
On Error GoTo EH
Dim bestPrimaryLen As Double
Dim bestSecondaryLen As Double
Dim bestX(2) As Double
Dim bestY(2) As Double
Dim bestCorner(2) As Double
TryGetBottomLeftCornerOrientation = False
If GetBestSharedCornerOrientationCandidate(face, faceNormal, bestPrimaryLen, bestSecondaryLen, bestX, bestY, bestCorner) Then
TryGetBottomLeftCornerOrientation = ApplyBottomLeftOrientationCandidate(faceNormal, xDir, bestX, bestY, bestCorner, bestPrimaryLen, bestSecondaryLen, "Corner orientation", "Shared corner")
Else
LogEvent " | INFO | Corner orientation scan: no perpendicular shared-corner pair satisfied tolerance"
End If
Exit Function
EH:
LogEvent " | ERROR | TryGetBottomLeftCornerOrientation: " & Err.Number & " - " & Err.Description
End Function
Private Function GetBestSharedCornerOrientationCandidate(ByVal face As SldWorks.Face2, _
ByRef faceNormal() As Double, _
ByRef bestPrimaryLen As Double, _
ByRef bestSecondaryLen As Double, _
ByRef bestX() As Double, _
ByRef bestY() As Double, _
ByRef bestCorner() As Double) As Boolean
On Error GoTo EH
GetBestSharedCornerOrientationCandidate = False
If face Is Nothing Then Exit Function
Dim vEdges As Variant
vEdges = face.GetEdges
If IsEmpty(vEdges) Then
LogEvent " | INFO | Corner orientation scan: face has no edges"
Exit Function
End If
If Not IsArray(vEdges) Then
LogEvent " | INFO | Corner orientation scan: face edges are not an array"
Exit Function
End If
Dim foundPair As Boolean
foundPair = False
bestPrimaryLen = -1#
bestSecondaryLen = -1#
Dim i As Long
Dim j As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim ed1 As SldWorks.Edge
Set ed1 = vEdges(i)
If Not ed1 Is Nothing Then
If EdgeIsLinear(ed1) Then
Dim e1p0(2) As Double, e1p1(2) As Double
If GetEdgeEndPoints(ed1, e1p0, e1p1) Then
For j = i + 1 To UBound(vEdges)
Dim ed2 As SldWorks.Edge
Set ed2 = vEdges(j)
If Not ed2 Is Nothing Then
If EdgeIsLinear(ed2) Then
Dim e2p0(2) As Double, e2p1(2) As Double
If GetEdgeEndPoints(ed2, e2p0, e2p1) Then
Dim corner(2) As Double
Dim e1Far(2) As Double
Dim e2Far(2) As Double
If TryGetSharedCornerFromEdgeEndpoints(e1p0, e1p1, e2p0, e2p1, corner, e1Far, e2Far) Then
Dim dir1(2) As Double, dir2(2) As Double
dir1(0) = e1Far(0) - corner(0)
dir1(1) = e1Far(1) - corner(1)
dir1(2) = e1Far(2) - corner(2)
dir2(0) = e2Far(0) - corner(0)
dir2(1) = e2Far(1) - corner(1)
dir2(2) = e2Far(2) - corner(2)
ProjectVectorOntoPlane dir1, faceNormal, dir1
ProjectVectorOntoPlane dir2, faceNormal, dir2
Dim len1 As Double, len2 As Double
len1 = VecLength(dir1)
len2 = VecLength(dir2)
If len1 > EPS And len2 > EPS Then
NormalizeVec dir1
NormalizeVec dir2
Dim perpDot As Double
perpDot = Abs(DotProduct(dir1, dir2))
LogEvent " | INFO | Corner pair candidate | EdgeIdx=" & i & "/" & j & _
" | corner=(" & Dbl3ToStr(corner) & ")" & _
" | len1=" & FormatNumber(len1, 8) & _
" | len2=" & FormatNumber(len2, 8) & _
" | |dot|=" & FormatNumber(perpDot, 8)
If perpDot <= PERP_DOT_TOL Then
Dim primaryLen As Double
Dim secondaryLen As Double
Dim candX(2) As Double
Dim candY(2) As Double
If (len1 > len2 + EPS) Or _
(Abs(len1 - len2) <= EPS And CompareVectorLex(dir1, dir2) >= 0) Then
primaryLen = len1
secondaryLen = len2
candX(0) = dir1(0): candX(1) = dir1(1): candX(2) = dir1(2)
candY(0) = dir2(0): candY(1) = dir2(1): candY(2) = dir2(2)
Else
primaryLen = len2
secondaryLen = len1
candX(0) = dir2(0): candX(1) = dir2(1): candX(2) = dir2(2)
candY(0) = dir1(0): candY(1) = dir1(1): candY(2) = dir1(2)
End If
If (primaryLen > bestPrimaryLen + EPS) Or _
(Abs(primaryLen - bestPrimaryLen) <= EPS And secondaryLen > bestSecondaryLen + EPS) Or _
(Abs(primaryLen - bestPrimaryLen) <= EPS And Abs(secondaryLen - bestSecondaryLen) <= EPS And CompareVectorLex(candX, bestX) > 0) Then
bestPrimaryLen = primaryLen
bestSecondaryLen = secondaryLen
bestX(0) = candX(0): bestX(1) = candX(1): bestX(2) = candX(2)
bestY(0) = candY(0): bestY(1) = candY(1): bestY(2) = candY(2)
bestCorner(0) = corner(0)
bestCorner(1) = corner(1)
bestCorner(2) = corner(2)
foundPair = True
End If
End If
End If
End If
End If
End If
End If
Next j
End If
End If
End If
Next i
GetBestSharedCornerOrientationCandidate = foundPair
Exit Function
EH:
LogEvent " | ERROR | GetBestSharedCornerOrientationCandidate: " & Err.Number & " - " & Err.Description
End Function
Private Function TryGetBottomLeftVirtualCornerOrientation(ByVal face As SldWorks.Face2, _
ByRef faceNormal() As Double, _
ByRef xDir() As Double) As Boolean
On Error GoTo EH
Dim bestPrimaryLen As Double
Dim bestSecondaryLen As Double
Dim bestX(2) As Double
Dim bestY(2) As Double
Dim bestCorner(2) As Double
TryGetBottomLeftVirtualCornerOrientation = False
If GetBestVirtualCornerOrientationCandidate(face, faceNormal, bestPrimaryLen, bestSecondaryLen, bestX, bestY, bestCorner) Then
TryGetBottomLeftVirtualCornerOrientation = ApplyBottomLeftOrientationCandidate(faceNormal, xDir, bestX, bestY, bestCorner, bestPrimaryLen, bestSecondaryLen, "Virtual corner orientation", "Virtual corner")
Else
LogEvent " | INFO | Virtual corner orientation scan: no non-intersecting perpendicular pair satisfied tolerance"
End If
Exit Function
EH:
LogEvent " | ERROR | TryGetBottomLeftVirtualCornerOrientation: " & Err.Number & " - " & Err.Description
End Function
Private Function GetBestVirtualCornerOrientationCandidate(ByVal face As SldWorks.Face2, _
ByRef faceNormal() As Double, _
ByRef bestPrimaryLen As Double, _
ByRef bestSecondaryLen As Double, _
ByRef bestX() As Double, _
ByRef bestY() As Double, _
ByRef bestCorner() As Double) As Boolean
On Error GoTo EH
GetBestVirtualCornerOrientationCandidate = False
If face Is Nothing Then Exit Function
Dim vEdges As Variant
vEdges = face.GetEdges
If IsEmpty(vEdges) Then
LogEvent " | INFO | Virtual corner orientation scan: face has no edges"
Exit Function
End If
If Not IsArray(vEdges) Then
LogEvent " | INFO | Virtual corner orientation scan: face edges are not an array"
Exit Function
End If
Dim foundPair As Boolean
foundPair = False
bestPrimaryLen = -1#
bestSecondaryLen = -1#
Dim i As Long
Dim j As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim ed1 As SldWorks.Edge
Set ed1 = vEdges(i)
If Not ed1 Is Nothing Then
If EdgeIsLinear(ed1) Then
Dim e1p0(2) As Double, e1p1(2) As Double
If GetEdgeEndPoints(ed1, e1p0, e1p1) Then
For j = i + 1 To UBound(vEdges)
Dim ed2 As SldWorks.Edge
Set ed2 = vEdges(j)
If Not ed2 Is Nothing Then
If EdgeIsLinear(ed2) Then
Dim e2p0(2) As Double, e2p1(2) As Double
If GetEdgeEndPoints(ed2, e2p0, e2p1) Then
Dim sharedCorner(2) As Double
Dim sharedFar1(2) As Double
Dim sharedFar2(2) As Double
If Not TryGetSharedCornerFromEdgeEndpoints(e1p0, e1p1, e2p0, e2p1, sharedCorner, sharedFar1, sharedFar2) Then
Dim dir1Raw(2) As Double
Dim dir2Raw(2) As Double
Dim trueLen1 As Double
Dim trueLen2 As Double
dir1Raw(0) = e1p1(0) - e1p0(0)
dir1Raw(1) = e1p1(1) - e1p0(1)
dir1Raw(2) = e1p1(2) - e1p0(2)
dir2Raw(0) = e2p1(0) - e2p0(0)
dir2Raw(1) = e2p1(1) - e2p0(1)
dir2Raw(2) = e2p1(2) - e2p0(2)
ProjectVectorOntoPlane dir1Raw, faceNormal, dir1Raw
ProjectVectorOntoPlane dir2Raw, faceNormal, dir2Raw
trueLen1 = Distance3(e1p0, e1p1)
trueLen2 = Distance3(e2p0, e2p1)
If VecLength(dir1Raw) > EPS And VecLength(dir2Raw) > EPS Then
NormalizeVec dir1Raw
NormalizeVec dir2Raw
Dim perpDot As Double
perpDot = Abs(DotProduct(dir1Raw, dir2Raw))
LogEvent " | INFO | Virtual corner pair candidate | EdgeIdx=" & i & "/" & j & _
" | len1=" & FormatNumber(trueLen1, 8) & _
" | len2=" & FormatNumber(trueLen2, 8) & _
" | |dot|=" & FormatNumber(perpDot, 8)
If perpDot <= PERP_DOT_TOL Then
Dim virtualCorner(2) As Double
If TryGetProjectedLineIntersection(e1p0, dir1Raw, e2p0, dir2Raw, faceNormal, virtualCorner) Then
Dim dir1(2) As Double
Dim dir2(2) As Double
If GetEdgeDirectionAwayFromReference(e1p0, e1p1, virtualCorner, dir1) Then
If GetEdgeDirectionAwayFromReference(e2p0, e2p1, virtualCorner, dir2) Then
Dim primaryLen As Double
Dim secondaryLen As Double
Dim candX(2) As Double
Dim candY(2) As Double
If (trueLen1 > trueLen2 + EPS) Or _
(Abs(trueLen1 - trueLen2) <= EPS And CompareVectorLex(dir1, dir2) >= 0) Then
primaryLen = trueLen1
secondaryLen = trueLen2
candX(0) = dir1(0): candX(1) = dir1(1): candX(2) = dir1(2)
candY(0) = dir2(0): candY(1) = dir2(1): candY(2) = dir2(2)
Else
primaryLen = trueLen2
secondaryLen = trueLen1
candX(0) = dir2(0): candX(1) = dir2(1): candX(2) = dir2(2)
candY(0) = dir1(0): candY(1) = dir1(1): candY(2) = dir1(2)
End If
If (primaryLen > bestPrimaryLen + EPS) Or _
(Abs(primaryLen - bestPrimaryLen) <= EPS And secondaryLen > bestSecondaryLen + EPS) Or _
(Abs(primaryLen - bestPrimaryLen) <= EPS And Abs(secondaryLen - bestSecondaryLen) <= EPS And CompareVectorLex(candX, bestX) > 0) Then
bestPrimaryLen = primaryLen
bestSecondaryLen = secondaryLen
bestX(0) = candX(0): bestX(1) = candX(1): bestX(2) = candX(2)
bestY(0) = candY(0): bestY(1) = candY(1): bestY(2) = candY(2)
bestCorner(0) = virtualCorner(0)
bestCorner(1) = virtualCorner(1)
bestCorner(2) = virtualCorner(2)
foundPair = True
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next j
End If
End If
End If
Next i
GetBestVirtualCornerOrientationCandidate = foundPair
Exit Function
EH:
LogEvent " | ERROR | GetBestVirtualCornerOrientationCandidate: " & Err.Number & " - " & Err.Description
End Function
Private Function IsPairLengthBetter(ByVal candidatePrimaryLen As Double, _
ByVal candidateSecondaryLen As Double, _
ByVal referencePrimaryLen As Double, _
ByVal referenceSecondaryLen As Double) As Boolean
IsPairLengthBetter = False
If candidatePrimaryLen > referencePrimaryLen + EPS Then
IsPairLengthBetter = True
Exit Function
End If
If Abs(candidatePrimaryLen - referencePrimaryLen) <= EPS Then
If candidateSecondaryLen > referenceSecondaryLen + EPS Then
IsPairLengthBetter = True
Exit Function
End If
End If
End Function
Private Function ApplyBottomLeftOrientationCandidate(ByRef faceNormal() As Double, _
ByRef xDir() As Double, _
ByRef bestX() As Double, _
ByRef bestY() As Double, _
ByRef bestCorner() As Double, _
ByVal bestPrimaryLen As Double, _
ByVal bestSecondaryLen As Double, _
ByVal selectionLabel As String, _
ByVal cornerLabel As String) As Boolean
On Error GoTo EH
ApplyBottomLeftOrientationCandidate = False
xDir(0) = bestX(0)
xDir(1) = bestX(1)
xDir(2) = bestX(2)
NormalizeVec xDir
Dim currentY(2) As Double
CrossProduct faceNormal, xDir, currentY
NormalizeVec currentY
Dim flippedNormal As Boolean
flippedNormal = False
If DotProduct(currentY, bestY) < 0# Then
FlipVec faceNormal
flippedNormal = True
CrossProduct faceNormal, xDir, currentY
NormalizeVec currentY
End If
LogEvent " | INFO | " & selectionLabel & " selected"
LogEvent " | INFO | " & cornerLabel & " = (" & Dbl3ToStr(bestCorner) & ")"
LogEvent " | INFO | Bottom edge X = (" & Dbl3ToStr(xDir) & ") | len = " & FormatNumber(bestPrimaryLen, 8)
LogEvent " | INFO | Left edge Y = (" & Dbl3ToStr(bestY) & ") | len = " & FormatNumber(bestSecondaryLen, 8)
LogEvent " | INFO | Face normal = (" & Dbl3ToStr(faceNormal) & ") | flipped=" & CStr(flippedNormal)
ApplyBottomLeftOrientationCandidate = True
Exit Function
EH:
LogEvent " | ERROR | ApplyBottomLeftOrientationCandidate: " & Err.Number & " - " & Err.Description
End Function
Private Function TryGetProjectedLineIntersection(ByRef line1Point() As Double, _
ByRef line1DirUnit() As Double, _
ByRef line2Point() As Double, _
ByRef line2DirUnit() As Double, _
ByRef faceNormal() As Double, _
ByRef intersection() As Double) As Boolean
On Error GoTo EH
TryGetProjectedLineIntersection = False
Dim uv As Double
uv = DotProduct(line1DirUnit, line2DirUnit)
Dim denom As Double
denom = 1# - (uv * uv)
If denom <= EPS Then Exit Function
Dim delta(2) As Double
delta(0) = line2Point(0) - line1Point(0)
delta(1) = line2Point(1) - line1Point(1)
delta(2) = line2Point(2) - line1Point(2)
ProjectVectorOntoPlane delta, faceNormal, delta
Dim du As Double
Dim dv As Double
du = DotProduct(delta, line1DirUnit)
dv = DotProduct(delta, line2DirUnit)
Dim t As Double
t = (du - (uv * dv)) / denom
intersection(0) = line1Point(0) + (line1DirUnit(0) * t)
intersection(1) = line1Point(1) + (line1DirUnit(1) * t)
intersection(2) = line1Point(2) + (line1DirUnit(2) * t)
TryGetProjectedLineIntersection = True
Exit Function
EH:
LogEvent " | ERROR | TryGetProjectedLineIntersection: " & Err.Number & " - " & Err.Description
End Function
Private Function GetEdgeDirectionAwayFromReference(ByRef p0() As Double, _
ByRef p1() As Double, _
ByRef refPoint() As Double, _
ByRef dirOut() As Double) As Boolean
On Error GoTo EH
GetEdgeDirectionAwayFromReference = False
Dim d0 As Double
Dim d1 As Double
d0 = Distance3(p0, refPoint)
d1 = Distance3(p1, refPoint)
If (d0 <= PT_TOL) And (d1 <= PT_TOL) Then Exit Function
If d0 < d1 - PT_TOL Then
dirOut(0) = p1(0) - p0(0)
dirOut(1) = p1(1) - p0(1)
dirOut(2) = p1(2) - p0(2)
ElseIf d1 < d0 - PT_TOL Then
dirOut(0) = p0(0) - p1(0)
dirOut(1) = p0(1) - p1(1)
dirOut(2) = p0(2) - p1(2)
Else
dirOut(0) = p1(0) - p0(0)
dirOut(1) = p1(1) - p0(1)
dirOut(2) = p1(2) - p0(2)
StabilizeVectorSign dirOut
End If
If VecLength(dirOut) <= EPS Then Exit Function
NormalizeVec dirOut
GetEdgeDirectionAwayFromReference = True
Exit Function
EH:
LogEvent " | ERROR | GetEdgeDirectionAwayFromReference: " & Err.Number & " - " & Err.Description
End Function
Private Function TryGetSharedCornerFromEdgeEndpoints(ByRef a0() As Double, _
ByRef a1() As Double, _
ByRef b0() As Double, _
ByRef b1() As Double, _
ByRef corner() As Double, _
ByRef aFar() As Double, _
ByRef bFar() As Double) As Boolean
TryGetSharedCornerFromEdgeEndpoints = False
If PointsCoincident3(a0, b0) Then
CopyPoint3 a0, corner
CopyPoint3 a1, aFar
CopyPoint3 b1, bFar
TryGetSharedCornerFromEdgeEndpoints = True
Exit Function
End If
If PointsCoincident3(a0, b1) Then
CopyPoint3 a0, corner
CopyPoint3 a1, aFar
CopyPoint3 b0, bFar
TryGetSharedCornerFromEdgeEndpoints = True
Exit Function
End If
If PointsCoincident3(a1, b0) Then
CopyPoint3 a1, corner
CopyPoint3 a0, aFar
CopyPoint3 b1, bFar
TryGetSharedCornerFromEdgeEndpoints = True
Exit Function
End If
If PointsCoincident3(a1, b1) Then
CopyPoint3 a1, corner
CopyPoint3 a0, aFar
CopyPoint3 b0, bFar
TryGetSharedCornerFromEdgeEndpoints = True
Exit Function
End If
End Function
Private Function PointsCoincident3(ByRef p1() As Double, ByRef p2() As Double) As Boolean
PointsCoincident3 = (Distance3(p1, p2) <= PT_TOL)
End Function
Private Sub CopyPoint3(ByRef src() As Double, ByRef dst() As Double)
dst(0) = src(0)
dst(1) = src(1)
dst(2) = src(2)
End Sub
Private Sub ChooseFallbackXAxis(ByRef n() As Double, ByRef x() As Double)
Dim ref(2) As Double
If Abs(n(2)) < 0.9 Then
ref(0) = 0#: ref(1) = 0#: ref(2) = 1#
Else
ref(0) = 0#: ref(1) = 1#: ref(2) = 0#
End If
CrossProduct ref, n, x
NormalizeVec x
StabilizeVectorSign x
End Sub
Private Function BuildViewOrientationTransform(ByRef xAxis() As Double, _
ByRef zAxis() As Double) As SldWorks.MathTransform
On Error GoTo EH
Dim x(2) As Double, y(2) As Double, z(2) As Double
x(0) = xAxis(0): x(1) = xAxis(1): x(2) = xAxis(2)
z(0) = zAxis(0): z(1) = zAxis(1): z(2) = zAxis(2)
NormalizeVec x
NormalizeVec z
ProjectVectorOntoPlane x, z, x
NormalizeVec x
CrossProduct z, x, y
NormalizeVec y
CrossProduct y, z, x
NormalizeVec x
Dim data(15) As Double
Dim i As Long
For i = 0 To 15
data(i) = 0#
Next i
' Basis vectors as COLUMNS
data(0) = x(0): data(1) = y(0): data(2) = z(0)
data(3) = x(1): data(4) = y(1): data(5) = z(1)
data(6) = x(2): data(7) = y(2): data(8) = z(2)
data(9) = 0#
data(10) = 0#
data(11) = 0#
data(12) = 1#
data(13) = 0#
data(14) = 0#
data(15) = 0#
LogEvent " | INFO | BuildViewOrientationTransform axes:"
LogEvent " | INFO | X = (" & Dbl3ToStr(x) & ")"
LogEvent " | INFO | Y = (" & Dbl3ToStr(y) & ")"
LogEvent " | INFO | Z = (" & Dbl3ToStr(z) & ")"
Set BuildViewOrientationTransform = swMathUtil.CreateTransform(data)
Exit Function
EH:
LogEvent " | ERROR | BuildViewOrientationTransform: " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' EXPORT
'=========================================================================================
Private Function ExportSingleBodyPartAsOrientedDxfFromSource(ByVal srcDoc As SldWorks.ModelDoc2, _
ByRef faceNormal() As Double, _
ByRef xDir() As Double, _
ByVal finalDxfPath As String, _
ByVal contextLabel As String, _
ByVal preserveCornerOrientation As Boolean) As Boolean
On Error GoTo EH
ExportSingleBodyPartAsOrientedDxfFromSource = False
If srcDoc Is Nothing Then
LogEvent " | FAIL | Direct single-body source export: srcDoc is Nothing"
Exit Function
End If
If srcDoc.GetType <> swDocPART Then
LogEvent " | FAIL | Direct single-body source export requires PART doc, got " & DocTypeName(srcDoc.GetType)
Exit Function
End If
If Len(Trim$(srcDoc.GetPathName)) = 0 Then
LogEvent " | FAIL | Direct single-body source export requires saved part path"
Exit Function
End If
If Not ShouldAttemptFastDirectDxfExport(preserveCornerOrientation) Then
LogEvent " | FAIL | Direct single-body source export is disabled by current toggle settings"
Exit Function
End If
Dim originalUnits As Long
Dim restoreUnits As Boolean
Dim originalViewXf As Object
Dim alignmentData(0 To 11) As Double
Dim varAlignment As Variant
Dim swSrcPart As SldWorks.PartDoc
Set swSrcPart = srcDoc
BuildIdentityDwgAlignment alignmentData
varAlignment = alignmentData
LogEvent " | INFO | Direct single-body source export start"
LogEvent " | INFO | contextLabel = " & contextLabel
LogEvent " | INFO | sourcePath = " & srcDoc.GetPathName
LogEvent " | INFO | finalDxfPath = " & finalDxfPath
LogEvent " | INFO | mode = *Current view on source part"
LogEvent " | INFO | preserveCornerOrientation = " & CStr(preserveCornerOrientation)
If Not ActivateDocumentByTitle(srcDoc.GetTitle) Then
LogEvent " | WARN | Could not explicitly activate source part before direct export"
End If
Set originalViewXf = GetCurrentModelViewTransform(srcDoc)
If originalViewXf Is Nothing Then
LogEvent " | WARN | Could not capture original source-part view transform"
Else
LogEvent " | INFO | Captured original source-part view transform"
End If
originalUnits = GetModelLinearUnitsSafe(srcDoc)
restoreUnits = (originalUnits <> -1)
If Not OrientModelCurrentView(srcDoc, xDir, faceNormal) Then
LogEvent " | FAIL | Could not orient source part current view for direct export"
GoTo CleanupAndExit
End If
If Not HideAllSketchesInModel(srcDoc) Then
LogEvent " | WARN | HideAllSketchesInModel returned False on source part before direct export"
End If
If DIRECT_TEMP_PART_FORCE_INCH_UNITS Then
If ForceModelLinearUnitsToInches(srcDoc) Then
LogEvent " | INFO | Source part linear units forced to inches for direct export"
Else
LogEvent " | WARN | Source part units could not be forced to inches before direct export"
End If
End If
srcDoc.ForceRebuild3 True
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then srcDoc.GraphicsRedraw2
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
srcDoc.ViewZoomtofit2
Else
LogEvent " | INFO | Source ViewZoomtofit2 skipped before direct export for batch stability"
End If
If TryDirectExportToDxfByViewName(swSrcPart, srcDoc.GetPathName, finalDxfPath, "*Current", varAlignment) Then
ExportSingleBodyPartAsOrientedDxfFromSource = True
Else
LogEvent " | FAIL | Direct single-body source export failed using *Current view"
End If
CleanupAndExit:
If restoreUnits Then
If RestoreModelLinearUnits(srcDoc, originalUnits) Then
LogEvent " | INFO | Restored source part linear units after direct export"
Else
LogEvent " | WARN | Could not restore source part linear units after direct export"
End If
End If
If Not originalViewXf Is Nothing Then
If RestoreCurrentModelViewTransform(srcDoc, originalViewXf) Then
LogEvent " | INFO | Restored source part original view transform after direct export"
Else
LogEvent " | WARN | Could not restore source part original view transform"
End If
End If
Exit Function
EH:
LogEvent " | ERROR | ExportSingleBodyPartAsOrientedDxfFromSource(" & contextLabel & "): " & Err.Number & " - " & Err.Description
End Function
Private Function OrientModelCurrentView(ByVal mdl As SldWorks.ModelDoc2, _
ByRef xDir() As Double, _
ByRef faceNormal() As Double) As Boolean
On Error GoTo EH
OrientModelCurrentView = False
If mdl Is Nothing Then Exit Function
Dim viewXf As SldWorks.MathTransform
Set viewXf = BuildViewOrientationTransform(xDir, faceNormal)
If viewXf Is Nothing Then
LogEvent " | FAIL | BuildViewOrientationTransform returned Nothing"
Exit Function
End If
Dim mvObj As Object
Set mvObj = mdl.ActiveView
If mvObj Is Nothing Then
LogEvent " | FAIL | mdl.ActiveView returned Nothing"
Exit Function
End If
LogEvent " | INFO | Setting current model view orientation without temp-part save/reopen"
On Error Resume Next
CallByName mvObj, "Orientation3", VbSet, viewXf
If Err.Number <> 0 Then
LogEvent " | FAIL | Setting current view Orientation3 failed: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then
mdl.GraphicsRedraw2
End If
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
mdl.ViewZoomtofit2
Else
LogEvent " | INFO | ViewZoomtofit2 skipped for batch stability"
End If
OrientModelCurrentView = True
Exit Function
EH:
LogEvent " | ERROR | OrientModelCurrentView: " & Err.Number & " - " & Err.Description
End Function
Private Function GetCurrentModelViewTransform(ByVal mdl As SldWorks.ModelDoc2) As Object
On Error GoTo EH
Set GetCurrentModelViewTransform = Nothing
If mdl Is Nothing Then Exit Function
Dim mvObj As Object
Dim xfObj As Object
Set mvObj = mdl.ActiveView
If mvObj Is Nothing Then
LogEvent " | WARN | GetCurrentModelViewTransform: ActiveView is Nothing"
Exit Function
End If
On Error Resume Next
Set xfObj = CallByName(mvObj, "Orientation3", VbGet)
If Err.Number <> 0 Then
LogEvent " | WARN | GetCurrentModelViewTransform failed: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
Set GetCurrentModelViewTransform = xfObj
Exit Function
EH:
LogEvent " | ERROR | GetCurrentModelViewTransform: " & Err.Number & " - " & Err.Description
End Function
Private Function RestoreCurrentModelViewTransform(ByVal mdl As SldWorks.ModelDoc2, ByVal xfObj As Object) As Boolean
On Error GoTo EH
RestoreCurrentModelViewTransform = False
If mdl Is Nothing Then Exit Function
If xfObj Is Nothing Then Exit Function
Dim mvObj As Object
Set mvObj = mdl.ActiveView
If mvObj Is Nothing Then
LogEvent " | WARN | RestoreCurrentModelViewTransform: ActiveView is Nothing"
Exit Function
End If
On Error Resume Next
CallByName mvObj, "Orientation3", VbSet, xfObj
If Err.Number <> 0 Then
LogEvent " | WARN | RestoreCurrentModelViewTransform failed: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then
mdl.GraphicsRedraw2
End If
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
mdl.ViewZoomtofit2
Else
LogEvent " | INFO | ViewZoomtofit2 skipped while restoring view for batch stability"
End If
RestoreCurrentModelViewTransform = True
Exit Function
EH:
LogEvent " | ERROR | RestoreCurrentModelViewTransform: " & Err.Number & " - " & Err.Description
End Function
Private Function GetModelLinearUnitsSafe(ByVal mdl As SldWorks.ModelDoc2) As Long
On Error GoTo EH
GetModelLinearUnitsSafe = -1
If mdl Is Nothing Then Exit Function
On Error Resume Next
GetModelLinearUnitsSafe = mdl.GetUserPreferenceIntegerValue(swUnitsLinear)
If Err.Number <> 0 Then
LogEvent " | WARN | GetModelLinearUnitsSafe failed: " & Err.Number & " - " & Err.Description
Err.Clear
GetModelLinearUnitsSafe = -1
End If
On Error GoTo EH
Exit Function
EH:
LogEvent " | ERROR | GetModelLinearUnitsSafe: " & Err.Number & " - " & Err.Description
GetModelLinearUnitsSafe = -1
End Function
Private Function RestoreModelLinearUnits(ByVal mdl As SldWorks.ModelDoc2, ByVal targetUnits As Long) As Boolean
On Error GoTo EH
RestoreModelLinearUnits = False
If mdl Is Nothing Then Exit Function
If targetUnits < 0 Then Exit Function
mdl.SetUserPreferenceIntegerValue swUnitsLinear, targetUnits
RestoreModelLinearUnits = (GetModelLinearUnitsSafe(mdl) = targetUnits)
Exit Function
EH:
LogEvent " | ERROR | RestoreModelLinearUnits: " & Err.Number & " - " & Err.Description
End Function
Private Function ExportBodyAsOrientedDxf(ByVal srcBody As SldWorks.Body2, _
ByRef faceNormal() As Double, _
ByRef xDir() As Double, _
ByVal finalDxfPath As String, _
ByVal cutListName As String, _
ByVal preserveCornerOrientation As Boolean) As Boolean
On Error GoTo EH
ExportBodyAsOrientedDxf = False
Dim tempRoot As String
tempRoot = GetLocalTempRoot()
If Len(tempRoot) = 0 Then
LogEvent " | FAIL | Could not create local temp root"
Exit Function
End If
LogEvent " | INFO | Local temp workspace = " & tempRoot
LogEvent " | INFO | DXF export mode = " & GetDxfExportModeName()
LogEvent " | INFO | R7 export mode: isolated temp part + view orientation; physical body flatten = " & CStr(PHYSICALLY_FLATTEN_TEMP_BODY_FOR_DXF)
LogEvent " | INFO | Current-view export after physical flatten = " & CStr(TEMP_PART_EXPORT_USE_CURRENT_VIEW_V15_ROTATION)
Dim tempPartPath As String
Dim tempDrwPath As String
tempPartPath = CombinePathSafe(tempRoot, "body_temp.sldprt")
tempDrwPath = CombinePathSafe(tempRoot, "body_temp.slddrw")
LogEvent " | INFO | Temp part path = " & tempPartPath
LogEvent " | INFO | Temp drawing path = " & tempDrwPath
If ContainsControlCharacters(tempPartPath) Or ContainsControlCharacters(tempDrwPath) Then
LogEvent " | FAIL | Temp path contains a control character; aborting this export to prevent SolidWorks invalid-argument crash"
GoTo CleanupAndExit
End If
Dim tempPartDoc As SldWorks.ModelDoc2
Dim tempBody As SldWorks.Body2
Dim exportFaceN(2) As Double
Dim exportXDir(2) As Double
CopyVector3 faceNormal, exportFaceN
CopyVector3 xDir, exportXDir
If PHYSICALLY_FLATTEN_TEMP_BODY_FOR_DXF Then
Set tempBody = CopyAndFlattenBodyForDxf(srcBody, xDir, faceNormal, cutListName)
If tempBody Is Nothing Then
If FALL_BACK_TO_VIEW_EXPORT_IF_BODY_FLATTEN_FAILS Then
LogEvent " | WARN | Physical temp-body flatten failed; falling back to stable view-oriented isolated temp-part export"
Set tempBody = srcBody.Copy
If tempBody Is Nothing Then
LogEvent " | FAIL | Body copy returned Nothing after physical-flatten fallback"
GoTo CleanupAndExit
End If
CopyVector3 faceNormal, exportFaceN
CopyVector3 xDir, exportXDir
Else
LogEvent " | FAIL | Physical temp-body flatten failed and fallback is disabled"
GoTo CleanupAndExit
End If
Else
exportXDir(0) = 1#: exportXDir(1) = 0#: exportXDir(2) = 0#
exportFaceN(0) = 0#: exportFaceN(1) = 0#: exportFaceN(2) = 1#
LogEvent " | INFO | Temp body physically flattened. Export axes forced to X=(1,0,0), Z=(0,0,1)"
End If
Else
Set tempBody = srcBody.Copy
If tempBody Is Nothing Then
LogEvent " | FAIL | Body copy returned Nothing"
GoTo CleanupAndExit
End If
LogEvent " | INFO | Physical body flatten skipped; using stable view-oriented isolated temp-part export"
End If
Set tempPartDoc = CreateTempPartFromBody(tempBody, tempPartPath, Not (USE_FAST_MODE And FAST_MODE_SINGLE_TEMP_PART_SAVE))
If tempPartDoc Is Nothing Then
LogEvent " | FAIL | Temp part creation failed"
GoTo CleanupAndExit
End If
If TEMP_PART_EXPORT_USE_CURRENT_VIEW_V15_ROTATION Then
LogEvent " | INFO | Orienting temp part using stable current-view logic after physical flatten"
If Not OrientModelCurrentView(tempPartDoc, exportXDir, exportFaceN) Then
LogEvent " | FAIL | Could not orient temp part current view"
GoTo CleanupAndExit
End If
'Keep the named view as a diagnostic/safety artifact, but R5 does not export from it by default.
On Error Resume Next
tempPartDoc.DeleteNamedView TEMP_VIEW_NAME
Err.Clear
tempPartDoc.NameView TEMP_VIEW_NAME
Err.Clear
On Error GoTo EH
Else
If Not OrientAndNameTempPartView(tempPartDoc, exportXDir, exportFaceN, TEMP_VIEW_NAME) Then
LogEvent " | FAIL | Could not orient/name temp part view"
GoTo CleanupAndExit
End If
End If
If Not HideAllSketchesInModel(tempPartDoc) Then
LogEvent " | WARN | HideAllSketchesInModel returned False after view orientation"
End If
LogEvent " | INFO | Saving temp part after custom orientation"
If Not TrySaveModelToPath(tempPartDoc, tempPartPath) Then
LogEvent " | FAIL | Could not persist temp part file before DXF export"
GoTo CleanupAndExit
End If
If ShouldAttemptFastDirectDxfExport(preserveCornerOrientation) Then
If TEMP_PART_EXPORT_USE_CURRENT_VIEW_V15_ROTATION Then
LogEvent " | INFO | Trying direct temp-part DXF export by *Current view (V15 rotation match)"
If ExportTempPartToDxf_DirectByCurrentView(tempPartDoc, tempPartPath, finalDxfPath, exportXDir, exportFaceN, preserveCornerOrientation) Then
Call FinalizeWaterjetDxfAfterExport(finalDxfPath, cutListName, preserveCornerOrientation)
ExportBodyAsOrientedDxf = True
GoTo CleanupAndExit
End If
If TEMP_PART_NAMED_VIEW_EXPORT_FALLBACK Then
LogEvent " | WARN | *Current view export failed; named-view fallback enabled"
If ExportTempPartToDxf_DirectByAnnotationView(tempPartDoc, tempPartPath, finalDxfPath, TEMP_VIEW_NAME, preserveCornerOrientation) Then
Call FinalizeWaterjetDxfAfterExport(finalDxfPath, cutListName, preserveCornerOrientation)
ExportBodyAsOrientedDxf = True
GoTo CleanupAndExit
End If
Else
LogEvent " | FAIL | *Current view export failed; named-view fallback is disabled to prevent wrong in-plane rotation"
End If
Else
Set tempPartDoc = ReopenTempPartForDirectExport(tempPartDoc, tempPartPath)
If tempPartDoc Is Nothing Then
LogEvent " | WARN | Could not reopen temp part for direct export; drawing fallback may still be attempted"
Else
If Not HideAllSketchesInModel(tempPartDoc) Then
LogEvent " | WARN | HideAllSketchesInModel returned False after temp-part reopen"
End If
LogEvent " | INFO | Trying direct part DXF export by named annotation view"
If ExportTempPartToDxf_DirectByAnnotationView(tempPartDoc, tempPartPath, finalDxfPath, TEMP_VIEW_NAME, preserveCornerOrientation) Then
Call FinalizeWaterjetDxfAfterExport(finalDxfPath, cutListName, preserveCornerOrientation)
ExportBodyAsOrientedDxf = True
GoTo CleanupAndExit
End If
End If
End If
Else
LogEvent " | WARN | Direct part DXF export disabled by current toggles; checking drawing fallback"
End If
If EXPERIMENTAL_DIRECT_FALLBACK_TO_DRAWING Then
LogEvent " | WARN | Direct part DXF export failed or was skipped; attempting named-view drawing fallback"
If tempPartDoc Is Nothing Then
Dim reopenErrs As Long
Dim reopenWarns As Long
reopenErrs = 0
reopenWarns = 0
LogEvent " | INFO | Reopening temp part for drawing fallback: " & tempPartPath
Set tempPartDoc = swApp.OpenDoc6(tempPartPath, swDocPART, swOpenDocOptions_Silent Or swOpenDocOptions_ReadOnly, "", reopenErrs, reopenWarns)
LogEvent " | INFO | Drawing fallback temp reopen errs=" & CStr(reopenErrs) & " warns=" & CStr(reopenWarns)
End If
DeleteFileIfExists finalDxfPath
If ExportTempPartToDxf_ByNamedViewDrawing(tempPartDoc, tempPartPath, tempDrwPath, finalDxfPath, TEMP_VIEW_NAME, exportXDir, exportFaceN, preserveCornerOrientation) Then
Call FinalizeWaterjetDxfAfterExport(finalDxfPath, cutListName, preserveCornerOrientation)
ExportBodyAsOrientedDxf = True
LogEvent " | OK | Drawing fallback DXF export succeeded => " & finalDxfPath
GoTo CleanupAndExit
Else
LogEvent " | FAIL | Drawing fallback DXF export failed => " & finalDxfPath
End If
Else
LogEvent " | FAIL | Direct part DXF export failed and drawing fallback is disabled"
End If
CleanupAndExit:
CloseModelDocSafe tempPartDoc
DeleteFileIfExists tempPartPath
DeleteFileIfExists tempDrwPath
DeleteFolderIfEmpty tempRoot
Exit Function
EH:
LogEvent " | ERROR | ExportBodyAsOrientedDxf(" & cutListName & "): " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' R9 DXF POST-EXPORT ORIENTATION NORMALIZATION
'=========================================================================================
' SolidWorks current-view DXF export has proven stable on isolated temp parts, but field
' output showed that it can still ignore / distort arbitrary in-plane roll. This section
' makes the final DXF deterministic for nesting by correcting the actual exported 2D
' coordinates after SolidWorks writes the file.
'
' The macro does NOT touch the source model and does NOT re-enable Body.ApplyTransform.
' It only edits the generated DXF text file.
'=========================================================================================
Private Sub FinalizeWaterjetDxfAfterExport(ByVal dxfPath As String, _
ByVal contextLabel As String, _
ByVal preserveCornerOrientation As Boolean)
On Error GoTo EH
If Not POSTPROCESS_DXF_ORIENTATION_TO_HORIZONTAL Then
LogEvent " | INFO | DXF post-process orientation normalization disabled"
Exit Sub
End If
If Len(Trim$(dxfPath)) = 0 Then
LogEvent " | WARN | DXF post-process skipped: output path is blank"
Exit Sub
End If
If Not FileExists(dxfPath) Then
LogEvent " | WARN | DXF post-process skipped: file does not exist => " & dxfPath
Exit Sub
End If
LogEvent " | CHECK | R10 DXF post-process orientation start | context=" & contextLabel & _
" | preserveCornerOrientation=" & CStr(preserveCornerOrientation)
If NormalizeDxfForHorizontalNesting(dxfPath, contextLabel) Then
LogEvent " | OK | R10 DXF post-process orientation completed => " & dxfPath
Else
LogEvent " | WARN | R10 DXF post-process orientation could not normalize this file. Keeping SolidWorks DXF as exported => " & dxfPath
End If
Exit Sub
EH:
LogEvent " | WARN | FinalizeWaterjetDxfAfterExport(" & contextLabel & "): " & Err.Number & " - " & Err.Description
End Sub
Private Function NormalizeDxfForHorizontalNesting(ByVal dxfPath As String, _
ByVal contextLabel As String) As Boolean
On Error GoTo EH
NormalizeDxfForHorizontalNesting = False
Dim lines() As String
Dim lineCount As Long
If Not ReadTextFileLinesANSI(dxfPath, lines, lineCount) Then
LogEvent " | WARN | DXF normalize: could not read file => " & dxfPath
Exit Function
End If
If lineCount < 4 Then
LogEvent " | WARN | DXF normalize: file has too few lines => " & dxfPath
Exit Function
End If
Dim entStartIndex As Long
Dim entEndIndex As Long
If Not FindDxfEntitiesRange(lines, lineCount, entStartIndex, entEndIndex) Then
LogEvent " | WARN | DXF normalize: ENTITIES section not found. File left unchanged | context=" & contextLabel
Exit Function
End If
LogEvent " | INFO | DXF normalize ENTITIES range | startLineIndex=" & CStr(entStartIndex) & _
" | endLineIndex=" & CStr(entEndIndex)
Dim rotationRad As Double
Dim selectedLen As Double
Dim secondaryLen As Double
Dim segmentCount As Long
Dim selectionMode As String
Dim usedRightAnglePair As Boolean
If Not FindProductionDxfNestingRotation(lines, lineCount, entStartIndex, entEndIndex, _
rotationRad, selectedLen, secondaryLen, segmentCount, _
selectionMode, usedRightAnglePair) Then
LogEvent " | WARN | DXF normalize: no usable linear segments found | context=" & contextLabel
Exit Function
End If
LogEvent " | INFO | DXF normalize selected orientation | context=" & contextLabel & _
" | mode=" & selectionMode & _
" | segments=" & CStr(segmentCount) & _
" | primaryLen=" & FormatDxfLogNumber(selectedLen) & _
" | secondaryLen=" & FormatDxfLogNumber(secondaryLen) & _
" | rotationDeg=" & FormatDxfLogNumber(RadToDeg(rotationRad)) & _
" | rightAnglePair=" & CStr(usedRightAnglePair)
Dim minX As Double, minY As Double, maxX As Double, maxY As Double
Dim pointCount As Long
If Not GetRotatedDxfPointBounds(lines, lineCount, entStartIndex, entEndIndex, rotationRad, minX, minY, maxX, maxY, pointCount) Then
LogEvent " | WARN | DXF normalize: could not calculate rotated bounds | context=" & contextLabel
Exit Function
End If
LogEvent " | INFO | DXF normalize bounds after production rotation | W=" & FormatDxfLogNumber(maxX - minX) & _
" | H=" & FormatDxfLogNumber(maxY - minY) & _
" | points=" & CStr(pointCount)
If DXF_POSTPROCESS_FORCE_WIDE_ENVELOPE Then
If (Not DXF_POSTPROCESS_FORCE_WIDE_ONLY_FOR_FALLBACK) Or (Not usedRightAnglePair) Then
If (maxY - minY) > (maxX - minX) + EPS Then
rotationRad = rotationRad + (PI_VAL / 2#)
If Not GetRotatedDxfPointBounds(lines, lineCount, entStartIndex, entEndIndex, rotationRad, minX, minY, maxX, maxY, pointCount) Then
LogEvent " | WARN | DXF normalize: could not calculate bounds after secondary 90-degree correction"
Exit Function
End If
LogEvent " | INFO | DXF normalize applied secondary +90 deg correction for fallback wide nesting envelope"
LogEvent " | INFO | DXF normalize bounds after secondary correction | W=" & FormatDxfLogNumber(maxX - minX) & _
" | H=" & FormatDxfLogNumber(maxY - minY)
End If
Else
LogEvent " | INFO | DXF normalize skipped automatic wide-envelope correction because right-angle bottom-leg orientation was selected"
End If
End If
Dim offsetX As Double
Dim offsetY As Double
offsetX = 0#
offsetY = 0#
If DXF_POSTPROCESS_TRANSLATE_TO_POSITIVE_XY Then
offsetX = -minX
offsetY = -minY
LogEvent " | INFO | DXF normalize translate to positive XY | offsetX=" & FormatDxfLogNumber(offsetX) & _
" | offsetY=" & FormatDxfLogNumber(offsetY)
End If
If DXF_POSTPROCESS_KEEP_BACKUP_FILE Then
CopyFileIfExists dxfPath, dxfPath & ".pre_R10_orientation_backup"
End If
If Not ApplyDxf2DRotationToLines(lines, lineCount, entStartIndex, entEndIndex, rotationRad, offsetX, offsetY) Then
LogEvent " | WARN | DXF normalize: coordinate rewrite failed | context=" & contextLabel
Exit Function
End If
If Not WriteTextFileLinesANSI(dxfPath, lines, lineCount) Then
LogEvent " | WARN | DXF normalize: failed to write normalized DXF => " & dxfPath
Exit Function
End If
NormalizeDxfForHorizontalNesting = True
Exit Function
EH:
LogEvent " | WARN | NormalizeDxfForHorizontalNesting(" & contextLabel & "): " & Err.Number & " - " & Err.Description
End Function
Private Function ReadTextFileLinesANSI(ByVal filePath As String, _
ByRef lines() As String, _
ByRef lineCount As Long) As Boolean
On Error GoTo EH
ReadTextFileLinesANSI = False
lineCount = 0
If Len(Trim$(filePath)) = 0 Then Exit Function
If Not FileExists(filePath) Then Exit Function
Dim ff As Integer
Dim s As String
ff = FreeFile
Open filePath For Input As #ff
Do Until EOF(ff)
Line Input #ff, s
If lineCount = 0 Then
ReDim lines(0 To 0)
Else
ReDim Preserve lines(0 To lineCount)
End If
lines(lineCount) = s
lineCount = lineCount + 1
Loop
Close #ff
ReadTextFileLinesANSI = (lineCount > 0)
Exit Function
EH:
On Error Resume Next
If ff <> 0 Then Close #ff
LogEvent " | WARN | ReadTextFileLinesANSI(" & filePath & "): " & Err.Number & " - " & Err.Description
End Function
Private Function WriteTextFileLinesANSI(ByVal filePath As String, _
ByRef lines() As String, _
ByVal lineCount As Long) As Boolean
On Error GoTo EH
WriteTextFileLinesANSI = False
If Len(Trim$(filePath)) = 0 Then Exit Function
If lineCount <= 0 Then Exit Function
Dim ff As Integer
Dim i As Long
ff = FreeFile
Open filePath For Output As #ff
For i = 0 To lineCount - 1
Print #ff, lines(i)
Next i
Close #ff
WriteTextFileLinesANSI = True
Exit Function
EH:
On Error Resume Next
If ff <> 0 Then Close #ff
LogEvent " | WARN | WriteTextFileLinesANSI(" & filePath & "): " & Err.Number & " - " & Err.Description
End Function
Private Function FindProductionDxfNestingRotation(ByRef lines() As String, _
ByVal lineCount As Long, _
ByVal entStartIndex As Long, _
ByVal entEndIndex As Long, _
ByRef rotationRad As Double, _
ByRef selectedLen As Double, _
ByRef secondaryLen As Double, _
ByRef segmentCount As Long, _
ByRef selectionMode As String, _
ByRef usedRightAnglePair As Boolean) As Boolean
On Error GoTo EH
FindProductionDxfNestingRotation = False
rotationRad = 0#
selectedLen = 0#
secondaryLen = 0#
segmentCount = 0
selectionMode = ""
usedRightAnglePair = False
Dim sx0() As Double
Dim sy0() As Double
Dim sx1() As Double
Dim sy1() As Double
Dim slen() As Double
If Not CollectDxfLinearSegments(lines, lineCount, entStartIndex, entEndIndex, sx0, sy0, sx1, sy1, slen, segmentCount) Then
LogEvent " | WARN | Production DXF rotation: no linear segments collected"
Exit Function
End If
LogEvent " | INFO | Production DXF rotation: linear segment count = " & CStr(segmentCount)
If DXF_POSTPROCESS_PREFER_RIGHT_ANGLE_LEG_PAIR Then
If SelectDxfRightAngleBottomLegRotation(sx0, sy0, sx1, sy1, slen, segmentCount, _
rotationRad, selectedLen, secondaryLen) Then
selectionMode = "RIGHT_ANGLE_LEG_PAIR_BOTTOM_EDGE"
usedRightAnglePair = True
FindProductionDxfNestingRotation = True
Exit Function
End If
LogEvent " | INFO | Production DXF rotation: no qualifying right-angle leg pair found; falling back to dominant edge"
End If
If SelectDxfDominantBottomEdgeRotation(sx0, sy0, sx1, sy1, slen, segmentCount, _
rotationRad, selectedLen, secondaryLen) Then
selectionMode = "DOMINANT_EDGE_BOTTOM_FALLBACK"
usedRightAnglePair = False
FindProductionDxfNestingRotation = True
Exit Function
End If
Exit Function
EH:
LogEvent " | WARN | FindProductionDxfNestingRotation: " & Err.Number & " - " & Err.Description
End Function
Private Function CollectDxfLinearSegments(ByRef lines() As String, _
ByVal lineCount As Long, _
ByVal entStartIndex As Long, _
ByVal entEndIndex As Long, _
ByRef sx0() As Double, _
ByRef sy0() As Double, _
ByRef sx1() As Double, _
ByRef sy1() As Double, _
ByRef slen() As Double, _
ByRef segmentCount As Long) As Boolean
On Error GoTo EH
CollectDxfLinearSegments = False
segmentCount = 0
Dim currentEntity As String
Dim inOldPolyline As Boolean
Dim oldPolylineClosed As Boolean
Dim lineHaveStart As Boolean
Dim lineHaveEnd As Boolean
Dim lineX0 As Double, lineY0 As Double
Dim lineX1 As Double, lineY1 As Double
Dim polyX() As Double
Dim polyY() As Double
Dim polyCount As Long
Dim polyClosed As Boolean
Dim oldPolyX() As Double
Dim oldPolyY() As Double
Dim oldPolyCount As Long
Dim i As Long
Dim codeNum As Long
Dim valText As String
currentEntity = ""
inOldPolyline = False
oldPolylineClosed = False
polyCount = 0
oldPolyCount = 0
For i = entStartIndex To entEndIndex Step 2
codeNum = DxfGroupCodeToLong(lines(i))
valText = Trim$(lines(i + 1))
If codeNum = 0 Then
AddPendingDxfEntitySegments currentEntity, _
lineHaveStart, lineHaveEnd, lineX0, lineY0, lineX1, lineY1, _
polyX, polyY, polyCount, polyClosed, _
sx0, sy0, sx1, sy1, slen, segmentCount
currentEntity = UCase$(valText)
lineHaveStart = False
lineHaveEnd = False
polyCount = 0
polyClosed = False
If currentEntity = "POLYLINE" Then
inOldPolyline = True
oldPolylineClosed = False
oldPolyCount = 0
ElseIf currentEntity = "SEQEND" Then
If inOldPolyline Then
AddDxfPolylineSegmentsToArrays oldPolyX, oldPolyY, oldPolyCount, oldPolylineClosed, _
sx0, sy0, sx1, sy1, slen, segmentCount
inOldPolyline = False
oldPolylineClosed = False
oldPolyCount = 0
End If
End If
Else
Select Case currentEntity
Case "LINE"
If codeNum = 10 Then
If TryReadDxfXYAt(lines, lineCount, i, 10, lineX0, lineY0) Then lineHaveStart = True
ElseIf codeNum = 11 Then
If TryReadDxfXYAt(lines, lineCount, i, 11, lineX1, lineY1) Then lineHaveEnd = True
End If
Case "LWPOLYLINE"
If codeNum = 10 Then
Dim px As Double, py As Double
If TryReadDxfXYAt(lines, lineCount, i, 10, px, py) Then
AddDxf2DPoint polyX, polyY, polyCount, px, py
End If
ElseIf codeNum = 70 Then
polyClosed = ((CLng(Val(valText)) And 1) <> 0)
End If
Case "POLYLINE"
If codeNum = 70 Then
oldPolylineClosed = ((CLng(Val(valText)) And 1) <> 0)
End If
Case "VERTEX"
If inOldPolyline Then
If codeNum = 10 Then
Dim vx As Double, vy As Double
If TryReadDxfXYAt(lines, lineCount, i, 10, vx, vy) Then
AddDxf2DPoint oldPolyX, oldPolyY, oldPolyCount, vx, vy
End If
End If
End If
End Select
End If
Next i
AddPendingDxfEntitySegments currentEntity, _
lineHaveStart, lineHaveEnd, lineX0, lineY0, lineX1, lineY1, _
polyX, polyY, polyCount, polyClosed, _
sx0, sy0, sx1, sy1, slen, segmentCount
If inOldPolyline Then
AddDxfPolylineSegmentsToArrays oldPolyX, oldPolyY, oldPolyCount, oldPolylineClosed, _
sx0, sy0, sx1, sy1, slen, segmentCount
End If
CollectDxfLinearSegments = (segmentCount > 0)
Exit Function
EH:
LogEvent " | WARN | CollectDxfLinearSegments: " & Err.Number & " - " & Err.Description
End Function
Private Sub AddPendingDxfEntitySegments(ByVal entityName As String, _
ByVal lineHaveStart As Boolean, _
ByVal lineHaveEnd As Boolean, _
ByVal lineX0 As Double, _
ByVal lineY0 As Double, _
ByVal lineX1 As Double, _
ByVal lineY1 As Double, _
ByRef polyX() As Double, _
ByRef polyY() As Double, _
ByVal polyCount As Long, _
ByVal polyClosed As Boolean, _
ByRef sx0() As Double, _
ByRef sy0() As Double, _
ByRef sx1() As Double, _
ByRef sy1() As Double, _
ByRef slen() As Double, _
ByRef segmentCount As Long)
On Error GoTo EH
Select Case UCase$(entityName)
Case "LINE"
If lineHaveStart And lineHaveEnd Then
AddDxfLinearSegmentToArrays lineX0, lineY0, lineX1, lineY1, sx0, sy0, sx1, sy1, slen, segmentCount
End If
Case "LWPOLYLINE"
AddDxfPolylineSegmentsToArrays polyX, polyY, polyCount, polyClosed, sx0, sy0, sx1, sy1, slen, segmentCount
End Select
Exit Sub
EH:
LogEvent " | WARN | AddPendingDxfEntitySegments(" & entityName & "): " & Err.Number & " - " & Err.Description
End Sub
Private Sub AddDxfPolylineSegmentsToArrays(ByRef px() As Double, _
ByRef py() As Double, _
ByVal ptCount As Long, _
ByVal isClosed As Boolean, _
ByRef sx0() As Double, _
ByRef sy0() As Double, _
ByRef sx1() As Double, _
ByRef sy1() As Double, _
ByRef slen() As Double, _
ByRef segmentCount As Long)
On Error GoTo EH
If ptCount < 2 Then Exit Sub
Dim i As Long
For i = 0 To ptCount - 2
AddDxfLinearSegmentToArrays px(i), py(i), px(i + 1), py(i + 1), sx0, sy0, sx1, sy1, slen, segmentCount
Next i
If isClosed And ptCount > 2 Then
AddDxfLinearSegmentToArrays px(ptCount - 1), py(ptCount - 1), px(0), py(0), sx0, sy0, sx1, sy1, slen, segmentCount
End If
Exit Sub
EH:
LogEvent " | WARN | AddDxfPolylineSegmentsToArrays: " & Err.Number & " - " & Err.Description
End Sub
Private Sub AddDxfLinearSegmentToArrays(ByVal x0 As Double, _
ByVal y0 As Double, _
ByVal x1 As Double, _
ByVal y1 As Double, _
ByRef sx0() As Double, _
ByRef sy0() As Double, _
ByRef sx1() As Double, _
ByRef sy1() As Double, _
ByRef slen() As Double, _
ByRef segmentCount As Long)
On Error GoTo EH
Dim dx As Double
Dim dy As Double
Dim L As Double
dx = x1 - x0
dy = y1 - y0
L = Sqr(dx * dx + dy * dy)
If L < DXF_POSTPROCESS_MIN_SEGMENT_LENGTH Then Exit Sub
If segmentCount = 0 Then
ReDim sx0(0 To 0)
ReDim sy0(0 To 0)
ReDim sx1(0 To 0)
ReDim sy1(0 To 0)
ReDim slen(0 To 0)
Else
ReDim Preserve sx0(0 To segmentCount)
ReDim Preserve sy0(0 To segmentCount)
ReDim Preserve sx1(0 To segmentCount)
ReDim Preserve sy1(0 To segmentCount)
ReDim Preserve slen(0 To segmentCount)
End If
sx0(segmentCount) = x0
sy0(segmentCount) = y0
sx1(segmentCount) = x1
sy1(segmentCount) = y1
slen(segmentCount) = L
segmentCount = segmentCount + 1
Exit Sub
EH:
LogEvent " | WARN | AddDxfLinearSegmentToArrays: " & Err.Number & " - " & Err.Description
End Sub
Private Function SelectDxfRightAngleBottomLegRotation(ByRef sx0() As Double, _
ByRef sy0() As Double, _
ByRef sx1() As Double, _
ByRef sy1() As Double, _
ByRef slen() As Double, _
ByVal segmentCount As Long, _
ByRef bestRotationRad As Double, _
ByRef bestPrimaryLen As Double, _
ByRef bestSecondaryLen As Double) As Boolean
On Error GoTo EH
SelectDxfRightAngleBottomLegRotation = False
Dim bestBottomPenalty As Double
Dim bestArea As Double
bestBottomPenalty = 1E+30
bestPrimaryLen = -1#
bestSecondaryLen = -1#
bestArea = -1#
Dim i As Long
Dim j As Long
For i = 0 To segmentCount - 2
For j = i + 1 To segmentCount - 1
Dim cornerX As Double, cornerY As Double
Dim iFarX As Double, iFarY As Double
Dim jFarX As Double, jFarY As Double
If TryGetSharedDxfSegmentCorner(sx0(i), sy0(i), sx1(i), sy1(i), _
sx0(j), sy0(j), sx1(j), sy1(j), _
cornerX, cornerY, iFarX, iFarY, jFarX, jFarY) Then
Dim ix As Double, iy As Double
Dim jx As Double, jy As Double
Dim iLen As Double, jLen As Double
ix = iFarX - cornerX
iy = iFarY - cornerY
jx = jFarX - cornerX
jy = jFarY - cornerY
iLen = Sqr(ix * ix + iy * iy)
jLen = Sqr(jx * jx + jy * jy)
If iLen >= DXF_POSTPROCESS_MIN_SEGMENT_LENGTH And jLen >= DXF_POSTPROCESS_MIN_SEGMENT_LENGTH Then
ix = ix / iLen
iy = iy / iLen
jx = jx / jLen
jy = jy / jLen
Dim dotAbs As Double
dotAbs = Abs((ix * jx) + (iy * jy))
If dotAbs <= DXF_POSTPROCESS_PERP_DOT_TOL Then
Dim xVecX As Double, xVecY As Double
Dim yVecX As Double, yVecY As Double
Dim primaryLen As Double
Dim secondaryLen As Double
If DXF_POSTPROCESS_PREFER_LONGER_RIGHT_ANGLE_LEG_HORIZONTAL Then
If iLen >= jLen Then
xVecX = ix: xVecY = iy
yVecX = jx: yVecY = jy
primaryLen = iLen
secondaryLen = jLen
Else
xVecX = jx: xVecY = jy
yVecX = ix: yVecY = iy
primaryLen = jLen
secondaryLen = iLen
End If
Else
xVecX = ix: xVecY = iy
yVecX = jx: yVecY = jy
primaryLen = iLen
secondaryLen = jLen
End If
Dim rotationRad As Double
rotationRad = -Atn2(xVecY, xVecX)
Dim c As Double, s As Double
Dim yRotX As Double, yRotY As Double
c = Cos(rotationRad)
s = Sin(rotationRad)
RotatePoint2D yVecX, yVecY, c, s, yRotX, yRotY
'If the adjacent/opposite leg points downward after rotation,
'rotate 180 degrees. The selected edge remains horizontal,
'but the right-angle corner becomes the lower corner.
If yRotY < -EPS Then
rotationRad = rotationRad + PI_VAL
End If
Dim minX As Double, minY As Double, maxX As Double, maxY As Double
Dim pointCount As Long
If GetDxfSegmentEndpointBoundsAfterRotation(sx0, sy0, sx1, sy1, segmentCount, rotationRad, minX, minY, maxX, maxY, pointCount) Then
Dim edgeRX As Double, edgeRY As Double
c = Cos(rotationRad)
s = Sin(rotationRad)
RotatePoint2D cornerX, cornerY, c, s, edgeRX, edgeRY
Dim bottomPenalty As Double
bottomPenalty = Abs(edgeRY - minY)
Dim area As Double
area = primaryLen * secondaryLen
If IsDxfRightAngleCandidateBetter(bottomPenalty, primaryLen, secondaryLen, area, _
bestBottomPenalty, bestPrimaryLen, bestSecondaryLen, bestArea) Then
bestBottomPenalty = bottomPenalty
bestPrimaryLen = primaryLen
bestSecondaryLen = secondaryLen
bestArea = area
bestRotationRad = rotationRad
SelectDxfRightAngleBottomLegRotation = True
LogEvent " | INFO | DXF right-angle candidate accepted | pair=" & CStr(i) & "/" & CStr(j) & _
" | primary=" & FormatDxfLogNumber(primaryLen) & _
" | secondary=" & FormatDxfLogNumber(secondaryLen) & _
" | bottomPenalty=" & FormatDxfLogNumber(bottomPenalty) & _
" | rotationDeg=" & FormatDxfLogNumber(RadToDeg(rotationRad))
End If
End If
End If
End If
End If
Next j
Next i
If SelectDxfRightAngleBottomLegRotation Then
LogEvent " | INFO | DXF right-angle bottom-leg orientation selected | primary=" & FormatDxfLogNumber(bestPrimaryLen) & _
" | secondary=" & FormatDxfLogNumber(bestSecondaryLen) & _
" | bottomPenalty=" & FormatDxfLogNumber(bestBottomPenalty)
End If
Exit Function
EH:
LogEvent " | WARN | SelectDxfRightAngleBottomLegRotation: " & Err.Number & " - " & Err.Description
End Function
Private Function IsDxfRightAngleCandidateBetter(ByVal candBottomPenalty As Double, _
ByVal candPrimaryLen As Double, _
ByVal candSecondaryLen As Double, _
ByVal candArea As Double, _
ByVal bestBottomPenalty As Double, _
ByVal bestPrimaryLen As Double, _
ByVal bestSecondaryLen As Double, _
ByVal bestArea As Double) As Boolean
IsDxfRightAngleCandidateBetter = False
'First priority: selected leg should be on the bottom, not on the top.
If candBottomPenalty < bestBottomPenalty - DXF_POSTPROCESS_BOTTOM_EDGE_TOL Then
IsDxfRightAngleCandidateBetter = True
Exit Function
End If
If Abs(candBottomPenalty - bestBottomPenalty) <= DXF_POSTPROCESS_BOTTOM_EDGE_TOL Then
'Then prefer a stronger real corner: larger shorter leg first, then area, then primary length.
If candSecondaryLen > bestSecondaryLen + EPS Then
IsDxfRightAngleCandidateBetter = True
Exit Function
End If
If Abs(candSecondaryLen - bestSecondaryLen) <= EPS Then
If candArea > bestArea + EPS Then
IsDxfRightAngleCandidateBetter = True
Exit Function
End If
If Abs(candArea - bestArea) <= EPS Then
If candPrimaryLen > bestPrimaryLen + EPS Then
IsDxfRightAngleCandidateBetter = True
Exit Function
End If
End If
End If
End If
End Function
Private Function SelectDxfDominantBottomEdgeRotation(ByRef sx0() As Double, _
ByRef sy0() As Double, _
ByRef sx1() As Double, _
ByRef sy1() As Double, _
ByRef slen() As Double, _
ByVal segmentCount As Long, _
ByRef bestRotationRad As Double, _
ByRef bestLen As Double, _
ByRef secondaryLen As Double) As Boolean
On Error GoTo EH
SelectDxfDominantBottomEdgeRotation = False
bestLen = -1#
secondaryLen = 0#
Dim i As Long
Dim bestIndex As Long
bestIndex = -1
For i = 0 To segmentCount - 1
If slen(i) > bestLen + EPS Then
bestLen = slen(i)
bestIndex = i
ElseIf Abs(slen(i) - bestLen) <= EPS Then
Dim candAngle As Double
Dim bestAngle As Double
candAngle = NormalizeAngleToHalfPi(Atn2(sy1(i) - sy0(i), sx1(i) - sx0(i)))
bestAngle = NormalizeAngleToHalfPi(Atn2(sy1(bestIndex) - sy0(bestIndex), sx1(bestIndex) - sx0(bestIndex)))
If Abs(candAngle) < Abs(bestAngle) - EPS Then bestIndex = i
End If
Next i
If bestIndex < 0 Then Exit Function
Dim angleRad As Double
angleRad = Atn2(sy1(bestIndex) - sy0(bestIndex), sx1(bestIndex) - sx0(bestIndex))
bestRotationRad = -NormalizeAngleToHalfPi(angleRad)
Dim minX As Double, minY As Double, maxX As Double, maxY As Double
Dim pointCount As Long
If GetDxfSegmentEndpointBoundsAfterRotation(sx0, sy0, sx1, sy1, segmentCount, bestRotationRad, minX, minY, maxX, maxY, pointCount) Then
Dim c As Double, s As Double
Dim r0x As Double, r0y As Double
Dim r1x As Double, r1y As Double
c = Cos(bestRotationRad)
s = Sin(bestRotationRad)
RotatePoint2D sx0(bestIndex), sy0(bestIndex), c, s, r0x, r0y
RotatePoint2D sx1(bestIndex), sy1(bestIndex), c, s, r1x, r1y
Dim edgeY As Double
edgeY = (r0y + r1y) / 2#
'If the selected dominant edge is closer to the top than the bottom,
'rotate 180 degrees so the same edge becomes the bottom nesting edge.
If Abs(edgeY - maxY) < Abs(edgeY - minY) Then
bestRotationRad = bestRotationRad + PI_VAL
LogEvent " | INFO | DXF dominant fallback rotated 180 degrees to place longest edge on bottom"
End If
End If
SelectDxfDominantBottomEdgeRotation = True
Exit Function
EH:
LogEvent " | WARN | SelectDxfDominantBottomEdgeRotation: " & Err.Number & " - " & Err.Description
End Function
Private Function TryGetSharedDxfSegmentCorner(ByVal a0x As Double, _
ByVal a0y As Double, _
ByVal a1x As Double, _
ByVal a1y As Double, _
ByVal b0x As Double, _
ByVal b0y As Double, _
ByVal b1x As Double, _
ByVal b1y As Double, _
ByRef cornerX As Double, _
ByRef cornerY As Double, _
ByRef aFarX As Double, _
ByRef aFarY As Double, _
ByRef bFarX As Double, _
ByRef bFarY As Double) As Boolean
TryGetSharedDxfSegmentCorner = False
If DxfPointsCoincident2(a0x, a0y, b0x, b0y) Then
cornerX = a0x: cornerY = a0y
aFarX = a1x: aFarY = a1y
bFarX = b1x: bFarY = b1y
TryGetSharedDxfSegmentCorner = True
Exit Function
End If
If DxfPointsCoincident2(a0x, a0y, b1x, b1y) Then
cornerX = a0x: cornerY = a0y
aFarX = a1x: aFarY = a1y
bFarX = b0x: bFarY = b0y
TryGetSharedDxfSegmentCorner = True
Exit Function
End If
If DxfPointsCoincident2(a1x, a1y, b0x, b0y) Then
cornerX = a1x: cornerY = a1y
aFarX = a0x: aFarY = a0y
bFarX = b1x: bFarY = b1y
TryGetSharedDxfSegmentCorner = True
Exit Function
End If
If DxfPointsCoincident2(a1x, a1y, b1x, b1y) Then
cornerX = a1x: cornerY = a1y
aFarX = a0x: aFarY = a0y
bFarX = b0x: bFarY = b0y
TryGetSharedDxfSegmentCorner = True
Exit Function
End If
End Function
Private Function DxfPointsCoincident2(ByVal x1 As Double, _
ByVal y1 As Double, _
ByVal x2 As Double, _
ByVal y2 As Double) As Boolean
DxfPointsCoincident2 = (Sqr((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1)) <= DXF_POSTPROCESS_POINT_TOL)
End Function
Private Function GetDxfSegmentEndpointBoundsAfterRotation(ByRef sx0() As Double, _
ByRef sy0() As Double, _
ByRef sx1() As Double, _
ByRef sy1() As Double, _
ByVal segmentCount As Long, _
ByVal rotationRad As Double, _
ByRef minX As Double, _
ByRef minY As Double, _
ByRef maxX As Double, _
ByRef maxY As Double, _
ByRef pointCount As Long) As Boolean
On Error GoTo EH
GetDxfSegmentEndpointBoundsAfterRotation = False
pointCount = 0
Dim c As Double, s As Double
c = Cos(rotationRad)
s = Sin(rotationRad)
Dim i As Long
Dim rx As Double, ry As Double
For i = 0 To segmentCount - 1
RotatePoint2D sx0(i), sy0(i), c, s, rx, ry
ExpandDxfBounds rx, ry, minX, minY, maxX, maxY, pointCount
RotatePoint2D sx1(i), sy1(i), c, s, rx, ry
ExpandDxfBounds rx, ry, minX, minY, maxX, maxY, pointCount
Next i
GetDxfSegmentEndpointBoundsAfterRotation = (pointCount > 0)
Exit Function
EH:
LogEvent " | WARN | GetDxfSegmentEndpointBoundsAfterRotation: " & Err.Number & " - " & Err.Description
End Function
Private Sub ExpandDxfBounds(ByVal x As Double, _
ByVal y As Double, _
ByRef minX As Double, _
ByRef minY As Double, _
ByRef maxX As Double, _
ByRef maxY As Double, _
ByRef pointCount As Long)
If pointCount = 0 Then
minX = x: maxX = x
minY = y: maxY = y
Else
If x < minX Then minX = x
If x > maxX Then maxX = x
If y < minY Then minY = y
If y > maxY Then maxY = y
End If
pointCount = pointCount + 1
End Sub
Private Function FindDxfEntitiesRange(ByRef lines() As String, _
ByVal lineCount As Long, _
ByRef entStartIndex As Long, _
ByRef entEndIndex As Long) As Boolean
On Error GoTo EH
FindDxfEntitiesRange = False
entStartIndex = 0
entEndIndex = 0
If lineCount < 6 Then Exit Function
Dim i As Long
Dim codeNum As Long
Dim valueText As String
Dim pendingSection As Boolean
Dim insideEntities As Boolean
pendingSection = False
insideEntities = False
For i = 0 To lineCount - 2 Step 2
codeNum = DxfGroupCodeToLong(lines(i))
valueText = UCase$(Trim$(lines(i + 1)))
If pendingSection And codeNum = 2 Then
If valueText = "ENTITIES" Then
insideEntities = True
entStartIndex = i + 2
End If
pendingSection = False
ElseIf codeNum = 0 And valueText = "SECTION" Then
pendingSection = True
ElseIf insideEntities And codeNum = 0 And valueText = "ENDSEC" Then
entEndIndex = i - 2
If entEndIndex >= entStartIndex Then
FindDxfEntitiesRange = True
End If
Exit Function
End If
Next i
If insideEntities Then
entEndIndex = lineCount - 2
FindDxfEntitiesRange = (entEndIndex >= entStartIndex)
End If
Exit Function
EH:
LogEvent " | WARN | FindDxfEntitiesRange: " & Err.Number & " - " & Err.Description
End Function
Private Function FindDominantDxfLinearAngle(ByRef lines() As String, _
ByVal lineCount As Long, _
ByVal entStartIndex As Long, _
ByVal entEndIndex As Long, _
ByRef bestAngleRad As Double, _
ByRef bestLen As Double, _
ByRef segmentCount As Long) As Boolean
On Error GoTo EH
FindDominantDxfLinearAngle = False
bestAngleRad = 0#
bestLen = -1#
segmentCount = 0
Dim currentEntity As String
Dim inOldPolyline As Boolean
Dim oldPolylineClosed As Boolean
Dim lineHaveStart As Boolean
Dim lineHaveEnd As Boolean
Dim lineX0 As Double, lineY0 As Double
Dim lineX1 As Double, lineY1 As Double
Dim polyX() As Double
Dim polyY() As Double
Dim polyCount As Long
Dim polyClosed As Boolean
Dim oldPolyX() As Double
Dim oldPolyY() As Double
Dim oldPolyCount As Long
Dim i As Long
Dim codeNum As Long
Dim valText As String
currentEntity = ""
inOldPolyline = False
oldPolylineClosed = False
polyCount = 0
oldPolyCount = 0
For i = entStartIndex To entEndIndex Step 2
codeNum = DxfGroupCodeToLong(lines(i))
valText = Trim$(lines(i + 1))
If codeNum = 0 Then
FinalizeDxfSegmentEntity currentEntity, _
lineHaveStart, lineHaveEnd, lineX0, lineY0, lineX1, lineY1, _
polyX, polyY, polyCount, polyClosed, _
bestAngleRad, bestLen, segmentCount
currentEntity = UCase$(valText)
lineHaveStart = False
lineHaveEnd = False
polyCount = 0
polyClosed = False
If currentEntity = "POLYLINE" Then
inOldPolyline = True
oldPolylineClosed = False
oldPolyCount = 0
ElseIf currentEntity = "SEQEND" Then
If inOldPolyline Then
AddDxfPolylineSegments oldPolyX, oldPolyY, oldPolyCount, oldPolylineClosed, bestAngleRad, bestLen, segmentCount
inOldPolyline = False
oldPolylineClosed = False
oldPolyCount = 0
End If
End If
Else
Select Case currentEntity
Case "LINE"
If codeNum = 10 Then
If TryReadDxfXYAt(lines, lineCount, i, 10, lineX0, lineY0) Then lineHaveStart = True
ElseIf codeNum = 11 Then
If TryReadDxfXYAt(lines, lineCount, i, 11, lineX1, lineY1) Then lineHaveEnd = True
End If
Case "LWPOLYLINE"
If codeNum = 10 Then
Dim px As Double, py As Double
If TryReadDxfXYAt(lines, lineCount, i, 10, px, py) Then
AddDxf2DPoint polyX, polyY, polyCount, px, py
End If
ElseIf codeNum = 70 Then
polyClosed = ((CLng(Val(valText)) And 1) <> 0)
End If
Case "POLYLINE"
If codeNum = 70 Then
oldPolylineClosed = ((CLng(Val(valText)) And 1) <> 0)
End If
Case "VERTEX"
If inOldPolyline Then
If codeNum = 10 Then
Dim vx As Double, vy As Double
If TryReadDxfXYAt(lines, lineCount, i, 10, vx, vy) Then
AddDxf2DPoint oldPolyX, oldPolyY, oldPolyCount, vx, vy
End If
End If
End If
End Select
End If
Next i
FinalizeDxfSegmentEntity currentEntity, _
lineHaveStart, lineHaveEnd, lineX0, lineY0, lineX1, lineY1, _
polyX, polyY, polyCount, polyClosed, _
bestAngleRad, bestLen, segmentCount
If inOldPolyline Then
AddDxfPolylineSegments oldPolyX, oldPolyY, oldPolyCount, oldPolylineClosed, bestAngleRad, bestLen, segmentCount
End If
FindDominantDxfLinearAngle = (segmentCount > 0 And bestLen > 0#)
Exit Function
EH:
LogEvent " | WARN | FindDominantDxfLinearAngle: " & Err.Number & " - " & Err.Description
End Function
Private Sub FinalizeDxfSegmentEntity(ByVal entityName As String, _
ByVal lineHaveStart As Boolean, _
ByVal lineHaveEnd As Boolean, _
ByVal lineX0 As Double, _
ByVal lineY0 As Double, _
ByVal lineX1 As Double, _
ByVal lineY1 As Double, _
ByRef polyX() As Double, _
ByRef polyY() As Double, _
ByVal polyCount As Long, _
ByVal polyClosed As Boolean, _
ByRef bestAngleRad As Double, _
ByRef bestLen As Double, _
ByRef segmentCount As Long)
On Error GoTo EH
Select Case UCase$(entityName)
Case "LINE"
If lineHaveStart And lineHaveEnd Then
ConsiderDxfLinearSegment lineX0, lineY0, lineX1, lineY1, bestAngleRad, bestLen, segmentCount
End If
Case "LWPOLYLINE"
AddDxfPolylineSegments polyX, polyY, polyCount, polyClosed, bestAngleRad, bestLen, segmentCount
End Select
Exit Sub
EH:
LogEvent " | WARN | FinalizeDxfSegmentEntity(" & entityName & "): " & Err.Number & " - " & Err.Description
End Sub
Private Sub AddDxfPolylineSegments(ByRef px() As Double, _
ByRef py() As Double, _
ByVal ptCount As Long, _
ByVal isClosed As Boolean, _
ByRef bestAngleRad As Double, _
ByRef bestLen As Double, _
ByRef segmentCount As Long)
On Error GoTo EH
If ptCount < 2 Then Exit Sub
Dim i As Long
For i = 0 To ptCount - 2
ConsiderDxfLinearSegment px(i), py(i), px(i + 1), py(i + 1), bestAngleRad, bestLen, segmentCount
Next i
If isClosed And ptCount > 2 Then
ConsiderDxfLinearSegment px(ptCount - 1), py(ptCount - 1), px(0), py(0), bestAngleRad, bestLen, segmentCount
End If
Exit Sub
EH:
LogEvent " | WARN | AddDxfPolylineSegments: " & Err.Number & " - " & Err.Description
End Sub
Private Sub ConsiderDxfLinearSegment(ByVal x0 As Double, _
ByVal y0 As Double, _
ByVal x1 As Double, _
ByVal y1 As Double, _
ByRef bestAngleRad As Double, _
ByRef bestLen As Double, _
ByRef segmentCount As Long)
On Error GoTo EH
Dim dx As Double
Dim dy As Double
Dim L As Double
Dim a As Double
dx = x1 - x0
dy = y1 - y0
L = Sqr(dx * dx + dy * dy)
If L < DXF_POSTPROCESS_MIN_SEGMENT_LENGTH Then Exit Sub
a = NormalizeAngleToHalfPi(Atn2(dy, dx))
segmentCount = segmentCount + 1
If L > bestLen + EPS Then
bestLen = L
bestAngleRad = a
ElseIf Abs(L - bestLen) <= EPS Then
'Tie-breaker: prefer the segment requiring less rotation, then stable positive angle.
If Abs(a) < Abs(bestAngleRad) - EPS Then
bestAngleRad = a
ElseIf Abs(Abs(a) - Abs(bestAngleRad)) <= EPS Then
If a > bestAngleRad Then bestAngleRad = a
End If
End If
Exit Sub
EH:
LogEvent " | WARN | ConsiderDxfLinearSegment: " & Err.Number & " - " & Err.Description
End Sub
Private Function NormalizeAngleToHalfPi(ByVal angleRad As Double) As Double
Do While angleRad <= -PI_VAL / 2#
angleRad = angleRad + PI_VAL
Loop
Do While angleRad > PI_VAL / 2#
angleRad = angleRad - PI_VAL
Loop
NormalizeAngleToHalfPi = angleRad
End Function
Private Function GetRotatedDxfPointBounds(ByRef lines() As String, _
ByVal lineCount As Long, _
ByVal entStartIndex As Long, _
ByVal entEndIndex As Long, _
ByVal rotationRad As Double, _
ByRef minX As Double, _
ByRef minY As Double, _
ByRef maxX As Double, _
ByRef maxY As Double, _
ByRef pointCount As Long) As Boolean
On Error GoTo EH
GetRotatedDxfPointBounds = False
pointCount = 0
Dim c As Double
Dim s As Double
c = Cos(rotationRad)
s = Sin(rotationRad)
Dim i As Long
Dim codeNum As Long
Dim x As Double, y As Double
Dim rx As Double, ry As Double
Dim currentEntity As String
currentEntity = ""
For i = entStartIndex To entEndIndex Step 2
codeNum = DxfGroupCodeToLong(lines(i))
If codeNum = 0 Then
currentEntity = UCase$(Trim$(lines(i + 1)))
ElseIf IsDxfPointXCode(codeNum) Then
If IsDxfCoordinatePairAllowedForEntity(currentEntity, codeNum) Then
If TryReadDxfXYAt(lines, lineCount, i, codeNum, x, y) Then
RotatePoint2D x, y, c, s, rx, ry
If pointCount = 0 Then
minX = rx: maxX = rx
minY = ry: maxY = ry
Else
If rx < minX Then minX = rx
If rx > maxX Then maxX = rx
If ry < minY Then minY = ry
If ry > maxY Then maxY = ry
End If
pointCount = pointCount + 1
End If
End If
End If
Next i
GetRotatedDxfPointBounds = (pointCount > 0)
Exit Function
EH:
LogEvent " | WARN | GetRotatedDxfPointBounds: " & Err.Number & " - " & Err.Description
End Function
Private Function ApplyDxf2DRotationToLines(ByRef lines() As String, _
ByVal lineCount As Long, _
ByVal entStartIndex As Long, _
ByVal entEndIndex As Long, _
ByVal rotationRad As Double, _
ByVal offsetX As Double, _
ByVal offsetY As Double) As Boolean
On Error GoTo EH
ApplyDxf2DRotationToLines = False
Dim c As Double
Dim s As Double
Dim rotDeg As Double
c = Cos(rotationRad)
s = Sin(rotationRad)
rotDeg = RadToDeg(rotationRad)
Dim i As Long
Dim codeNum As Long
Dim x As Double, y As Double
Dim rx As Double, ry As Double
Dim currentEntity As String
Dim useTranslation As Boolean
currentEntity = ""
For i = entStartIndex To entEndIndex Step 2
codeNum = DxfGroupCodeToLong(lines(i))
If codeNum = 0 Then
currentEntity = UCase$(Trim$(lines(i + 1)))
ElseIf IsDxfPointXCode(codeNum) Then
If IsDxfCoordinatePairAllowedForEntity(currentEntity, codeNum) Then
If TryReadDxfXYAt(lines, lineCount, i, codeNum, x, y) Then
RotatePoint2D x, y, c, s, rx, ry
useTranslation = True
If currentEntity = "ELLIPSE" And codeNum = 11 Then
'Ellipse 11/21 is the major-axis vector, not a point.
useTranslation = False
End If
If useTranslation Then
rx = rx + offsetX
ry = ry + offsetY
End If
lines(i + 1) = FormatDxfDouble(rx)
lines(i + 3) = FormatDxfDouble(ry)
End If
End If
ElseIf currentEntity = "ARC" Then
If codeNum = 50 Or codeNum = 51 Then
lines(i + 1) = FormatDxfDouble(NormalizeDegrees360(DxfTextToDouble(lines(i + 1)) + rotDeg))
End If
ElseIf currentEntity = "TEXT" Or currentEntity = "MTEXT" Or currentEntity = "INSERT" Then
If codeNum = 50 Then
lines(i + 1) = FormatDxfDouble(NormalizeDegrees360(DxfTextToDouble(lines(i + 1)) + rotDeg))
End If
End If
Next i
ApplyDxf2DRotationToLines = True
Exit Function
EH:
LogEvent " | WARN | ApplyDxf2DRotationToLines: " & Err.Number & " - " & Err.Description
End Function
Private Function IsDxfPointXCode(ByVal codeNum As Long) As Boolean
'Waterjet exports mostly use 10/20, 11/21, etc.
'Do not include 210/220 extrusion vectors here; changing extrusion vectors can corrupt DXF import.
IsDxfPointXCode = (codeNum >= 10 And codeNum <= 18)
End Function
Private Function IsDxfCoordinatePairAllowedForEntity(ByVal entityName As String, ByVal xCode As Long) As Boolean
'Default to allowing common 2D geometry point codes.
'A small deny-list protects known vector-only pairs.
IsDxfCoordinatePairAllowedForEntity = True
Select Case UCase$(entityName)
Case "ELLIPSE"
'10/20 center is a point; 11/21 major-axis is a vector.
If xCode = 11 Then
IsDxfCoordinatePairAllowedForEntity = True
End If
End Select
End Function
Private Function TryReadDxfXYAt(ByRef lines() As String, _
ByVal lineCount As Long, _
ByVal codeIndex As Long, _
ByVal xCode As Long, _
ByRef xOut As Double, _
ByRef yOut As Double) As Boolean
On Error GoTo EH
TryReadDxfXYAt = False
If codeIndex < 0 Then Exit Function
If codeIndex + 3 >= lineCount Then Exit Function
If DxfGroupCodeToLong(lines(codeIndex)) <> xCode Then Exit Function
If DxfGroupCodeToLong(lines(codeIndex + 2)) <> xCode + 10 Then Exit Function
xOut = DxfTextToDouble(lines(codeIndex + 1))
yOut = DxfTextToDouble(lines(codeIndex + 3))
TryReadDxfXYAt = True
Exit Function
EH:
TryReadDxfXYAt = False
End Function
Private Sub AddDxf2DPoint(ByRef px() As Double, _
ByRef py() As Double, _
ByRef ptCount As Long, _
ByVal x As Double, _
ByVal y As Double)
On Error GoTo EH
If ptCount = 0 Then
ReDim px(0 To 0)
ReDim py(0 To 0)
Else
ReDim Preserve px(0 To ptCount)
ReDim Preserve py(0 To ptCount)
End If
px(ptCount) = x
py(ptCount) = y
ptCount = ptCount + 1
Exit Sub
EH:
LogEvent " | WARN | AddDxf2DPoint: " & Err.Number & " - " & Err.Description
End Sub
Private Sub RotatePoint2D(ByVal x As Double, _
ByVal y As Double, _
ByVal c As Double, _
ByVal s As Double, _
ByRef xOut As Double, _
ByRef yOut As Double)
xOut = (x * c) - (y * s)
yOut = (x * s) + (y * c)
End Sub
Private Function DxfGroupCodeToLong(ByVal codeText As String) As Long
On Error GoTo EH
codeText = Trim$(codeText)
If Len(codeText) = 0 Then
DxfGroupCodeToLong = -999999
Else
DxfGroupCodeToLong = CLng(Val(codeText))
End If
Exit Function
EH:
DxfGroupCodeToLong = -999999
End Function
Private Function DxfTextToDouble(ByVal valueText As String) As Double
On Error GoTo EH
valueText = Trim$(valueText)
valueText = Replace$(valueText, ",", ".")
If Len(valueText) = 0 Then
DxfTextToDouble = 0#
Else
DxfTextToDouble = Val(valueText)
End If
Exit Function
EH:
DxfTextToDouble = 0#
End Function
Private Function FormatDxfDouble(ByVal value As Double) As String
On Error GoTo EH
Dim fmt As String
Dim s As String
If DXF_POSTPROCESS_OUTPUT_DECIMALS <= 0 Then
FormatDxfDouble = Trim$(Str$(value))
Exit Function
End If
fmt = "0." & String$(DXF_POSTPROCESS_OUTPUT_DECIMALS, "0")
s = Format$(value, fmt)
s = Replace$(s, ",", ".")
FormatDxfDouble = s
Exit Function
EH:
FormatDxfDouble = Trim$(Str$(value))
End Function
Private Function FormatDxfLogNumber(ByVal value As Double) As String
On Error Resume Next
FormatDxfLogNumber = Replace$(Format$(value, "0.000000"), ",", ".")
End Function
Private Function NormalizeDegrees360(ByVal degVal As Double) As Double
Do While degVal < 0#
degVal = degVal + 360#
Loop
Do While degVal >= 360#
degVal = degVal - 360#
Loop
NormalizeDegrees360 = degVal
End Function
Private Sub CopyFileIfExists(ByVal sourcePath As String, ByVal destPath As String)
On Error GoTo EH
If Len(Trim$(sourcePath)) = 0 Then Exit Sub
If Len(Trim$(destPath)) = 0 Then Exit Sub
If Not FileExists(sourcePath) Then Exit Sub
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(destPath) Then fso.DeleteFile destPath, True
fso.CopyFile sourcePath, destPath, True
LogEvent " | INFO | DXF post-process backup written => " & destPath
Exit Sub
EH:
LogEvent " | WARN | CopyFileIfExists failed: " & Err.Number & " - " & Err.Description
End Sub
Private Function CopyAndFlattenBodyForDxf(ByVal srcBody As SldWorks.Body2, _
ByRef xDir() As Double, _
ByRef faceNormal() As Double, _
ByVal contextLabel As String) As SldWorks.Body2
On Error GoTo EH
Set CopyAndFlattenBodyForDxf = Nothing
If srcBody Is Nothing Then
LogEvent " | FAIL | CopyAndFlattenBodyForDxf: source body is Nothing for " & contextLabel
Exit Function
End If
Dim tempBody As SldWorks.Body2
Set tempBody = srcBody.Copy
If tempBody Is Nothing Then
LogEvent " | FAIL | CopyAndFlattenBodyForDxf: Body.Copy returned Nothing for " & contextLabel
Exit Function
End If
Dim xf As SldWorks.MathTransform
Set xf = BuildBodyFlattenTransform(xDir, faceNormal)
If xf Is Nothing Then
LogEvent " | FAIL | CopyAndFlattenBodyForDxf: BuildBodyFlattenTransform returned Nothing for " & contextLabel
Exit Function
End If
Dim ok As Boolean
ok = False
On Error Resume Next
ok = CBool(tempBody.ApplyTransform(xf))
If Err.Number <> 0 Then
LogEvent " | FAIL | CopyAndFlattenBodyForDxf: Body.ApplyTransform failed for " & contextLabel & ": " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
If Not ok Then
LogEvent " | FAIL | CopyAndFlattenBodyForDxf: Body.ApplyTransform returned False for " & contextLabel
Exit Function
End If
LogEvent " | INFO | Physical body flatten transform applied for " & contextLabel
Set CopyAndFlattenBodyForDxf = tempBody
Exit Function
EH:
LogEvent " | ERROR | CopyAndFlattenBodyForDxf(" & contextLabel & "): " & Err.Number & " - " & Err.Description
End Function
Private Function BuildBodyFlattenTransform(ByRef xAxis() As Double, _
ByRef zAxis() As Double) As SldWorks.MathTransform
On Error GoTo EH
Set BuildBodyFlattenTransform = Nothing
Dim x(2) As Double
Dim y(2) As Double
Dim z(2) As Double
CopyVector3 xAxis, x
CopyVector3 zAxis, z
If VecLength(x) <= EPS Or VecLength(z) <= EPS Then
LogEvent " | FAIL | BuildBodyFlattenTransform: input axis length was zero"
Exit Function
End If
NormalizeVec x
NormalizeVec z
ProjectVectorOntoPlane x, z, x
If VecLength(x) <= EPS Then
LogEvent " | WARN | BuildBodyFlattenTransform: projected X was zero; choosing fallback X"
ChooseFallbackXAxis z, x
End If
NormalizeVec x
CrossProduct z, x, y
If VecLength(y) <= EPS Then
LogEvent " | FAIL | BuildBodyFlattenTransform: computed Y axis was zero"
Exit Function
End If
NormalizeVec y
CrossProduct y, z, x
NormalizeVec x
' Body transform maps source model coordinates into nesting/export coordinates:
' newX = dot(oldPoint, selectedX)
' newY = dot(oldPoint, selectedY)
' newZ = dot(oldPoint, selectedNormal)
' This physically places the copied body flat on the XY plane with the nesting X axis horizontal.
Dim data(15) As Double
Dim i As Long
For i = 0 To 15
data(i) = 0#
Next i
data(0) = x(0): data(1) = x(1): data(2) = x(2)
data(3) = y(0): data(4) = y(1): data(5) = y(2)
data(6) = z(0): data(7) = z(1): data(8) = z(2)
data(9) = 0#
data(10) = 0#
data(11) = 0#
data(12) = 1#
data(13) = 0#
data(14) = 0#
data(15) = 0#
LogEvent " | INFO | BuildBodyFlattenTransform axes mapped to output:"
LogEvent " | INFO | Source X-to-output horizontal = (" & Dbl3ToStr(x) & ")"
LogEvent " | INFO | Source Y-to-output vertical = (" & Dbl3ToStr(y) & ")"
LogEvent " | INFO | Source Z-to-output normal = (" & Dbl3ToStr(z) & ")"
LogEvent " | INFO | Matrix mode = ROW_DOT_PRODUCT_WORLD_TO_NESTING"
Set BuildBodyFlattenTransform = swMathUtil.CreateTransform(data)
Exit Function
EH:
LogEvent " | ERROR | BuildBodyFlattenTransform: " & Err.Number & " - " & Err.Description
End Function
Private Sub CopyVector3(ByRef src() As Double, ByRef dst() As Double)
On Error Resume Next
dst(0) = src(0)
dst(1) = src(1)
dst(2) = src(2)
End Sub
Private Function CreateTempPartFromBody(ByVal body As SldWorks.Body2, ByVal tempPartPath As String, Optional ByVal saveImmediately As Boolean = True) As SldWorks.ModelDoc2
On Error GoTo EH
Dim partTemplate As String
partTemplate = GetPartTemplatePath()
If Len(partTemplate) = 0 Then
LogEvent " | FAIL | No default part template available"
Exit Function
End If
LogEvent " | INFO | Temp part template = " & partTemplate
LogEvent " | INFO | Temp part target = " & tempPartPath
Dim tempDoc As SldWorks.ModelDoc2
Set tempDoc = swApp.NewDocument(partTemplate, 0, 0#, 0#)
If tempDoc Is Nothing Then
LogEvent " | FAIL | New temp part document creation failed"
Exit Function
End If
Dim tempPart As SldWorks.PartDoc
Set tempPart = tempDoc
tempDoc.ClearSelection2 True
Dim newFeat As SldWorks.Feature
Set newFeat = tempPart.CreateFeatureFromBody3(body, False, swCreateFeatureBodySimplify)
If newFeat Is Nothing Then
LogEvent " | FAIL | CreateFeatureFromBody3 returned Nothing"
swApp.CloseDoc tempDoc.GetTitle
Exit Function
End If
tempDoc.ForceRebuild3 True
If Not HideAllSketchesInModel(tempDoc) Then
LogEvent " | WARN | HideAllSketchesInModel returned False during temp part creation"
End If
If DIRECT_TEMP_PART_FORCE_INCH_UNITS Then
If ForceModelLinearUnitsToInches(tempDoc) Then
LogEvent " | INFO | Temp part units forced to inches for direct DXF export"
Else
LogEvent " | WARN | Temp part units could not be forced to inches"
End If
End If
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then
tempDoc.ViewZoomtofit2
End If
If saveImmediately Then
If Not TrySaveModelToPath(tempDoc, tempPartPath) Then
LogEvent " | FAIL | All temp part save attempts failed"
swApp.CloseDoc tempDoc.GetTitle
Exit Function
End If
LogEvent " | INFO | Temp part saved = " & tempPartPath
Else
LogEvent " | INFO | Temp part created in memory; initial disk save deferred"
End If
Set CreateTempPartFromBody = tempDoc
Exit Function
EH:
LogEvent " | ERROR | CreateTempPartFromBody: " & Err.Number & " - " & Err.Description
End Function
Private Function TrySaveModelToPath(ByVal mdl As SldWorks.ModelDoc2, ByVal filePath As String) As Boolean
On Error GoTo EH
TrySaveModelToPath = False
If mdl Is Nothing Then Exit Function
If Len(filePath) = 0 Then Exit Function
DeleteFileIfExists filePath
Dim actErr As Long
actErr = 0
On Error Resume Next
swApp.ActivateDoc3 mdl.GetTitle, False, swDontRebuildActiveDoc, actErr
Err.Clear
On Error GoTo EH
mdl.ForceRebuild3 True
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
mdl.ViewZoomtofit2
Else
LogEvent " | INFO | Save ViewZoomtofit2 skipped for batch stability"
End If
DoEvents
Dim errs As Long, warns As Long
errs = 0: warns = 0
LogEvent " | INFO | Save attempt 1: Extension.SaveAs"
If mdl.Extension.SaveAs(filePath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, errs, warns) Then
LogEvent " | INFO | Save attempt 1 returned True. errs=" & errs & " warns=" & warns
If FileExists(filePath) Then
TrySaveModelToPath = True
Exit Function
End If
LogEvent " | WARN | Save attempt 1 returned True but file not found"
Else
LogEvent " | WARN | Save attempt 1 returned False. errs=" & errs & " warns=" & warns
End If
errs = 0: warns = 0
LogEvent " | INFO | Save attempt 2: Extension.SaveAs with COPY option"
If mdl.Extension.SaveAs(filePath, swSaveAsCurrentVersion, swSaveAsOptions_Silent Or swSaveAsOptions_Copy, Nothing, errs, warns) Then
LogEvent " | INFO | Save attempt 2 returned True. errs=" & errs & " warns=" & warns
If FileExists(filePath) Then
TrySaveModelToPath = True
Exit Function
End If
LogEvent " | WARN | Save attempt 2 returned True but file not found"
Else
LogEvent " | WARN | Save attempt 2 returned False. errs=" & errs & " warns=" & warns
End If
errs = 0: warns = 0
LogEvent " | INFO | Save attempt 3: Extension.SaveAs after re-activate"
actErr = 0
On Error Resume Next
swApp.ActivateDoc3 mdl.GetTitle, True, swDontRebuildActiveDoc, actErr
Err.Clear
On Error GoTo EH
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then mdl.GraphicsRedraw2
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
mdl.ViewZoomtofit2
Else
LogEvent " | INFO | Save retry ViewZoomtofit2 skipped for batch stability"
End If
DoEvents
If mdl.Extension.SaveAs(filePath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, errs, warns) Then
LogEvent " | INFO | Save attempt 3 returned True. errs=" & errs & " warns=" & warns
If FileExists(filePath) Then
TrySaveModelToPath = True
Exit Function
End If
LogEvent " | WARN | Save attempt 3 returned True but file not found"
Else
LogEvent " | WARN | Save attempt 3 returned False. errs=" & errs & " warns=" & warns
End If
Exit Function
EH:
LogEvent " | ERROR | TrySaveModelToPath: " & Err.Number & " - " & Err.Description
End Function
Private Function OrientAndNameTempPartView(ByVal tempDoc As SldWorks.ModelDoc2, _
ByRef xDir() As Double, _
ByRef faceNormal() As Double, _
ByVal viewName As String) As Boolean
On Error GoTo EH
OrientAndNameTempPartView = False
If tempDoc Is Nothing Then Exit Function
Dim viewXf As SldWorks.MathTransform
Set viewXf = BuildViewOrientationTransform(xDir, faceNormal)
If viewXf Is Nothing Then
LogEvent " | FAIL | BuildViewOrientationTransform returned Nothing"
Exit Function
End If
Dim mvObj As Object
Set mvObj = tempDoc.ActiveView
If mvObj Is Nothing Then
LogEvent " | FAIL | tempDoc.ActiveView returned Nothing"
Exit Function
End If
LogEvent " | INFO | Setting current model view orientation"
On Error Resume Next
CallByName mvObj, "Orientation3", VbSet, viewXf
If Err.Number <> 0 Then
LogEvent " | FAIL | Setting Orientation3 failed: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then tempDoc.GraphicsRedraw2
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
tempDoc.ViewZoomtofit2
Else
LogEvent " | INFO | Temp part ViewZoomtofit2 skipped after orientation for batch stability"
End If
On Error Resume Next
tempDoc.DeleteNamedView viewName
Err.Clear
On Error GoTo EH
LogEvent " | INFO | Naming current view as [" & viewName & "]"
tempDoc.NameView viewName
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then tempDoc.GraphicsRedraw2
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
tempDoc.ViewZoomtofit2
Else
LogEvent " | INFO | Temp part ViewZoomtofit2 skipped after NameView for batch stability"
End If
OrientAndNameTempPartView = True
Exit Function
EH:
LogEvent " | ERROR | OrientAndNameTempPartView: " & Err.Number & " - " & Err.Description
End Function
Private Function ReopenTempPartForDirectExport(ByRef currentDoc As SldWorks.ModelDoc2, ByVal tempPartPath As String) As SldWorks.ModelDoc2
On Error GoTo EH
Set ReopenTempPartForDirectExport = Nothing
If Len(Trim$(tempPartPath)) = 0 Then Exit Function
If Not FileExists(tempPartPath) Then
LogEvent " | FAIL | ReopenTempPartForDirectExport: temp part file does not exist: " & tempPartPath
Exit Function
End If
LogEvent " | INFO | Closing in-memory temp part before direct reopen"
CloseModelDocSafe currentDoc
Dim errs As Long
Dim warns As Long
errs = 0
warns = 0
LogEvent " | INFO | Reopening persisted temp part for direct export: " & tempPartPath
Set ReopenTempPartForDirectExport = swApp.OpenDoc6(tempPartPath, swDocPART, swOpenDocOptions_Silent Or swOpenDocOptions_ReadOnly, "", errs, warns)
LogEvent " | INFO | Reopen temp part result errs=" & errs & " warns=" & warns
If ReopenTempPartForDirectExport Is Nothing Then
LogEvent " | FAIL | ReopenTempPartForDirectExport returned Nothing"
End If
Exit Function
EH:
LogEvent " | ERROR | ReopenTempPartForDirectExport: " & Err.Number & " - " & Err.Description
End Function
Private Function ExportTempPartToDxf_DirectByCurrentView(ByVal tempPartDoc As SldWorks.ModelDoc2, _
ByVal tempPartPath As String, _
ByVal finalDxfPath As String, _
ByRef xDir() As Double, _
ByRef faceNormal() As Double, _
ByVal preserveCornerOrientation As Boolean) As Boolean
On Error GoTo EH
ExportTempPartToDxf_DirectByCurrentView = False
If tempPartDoc Is Nothing Then
LogEvent " | FAIL | Current-view export: tempPartDoc is Nothing"
Exit Function
End If
If tempPartDoc.GetType <> swDocPART Then
LogEvent " | FAIL | Current-view export requires PART doc, got " & DocTypeName(tempPartDoc.GetType)
Exit Function
End If
If Len(Trim$(tempPartPath)) = 0 Then
LogEvent " | FAIL | Current-view export requires saved temp part path"
Exit Function
End If
If Not FileExists(tempPartPath) Then
LogEvent " | FAIL | Current-view export temp part file does not exist: " & tempPartPath
Exit Function
End If
Dim swTempPart As SldWorks.PartDoc
Set swTempPart = tempPartDoc
Dim alignmentData(0 To 11) As Double
Dim varAlignment As Variant
BuildIdentityDwgAlignment alignmentData
varAlignment = alignmentData
LogEvent " | INFO | Direct temp-part current-view export start"
LogEvent " | INFO | tempPartPath = " & tempPartPath
LogEvent " | INFO | finalDxfPath = " & finalDxfPath
LogEvent " | INFO | mode = *Current view on isolated temp part"
LogEvent " | INFO | preserveCornerOrientation = " & CStr(preserveCornerOrientation)
If Not ActivateDocumentByTitle(tempPartDoc.GetTitle) Then
LogEvent " | WARN | Current-view export could not explicitly activate temp part"
End If
If DIRECT_TEMP_PART_FORCE_INCH_UNITS Then
If ForceModelLinearUnitsToInches(tempPartDoc) Then
LogEvent " | INFO | Current-view export temp part linear units = INCHES"
Else
LogEvent " | WARN | Current-view export could not confirm INCH units on temp part"
End If
End If
'Critical R5 change:
'Re-apply the view immediately before ExportToDWG2 and export *Current.
'This mirrors the V15 single-body direct-source path, but on an isolated temp part so the source model is not touched.
If Not OrientModelCurrentView(tempPartDoc, xDir, faceNormal) Then
LogEvent " | FAIL | Could not orient temp part current view immediately before DXF export"
Exit Function
End If
If Not HideAllSketchesInModel(tempPartDoc) Then
LogEvent " | WARN | HideAllSketchesInModel returned False immediately before current-view DXF export"
End If
tempPartDoc.ForceRebuild3 True
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then tempPartDoc.GraphicsRedraw2
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
tempPartDoc.ViewZoomtofit2
Else
LogEvent " | INFO | Current-view temp-part ViewZoomtofit2 skipped for batch stability"
End If
LogEvent " | INFO | Direct export requested view name = [*Current]"
If TryDirectExportToDxfByViewName(swTempPart, tempPartPath, finalDxfPath, "*Current", varAlignment) Then
ExportTempPartToDxf_DirectByCurrentView = True
Exit Function
End If
Exit Function
EH:
LogEvent " | ERROR | ExportTempPartToDxf_DirectByCurrentView: " & Err.Number & " - " & Err.Description
End Function
Private Function ExportTempPartToDxf_DirectByAnnotationView(ByVal tempPartDoc As SldWorks.ModelDoc2, _
ByVal tempPartPath As String, _
ByVal finalDxfPath As String, _
ByVal modelViewName As String, _
ByVal preserveCornerOrientation As Boolean) As Boolean
On Error GoTo EH
ExportTempPartToDxf_DirectByAnnotationView = False
If tempPartDoc Is Nothing Then
LogEvent " | FAIL | Direct export: tempPartDoc is Nothing"
Exit Function
End If
If tempPartDoc.GetType <> swDocPART Then
LogEvent " | FAIL | Direct export requires PART doc, got " & DocTypeName(tempPartDoc.GetType)
Exit Function
End If
Dim swTempPart As SldWorks.PartDoc
Set swTempPart = tempPartDoc
Dim alignmentData(0 To 11) As Double
Dim varAlignment As Variant
BuildIdentityDwgAlignment alignmentData
varAlignment = alignmentData
If Not ActivateDocumentByTitle(tempPartDoc.GetTitle) Then
LogEvent " | WARN | Direct export could not explicitly activate temp part"
End If
tempPartDoc.ForceRebuild3 True
If Not HideAllSketchesInModel(tempPartDoc) Then
LogEvent " | WARN | HideAllSketchesInModel returned False immediately before direct DXF export"
End If
If DIRECT_TEMP_PART_FORCE_INCH_UNITS Then
If ForceModelLinearUnitsToInches(tempPartDoc) Then
LogEvent " | INFO | Direct export temp part linear units = INCHES"
Else
LogEvent " | WARN | Direct export could not confirm INCH units on temp part"
End If
End If
If Not FAST_MODE_MINIMIZE_EXTRA_REDRAWS Then tempPartDoc.GraphicsRedraw2
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then
tempPartDoc.ViewZoomtofit2
Else
LogEvent " | INFO | Direct temp-part ViewZoomtofit2 skipped for batch stability"
End If
LogEvent " | INFO | Direct export preserveCornerOrientation = " & CStr(preserveCornerOrientation)
LogEvent " | INFO | Direct export requested view name = [" & modelViewName & "]"
If TryDirectExportToDxfByViewName(swTempPart, tempPartPath, finalDxfPath, modelViewName, varAlignment) Then
ExportTempPartToDxf_DirectByAnnotationView = True
Exit Function
End If
If EXPERIMENTAL_DIRECT_ALLOW_CURRENT_VIEW_FALLBACK Then
LogEvent " | WARN | Experimental direct export by named view failed; trying *Current fallback"
If TryDirectExportToDxfByViewName(swTempPart, tempPartPath, finalDxfPath, "*Current", varAlignment) Then
ExportTempPartToDxf_DirectByAnnotationView = True
Exit Function
End If
Else
LogEvent " | INFO | *Current fallback disabled to avoid losing deterministic orientation"
End If
Exit Function
EH:
LogEvent " | ERROR | ExportTempPartToDxf_DirectByAnnotationView: " & Err.Number & " - " & Err.Description
End Function
Private Function TryDirectExportToDxfByViewName(ByVal swTempPart As SldWorks.PartDoc, _
ByVal modelPath As String, _
ByVal finalDxfPath As String, _
ByVal viewName As String, _
ByVal varAlignment As Variant) As Boolean
On Error GoTo EH
Dim dataViews(0 To 0) As String
Dim varViews As Variant
Dim resultVar As Variant
Dim ok As Boolean
TryDirectExportToDxfByViewName = False
dataViews(0) = viewName
varViews = dataViews
DeleteFileIfExists finalDxfPath
LogEvent " | INFO | Direct ExportToDWG2 start"
LogEvent " | INFO | modelPath = " & modelPath
LogEvent " | INFO | finalDxfPath = " & finalDxfPath
LogEvent " | INFO | viewName = " & viewName
On Error Resume Next
resultVar = CallByName(swTempPart, "ExportToDWG2", VbMethod, _
finalDxfPath, _
modelPath, _
SW_EXPORT_TO_DWG_ANNOTATION_VIEWS, _
True, _
varAlignment, _
False, _
False, _
0, _
varViews)
If Err.Number <> 0 Then
LogEvent " | WARN | CallByName ExportToDWG2 failed for [" & viewName & "]: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
ok = False
On Error Resume Next
ok = CBool(resultVar)
On Error GoTo EH
LogEvent " | INFO | ExportToDWG2 result = " & CStr(ok)
If Not ok Then Exit Function
If Not FileExists(finalDxfPath) Then
LogEvent " | WARN | ExportToDWG2 returned True but output file not found"
Exit Function
End If
If GetFileSizeSafe(finalDxfPath) <= 0 Then
LogEvent " | WARN | ExportToDWG2 created zero-byte DXF"
Exit Function
End If
LogEvent " | INFO | Direct ExportToDWG2 succeeded. File size = " & CStr(GetFileSizeSafe(finalDxfPath))
TryDirectExportToDxfByViewName = True
Exit Function
EH:
LogEvent " | ERROR | TryDirectExportToDxfByViewName(" & viewName & "): " & Err.Number & " - " & Err.Description
End Function
Private Sub BuildIdentityDwgAlignment(ByRef alignmentData() As Double)
alignmentData(0) = 0#
alignmentData(1) = 0#
alignmentData(2) = 0#
alignmentData(3) = 1#
alignmentData(4) = 0#
alignmentData(5) = 0#
alignmentData(6) = 0#
alignmentData(7) = 1#
alignmentData(8) = 0#
alignmentData(9) = 0#
alignmentData(10) = 0#
alignmentData(11) = 1#
End Sub
Private Function ActivateDocumentByTitle(ByVal docTitle As String) As Boolean
On Error GoTo EH
ActivateDocumentByTitle = False
If Len(Trim$(docTitle)) = 0 Then Exit Function
Dim actErr As Long
Dim mdl As SldWorks.ModelDoc2
Set mdl = swApp.ActivateDoc3(docTitle, False, 0, actErr)
LogEvent " | INFO | ActivateDoc3 [" & docTitle & "] err=" & actErr
If Not mdl Is Nothing Then
ActivateDocumentByTitle = True
Exit Function
End If
If Not swApp.ActiveDoc Is Nothing Then
If StrComp(swApp.ActiveDoc.GetTitle, docTitle, vbTextCompare) = 0 Then
ActivateDocumentByTitle = True
End If
End If
Exit Function
EH:
LogEvent " | ERROR | ActivateDocumentByTitle(" & docTitle & "): " & Err.Number & " - " & Err.Description
End Function
Private Function ForceModelLinearUnitsToInches(ByVal mdl As SldWorks.ModelDoc2) As Boolean
On Error GoTo EH
ForceModelLinearUnitsToInches = False
If mdl Is Nothing Then Exit Function
Dim beforeUnits As Long
Dim afterUnits As Long
On Error Resume Next
beforeUnits = mdl.GetUserPreferenceIntegerValue(swUnitsLinear)
Err.Clear
On Error GoTo EH
LogEvent " | INFO | ForceModelLinearUnitsToInches before = " & CStr(beforeUnits)
mdl.SetUserPreferenceIntegerValue swUnitsLinear, swINCHES
On Error Resume Next
afterUnits = mdl.GetUserPreferenceIntegerValue(swUnitsLinear)
Err.Clear
On Error GoTo EH
LogEvent " | INFO | ForceModelLinearUnitsToInches after = " & CStr(afterUnits)
ForceModelLinearUnitsToInches = (afterUnits = swINCHES)
Exit Function
EH:
LogEvent " | ERROR | ForceModelLinearUnitsToInches: " & Err.Number & " - " & Err.Description
End Function
Private Sub CloseModelDocSafe(ByRef mdl As SldWorks.ModelDoc2)
On Error Resume Next
If mdl Is Nothing Then Exit Sub
Dim ttl As String
ttl = mdl.GetTitle
If Len(ttl) > 0 Then
swApp.CloseDoc ttl
End If
Set mdl = Nothing
End Sub
Private Function GetFileSizeSafe(ByVal filePath As String) As Double
On Error GoTo EH
GetFileSizeSafe = 0#
If Not FileExists(filePath) Then Exit Function
GetFileSizeSafe = CDbl(FileLen(filePath))
Exit Function
EH:
GetFileSizeSafe = 0#
End Function
Private Function GetDxfExportModeName() As String
If USE_FAST_MODE Then
If USE_EXPERIMENTAL_FAST_DIRECT_DXF Then
If TEMP_PART_EXPORT_USE_CURRENT_VIEW_V15_ROTATION Then
If TEMP_PART_NAMED_VIEW_EXPORT_FALLBACK Then
GetDxfExportModeName = "FAST_MODE_TEMP_PART_CURRENT_VIEW_V15_ROTATION_WITH_NAMED_VIEW_FALLBACK"
Else
GetDxfExportModeName = "FAST_MODE_TEMP_PART_CURRENT_VIEW_V15_ROTATION_ONLY"
End If
ElseIf EXPERIMENTAL_DIRECT_FALLBACK_TO_DRAWING Then
GetDxfExportModeName = "FAST_MODE_DIRECT_PART_EXPORT_WITH_MANUAL_DRAWING_FALLBACK"
Else
GetDxfExportModeName = "FAST_MODE_DIRECT_PART_EXPORT_ONLY"
End If
Else
GetDxfExportModeName = "FAST_MODE_DIRECT_PART_EXPORT_DISABLED"
End If
Else
GetDxfExportModeName = "LEGACY_SAFE_MODE"
End If
End Function
Private Function ShouldAttemptFastDirectDxfExport(ByVal preserveCornerOrientation As Boolean) As Boolean
ShouldAttemptFastDirectDxfExport = False
If Not USE_FAST_MODE Then Exit Function
If Not USE_EXPERIMENTAL_FAST_DIRECT_DXF Then Exit Function
LogEvent " | INFO | Direct part-export path enabled. preserveCornerOrientation=" & CStr(preserveCornerOrientation)
ShouldAttemptFastDirectDxfExport = True
End Function
Private Function ExportTempPartToDxf_ByNamedViewDrawing(ByVal tempPartDoc As SldWorks.ModelDoc2, _
ByVal tempPartPath As String, _
ByVal tempDrwPath As String, _
ByVal finalDxfPath As String, _
ByVal modelViewName As String, _
ByRef xDir() As Double, _
ByRef faceNormal() As Double, _
ByVal preserveCornerOrientation As Boolean) As Boolean
On Error GoTo EH
ExportTempPartToDxf_ByNamedViewDrawing = False
If tempPartDoc Is Nothing Then
LogEvent " | FAIL | Drawing fallback: tempPartDoc is Nothing"
Exit Function
End If
If Len(Trim$(tempPartPath)) = 0 Or Not FileExists(tempPartPath) Then
LogEvent " | FAIL | Drawing fallback: temp part path is invalid/missing: " & tempPartPath
Exit Function
End If
Dim drwTemplate As String
drwTemplate = GetDrawingTemplatePath()
If Len(drwTemplate) = 0 Then
LogEvent " | FAIL | No drawing template available for export"
Exit Function
End If
Dim bbox As Variant
bbox = GetFirstBodyBoxFromPart(tempPartDoc)
Dim w As Double, h As Double
If Not IsEmpty(bbox) Then
w = Abs(CDbl(bbox(3)) - CDbl(bbox(0))) + 2# * SHEET_MARGIN_M
h = Abs(CDbl(bbox(4)) - CDbl(bbox(1))) + 2# * SHEET_MARGIN_M
Else
w = MIN_SHEET_W_M
h = MIN_SHEET_H_M
End If
If w < MIN_SHEET_W_M Then w = MIN_SHEET_W_M
If h < MIN_SHEET_H_M Then h = MIN_SHEET_H_M
LogEvent " | INFO | Drawing export sheet size (m) = " & FormatNumber(w, 4) & " x " & FormatNumber(h, 4)
LogEvent " | INFO | Creating drawing view from model view [" & modelViewName & "]"
Dim drwDoc As SldWorks.ModelDoc2
Set drwDoc = swApp.NewDocument(drwTemplate, swDwgPapersUserDefined, w, h)
If drwDoc Is Nothing Then
LogEvent " | FAIL | New drawing creation failed"
Exit Function
End If
Dim drw As SldWorks.DrawingDoc
Set drw = drwDoc
Dim viewX As Double, viewY As Double
viewX = w / 2#
viewY = h / 2#
Dim v As SldWorks.View
Set v = drw.CreateDrawViewFromModelView3(tempPartPath, modelViewName, viewX, viewY, 0#)
If v Is Nothing Then
LogEvent " | FAIL | CreateDrawViewFromModelView3 returned Nothing for view [" & modelViewName & "]"
GoTo CleanupAndExit
End If
On Error Resume Next
v.UseSheetScale = False
v.ScaleDecimal = 1#
On Error GoTo EH
drwDoc.ForceRebuild3 True
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then drwDoc.ViewZoomtofit2
If CorrectDrawingViewRoll(v, xDir, faceNormal, preserveCornerOrientation) Then
drwDoc.ForceRebuild3 True
If Not AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH Then drwDoc.ViewZoomtofit2
Else
LogEvent " | WARN | CorrectDrawingViewRoll did not make a change"
End If
If Not TrySaveModelToPath(drwDoc, tempDrwPath) Then
LogEvent " | WARN | Temp drawing save failed; continuing DXF save"
End If
Dim errs As Long, warns As Long
errs = 0: warns = 0
If drwDoc.Extension.SaveAs(finalDxfPath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, errs, warns) Then
LogEvent " | INFO | Drawing SaveAs DXF succeeded. errs=" & errs & " warns=" & warns
If FileExists(finalDxfPath) Then
If GetFileSizeSafe(finalDxfPath) > 0 Then
ExportTempPartToDxf_ByNamedViewDrawing = True
Else
LogEvent " | WARN | Drawing fallback created zero-byte DXF"
End If
Else
LogEvent " | WARN | Drawing SaveAs returned True but DXF file was not found"
End If
Else
LogEvent " | FAIL | Drawing SaveAs DXF failed. errs=" & errs & " warns=" & warns
End If
CleanupAndExit:
CloseModelDocSafe drwDoc
Exit Function
EH:
LogEvent " | ERROR | ExportTempPartToDxf_ByNamedViewDrawing: " & Err.Number & " - " & Err.Description
Resume CleanupAndExit
End Function
Private Function CorrectDrawingViewRoll(ByVal v As SldWorks.View, _
ByRef xDir() As Double, _
ByRef faceNormal() As Double, _
ByVal preserveCornerOrientation As Boolean) As Boolean
On Error GoTo EH
CorrectDrawingViewRoll = False
If v Is Nothing Then Exit Function
Dim ang As Double
If GetModelVectorAngleInView(v, xDir, ang) Then
LogEvent " | INFO | View roll correction angle = " & FormatNumber(RadToDeg(ang), 4) & " deg"
Dim curAngle As Double
curAngle = 0#
On Error Resume Next
curAngle = CDbl(CallByName(v, "Angle", VbGet))
If Err.Number <> 0 Then
LogEvent " | WARN | Could not read View.Angle: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Else
CallByName v, "Angle", VbLet, (curAngle - ang)
If Err.Number <> 0 Then
LogEvent " | WARN | Could not write View.Angle: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Else
CorrectDrawingViewRoll = True
End If
End If
On Error GoTo EH
Else
LogEvent " | WARN | Could not determine in-view angle for xDir"
End If
Dim outline As Variant
outline = v.GetOutline
If VariantHasAtLeast4Numbers(outline) Then
Dim width As Double, height As Double
width = Abs(CDbl(outline(2)) - CDbl(outline(0)))
height = Abs(CDbl(outline(3)) - CDbl(outline(1)))
LogEvent " | INFO | Post-roll outline W x H = " & FormatNumber(width, 6) & " x " & FormatNumber(height, 6)
If preserveCornerOrientation Then
LogEvent " | INFO | Corner-driven orientation active -> skipping legacy 90-degree width/height auto-rotate"
ElseIf height > width + EPS Then
LogEvent " | INFO | Applying additional +90 deg correction because view is taller than wide"
Dim curAngle2 As Double
curAngle2 = 0#
On Error Resume Next
curAngle2 = CDbl(CallByName(v, "Angle", VbGet))
If Err.Number = 0 Then
CallByName v, "Angle", VbLet, (curAngle2 + PI_VAL / 2#)
If Err.Number = 0 Then
CorrectDrawingViewRoll = True
Else
LogEvent " | WARN | Secondary 90-degree correction failed: " & Err.Number & " - " & Err.Description
Err.Clear
End If
Else
LogEvent " | WARN | Could not read View.Angle for 90-degree correction: " & Err.Number & " - " & Err.Description
Err.Clear
End If
On Error GoTo EH
End If
End If
Dim vx As Double, vy As Double, vz As Double
If TransformModelVectorToView(v, faceNormal, vx, vy, vz) Then
LogEvent " | INFO | Face normal in view coords = (" & _
FormatNumber(vx, 6) & ", " & FormatNumber(vy, 6) & ", " & FormatNumber(vz, 6) & ")"
End If
Exit Function
EH:
LogEvent " | ERROR | CorrectDrawingViewRoll: " & Err.Number & " - " & Err.Description
End Function
Private Function GetModelVectorAngleInView(ByVal v As SldWorks.View, _
ByRef modelVec() As Double, _
ByRef angRad As Double) As Boolean
On Error GoTo EH
GetModelVectorAngleInView = False
angRad = 0#
Dim vx As Double, vy As Double, vz As Double
If Not TransformModelVectorToView(v, modelVec, vx, vy, vz) Then Exit Function
If Abs(vx) <= EPS And Abs(vy) <= EPS Then Exit Function
angRad = Atn2(vy, vx)
GetModelVectorAngleInView = True
Exit Function
EH:
LogEvent " | ERROR | GetModelVectorAngleInView: " & Err.Number & " - " & Err.Description
End Function
Private Function TransformModelVectorToView(ByVal v As SldWorks.View, _
ByRef modelVec() As Double, _
ByRef outX As Double, _
ByRef outY As Double, _
ByRef outZ As Double) As Boolean
On Error GoTo EH
TransformModelVectorToView = False
If v Is Nothing Then Exit Function
Dim mtv As SldWorks.MathTransform
Set mtv = v.ModelToViewTransform
If mtv Is Nothing Then Exit Function
Dim data(2) As Double
data(0) = modelVec(0)
data(1) = modelVec(1)
data(2) = modelVec(2)
Dim mv As SldWorks.MathVector
Set mv = swMathUtil.CreateVector(data)
If mv Is Nothing Then Exit Function
Dim tv As SldWorks.MathVector
Set tv = mv.MultiplyTransform(mtv)
If tv Is Nothing Then Exit Function
Dim arr As Variant
arr = tv.ArrayData
If Not VariantHas3Numbers(arr) Then Exit Function
outX = CDbl(arr(0))
outY = CDbl(arr(1))
outZ = CDbl(arr(2))
TransformModelVectorToView = True
Exit Function
EH:
LogEvent " | ERROR | TransformModelVectorToView: " & Err.Number & " - " & Err.Description
End Function
Private Function VariantHasAtLeast9Numbers(ByVal v As Variant) As Boolean
On Error GoTo EH
VariantHasAtLeast9Numbers = False
If IsEmpty(v) Then Exit Function
If Not IsArray(v) Then Exit Function
Dim lb As Long, ub As Long
lb = LBound(v)
ub = UBound(v)
If (ub - lb + 1) < 9 Then Exit Function
Dim i As Long, tmp As Double
For i = 0 To 8
tmp = CDbl(v(lb + i))
Next i
VariantHasAtLeast9Numbers = True
Exit Function
EH:
VariantHasAtLeast9Numbers = False
End Function
Private Function VariantHasAtLeast4Numbers(ByVal v As Variant) As Boolean
On Error GoTo EH
VariantHasAtLeast4Numbers = False
If IsEmpty(v) Then Exit Function
If Not IsArray(v) Then Exit Function
Dim lb As Long, ub As Long
lb = LBound(v)
ub = UBound(v)
If (ub - lb + 1) < 4 Then Exit Function
Dim i As Long, tmp As Double
For i = 0 To 3
tmp = CDbl(v(lb + i))
Next i
VariantHasAtLeast4Numbers = True
Exit Function
EH:
VariantHasAtLeast4Numbers = False
End Function
Private Function GetFirstBodyBoxFromPart(ByVal mdl As SldWorks.ModelDoc2) As Variant
On Error GoTo EH
Dim p As SldWorks.PartDoc
Set p = mdl
Dim vBodies As Variant
vBodies = p.GetBodies2(swSolidBody, True)
If IsEmpty(vBodies) Then
vBodies = p.GetBodies2(swAllBodies, True)
End If
If IsEmpty(vBodies) Then Exit Function
If Not IsArray(vBodies) Then Exit Function
Dim b As SldWorks.Body2
Set b = vBodies(LBound(vBodies))
If b Is Nothing Then Exit Function
GetFirstBodyBoxFromPart = b.GetBodyBox
Exit Function
EH:
LogEvent " | ERROR | GetFirstBodyBoxFromPart: " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' TEMPLATE HELPERS
'=========================================================================================
Private Function GetPartTemplatePath() As String
On Error GoTo EH
GetPartTemplatePath = Trim$(swApp.GetUserPreferenceStringValue(swDefaultTemplatePart))
If Len(GetPartTemplatePath) = 0 Then
GetPartTemplatePath = Trim$(swApp.GetDocumentTemplate(swDocPART, "", 0#, 0#, 0#))
End If
Exit Function
EH:
LogEvent " | ERROR | GetPartTemplatePath: " & Err.Number & " - " & Err.Description
End Function
Private Function GetDrawingTemplatePath() As String
On Error GoTo EH
If FileExists(CUSTOM_DRAWING_TEMPLATE) Then
GetDrawingTemplatePath = CUSTOM_DRAWING_TEMPLATE
LogEvent " | INFO | Using custom drawing template = " & GetDrawingTemplatePath
Exit Function
End If
LogEvent " | WARN | Custom drawing template not found, falling back"
GetDrawingTemplatePath = Trim$(swApp.GetUserPreferenceStringValue(swDefaultTemplateDrawing))
If Len(GetDrawingTemplatePath) = 0 Then
GetDrawingTemplatePath = Trim$(swApp.GetDocumentTemplate(swDocDRAWING, "", 0#, 0#, 0#))
End If
Exit Function
EH:
LogEvent " | ERROR | GetDrawingTemplatePath: " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' TEMP PATH HELPERS
'=========================================================================================
Private Function HideAllSketchesInModel(ByVal mdl As SldWorks.ModelDoc2) As Boolean
On Error GoTo EH
HideAllSketchesInModel = False
If mdl Is Nothing Then Exit Function
If Not HIDE_SKETCHES_BEFORE_DXF_EXPORT Then
LogEvent " | INFO | Sketch hiding skipped by stability setting HIDE_SKETCHES_BEFORE_DXF_EXPORT=False"
HideAllSketchesInModel = True
Exit Function
End If
If Not ActivateDocumentByTitle(mdl.GetTitle) Then
LogEvent " | WARN | HideAllSketchesInModel could not explicitly activate [" & mdl.GetTitle & "]"
End If
Dim feat As SldWorks.Feature
Dim hiddenCount As Long
Dim visitCount As Long
Set feat = mdl.FirstFeature
Do While Not feat Is Nothing
visitCount = visitCount + 1
HideSketchFeatureRecursive feat, hiddenCount
Set feat = feat.GetNextFeature
Loop
mdl.ClearSelection2 True
mdl.GraphicsRedraw2
LogEvent " | INFO | HideAllSketchesInModel visited top-level features = " & CStr(visitCount) & " | sketches hidden = " & CStr(hiddenCount)
HideAllSketchesInModel = True
Exit Function
EH:
LogEvent " | ERROR | HideAllSketchesInModel: " & Err.Number & " - " & Err.Description
End Function
Private Sub HideSketchFeatureRecursive(ByVal feat As SldWorks.Feature, ByRef hiddenCount As Long)
On Error GoTo EH
If feat Is Nothing Then Exit Sub
Dim typeName As String
typeName = feat.GetTypeName2
If IsSketchFeatureType(typeName) Then
LogEvent " | INFO | Hiding sketch feature [" & feat.Name & "] type=[" & typeName & "]"
If BlankSketchFeatureBySelection(feat) Then
hiddenCount = hiddenCount + 1
Else
LogEvent " | WARN | Could not blank sketch feature [" & feat.Name & "]"
End If
End If
Dim subFeat As SldWorks.Feature
Set subFeat = feat.GetFirstSubFeature
Do While Not subFeat Is Nothing
HideSketchFeatureRecursive subFeat, hiddenCount
Set subFeat = subFeat.GetNextSubFeature
Loop
Exit Sub
EH:
LogEvent " | ERROR | HideSketchFeatureRecursive(" & feat.Name & "): " & Err.Number & " - " & Err.Description
End Sub
Private Function IsSketchFeatureType(ByVal typeName As String) As Boolean
Dim t As String
t = UCase$(Trim$(typeName))
Select Case t
Case "PROFILEFEATURE", "SKETCH", "3DSKETCH", "3DSKETCHPROFILE", "DERIVEDSKETCH"
IsSketchFeatureType = True
Case Else
IsSketchFeatureType = False
End Select
End Function
Private Function BlankSketchFeatureBySelection(ByVal feat As SldWorks.Feature) As Boolean
On Error GoTo EH
BlankSketchFeatureBySelection = False
If feat Is Nothing Then Exit Function
If swApp.ActiveDoc Is Nothing Then Exit Function
swApp.ActiveDoc.ClearSelection2 True
If Not feat.Select2(False, -1) Then
LogEvent " | WARN | Select2 failed while trying to blank sketch [" & feat.Name & "]"
Exit Function
End If
swApp.ActiveDoc.BlankSketch
swApp.ActiveDoc.ClearSelection2 True
BlankSketchFeatureBySelection = True
Exit Function
EH:
LogEvent " | ERROR | BlankSketchFeatureBySelection(" & feat.Name & "): " & Err.Number & " - " & Err.Description
End Function
Private Function GetLocalTempRoot() As String
On Error GoTo EH
Dim baseTemp As String
baseTemp = Trim$(Environ$("TEMP"))
If Len(baseTemp) = 0 Then baseTemp = Trim$(Environ$("TMP"))
If Len(baseTemp) = 0 Then baseTemp = "C:\Temp"
Dim root As String
root = baseTemp & "\" & TEMP_PREFIX & SafeNowStamp()
GetLocalTempRoot = EnsureFolderExists(root)
Exit Function
EH:
LogEvent " | ERROR | GetLocalTempRoot: " & Err.Number & " - " & Err.Description
GetLocalTempRoot = ""
End Function
'=========================================================================================
' FILE / PATH HELPERS
'=========================================================================================
Private Sub WriteRunCompleteFile(ByVal summaryText As String)
On Error GoTo EH
If Not WRITE_RUN_COMPLETE_FILE Then Exit Sub
If Len(Trim$(gEventRootFolder)) = 0 Then Exit Sub
Dim completePath As String
completePath = CombinePathSafe(gEventRootFolder, "RUN_COMPLETE.txt")
Dim content As String
content = "SAVE_ALL_DXF_ACCORDING_TO_MATERIAL_THICKNESS_MACRO" & vbCrLf & _
"Revision: CRASH_SAFE_R10_PRODUCTION_VALIDATION_RIGHT_ANGLE_ORIENTATION" & vbCrLf & _
"Completed: " & TimeStamp() & vbCrLf & _
"Output folder: " & gEventRootFolder & vbCrLf & _
"Source-part direct export disabled: " & CStr(DISABLE_SOURCE_PART_DIRECT_EXPORT_FOR_STABILITY) & vbCrLf & _
"Physical temp-body flatten for DXF orientation: " & CStr(PHYSICALLY_FLATTEN_TEMP_BODY_FOR_DXF) & " (R7 default OFF)" & vbCrLf & _
vbCrLf & _
summaryText & vbCrLf
WriteTextFile completePath, content
LogEvent " | INFO | RUN_COMPLETE written => " & completePath
Exit Sub
EH:
LogEvent " | WARN | WriteRunCompleteFile failed: " & Err.Number & " - " & Err.Description
End Sub
Private Function PrepareRootOutputFolder(ByVal parentFolder As String, ByVal outFolderName As String) As String
On Error GoTo EH
PrepareRootOutputFolder = ""
parentFolder = Trim$(parentFolder)
outFolderName = Trim$(outFolderName)
If Len(parentFolder) = 0 Then Exit Function
If Len(outFolderName) = 0 Then Exit Function
Dim baseRootPath As String
Dim runPath As String
baseRootPath = CombinePathSafe(parentFolder, outFolderName)
' R6 network-safe behavior:
' The root folder is only ensured, not deleted. Each run gets a new child folder.
If Len(EnsureFolderExists(baseRootPath)) = 0 Then
LogEvent " | FAIL | Could not create/access base output root: " & baseRootPath
Exit Function
End If
If USE_TIMESTAMPED_RUN_FOLDER Then
runPath = CombinePathSafe(baseRootPath, BuildRunFolderName())
PrepareRootOutputFolder = EnsureFolderExists(runPath)
LogEvent " | INFO | Base output root = " & baseRootPath
LogEvent " | INFO | Timestamped run output folder = " & PrepareRootOutputFolder
Else
If CLEAR_DXF_ROOT_BEFORE_RUN Then
If Not ClearFolderContentsSafe(baseRootPath, outFolderName) Then
LogEvent " | WARN | DXF root cleanup returned False. Continuing after ensuring folder exists."
End If
Else
LogEvent " | INFO | Cleanup disabled. Reusing base output root without deleting contents: " & baseRootPath
End If
PrepareRootOutputFolder = EnsureFolderExists(baseRootPath)
End If
Exit Function
EH:
LogEvent " | ERROR | PrepareRootOutputFolder(" & parentFolder & ", " & outFolderName & "): " & Err.Number & " - " & Err.Description
End Function
Private Function BuildRunFolderName() As String
On Error GoTo EH
BuildRunFolderName = RUN_FOLDER_PREFIX & Format$(Now, "yyyymmdd_hhnnss")
Exit Function
EH:
BuildRunFolderName = RUN_FOLDER_PREFIX & "UNKNOWN_TIME"
End Function
Private Function ClearFolderContentsSafe(ByVal folderPath As String, ByVal expectedLeafName As String) As Boolean
On Error GoTo EH
ClearFolderContentsSafe = False
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Len(Trim$(folderPath)) = 0 Then Exit Function
If Not fso.FolderExists(folderPath) Then
ClearFolderContentsSafe = True
Exit Function
End If
If Not IsSafeOutputRootForCleanup(folderPath, expectedLeafName) Then
LogEvent " | FAIL | Cleanup refused. Folder did not pass safety check: " & folderPath
Exit Function
End If
LogEvent " | INFO | Clearing previous nesting batch contents from: " & folderPath
Dim fld As Object
Dim fil As Object
Dim subFld As Object
Set fld = fso.GetFolder(folderPath)
For Each fil In fld.Files
LogEvent " | INFO | Delete old output file: " & fil.path
fil.Delete True
Next fil
For Each subFld In fld.SubFolders
LogEvent " | INFO | Delete old output folder: " & subFld.path
subFld.Delete True
Next subFld
ClearFolderContentsSafe = True
Exit Function
EH:
LogEvent " | ERROR | ClearFolderContentsSafe(" & folderPath & "): " & Err.Number & " - " & Err.Description
End Function
Private Function IsSafeOutputRootForCleanup(ByVal folderPath As String, ByVal expectedLeafName As String) As Boolean
On Error GoTo EH
IsSafeOutputRootForCleanup = False
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Len(Trim$(folderPath)) < 6 Then Exit Function
If StrComp(fso.GetFileName(folderPath), expectedLeafName, vbTextCompare) <> 0 Then Exit Function
If StrComp(expectedLeafName, OUT_FOLDER_NAME, vbTextCompare) <> 0 Then Exit Function
IsSafeOutputRootForCleanup = True
Exit Function
EH:
LogEvent " | ERROR | IsSafeOutputRootForCleanup(" & folderPath & "): " & Err.Number & " - " & Err.Description
End Function
Private Function EnsureFolderExists(ByVal folderPath As String) As String
On Error GoTo EH
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
folderPath = Trim$(folderPath)
If Len(folderPath) = 0 Then Exit Function
If fso.FolderExists(folderPath) Then
EnsureFolderExists = folderPath
Exit Function
End If
Dim parentPath As String
parentPath = fso.GetParentFolderName(folderPath)
If Len(parentPath) > 0 Then
If Not fso.FolderExists(parentPath) Then
If Len(EnsureFolderExists(parentPath)) = 0 Then
EnsureFolderExists = ""
Exit Function
End If
End If
End If
If Not fso.FolderExists(folderPath) Then
fso.CreateFolder folderPath
End If
If fso.FolderExists(folderPath) Then
EnsureFolderExists = folderPath
Else
EnsureFolderExists = ""
End If
Exit Function
EH:
LogEvent " | ERROR | EnsureFolderExists(" & folderPath & "): " & Err.Number & " - " & Err.Description
EnsureFolderExists = ""
End Function
Private Function CombinePathSafe(ByVal folderPath As String, ByVal leafName As String) As String
'Builds Windows paths without accidental control characters or double separators.
folderPath = Trim$(folderPath)
leafName = Trim$(leafName)
If Len(folderPath) = 0 Then
CombinePathSafe = leafName
ElseIf Right$(folderPath, 1) = "\" Then
CombinePathSafe = folderPath & leafName
Else
CombinePathSafe = folderPath & "\" & leafName
End If
End Function
Private Function ContainsControlCharacters(ByVal valueText As String) As Boolean
Dim i As Long
Dim c As Integer
ContainsControlCharacters = False
For i = 1 To Len(valueText)
c = Asc(Mid$(valueText, i, 1))
If c >= 0 And c < 32 Then
ContainsControlCharacters = True
Exit Function
End If
Next i
End Function
Private Function GetFolderFromPath(ByVal fullPath As String) As String
Dim p As Long
p = InStrRev(fullPath, "\")
If p > 0 Then
GetFolderFromPath = Left$(fullPath, p - 1)
Else
GetFolderFromPath = ""
End If
End Function
Private Function GetUniqueOutputPath(ByVal folderPath As String, ByVal baseFileNameNoExt As String, ByVal extNoDot As String) As String
On Error GoTo EH
Dim candidate As String
Dim i As Long
candidate = folderPath & "\" & baseFileNameNoExt & "." & extNoDot
If Not FileExists(candidate) Then
GetUniqueOutputPath = candidate
Exit Function
End If
For i = 1 To 9999
candidate = folderPath & "\" & baseFileNameNoExt & "_" & Format$(i, "00") & "." & extNoDot
If Not FileExists(candidate) Then
GetUniqueOutputPath = candidate
Exit Function
End If
Next i
GetUniqueOutputPath = folderPath & "\" & baseFileNameNoExt & "_" & SafeNowStamp() & "." & extNoDot
Exit Function
EH:
LogEvent " | ERROR | GetUniqueOutputPath: " & Err.Number & " - " & Err.Description
End Function
Private Function FileExists(ByVal filePath As String) As Boolean
On Error Resume Next
FileExists = (Len(Dir$(filePath, vbNormal)) > 0)
End Function
Private Function FolderExistsSafe(ByVal folderPath As String) As Boolean
On Error GoTo EH
FolderExistsSafe = False
If Len(Trim$(folderPath)) = 0 Then Exit Function
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
FolderExistsSafe = fso.FolderExists(folderPath)
Exit Function
EH:
LogEvent " | WARN | FolderExistsSafe(" & folderPath & "): " & Err.Number & " - " & Err.Description
FolderExistsSafe = False
End Function
Private Sub DeleteFileIfExists(ByVal filePath As String)
On Error Resume Next
If Len(filePath) > 0 Then
If FileExists(filePath) Then Kill filePath
End If
End Sub
Private Sub DeleteFolderIfEmpty(ByVal folderPath As String)
On Error Resume Next
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(folderPath) Then
If fso.GetFolder(folderPath).Files.Count = 0 And fso.GetFolder(folderPath).SubFolders.Count = 0 Then
fso.DeleteFolder folderPath, True
End If
End If
End Sub
Private Sub CloseDocIfOpen(ByVal filePath As String)
On Error Resume Next
If Len(filePath) = 0 Then Exit Sub
Dim openDoc As SldWorks.ModelDoc2
Set openDoc = swApp.GetOpenDocumentByName(filePath)
If Not openDoc Is Nothing Then
swApp.CloseDoc openDoc.GetTitle
Exit Sub
End If
swApp.CloseDoc GetFileNameFromPath(filePath)
End Sub
Private Function GetFileNameFromPath(ByVal filePath As String) As String
Dim p As Long
p = InStrRev(filePath, "\")
If p > 0 Then
GetFileNameFromPath = Mid$(filePath, p + 1)
Else
GetFileNameFromPath = filePath
End If
End Function
Private Function GetFileStemFromPath(ByVal filePath As String) As String
Dim fileNameOnly As String
Dim p As Long
fileNameOnly = GetFileNameFromPath(filePath)
p = InStrRev(fileNameOnly, ".")
If p > 1 Then
GetFileStemFromPath = Left$(fileNameOnly, p - 1)
Else
GetFileStemFromPath = fileNameOnly
End If
End Function
Private Function SanitizeFileName(ByVal s As String) As String
Dim badChars As Variant
Dim i As Long
s = Trim$(s)
badChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
For i = LBound(badChars) To UBound(badChars)
s = Replace$(s, badChars(i), "_")
Next i
Do While InStr(s, "__") > 0
s = Replace$(s, "__", "_")
Loop
s = Trim$(s)
s = TrimDotsAndSpaces(s)
SanitizeFileName = s
End Function
Private Function TrimDotsAndSpaces(ByVal s As String) As String
Do While Len(s) > 0 And (Right$(s, 1) = "." Or Right$(s, 1) = " ")
s = Left$(s, Len(s) - 1)
Loop
Do While Len(s) > 0 And (Left$(s, 1) = "." Or Left$(s, 1) = " ")
s = Mid$(s, 2)
Loop
TrimDotsAndSpaces = s
End Function
'=========================================================================================
' VECTOR MATH
'=========================================================================================
Private Function VecLength(ByRef v() As Double) As Double
VecLength = Sqr(v(0) * v(0) + v(1) * v(1) + v(2) * v(2))
End Function
Private Sub NormalizeVec(ByRef v() As Double)
Dim L As Double
L = VecLength(v)
If L > EPS Then
v(0) = v(0) / L
v(1) = v(1) / L
v(2) = v(2) / L
End If
End Sub
Private Function DotProduct(ByRef a() As Double, ByRef b() As Double) As Double
DotProduct = a(0) * b(0) + a(1) * b(1) + a(2) * b(2)
End Function
Private Sub CrossProduct(ByRef a() As Double, ByRef b() As Double, ByRef outV() As Double)
outV(0) = a(1) * b(2) - a(2) * b(1)
outV(1) = a(2) * b(0) - a(0) * b(2)
outV(2) = a(0) * b(1) - a(1) * b(0)
End Sub
Private Sub ProjectVectorOntoPlane(ByRef v() As Double, ByRef n() As Double, ByRef outV() As Double)
Dim d As Double
d = DotProduct(v, n)
outV(0) = v(0) - d * n(0)
outV(1) = v(1) - d * n(1)
outV(2) = v(2) - d * n(2)
End Sub
Private Sub StabilizeVectorSign(ByRef v() As Double)
If Abs(v(0)) > EPS Then
If v(0) < 0# Then FlipVec v
ElseIf Abs(v(1)) > EPS Then
If v(1) < 0# Then FlipVec v
ElseIf Abs(v(2)) > EPS Then
If v(2) < 0# Then FlipVec v
End If
End Sub
Private Sub FlipVec(ByRef v() As Double)
v(0) = -v(0)
v(1) = -v(1)
v(2) = -v(2)
End Sub
Private Function CompareVectorLex(ByRef a() As Double, ByRef b() As Double) As Long
If Abs(a(0) - b(0)) > EPS Then
CompareVectorLex = Sgn(a(0) - b(0))
Exit Function
End If
If Abs(a(1) - b(1)) > EPS Then
CompareVectorLex = Sgn(a(1) - b(1))
Exit Function
End If
If Abs(a(2) - b(2)) > EPS Then
CompareVectorLex = Sgn(a(2) - b(2))
Exit Function
End If
CompareVectorLex = 0
End Function
Private Function Distance3(ByRef p0() As Double, ByRef p1() As Double) As Double
Distance3 = Sqr((p1(0) - p0(0)) ^ 2 + (p1(1) - p0(1)) ^ 2 + (p1(2) - p0(2)) ^ 2)
End Function
Private Function Dbl3ToStr(ByRef v() As Double) As String
Dbl3ToStr = FormatNumber(v(0), 8) & ", " & FormatNumber(v(1), 8) & ", " & FormatNumber(v(2), 8)
End Function
Private Function Atn2(ByVal y As Double, ByVal x As Double) As Double
If Abs(x) < EPS Then
If y > 0# Then
Atn2 = PI_VAL / 2#
ElseIf y < 0# Then
Atn2 = -PI_VAL / 2#
Else
Atn2 = 0#
End If
ElseIf x > 0# Then
Atn2 = Atn(y / x)
ElseIf x < 0# Then
If y >= 0# Then
Atn2 = Atn(y / x) + PI_VAL
Else
Atn2 = Atn(y / x) - PI_VAL
End If
End If
End Function
Private Function RadToDeg(ByVal rad As Double) As Double
RadToDeg = rad * 180# / PI_VAL
End Function
'=========================================================================================
' STRING / LOG HELPERS
'=========================================================================================
Private Function NzStr(ByVal s As String) As String
NzStr = Trim$(s & "")
End Function
'=========================================================================================
' PERSISTENT EVENT LOGGER
'=========================================================================================
Private Sub ResetEventLoggerState()
On Error Resume Next
gEventLogReady = False
gEventLogPath = ""
gEventLastPath = ""
gEventStatePath = ""
gEventRootFolder = ""
gEventSeq = 0
gEventLastLine = ""
gEventRunLabel = ""
gEventLastStage = ""
Set gEventPendingLines = New Collection
End Sub
Private Sub InitializeEventLogger(ByVal dxfRootFolder As String, ByVal runLabel As String)
On Error GoTo EH
If Not ENABLE_PERSISTENT_EVENT_LOGGER Then Exit Sub
gEventRootFolder = Trim$(dxfRootFolder)
gEventRunLabel = Trim$(runLabel)
If Len(gEventRunLabel) = 0 Then gEventRunLabel = "RUN"
If Len(gEventRootFolder) = 0 Then Exit Sub
gEventLogPath = CombinePathSafe(gEventRootFolder, EVENT_LOG_FILE_NAME)
gEventLastPath = CombinePathSafe(gEventRootFolder, EVENT_LAST_FILE_NAME)
gEventStatePath = CombinePathSafe(gEventRootFolder, EVENT_STATE_FILE_NAME)
If ContainsControlCharacters(gEventLogPath) Or ContainsControlCharacters(gEventLastPath) Or ContainsControlCharacters(gEventStatePath) Then
Debug.Print TimeStamp() & " | ERROR | Event logger path contains a control character. Logger disabled."
Exit Sub
End If
gEventLogReady = True
' Start each macro run with a fresh event log after the DXF root cleanup has completed.
WriteTextFileANSI gEventLogPath, _
"SAVE_ALL_DXF event log" & vbCrLf & _
"Started: " & TimeStamp() & vbCrLf & _
"Run label: " & gEventRunLabel & vbCrLf & _
"DXF root: " & gEventRootFolder & vbCrLf & _
String(110, "=") & vbCrLf, False
LogEventRaw String(110, "=")
LogEvent " | LOGGER | Persistent event logger initialized"
LogEvent " | LOGGER | Log path = " & gEventLogPath
LogEvent " | LOGGER | Last path = " & gEventLastPath
LogEvent " | LOGGER | State path= " & gEventStatePath
LogEvent " | LOGGER | Echo to Immediate Window = " & CStr(EVENT_LOG_ECHO_TO_IMMEDIATE)
FlushPendingEventLines
Exit Sub
EH:
On Error Resume Next
Debug.Print TimeStamp() & " | ERROR | InitializeEventLogger: " & Err.Number & " - " & Err.Description
End Sub
Private Sub LogEvent(ByVal messageText As String)
On Error GoTo EH
Dim cleanMessage As String
cleanMessage = CStr(messageText)
If Len(cleanMessage) > 0 Then
If Left$(cleanMessage, 1) = " " Then
cleanMessage = TimeStamp() & cleanMessage
Else
cleanMessage = TimeStamp() & " | " & cleanMessage
End If
Else
cleanMessage = TimeStamp()
End If
LogEventLine cleanMessage
Exit Sub
EH:
On Error Resume Next
Debug.Print TimeStamp() & " | ERROR | LogEvent internal failure: " & Err.Number & " - " & Err.Description
End Sub
Private Sub LogEventRaw(ByVal rawText As String)
On Error GoTo EH
LogEventLine CStr(rawText)
Exit Sub
EH:
On Error Resume Next
Debug.Print TimeStamp() & " | ERROR | LogEventRaw internal failure: " & Err.Number & " - " & Err.Description
End Sub
Private Sub LogEventLine(ByVal lineText As String)
On Error GoTo EH
Dim finalLine As String
gEventSeq = gEventSeq + 1
finalLine = Right$("00000000" & CStr(gEventSeq), 8) & " | " & lineText
gEventLastLine = finalLine
If EVENT_LOG_ECHO_TO_IMMEDIATE Then
Debug.Print finalLine
End If
If ENABLE_PERSISTENT_EVENT_LOGGER And gEventLogReady And Len(gEventLogPath) > 0 Then
AppendLineToTextFileANSI gEventLogPath, finalLine
WriteTextFileANSI gEventLastPath, finalLine & vbCrLf, False
WriteEventStateFile finalLine
Else
BufferEventLine finalLine
End If
Exit Sub
EH:
On Error Resume Next
If EVENT_LOG_ECHO_TO_IMMEDIATE Then Debug.Print TimeStamp() & " | ERROR | LogEventLine internal failure: " & Err.Number & " - " & Err.Description
End Sub
Private Sub BufferEventLine(ByVal finalLine As String)
On Error Resume Next
If gEventPendingLines Is Nothing Then Set gEventPendingLines = New Collection
If gEventPendingLines.Count < EVENT_LOG_MAX_BUFFER_BEFORE_INIT Then
gEventPendingLines.Add finalLine
End If
End Sub
Private Sub FlushPendingEventLines()
On Error GoTo EH
If gEventPendingLines Is Nothing Then Exit Sub
If Not gEventLogReady Then Exit Sub
Dim i As Long
For i = 1 To gEventPendingLines.Count
AppendLineToTextFileANSI gEventLogPath, CStr(gEventPendingLines(i))
Next i
Set gEventPendingLines = New Collection
Exit Sub
EH:
On Error Resume Next
Debug.Print TimeStamp() & " | ERROR | FlushPendingEventLines: " & Err.Number & " - " & Err.Description
End Sub
Private Sub WriteEventStateFile(ByVal finalLine As String)
On Error GoTo EH
If Not ENABLE_PERSISTENT_EVENT_LOGGER Then Exit Sub
If Len(gEventStatePath) = 0 Then Exit Sub
Dim s As String
s = "{" & vbCrLf & _
" ""eventSeq"": " & CStr(gEventSeq) & "," & vbCrLf & _
" ""timestamp"": """ & JsonEscape(TimeStamp()) & """," & vbCrLf & _
" ""runLabel"": """ & JsonEscape(gEventRunLabel) & """," & vbCrLf & _
" ""lastEvent"": """ & JsonEscape(finalLine) & """," & vbCrLf & _
" ""totalChecked"": " & CStr(gTotalChecked) & "," & vbCrLf & _
" ""totalEligible"": " & CStr(gTotalEligible) & "," & vbCrLf & _
" ""totalExported"": " & CStr(gTotalExported) & "," & vbCrLf & _
" ""totalSkipped"": " & CStr(gTotalSkipped) & "," & vbCrLf & _
" ""totalFailed"": " & CStr(gTotalFailed) & "," & vbCrLf & _
" ""totalQtyAccumulated"": " & CStr(gTotalQtyAccumulated) & "," & vbCrLf & _
" ""totalImmediateJsonFlushes"": " & CStr(gTotalImmediateJsonFlushes) & "," & vbCrLf & _
" ""eventLogPath"": """ & JsonEscape(gEventLogPath) & """" & vbCrLf & _
"}"
WriteTextFileANSI gEventStatePath, s, False
Exit Sub
EH:
On Error Resume Next
End Sub
Private Sub AppendLineToTextFileANSI(ByVal filePath As String, ByVal lineText As String)
On Error GoTo EH
If Len(Trim$(filePath)) = 0 Then Exit Sub
Dim ff As Integer
ff = FreeFile
Open filePath For Append As #ff
Print #ff, lineText
Close #ff
Exit Sub
EH:
On Error Resume Next
If ff <> 0 Then Close #ff
End Sub
Private Function WriteTextFileANSI(ByVal filePath As String, ByVal textOut As String, ByVal appendMode As Boolean) As Boolean
On Error GoTo EH
WriteTextFileANSI = False
If Len(Trim$(filePath)) = 0 Then Exit Function
Dim ff As Integer
ff = FreeFile
If appendMode Then
Open filePath For Append As #ff
Else
Open filePath For Output As #ff
End If
Print #ff, textOut;
Close #ff
WriteTextFileANSI = True
Exit Function
EH:
On Error Resume Next
If ff <> 0 Then Close #ff
End Function
Private Function TimeStamp() As String
TimeStamp = Format$(Now, "yyyy-mm-dd hh:nn:ss")
End Function
Private Function SafeNowStamp() As String
SafeNowStamp = Format$(Now, "yyyymmdd_hhnnss")
End Function
Procedure index · 242 declarations
File checksum
SHA-256: 1095df3ab6206913ef2e2a9767db9b379eb20723276a0be2b8242065ff8a3027