DXF & fabrication · Active export / V15 header
Active-Document Waterjet DXF Export
A SolidWorks VBA exporter for cut-list bodies using manufacturing properties and geometry-aware orientation.
ENGINEERING CONTRIBUTION
Integrated assembly recursion, unique part/configuration handling, export eligibility rules, and view-orientation logic.
Prerequisites
- SolidWorks VBA on Windows; a saved part, assembly, or a drawing with the intended view selected.
- DXF=YES manufacturing properties on eligible cut-list items or qualifying regular parts; DXY is a legacy fallback.
- Configure local drawing templates and verify the intended source configuration and output units.
Additional setup
- Configure CUSTOM_DRAWING_TEMPLATE when using drawing-based export routes.
SOURCE WALKTHROUGH
How the workflow fits together.
- 01
Dispatch by document type
main validates the active model, handles parts or assemblies, or resolves the selected drawing view's referenced part/configuration and orientation.
- 02
Gate and deduplicate
Assembly traversal processes unique part/configuration combinations. Evaluated DXF properties gate eligible cut-list items; regular parts use separate part-level rules.
- 03
Orient manufacturing geometry
Largest planar faces and a staged tab-aware/shared-corner/virtual-corner/longest-edge decision stack establish an export frame.
- 04
Export and normalize
Direct and temporary-part routes produce DXFs in WATERJET_DXF. Postprocessing corrects 2D roll/orientation; duplicate output names receive suffixes.
Output & model changes
- Creates output folders, DXFs and temporary documents/files.
- Can activate configurations, hide sketches, change views and rebuild models during export.
- The direct temporary-part toggle forces inch units; confirm the downstream DXF scale.
CODE & ENTRY POINTS
Read the implementation.
Find a procedure, follow an API call or download the module for your SolidWorks setup.
ActiveDocumentDxf.bas
Active-document export dispatcher, cut-list eligibility checks, configuration traversal, geometry-based export orientation and DXF postprocessing.
VBA · 6,702 lines
Entry points
API & integration calls
Attribute VB_Name = "AUTO_DXF_SAVE1"
Option Explicit
'=========================================================================================
' WATERJET_DXF_FROM_WELDMENT_CUTLIST_V15_DRAWING_VIEW_ORIENTATION
'
' 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 largest planar face as export normal
' - If configuration WATERJET_CUT exists, that configuration is used for nesting/export
' - Otherwise uses the referenced / active configuration as normal
' - 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>\WATERJET_DXF
' - Multi-body uses PART NUMBER.dxf; single-body parts use saved part file name directly
' - 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 = "WATERJET_DXF"
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_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"
'------------------------------------------
' 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
'------------------------------------------
' Orientation logic imported from SAVE_ALL_DXF_ACCORDING_TO_MATERIAL_THICKNESS_MACRO
'------------------------------------------
' Keeps AUTO DXF SAVE output/naming behavior, but uses the newer orientation decision stack:
' 1) optional tab-aware gusset manufacturing-corner detector
' 2) shared-corner right-angle pair
' 3) longer non-intersecting virtual-corner pair for chamfer-ignore behavior
' 4) longest single-edge fallback
' 5) final DXF 2D postprocess to correct SolidWorks current/named-view roll drift
Private Const AUTO_ORIENTATION_SOURCE_VERSION As String = "SAVE_ALL_R11_ORIENTATION_STACK"
Private Const AVOID_VIEW_ZOOM_TO_FIT_DURING_BATCH As Boolean = True
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
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
' ExportToDWG2 action value (compile-safe)
Private Const SW_EXPORT_TO_DWG_ANNOTATION_VIEWS As Long = 3
'------------------------------------------
' 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
'------------------------------------------
' 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
Debug.Print String(110, "=")
Debug.Print TimeStamp() & " | START | WATERJET_DXF_FROM_WELDMENT_CUTLIST_V15_DRAWING_VIEW_ORIENTATION"
Debug.Print TimeStamp() & " | INFO | Orientation stack imported from " & AUTO_ORIENTATION_SOURCE_VERSION
Debug.Print TimeStamp() & " | INFO | Tab-aware gusset orientation = " & CStr(ENABLE_TAB_AWARE_GUSSET_MODE)
Debug.Print TimeStamp() & " | INFO | DXF post-export orientation normalization = " & CStr(POSTPROCESS_DXF_ORIENTATION_TO_HORIZONTAL)
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 = EnsureFolderExists(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
Debug.Print TimeStamp() & " | INFO | Output folder = " & partOutDir
Debug.Print TimeStamp() & " | INFO | Running in PART mode"
Call ProcessPartDocument(swModel, partOutDir, GetActiveConfigurationName(swModel), swModel.GetPathName, swModel.GetTitle)
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 = EnsureFolderExists(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
Debug.Print TimeStamp() & " | INFO | Output folder = " & assyOutDir
Debug.Print TimeStamp() & " | INFO | Running in ASSEMBLY mode"
Call ProcessAssemblyDocument(swModel, assyOutDir)
Case swDocDRAWING
Debug.Print TimeStamp() & " | 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
Dim summary As String
summary = BuildSummaryText(summaryDocType)
Debug.Print TimeStamp() & " | DONE | " & Replace(summary, vbCrLf, " | ")
Debug.Print String(110, "=")
MsgBox summary, vbInformation, "Waterjet DXF Export Summary"
Exit Sub
EH:
Debug.Print TimeStamp() & " | 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 = "Waterjet DXF export 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
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
Debug.Print TimeStamp() & " | INFO | Active model = " & mdl.GetTitle
Debug.Print TimeStamp() & " | INFO | Path = " & mdl.GetPathName
Debug.Print TimeStamp() & " | INFO | Type = " & DocTypeName(mdl.GetType)
ValidateActiveModel = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
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"
Debug.Print TimeStamp() & " | FAIL | No selected drawing view could be resolved"
Exit Function
End If
gDrawingSelectedViewMode = True
gDrawingSelectedViewName = NzStr(selView.Name)
Debug.Print String(100, "-")
Debug.Print TimeStamp() & " | INFO | DRAWING SELECTED-VIEW MODE"
Debug.Print TimeStamp() & " | INFO | Drawing title | " & drawingTitle
Debug.Print TimeStamp() & " | 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"
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Referenced part | " & partMdl.GetTitle
Debug.Print TimeStamp() & " | INFO | Part path | " & gDrawingSelectedViewModelPath
Debug.Print TimeStamp() & " | 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"
Debug.Print TimeStamp() & " | FAIL | Referenced part path is blank"
GoTo CleanupAndExit
End If
Dim outDir As String
outDir = EnsureFolderExists(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
Debug.Print TimeStamp() & " | FAIL | Could not create output folder for drawing-selected-view mode"
GoTo CleanupAndExit
End If
Debug.Print TimeStamp() & " | INFO | Output folder | " & outDir
If Not SetOrientationOverrideFromDrawingView(selView) Then
MsgBox "Could not read orientation from the selected drawing view.", vbCritical, "Waterjet DXF Export"
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | Drawing SelectionManager is Nothing"
Exit Function
End If
Dim selCount As Long
selCount = selMgr.GetSelectedObjectCount2(-1)
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Resolved drawing view from selected object context"
Set GetSelectedDrawingViewFromActiveDrawing = objView
Exit Function
End If
Debug.Print TimeStamp() & " | WARN | Could not resolve selected drawing view"
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | ReferencedDocument unavailable on view [" & NzStr(curView.Name) & "] -> trying base view [" & NzStr(baseView.Name) & "]"
Set curView = baseView
Next depth
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | ReferencedDocument returned loaded model [" & mdl.GetTitle & "] type=" & DocTypeName(mdl.GetType)
If mdl.GetType = swDocPART Then
Set GetDrawingViewReferencedPartDocument = mdl
Else
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | GetReferencedModelName failed on drawing view [" & NzStr(refView.Name) & "]: " & Err.Number & " - " & Err.Description
Err.Clear
End If
On Error GoTo EH
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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) & "]"
Debug.Print TimeStamp() & " | INFO | Drawing-view orientation override enabled"
Debug.Print TimeStamp() & " | INFO | X override = (" & Dbl3ToStr(gOrientationOverrideX) & ")"
Debug.Print TimeStamp() & " | INFO | Z override = (" & Dbl3ToStr(gOrientationOverrideZ) & ")"
SetOrientationOverrideFromDrawingView = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | Drawing view ModelToViewTransform is Nothing"
Exit Function
End If
Dim arr As Variant
arr = mtv.ArrayData
If Not VariantHasAtLeast9Numbers(arr) Then
Debug.Print TimeStamp() & " | 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))
Debug.Print TimeStamp() & " | INFO | Drawing view raw transform rows:"
Debug.Print TimeStamp() & " | INFO | RowX = (" & Dbl3ToStr(xDir) & ")"
Debug.Print TimeStamp() & " | INFO | RowY = (" & Dbl3ToStr(yDir) & ")"
Debug.Print TimeStamp() & " | INFO | RowZ = (" & Dbl3ToStr(zDir) & ")"
If VecLength(xDir) <= EPS Or VecLength(zDir) <= EPS Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | Drawing view transform produced near-parallel X/Z vectors"
Exit Function
End If
Debug.Print TimeStamp() & " | INFO | Drawing view normalized orientation axes:"
Debug.Print TimeStamp() & " | INFO | X = (" & Dbl3ToStr(xDir) & ")"
Debug.Print TimeStamp() & " | INFO | Z = (" & Dbl3ToStr(zDir) & ")"
GetOrientationAxesFromDrawingView = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Switching part config from [" & oldCfg & "] to [" & effectiveConfig & "] for " & sourceLabel
If ActivateModelConfiguration(partMdl, effectiveConfig) Then
switchedCfg = True
Else
Debug.Print TimeStamp() & " | WARN | Could not switch to configuration [" & effectiveConfig & "] for " & sourceLabel & ". Continuing with active config [" & oldCfg & "]"
End If
End If
End If
partMdl.ForceRebuild3 True
Debug.Print String(100, "-")
Debug.Print TimeStamp() & " | INFO | PROCESS PART | " & sourceLabel
Debug.Print TimeStamp() & " | INFO | Source path | " & sourcePath
Debug.Print TimeStamp() & " | INFO | Requested cfg| " & targetConfig
Debug.Print TimeStamp() & " | INFO | Nesting cfg | " & effectiveConfig
Debug.Print TimeStamp() & " | INFO | Active cfg | " & GetActiveConfigurationName(partMdl)
If gHasOrientationOverride Then
Debug.Print TimeStamp() & " | INFO | Orientation | OVERRIDE ACTIVE -> " & gOrientationOverrideLabel
End If
If Not UpdateAllCutLists(partMdl) Then
Debug.Print TimeStamp() & " | WARN | Cut-list update returned False / partial"
End If
hasRealCutList = PartHasRealCutList(partMdl)
Debug.Print TimeStamp() & " | INFO | Real cut-list detected = " & CStr(hasRealCutList)
If hasRealCutList Then
ProcessCutLists partMdl, outDir
Else
ProcessRegularPart partMdl, outDir
End If
Cleanup:
If switchedCfg Then
Debug.Print TimeStamp() & " | INFO | Restoring original part config [" & oldCfg & "] for " & sourceLabel
Call ActivateModelConfiguration(partMdl, oldCfg)
partMdl.ForceRebuild3 True
End If
Exit Sub
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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")
Debug.Print TimeStamp() & " | INFO | Beginning recursive assembly traversal from root: " & rootComp.Name2
WalkAssemblyTree rootComp, outDir, dictPartCfg, dictAsmCfg
Exit Sub
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | Child component is Nothing"
GoTo NextChild
End If
If IsComponentSuppressedSafe(child) Then
gTotalSuppressedSkipped = gTotalSuppressedSkipped + 1
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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 = UCase$(compPath) & "|" & UCase$(effectivePartCfg)
If Not dictPartCfg.Exists(uniqueKey) Then
dictPartCfg.Add uniqueKey, True
gTotalUniquePartConfigs = gTotalUniquePartConfigs + 1
Debug.Print String(90, "-")
Debug.Print TimeStamp() & " | INFO | UNIQUE PART+CFG | " & child.Name2
Debug.Print TimeStamp() & " | INFO | Part path | " & compPath
Debug.Print TimeStamp() & " | INFO | Ref config | " & compCfg
Debug.Print TimeStamp() & " | INFO | Nesting config | " & effectivePartCfg
ProcessPartDocument compMdl, outDir, effectivePartCfg, compPath, child.Name2
Else
Debug.Print TimeStamp() & " | SKIP | Duplicate part+cfg already processed: " & child.Name2 & " | " & compPath & " | " & effectivePartCfg
End If
ElseIf compMdl.GetType = swDocASSEMBLY Then
uniqueKey = UCase$(compPath) & "|" & UCase$(compCfg)
If Not dictAsmCfg.Exists(uniqueKey) Then
dictAsmCfg.Add uniqueKey, True
Debug.Print String(90, "-")
Debug.Print TimeStamp() & " | INFO | ENTER SUBASM | " & child.Name2
Debug.Print TimeStamp() & " | INFO | Asm path | " & compPath
Debug.Print TimeStamp() & " | INFO | Ref config | " & compCfg
WalkAssemblyTree child, outDir, dictPartCfg, dictAsmCfg
Else
Debug.Print TimeStamp() & " | SKIP | Duplicate subassembly+cfg already traversed: " & child.Name2 & " | " & compPath & " | " & compCfg
End If
Else
Debug.Print TimeStamp() & " | SKIP | Unsupported component doc type: " & child.Name2 & " | " & DocTypeName(compMdl.GetType)
End If
If openedByUs Then
CloseDocIfOpen compPath
End If
NextChild:
Next i
Exit Sub
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | Unsupported component file type: " & path
Exit Function
End If
Dim errs As Long, warns As Long
errs = 0: warns = 0
Debug.Print TimeStamp() & " | INFO | Opening component silently: " & path
Set mdl = swApp.OpenDoc6(path, docType, swOpenDocOptions_Silent Or swOpenDocOptions_ReadOnly, "", errs, warns)
If mdl Is Nothing Then
Debug.Print TimeStamp() & " | FAIL | OpenDoc6 failed. errs=" & errs & " warns=" & warns & " | " & path
Exit Function
End If
If Not alreadyOpen Then openedByUs = True
Set EnsureComponentModelLoaded = mdl
Exit Function
EH:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | ERROR | GetActiveConfigurationName: " & Err.Number & " - " & Err.Description
End Function
Private Function FindPreferredWaterjetConfiguration(ByVal mdl As SldWorks.ModelDoc2) As String
On Error GoTo EH
FindPreferredWaterjetConfiguration = ""
If mdl Is Nothing 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, "WATERJET_CUT", vbTextCompare) = 0 Then
FindPreferredWaterjetConfiguration = CStr(vCfgNames(i))
Exit Function
End If
End If
Next i
Exit Function
EH:
Debug.Print TimeStamp() & " | ERROR | FindPreferredWaterjetConfiguration: " & Err.Number & " - " & Err.Description
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))
fallbackCfg = Trim$(requestedConfig)
If Len(fallbackCfg) = 0 Then
fallbackCfg = GetActiveConfigurationName(mdl)
End If
If Len(preferredCfg) > 0 Then
ResolveNestingConfiguration = preferredCfg
If writeLog Then
Debug.Print TimeStamp() & " | INFO | Nesting config override detected: using [" & preferredCfg & "] instead of requested [" & fallbackCfg & "]"
End If
Else
ResolveNestingConfiguration = fallbackCfg
If writeLog Then
Debug.Print TimeStamp() & " | INFO | No WATERJET_CUT config found. Using requested/active config [" & ResolveNestingConfiguration & "]"
End If
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
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
Debug.Print TimeStamp() & " | WARN | No real cut-list folders found in part: " & mdl.GetTitle
End If
Exit Sub
EH:
Debug.Print TimeStamp() & " | 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
If mdl.GetType <> swDocPART 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
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print String(80, "-")
Debug.Print TimeStamp() & " | 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
exportResolved = GetEffectivePartLevelDxfFlag(mdl, exportPropName, exportRaw)
partNoResolved = GetEvaluatedModelProperty(mdl, PROP_PARTNO, partNoRaw)
bodyCount = CountUsableBodiesInPart(mdl)
Debug.Print TimeStamp() & " | INFO | Effective regular-part export property = [" & exportPropName & "] raw=[" & exportRaw & "] eval=[" & exportResolved & "]"
Debug.Print TimeStamp() & " | INFO | PART PROP " & PROP_PARTNO & " raw=[" & partNoRaw & "] eval=[" & partNoResolved & "]"
Debug.Print TimeStamp() & " | INFO | Regular part usable body count = " & CStr(bodyCount)
If UCase$(Trim$(exportResolved)) <> PROP_TRUE_VALUE Then
gTotalSkipped = gTotalSkipped + 1
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Regular part orientation mode = selected drawing view override"
ElseIf usedPerpCorner Then
Debug.Print TimeStamp() & " | INFO | Regular part orientation mode = perpendicular edge pair -> shared or virtual corner driven bottom-left"
ElseIf usedFallbackEdge Then
Debug.Print TimeStamp() & " | WARN | Regular part orientation mode = fallback axis (no usable linear edge found)"
Else
Debug.Print TimeStamp() & " | INFO | Regular part orientation mode = longest single linear edge horizontal fallback"
End If
Dim baseName As String
baseName = ResolveDxfBaseNameForPart(mdl, partNoResolved, bodyCount, "regular part")
Dim finalDxfPath As String
finalDxfPath = GetUniqueOutputPath(outDir, baseName, "dxf")
If bodyCount = 1 Then
Debug.Print TimeStamp() & " | INFO | Export path = DIRECT_SOURCE_SINGLE_BODY"
If ExportSingleBodyPartAsOrientedDxfFromSource(mdl, faceN, xDir, finalDxfPath, mdl.GetTitle, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
Debug.Print TimeStamp() & " | OK | Regular part exported directly from source => " & finalDxfPath
Else
gTotalFailed = gTotalFailed + 1
Debug.Print TimeStamp() & " | FAIL | Regular part direct-from-source export failed => " & finalDxfPath
End If
Else
Debug.Print TimeStamp() & " | INFO | Export path = TEMP_PART_ISOLATED_BODY"
If ExportBodyAsOrientedDxf(repBody, faceN, xDir, finalDxfPath, mdl.GetTitle, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
Debug.Print TimeStamp() & " | OK | Regular part exported => " & finalDxfPath
Else
gTotalFailed = gTotalFailed + 1
Debug.Print TimeStamp() & " | FAIL | Regular part export failed => " & finalDxfPath
End If
End If
Exit Sub
EH:
gTotalFailed = gTotalFailed + 1
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | No body folders explicitly updated; rebuild still performed"
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Cut-list [" & feat.Name & "] body count = " & bodyCount
If bodyCount > 0 Then
IsRealCutListFolderFeature = True
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print String(80, "-")
Debug.Print TimeStamp() & " | 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
dxfResolved = GetEvaluatedCutListProperty(cpMgr, PROP_DXF, dxfRaw)
effectiveDxfRaw = dxfRaw
effectiveDxfResolved = dxfResolved
effectiveDxfSource = "CUTLIST." & PROP_DXF
partNoResolved = GetEvaluatedCutListProperty(cpMgr, PROP_PARTNO, partNoRaw)
bodyCount = CountUsableBodiesInPart(mdl)
Debug.Print TimeStamp() & " | INFO | PROP " & PROP_DXF & " raw=[" & dxfRaw & "] eval=[" & dxfResolved & "]"
Debug.Print TimeStamp() & " | INFO | PROP " & PROP_PARTNO & " raw=[" & partNoRaw & "] eval=[" & partNoResolved & "]"
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Single-body cut-list fallback to part property [" & partExportPropName & "] raw=[" & effectiveDxfRaw & "] eval=[" & effectiveDxfResolved & "]"
Else
Debug.Print TimeStamp() & " | INFO | Cut-list DXF blank and part is not single-body; no part-level fallback used"
End If
End If
Debug.Print TimeStamp() & " | INFO | Effective DXF source = " & effectiveDxfSource & " raw=[" & effectiveDxfRaw & "] eval=[" & effectiveDxfResolved & "]"
If UCase$(Trim$(effectiveDxfResolved)) <> PROP_TRUE_VALUE Then
gTotalSkipped = gTotalSkipped + 1
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Cut-list orientation mode = selected drawing view override"
ElseIf usedPerpCorner Then
Debug.Print TimeStamp() & " | INFO | Cut-list orientation mode = perpendicular edge pair -> shared or virtual corner driven bottom-left"
ElseIf usedFallbackEdge Then
Debug.Print TimeStamp() & " | WARN | Cut-list orientation mode = fallback axis (no usable linear edge found)"
Else
Debug.Print TimeStamp() & " | 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 & "]")
Dim outputPath As String
outputPath = GetUniqueOutputPath(outDir, baseName, "dxf")
If bodyCount = 1 Then
Debug.Print TimeStamp() & " | INFO | Export path = DIRECT_SOURCE_SINGLE_BODY"
If ExportSingleBodyPartAsOrientedDxfFromSource(mdl, faceN, xDir, outputPath, cutFeat.Name, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
Debug.Print TimeStamp() & " | OK | Exported directly from source => " & outputPath
Else
gTotalFailed = gTotalFailed + 1
Debug.Print TimeStamp() & " | FAIL | Direct-from-source export failed => " & outputPath
End If
Else
Debug.Print TimeStamp() & " | INFO | Export path = TEMP_PART_ISOLATED_BODY"
If ExportBodyAsOrientedDxf(repBody, faceN, xDir, outputPath, cutFeat.Name, usedPerpCorner) Then
gTotalExported = gTotalExported + 1
Debug.Print TimeStamp() & " | OK | Exported => " & outputPath
Else
gTotalFailed = gTotalFailed + 1
Debug.Print TimeStamp() & " | FAIL | Export failed => " & outputPath
End If
End If
Exit Sub
EH:
gTotalFailed = gTotalFailed + 1
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | INFO | Single-body " & contextLabel & " uses saved part file name directly for DXF base name => [" & baseName & "]"
Else
baseName = Trim$(preferredPartNo)
If Len(baseName) > 0 Then
Debug.Print TimeStamp() & " | INFO | Multi-body " & contextLabel & " uses PART NUMBER for DXF base name => [" & baseName & "]"
Else
baseName = GetFileStemFromPath(mdl.GetPathName)
Debug.Print TimeStamp() & " | 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"
Debug.Print TimeStamp() & " | WARN | Sanitized DXF base name became blank for " & contextLabel & "; using [PART]"
End If
ResolveDxfBaseNameForPart = baseName
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | [" & cutFeat.Name & "] GetBodyCount = " & bodyCount
If bodyCount <= 0 Then
Debug.Print TimeStamp() & " | FAIL | [" & cutFeat.Name & "] has no bodies"
Exit Function
End If
Dim vBodies As Variant
vBodies = bf.GetBodies
If IsEmpty(vBodies) Then
Debug.Print TimeStamp() & " | FAIL | [" & cutFeat.Name & "] GetBodies returned Empty"
Exit Function
End If
If Not IsArray(vBodies) Then
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | INFO | [" & cutFeat.Name & "] Body(" & i & ") type = " & bt & " [" & BodyTypeName(bt) & "]"
If bt = BODYTYPE_SOLID Then
Set GetRepresentativeBodyFromCutList = b
Debug.Print TimeStamp() & " | INFO | [" & cutFeat.Name & "] representative = SOLID body index " & i
Exit Function
End If
Else
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | [" & cutFeat.Name & "] representative = fallback body index " & i & " [" & BodyTypeName(bt) & "]"
Exit Function
End If
End If
Next i
Debug.Print TimeStamp() & " | FAIL | [" & cutFeat.Name & "] no usable representative body found"
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | No solid bodies found. Trying all bodies for regular part."
vBodies = p.GetBodies2(swAllBodies, True)
End If
If IsEmpty(vBodies) Then
Debug.Print TimeStamp() & " | FAIL | GetBodies2 returned Empty for regular part"
Exit Function
End If
If Not IsArray(vBodies) Then
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | INFO | Regular part Body(" & i & ") type = " & bt & " [" & BodyTypeName(bt) & "]"
If bt = BODYTYPE_SOLID Then
Set GetRepresentativeBodyFromPart = b
Debug.Print TimeStamp() & " | INFO | Regular part representative = SOLID body index " & i
Exit Function
End If
Else
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Regular part representative = fallback body index " & i & " [" & BodyTypeName(bt) & "]"
Exit Function
End If
End If
Next i
Debug.Print TimeStamp() & " | FAIL | No usable representative body found for regular part"
Exit Function
EH:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | CountUsableBodiesInPart: GetBodies2 returned Empty"
Exit Function
End If
If Not IsArray(vBodies) Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | CountUsableBodiesInPart = " & CStr(CountUsableBodiesInPart)
Exit Function
EH:
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | INFO | Effective part export lookup legacy [" & PROP_DXY & "] raw=[" & rawLegacy & "] eval=[" & evalLegacy & "]"
sourcePropName = PROP_DXY
rawValOut = rawLegacy
GetEffectivePartLevelDxfFlag = evalLegacy
Exit Function
EH:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | INFO | File property lookup " & propName & " raw=[" & tempRaw & "] eval=[" & tempEval & "]"
rawValOut = tempRaw
GetEvaluatedModelProperty = tempEval
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | ERROR | GetEvaluatedModelProperty(" & propName & "): " & Err.Number & " - " & Err.Description
End Function
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:
Debug.Print TimeStamp() & " | ERROR | GetEvaluatedPropertyValue(" & propName & "): " & Err.Number & " - " & Err.Description
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
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | INFO | Orientation mode = DRAWING_SELECTED_VIEW override"
Debug.Print TimeStamp() & " | INFO | Override label = " & gOrientationOverrideLabel
Debug.Print TimeStamp() & " | INFO | Override X = (" & Dbl3ToStr(xDir) & ")"
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | No planar face found on representative body for " & contextLabel
Exit Function
End If
If Not GetStableFaceNormal(refFace, faceN) Then
Debug.Print TimeStamp() & " | FAIL | Could not obtain face normal for " & contextLabel
Exit Function
End If
If Not FindHorizontalDirectionFromFace(refFace, faceN, xDir, usedFallbackEdge, usedPerpCorner) Then
Debug.Print TimeStamp() & " | FAIL | Could not determine horizontal direction for " & contextLabel
Exit Function
End If
GetExportOrientationForBody = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Largest planar face area = " & FormatNumber(bestArea, 8)
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | GetStableFaceNormal: start"
If face Is Nothing Then
Debug.Print TimeStamp() & " | FAIL | GetStableFaceNormal: face is Nothing"
Exit Function
End If
If TryGetNormalFromFaceVertices(face, n) Then
NormalizeVec n
If VecLength(n) > EPS Then
StabilizeVectorSign n
Debug.Print TimeStamp() & " | INFO | Face normal from face vertices = (" & Dbl3ToStr(n) & ")"
GetStableFaceNormal = True
Exit Function
End If
End If
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Face normal from Face2.Normal = (" & Dbl3ToStr(n) & ")"
GetStableFaceNormal = True
Exit Function
End If
Else
Debug.Print TimeStamp() & " | WARN | Face2.Normal did not return usable data"
End If
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Face normal from Surface.PlaneParams = (" & Dbl3ToStr(n) & ")"
GetStableFaceNormal = True
Exit Function
End If
Else
Debug.Print TimeStamp() & " | WARN | Surface.PlaneParams did not return usable data"
End If
Else
Debug.Print TimeStamp() & " | WARN | face.GetSurface returned Nothing inside GetStableFaceNormal"
End If
Debug.Print TimeStamp() & " | FAIL | GetStableFaceNormal exhausted all methods"
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | TryGetNormalFromFaceVertices: face.GetEdges returned Empty"
Exit Function
End If
If Not IsArray(vEdges) Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | TryGetNormalFromFaceVertices: unique point count = " & ptCount
If ptCount < 3 Then
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | INFO | TryGetNormalFromFaceVertices: using point indices " & i0 & "," & i1 & "," & i2
TryGetNormalFromFaceVertices = True
Exit Function
End If
Next i2
Next i1
Next i0
Debug.Print TimeStamp() & " | WARN | TryGetNormalFromFaceVertices: no non-collinear triplet found"
Exit Function
EH:
Debug.Print TimeStamp() & " | 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 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:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Corner orientation scan: no perpendicular shared-corner pair satisfied tolerance"
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | ERROR | TryGetBottomLeftCornerOrientation: " & Err.Number & " - " & Err.Description
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 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
Debug.Print TimeStamp() & " | INFO | Corner orientation scan: face has no edges"
Exit Function
End If
If Not IsArray(vEdges) Then
Debug.Print TimeStamp() & " | 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))
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Virtual corner orientation scan: no non-intersecting perpendicular pair satisfied tolerance"
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Virtual corner orientation scan: face has no edges"
Exit Function
End If
If Not IsArray(vEdges) Then
Debug.Print TimeStamp() & " | 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))
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | " & selectionLabel & " selected"
Debug.Print TimeStamp() & " | INFO | " & cornerLabel & " = (" & Dbl3ToStr(bestCorner) & ")"
Debug.Print TimeStamp() & " | INFO | Bottom edge X = (" & Dbl3ToStr(xDir) & ") | len = " & FormatNumber(bestPrimaryLen, 8)
Debug.Print TimeStamp() & " | INFO | Left edge Y = (" & Dbl3ToStr(bestY) & ") | len = " & FormatNumber(bestSecondaryLen, 8)
Debug.Print TimeStamp() & " | INFO | Face normal = (" & Dbl3ToStr(faceNormal) & ") | flipped=" & CStr(flippedNormal)
ApplyBottomLeftOrientationCandidate = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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#
Debug.Print TimeStamp() & " | INFO | BuildViewOrientationTransform axes:"
Debug.Print TimeStamp() & " | INFO | X = (" & Dbl3ToStr(x) & ")"
Debug.Print TimeStamp() & " | INFO | Y = (" & Dbl3ToStr(y) & ")"
Debug.Print TimeStamp() & " | INFO | Z = (" & Dbl3ToStr(z) & ")"
Set BuildViewOrientationTransform = swMathUtil.CreateTransform(data)
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | Direct single-body source export: srcDoc is Nothing"
Exit Function
End If
If srcDoc.GetType <> swDocPART Then
Debug.Print TimeStamp() & " | FAIL | Direct single-body source export requires PART doc, got " & DocTypeName(srcDoc.GetType)
Exit Function
End If
If Len(Trim$(srcDoc.GetPathName)) = 0 Then
Debug.Print TimeStamp() & " | FAIL | Direct single-body source export requires saved part path"
Exit Function
End If
If Not ShouldAttemptFastDirectDxfExport(preserveCornerOrientation) Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Direct single-body source export start"
Debug.Print TimeStamp() & " | INFO | contextLabel = " & contextLabel
Debug.Print TimeStamp() & " | INFO | sourcePath = " & srcDoc.GetPathName
Debug.Print TimeStamp() & " | INFO | finalDxfPath = " & finalDxfPath
Debug.Print TimeStamp() & " | INFO | mode = *Current view on source part"
Debug.Print TimeStamp() & " | INFO | preserveCornerOrientation = " & CStr(preserveCornerOrientation)
If Not ActivateDocumentByTitle(srcDoc.GetTitle) Then
Debug.Print TimeStamp() & " | WARN | Could not explicitly activate source part before direct export"
End If
Set originalViewXf = GetCurrentModelViewTransform(srcDoc)
If originalViewXf Is Nothing Then
Debug.Print TimeStamp() & " | WARN | Could not capture original source-part view transform"
Else
Debug.Print TimeStamp() & " | INFO | Captured original source-part view transform"
End If
originalUnits = GetModelLinearUnitsSafe(srcDoc)
restoreUnits = (originalUnits <> -1)
If Not OrientModelCurrentView(srcDoc, xDir, faceNormal) Then
Debug.Print TimeStamp() & " | FAIL | Could not orient source part current view for direct export"
GoTo CleanupAndExit
End If
If Not HideAllSketchesInModel(srcDoc) Then
Debug.Print TimeStamp() & " | WARN | HideAllSketchesInModel returned False on source part before direct export"
End If
If DIRECT_TEMP_PART_FORCE_INCH_UNITS Then
If ForceModelLinearUnitsToInches(srcDoc) Then
Debug.Print TimeStamp() & " | INFO | Source part linear units forced to inches for direct export"
Else
Debug.Print TimeStamp() & " | WARN | Source part units could not be forced to inches before direct export"
End If
End If
srcDoc.ForceRebuild3 True
srcDoc.GraphicsRedraw2
srcDoc.ViewZoomtofit2
If TryDirectExportToDxfByViewName(swSrcPart, srcDoc.GetPathName, finalDxfPath, "*Current", varAlignment) Then
Call FinalizeWaterjetDxfAfterExport(finalDxfPath, contextLabel, preserveCornerOrientation)
ExportSingleBodyPartAsOrientedDxfFromSource = True
Else
Debug.Print TimeStamp() & " | FAIL | Direct single-body source export failed using *Current view"
End If
CleanupAndExit:
If restoreUnits Then
If RestoreModelLinearUnits(srcDoc, originalUnits) Then
Debug.Print TimeStamp() & " | INFO | Restored source part linear units after direct export"
Else
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Restored source part original view transform after direct export"
Else
Debug.Print TimeStamp() & " | WARN | Could not restore source part original view transform"
End If
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | BuildViewOrientationTransform returned Nothing"
Exit Function
End If
Dim mvObj As Object
Set mvObj = mdl.ActiveView
If mvObj Is Nothing Then
Debug.Print TimeStamp() & " | FAIL | mdl.ActiveView returned Nothing"
Exit Function
End If
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | Setting current view Orientation3 failed: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
mdl.GraphicsRedraw2
mdl.ViewZoomtofit2
OrientModelCurrentView = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | GetCurrentModelViewTransform: ActiveView is Nothing"
Exit Function
End If
On Error Resume Next
Set xfObj = CallByName(mvObj, "Orientation3", VbGet)
If Err.Number <> 0 Then
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | RestoreCurrentModelViewTransform: ActiveView is Nothing"
Exit Function
End If
On Error Resume Next
CallByName mvObj, "Orientation3", VbSet, xfObj
If Err.Number <> 0 Then
Debug.Print TimeStamp() & " | WARN | RestoreCurrentModelViewTransform failed: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
mdl.GraphicsRedraw2
mdl.ViewZoomtofit2
RestoreCurrentModelViewTransform = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | GetModelLinearUnitsSafe failed: " & Err.Number & " - " & Err.Description
Err.Clear
GetModelLinearUnitsSafe = -1
End If
On Error GoTo EH
Exit Function
EH:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | Could not create local temp root"
Exit Function
End If
Debug.Print TimeStamp() & " | INFO | Local temp workspace = " & tempRoot
Debug.Print TimeStamp() & " | INFO | DXF export mode = " & GetDxfExportModeName()
Dim tempPartPath As String
tempPartPath = tempRoot & "\body_temp.sldprt"
Dim tempPartDoc As SldWorks.ModelDoc2
Dim tempBody As SldWorks.Body2
Set tempBody = srcBody.Copy
If tempBody Is Nothing Then
Debug.Print TimeStamp() & " | FAIL | Body copy returned Nothing"
GoTo CleanupAndExit
End If
Set tempPartDoc = CreateTempPartFromBody(tempBody, tempPartPath, Not (USE_FAST_MODE And FAST_MODE_SINGLE_TEMP_PART_SAVE))
If tempPartDoc Is Nothing Then
Debug.Print TimeStamp() & " | FAIL | Temp part creation failed"
GoTo CleanupAndExit
End If
If Not OrientAndNameTempPartView(tempPartDoc, xDir, faceNormal, TEMP_VIEW_NAME) Then
Debug.Print TimeStamp() & " | FAIL | Could not orient/name temp part view"
GoTo CleanupAndExit
End If
If Not HideAllSketchesInModel(tempPartDoc) Then
Debug.Print TimeStamp() & " | WARN | HideAllSketchesInModel returned False after view orientation"
End If
Debug.Print TimeStamp() & " | INFO | Saving temp part after custom named view creation"
If Not TrySaveModelToPath(tempPartDoc, tempPartPath) Then
Debug.Print TimeStamp() & " | FAIL | Could not persist custom named view to temp part file"
GoTo CleanupAndExit
End If
If Not ShouldAttemptFastDirectDxfExport(preserveCornerOrientation) Then
Debug.Print TimeStamp() & " | FAIL | Direct part DXF export is disabled by current toggle settings"
GoTo CleanupAndExit
End If
Set tempPartDoc = ReopenTempPartForDirectExport(tempPartDoc, tempPartPath)
If tempPartDoc Is Nothing Then
Debug.Print TimeStamp() & " | FAIL | Could not reopen temp part for direct export"
GoTo CleanupAndExit
End If
If Not HideAllSketchesInModel(tempPartDoc) Then
Debug.Print TimeStamp() & " | WARN | HideAllSketchesInModel returned False after temp-part reopen"
End If
Debug.Print TimeStamp() & " | 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
If EXPERIMENTAL_DIRECT_FALLBACK_TO_DRAWING Then
Debug.Print TimeStamp() & " | WARN | Direct part DXF export failed; manual drawing fallback is enabled"
Debug.Print TimeStamp() & " | WARN | This macro revision keeps the legacy drawing helper code, but the active production path is direct part export"
Else
Debug.Print TimeStamp() & " | FAIL | Direct part DXF export failed and drawing fallback is disabled"
End If
CleanupAndExit:
CloseModelDocSafe tempPartDoc
DeleteFileIfExists tempPartPath
DeleteFolderIfEmpty tempRoot
Exit Function
EH:
Debug.Print TimeStamp() & " | ERROR | ExportBodyAsOrientedDxf(" & cutListName & "): " & Err.Number & " - " & Err.Description
End Function
'=========================================================================================
' Imported SAVE_ALL DXF post-export orientation normalization
'=========================================================================================
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 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 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 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 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 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 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
Debug.Print TimeStamp() & " | FAIL | No default part template available"
Exit Function
End If
Debug.Print TimeStamp() & " | INFO | Temp part template = " & partTemplate
Debug.Print TimeStamp() & " | INFO | Temp part target = " & tempPartPath
Dim tempDoc As SldWorks.ModelDoc2
Set tempDoc = swApp.NewDocument(partTemplate, 0, 0#, 0#)
If tempDoc Is Nothing Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | CreateFeatureFromBody3 returned Nothing"
swApp.CloseDoc tempDoc.GetTitle
Exit Function
End If
tempDoc.ForceRebuild3 True
If Not HideAllSketchesInModel(tempDoc) Then
Debug.Print TimeStamp() & " | WARN | HideAllSketchesInModel returned False during temp part creation"
End If
If DIRECT_TEMP_PART_FORCE_INCH_UNITS Then
If ForceModelLinearUnitsToInches(tempDoc) Then
Debug.Print TimeStamp() & " | INFO | Temp part units forced to inches for direct DXF export"
Else
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | All temp part save attempts failed"
swApp.CloseDoc tempDoc.GetTitle
Exit Function
End If
Debug.Print TimeStamp() & " | INFO | Temp part saved = " & tempPartPath
Else
Debug.Print TimeStamp() & " | INFO | Temp part created in memory; initial disk save deferred"
End If
Set CreateTempPartFromBody = tempDoc
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
mdl.ViewZoomtofit2
DoEvents
Dim errs As Long, warns As Long
errs = 0: warns = 0
Debug.Print TimeStamp() & " | INFO | Save attempt 1: Extension.SaveAs"
If mdl.Extension.SaveAs(filePath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, errs, warns) Then
Debug.Print TimeStamp() & " | INFO | Save attempt 1 returned True. errs=" & errs & " warns=" & warns
If FileExists(filePath) Then
TrySaveModelToPath = True
Exit Function
End If
Debug.Print TimeStamp() & " | WARN | Save attempt 1 returned True but file not found"
Else
Debug.Print TimeStamp() & " | WARN | Save attempt 1 returned False. errs=" & errs & " warns=" & warns
End If
errs = 0: warns = 0
Debug.Print TimeStamp() & " | INFO | Save attempt 2: Extension.SaveAs with COPY option"
If mdl.Extension.SaveAs(filePath, swSaveAsCurrentVersion, swSaveAsOptions_Silent Or swSaveAsOptions_Copy, Nothing, errs, warns) Then
Debug.Print TimeStamp() & " | INFO | Save attempt 2 returned True. errs=" & errs & " warns=" & warns
If FileExists(filePath) Then
TrySaveModelToPath = True
Exit Function
End If
Debug.Print TimeStamp() & " | WARN | Save attempt 2 returned True but file not found"
Else
Debug.Print TimeStamp() & " | WARN | Save attempt 2 returned False. errs=" & errs & " warns=" & warns
End If
errs = 0: warns = 0
Debug.Print TimeStamp() & " | 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
mdl.GraphicsRedraw2
mdl.ViewZoomtofit2
DoEvents
If mdl.Extension.SaveAs(filePath, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, errs, warns) Then
Debug.Print TimeStamp() & " | INFO | Save attempt 3 returned True. errs=" & errs & " warns=" & warns
If FileExists(filePath) Then
TrySaveModelToPath = True
Exit Function
End If
Debug.Print TimeStamp() & " | WARN | Save attempt 3 returned True but file not found"
Else
Debug.Print TimeStamp() & " | WARN | Save attempt 3 returned False. errs=" & errs & " warns=" & warns
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | BuildViewOrientationTransform returned Nothing"
Exit Function
End If
Dim mvObj As Object
Set mvObj = tempDoc.ActiveView
If mvObj Is Nothing Then
Debug.Print TimeStamp() & " | FAIL | tempDoc.ActiveView returned Nothing"
Exit Function
End If
Debug.Print TimeStamp() & " | INFO | Setting current model view orientation"
On Error Resume Next
CallByName mvObj, "Orientation3", VbSet, viewXf
If Err.Number <> 0 Then
Debug.Print TimeStamp() & " | FAIL | Setting Orientation3 failed: " & Err.Number & " - " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
tempDoc.GraphicsRedraw2
tempDoc.ViewZoomtofit2
On Error Resume Next
tempDoc.DeleteNamedView viewName
Err.Clear
On Error GoTo EH
Debug.Print TimeStamp() & " | INFO | Naming current view as [" & viewName & "]"
tempDoc.NameView viewName
tempDoc.GraphicsRedraw2
tempDoc.ViewZoomtofit2
OrientAndNameTempPartView = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | ReopenTempPartForDirectExport: temp part file does not exist: " & tempPartPath
Exit Function
End If
Debug.Print TimeStamp() & " | INFO | Closing in-memory temp part before direct reopen"
CloseModelDocSafe currentDoc
Dim errs As Long
Dim warns As Long
errs = 0
warns = 0
Debug.Print TimeStamp() & " | INFO | Reopening persisted temp part for direct export: " & tempPartPath
Set ReopenTempPartForDirectExport = swApp.OpenDoc6(tempPartPath, swDocPART, swOpenDocOptions_Silent Or swOpenDocOptions_ReadOnly, "", errs, warns)
Debug.Print TimeStamp() & " | INFO | Reopen temp part result errs=" & errs & " warns=" & warns
If ReopenTempPartForDirectExport Is Nothing Then
Debug.Print TimeStamp() & " | FAIL | ReopenTempPartForDirectExport returned Nothing"
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | ERROR | ReopenTempPartForDirectExport: " & 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
Debug.Print TimeStamp() & " | FAIL | Direct export: tempPartDoc is Nothing"
Exit Function
End If
If tempPartDoc.GetType <> swDocPART Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | Direct export could not explicitly activate temp part"
End If
tempPartDoc.ForceRebuild3 True
If Not HideAllSketchesInModel(tempPartDoc) Then
Debug.Print TimeStamp() & " | WARN | HideAllSketchesInModel returned False immediately before direct DXF export"
End If
If DIRECT_TEMP_PART_FORCE_INCH_UNITS Then
If ForceModelLinearUnitsToInches(tempPartDoc) Then
Debug.Print TimeStamp() & " | INFO | Direct export temp part linear units = INCHES"
Else
Debug.Print TimeStamp() & " | WARN | Direct export could not confirm INCH units on temp part"
End If
End If
tempPartDoc.GraphicsRedraw2
tempPartDoc.ViewZoomtofit2
Debug.Print TimeStamp() & " | INFO | Direct export preserveCornerOrientation = " & CStr(preserveCornerOrientation)
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | *Current fallback disabled to avoid losing deterministic orientation"
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Direct ExportToDWG2 start"
Debug.Print TimeStamp() & " | INFO | modelPath = " & modelPath
Debug.Print TimeStamp() & " | INFO | finalDxfPath = " & finalDxfPath
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | ExportToDWG2 result = " & CStr(ok)
If Not ok Then Exit Function
If Not FileExists(finalDxfPath) Then
Debug.Print TimeStamp() & " | WARN | ExportToDWG2 returned True but output file not found"
Exit Function
End If
If GetFileSizeSafe(finalDxfPath) <= 0 Then
Debug.Print TimeStamp() & " | WARN | ExportToDWG2 created zero-byte DXF"
Exit Function
End If
Debug.Print TimeStamp() & " | INFO | Direct ExportToDWG2 succeeded. File size = " & CStr(GetFileSizeSafe(finalDxfPath))
TryDirectExportToDxfByViewName = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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)
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | ForceModelLinearUnitsToInches before = " & CStr(beforeUnits)
mdl.SetUserPreferenceIntegerValue swUnitsLinear, swINCHES
On Error Resume Next
afterUnits = mdl.GetUserPreferenceIntegerValue(swUnitsLinear)
Err.Clear
On Error GoTo EH
Debug.Print TimeStamp() & " | INFO | ForceModelLinearUnitsToInches after = " & CStr(afterUnits)
ForceModelLinearUnitsToInches = (afterUnits = swINCHES)
Exit Function
EH:
Debug.Print TimeStamp() & " | 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 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
Debug.Print TimeStamp() & " | 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
Dim drwTemplate As String
drwTemplate = GetDrawingTemplatePath()
If Len(drwTemplate) = 0 Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Drawing export sheet size (m) = " & FormatNumber(w, 4) & " x " & FormatNumber(h, 4)
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | FAIL | CreateDrawViewFromModelView3 returned Nothing for view [" & modelViewName & "]"
swApp.CloseDoc drwDoc.GetTitle
Exit Function
End If
On Error Resume Next
v.UseSheetScale = False
v.ScaleDecimal = 1#
On Error GoTo EH
drwDoc.ForceRebuild3 True
drwDoc.ViewZoomtofit2
If CorrectDrawingViewRoll(v, xDir, faceNormal, preserveCornerOrientation) Then
drwDoc.ForceRebuild3 True
drwDoc.ViewZoomtofit2
Else
Debug.Print TimeStamp() & " | WARN | CorrectDrawingViewRoll did not make a change"
End If
If Not TrySaveModelToPath(drwDoc, tempDrwPath) Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Drawing SaveAs DXF succeeded. errs=" & errs & " warns=" & warns
If FileExists(finalDxfPath) Then
ExportTempPartToDxf_ByNamedViewDrawing = True
End If
Else
Debug.Print TimeStamp() & " | FAIL | Drawing SaveAs DXF failed. errs=" & errs & " warns=" & warns
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | ERROR | ExportTempPartToDxf_ByNamedViewDrawing: " & Err.Number & " - " & Err.Description
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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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)))
Debug.Print TimeStamp() & " | INFO | Post-roll outline W x H = " & FormatNumber(width, 6) & " x " & FormatNumber(height, 6)
If preserveCornerOrientation Then
Debug.Print TimeStamp() & " | INFO | Corner-driven orientation active -> skipping legacy 90-degree width/height auto-rotate"
ElseIf height > width + EPS Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | WARN | Secondary 90-degree correction failed: " & Err.Number & " - " & Err.Description
Err.Clear
End If
Else
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Face normal in view coords = (" & _
FormatNumber(vx, 6) & ", " & FormatNumber(vy, 6) & ", " & FormatNumber(vz, 6) & ")"
End If
Exit Function
EH:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Using custom drawing template = " & GetDrawingTemplatePath
Exit Function
End If
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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 ActivateDocumentByTitle(mdl.GetTitle) Then
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | HideAllSketchesInModel visited top-level features = " & CStr(visitCount) & " | sketches hidden = " & CStr(hiddenCount)
HideAllSketchesInModel = True
Exit Function
EH:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | INFO | Hiding sketch feature [" & feat.Name & "] type=[" & typeName & "]"
If BlankSketchFeatureBySelection(feat) Then
hiddenCount = hiddenCount + 1
Else
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | 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:
Debug.Print TimeStamp() & " | ERROR | GetLocalTempRoot: " & Err.Number & " - " & Err.Description
GetLocalTempRoot = ""
End Function
'=========================================================================================
' FILE / PATH HELPERS
'=========================================================================================
Private Function EnsureFolderExists(ByVal folderPath As String) As String
On Error GoTo EH
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
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:
Debug.Print TimeStamp() & " | ERROR | EnsureFolderExists(" & folderPath & "): " & Err.Number & " - " & Err.Description
EnsureFolderExists = ""
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:
Debug.Print TimeStamp() & " | ERROR | GetUniqueOutputPath: " & Err.Number & " - " & Err.Description
End Function
' Lightweight compatibility wrapper for SAVE_ALL orientation routines.
' AUTO DXF SAVE keeps its existing Immediate-window logging behavior.
Private Sub LogEvent(ByVal messageText As String)
On Error Resume Next
Debug.Print TimeStamp() & messageText
End Sub
Private Function FileExists(ByVal filePath As String) As Boolean
On Error Resume Next
FileExists = (Len(Dir$(filePath, vbNormal)) > 0)
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
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 · 166 declarations
File checksum
SHA-256: 73188fcc4679705f67f83da25f44b4ab33da2095d87e84b386d31550bcba731f