Drawings & BOM · V8.12
Automated Cope Detail Drawing Generator
A SolidWorks VBA workflow that generates cope-detail views for weldment cut-list items and adds BOM balloons.
ENGINEERING CONTRIBUTION
Developed geometry classification, view competition, orientation logic, placement, sorting, and BOM-balloon workflows.
Prerequisites
- SolidWorks VBA with an active drawing and suitable referenced weldment/cut-list geometry.
- A BOM / Weldment Cut List table that resolves item numbers for balloons, plus compatible drawing sheet setup.
- Review output-sheet, balloon and logging constants before adapting the workflow.
Additional setup
- Requires a drawing BOM or weldment cut-list table with resolvable item numbers for balloon annotations.
SOURCE WALKTHROUGH
How the workflow fits together.
- 01
Validate drawing and cut lists
main connects to the active drawing, initializes logging and dispatches through guarded cut-list/body discovery.
- 02
Compete candidate views
Body fingerprints and categories influence scores across standard and optional custom orientations. Temporary views supply geometry evidence.
- 03
Orient and place details
Projected spans, linear edges and staged fallbacks control drawing-view rotation. Accepted views are sorted and placed in rows.
- 04
Annotate and restore
The workflow adds BOM balloons and restores temporary model/view state where possible. Failures are logged rather than treated as a completed detail.
Output & model changes
- RESET_OUTPUT_SHEET defaults to True: an existing COPE DETAILS sheet is deleted and recreated, including its prior contents.
- Creates drawing views and BOM balloons; uses temporary model/view orientation state and rebuilds during analysis.
- Writes diagnostics to the configured log folder; logs can contain document details.
CODE & ENTRY POINTS
Read the implementation.
Find a procedure, follow an API call or download the module for your SolidWorks setup.
CopeDetailGenerator.bas
Weldment body classification, category-specific view competition, orientation fallback logic, drawing placement and BOM-balloon annotation in one exported module.
VBA · 11,332 lines
Entry points
API & integration calls
Option Explicit
'====================================================================================
' AUTO_COPE_DETAIL_GENERATOR_V8_11_PLATE_FACE_CORNER_AND_CUSTOM_VIEW_TRUST
'
' PURPOSE (FAST MODE)
' - Generate one cope-detail drawing view per weldment cut-list item
' - FAST "simple stack" placement (row-by-row / wrap) for speed
' - Sort items ASCENDING by Part Number before placing
' - Notes OFF
' - Post-pass: add REAL BOM balloons ("bubbles") per view
' * Anchored to a VISIBLE entity (edge/vertex/face) inside each view
' * Then reposition bubble near top-right of that view
'
' REQUIREMENT
' - The drawing MUST contain a BOM / Weldment Cut List table that resolves item numbers.
' Without it, InsertBOMBalloon2 can return blank/incorrect bubbles or fail.
'
' VERSION NOTES (V8.12)
' - Preserves existing behavior
' - Keeps strengthened configuration assignment / validation from V8.4
' - Preserves existing behavior
' - Keeps strengthened configuration assignment / validation from V8.4
' - Replaces edge-only orientation logic with category-based body analysis
' - Isolates each cut-list body, fingerprints its geometry, and classifies it
' LINEAR STRUCTURAL / CURVED STRUCTURAL / SHEET-PLATE / ROUND STOCK / IRREGULAR
' - Still tries ALL six standard views first, then user-created named/custom model views
' - Scores candidate views using category-specific signals:
' projected straight-direction families, projected body point-cloud span, projected box area,
' visible edge evidence, and outline quality
' - Rotation now uses category-specific reference selection with staged discrete search:
' 90 deg -> 45 deg -> 30 deg -> 15 deg -> 10 deg -> 5 deg -> 2 deg -> 1 deg
' - For parts with no reliable straight edge, falls back to projected body-span / chord logic
' - Keeps visible-linear-edge and bbox sweep as final fallbacks
' - Adds detailed logging around body classification, view competition, and rotation testing
' - Adds body-box-corner projected-point fallback when round/cylindrical bodies return zero sampled points
' - Adds round-stock outline fallback so solid rods are not falsely rejected when projected principal metrics are unavailable
' - Treats ActivateModelConfigurationSafe as successful when the requested configuration is confirmed active after rebuild
'
'====================================================================================
'==========================
' USER SETTINGS
'==========================
Private Const MACRO_REVISION As String = "V8.12_ROUND_STOCK_PROJECTED_FALLBACK"
Private Const MACRO_TITLE As String = "AUTO_COPE_DETAIL_GENERATOR_V8_12_ROUND_STOCK_PROJECTED_FALLBACK"
Private Const OUTPUT_SHEET_NAME As String = "COPE DETAILS"
Private Const RESET_OUTPUT_SHEET As Boolean = True
' Permitted region margins (meters)
Private Const MARGIN_LEFT As Double = 0.025
Private Const MARGIN_RIGHT As Double = 0.025
Private Const MARGIN_TOP As Double = 0.025
Private Const MARGIN_BOTTOM As Double = 0.065 ' title block clearance
' FAST STACK placement gaps (meters)
Private Const STACK_GAP_X As Double = 0.01
Private Const STACK_GAP_Y As Double = 0.012
' Band above each view (reserved; we keep it even if notes are off)
Private Const NOTE_BAND_H As Double = 0.01
Private Const NOTE_TO_VIEW_GAP As Double = 0.004
Private Const STACK_WRAP_ROWS As Boolean = True
Private Const ALLOW_VERTICAL_OVERFLOW As Boolean = False
' === manual parking strip mode ===
Private Const MANUAL_PARK_STRIP_MODE As Boolean = True
Private Const PARK_STRIP_OFFSET_BELOW_SHEET As Double = 0.12 ' meters below sheet bottom
Private Const PARK_STRIP_ALLOW_WRAP As Boolean = True
Private Const PARK_STRIP_WRAP_WIDTH As Double = 0.75 ' width of parking row before wrapping
Private Const PARK_STRIP_ROW_GAP As Double = 0.03 ' gap between parking rows
' Scale behavior
' If DETAIL_SCALE_DECIMAL <= 0, use selected/reference view scale
' Else force this scale for all generated views
Private Const DETAIL_SCALE_DECIMAL As Double = 0#
' Optional scale limits if using reference scale (0 = disabled)
Private Const MIN_SCALE_DECIMAL As Double = 0#
Private Const MAX_SCALE_DECIMAL As Double = 0#
' Rotation / orientation
Private Const AUTO_ROTATE_TO_HORIZONTAL As Boolean = False ' candidate views are rotated during validation; do not rotate again after placement
' View-selection logic
Private Const ORIENT_TRY_ALL_STANDARD_VIEWS As Boolean = True
Private Const ORIENT_INCLUDE_CUSTOM_MODEL_VIEWS As Boolean = True
Private Const ORIENT_VIEWSEL_MIN_EDGE_LEN As Double = 0.0005 ' meters on sheet
Private Const ORIENT_VIEWSEL_LEN_EPS As Double = 0.0002
Private Const ORIENT_VIEWSEL_SCORE_EPS As Double = 0.5
Private Const ORIENT_VIEWSEL_ANGLE_EPS_DEG As Double = 0.5
Private Const ORIENT_LOG_VIEW_CANDIDATES As Boolean = True
Private Const TEMP_MODEL_VIEW_PREFIX As String = "AUTO_COPE_TMP_"
Private Const ALLOW_GENERATED_BODY_FRAME_VIEWS As Boolean = False ' production default: do not create temp named model views for orientation
Private Const BODY_ORIENT_MAX_CANDIDATES As Long = 12
Private Const BODY_ORIENT_FACE_DOT_LEN_MAX As Double = 0.35
Private Const STRICT_AXIS_HORIZONTAL_TOL_DEG As Double = 4#
Private Const STRICT_PLATE_PROFILE_RATIO_MIN As Double = 0.06
Private Const STRICT_STRUCT_PROFILE_RATIO_MIN As Double = 0.012
Private Const STRICT_MIN_PROFILE_ABS As Double = 0.003
' Primary rotation search = direct 3D-reference projection; the staged sweep is kept only as dormant legacy support.
Private Const ROT_USE_STAGED_DISCRETE_SEARCH As Boolean = False
Private Const ROT_DISCRETE_SUCCESS_TOL_DEG As Double = 3#
Private Const ROT_MIN_VISIBLE_EDGE_LEN As Double = 0.0005 ' meters on sheet
Private Const ROT_LOG_EDGE_CANDIDATES As Boolean = True
' Secondary / fallback rotation paths
Private Const ROT_USE_VISIBLE_LINEAR_EDGE_ALIGN As Boolean = True
Private Const ROT_SNAP_TOL_DEG As Double = 3#
Private Const ORIENT_SNAP_HORIZONTAL_BONUS As Double = 25000000#
Private Const ORIENT_SNAP_VERTICAL_BONUS As Double = 15000000#
Private Const SNAP_REF_USE_VISIBLE_EDGE_FIRST As Boolean = False
Private Const ROT_EDGE_CONFIRM_TOL_DEG As Double = 0.5
Private Const ANGLE_EDGE_FAMILY_TOL_DEG As Double = 1#
Private Const ANGLE_EDGE_FAMILY_FINAL_TOL_DEG As Double = 0.5
Private Const ANGLE_EDGE_MIN_PROJECTED_LEN As Double = 0.0005
Private Const ANGLE_EDGE_FAMILY_TOP_LOG_COUNT As Long = 3
Private Const PLATE_PERP_DOT_TOL As Double = 0.001
Private Const PLATE_POINT_TOL As Double = 0.000001
Private Const PLATE_FACE_NORMAL_EPS As Double = 0.0000001
Private Const PLATE_CUSTOM_VIEW_PENALTY As Double = 2500#
Private Const PLATE_CUSTOM_VIEW_STRICT_PENALTY As Double = 6000#
' Final fallback = bbox sweep
Private Const ROT_SWEEP_COARSE_STEP_DEG As Double = 10#
Private Const ROT_SWEEP_FINE_STEP_DEG As Double = 1#
' Category-based orientation engine
Private Const CAT_LOG_ANALYSIS As Boolean = True
Private Const CAT_FAMILY_ANGLE_TOL_DEG As Double = 10#
Private Const CAT_MIN_LINE_LEN_MODEL As Double = 0.000001
Private Const CAT_POINT_KEY_DECIMALS As Long = 6
Private Const CAT_PLATE_THIN_RATIO_MAX As Double = 0.16
Private Const CAT_CURVED_EDGE_RATIO_TRIGGER As Double = 0.6
Private Const CAT_REF_SUCCESS_TOL_DEG As Double = 1#
Private Const CAT_NAME_LINEAR_STRUCTURAL As String = "LINEAR_STRUCTURAL"
Private Const CAT_NAME_CURVED_STRUCTURAL As String = "CURVED_STRUCTURAL"
Private Const CAT_NAME_SHEET_PLATE As String = "SHEET_PLATE"
Private Const CAT_NAME_ROUND_STOCK As String = "ROUND_STOCK"
Private Const CAT_NAME_IRREGULAR As String = "IRREGULAR"
Private Const CAT_SUBTYPE_UNKNOWN As String = "UNKNOWN"
Private Const CAT_SUBTYPE_CHANNEL As String = "CHANNEL"
Private Const CAT_SUBTYPE_ANGLE As String = "ANGLE"
Private Const CAT_SUBTYPE_PLATE As String = "PLATE"
Private Const CAT_SUBTYPE_GUSSET As String = "GUSSET"
Private Const CAT_SUBTYPE_RECT_MEMBER As String = "RECT_MEMBER"
Private Const CAT_SUBTYPE_ROUND As String = "ROUND"
Private Const CAT_LINEAR_PROFILE_RATIO_MIN As Double = 0.05
Private Const CAT_LINEAR_PROFILE_ABS_MIN As Double = 0.001
Private Const CAT_ANGLE_PROFILE_RATIO_MIN As Double = 0.018
Private Const CAT_CHANNEL_PROFILE_RATIO_MIN As Double = 0.025
Private Const CAT_SECTION_PROFILE_ABS_MIN As Double = 0.0015
Private Const CAT_PLATE_FACE_RATIO_MIN As Double = 0.08
Private Const CAT_PLATE_FACE_ABS_MIN As Double = 0.001
Private Const CAT_MAJOR_HORIZONTAL_TOL_DEG As Double = 3#
Private Const CAT_OUTLINE_HORIZONTAL_RATIO_MIN As Double = 0.9
Private Const CAT_REJECT_PENALTY As Double = 50000000#
' Notes OFF
Private Const ADD_LABEL_NOTE As Boolean = False
' BOM balloons (REAL bubbles) - requires BOM / Cut List table in drawing
Private Const ADD_BOM_BALLOON_AFTER_PLACE As Boolean = True
Private Const BALLOON_OFFSET_X As Double = 0.018
Private Const BALLOON_OFFSET_Y As Double = 0.01
Private Const BALLOON_RETRY_COUNT As Long = 3
' NEW: stronger configuration assignment / validation
Private Const VIEW_CFG_RETRY_COUNT As Long = 3
' Placement tolerance / retries
Private Const POS_TOL As Double = 0.003
Private Const POS_RETRY As Long = 3
' Staging (off-sheet) placement for temporary manipulation
Private Const STAGING_OFFSET_X As Double = 0.35
' Cut-list property candidates
Private Const PROP_ITEMNO_1 As String = "ITEM NO."
Private Const PROP_ITEMNO_2 As String = "Item"
Private Const PROP_ITEMNO_3 As String = "Item Number"
Private Const PROP_ITEMNO_4 As String = "SW-CutListItemNumber"
Private Const PROP_PN_1 As String = "PartNo"
Private Const PROP_PN_2 As String = "Part Number"
Private Const PROP_PN_3 As String = "PART NUMBER"
Private Const PROP_PN_4 As String = "SW-Part Number"
Private Const PROP_QTY_1 As String = "QTY"
Private Const PROP_QTY_2 As String = "Quantity"
Private Const PROP_QTY_3 As String = "SW-Quantity"
' Feature-tree traversal guardrails. SolidWorks feature/subfeature links can
' revisit folders through multiple paths; never recurse without a visited set.
Private Const CUTLIST_MAX_FEATURE_DEPTH As Long = 24
Private Const CUTLIST_MAX_FEATURE_SCAN As Long = 5000
'==========================
' MODULE GLOBALS
'==========================
Private g_swApp As SldWorks.SldWorks
Private g_swDrwModel As SldWorks.ModelDoc2
Private g_swDraw As SldWorks.DrawingDoc
Private g_refView As SldWorks.View
Private g_modelPath As String
Private g_refCfgRaw As String
Private g_refCfg As String
Private g_refModel As SldWorks.ModelDoc2
Private g_openedModel As Boolean
Private g_openedModelTitle As String
Private g_tempViewNames As Collection
Private g_keepTempViewNames As Object
' File-based debug logger.
' All run logs are written to the required project folder:
' C:\Public\AutoCopeLogs
Private Const DEBUG_LOG_FOLDER As String = "C:\Public\AutoCopeLogs"
Private Const DEBUG_LOG_PREFIX As String = "AUTO_COPE_DETAIL_GENERATO_"
Private g_debugLogPath As String
Private g_debugLogFileNo As Integer
Private g_debugLogEnabled As Boolean
Private g_debugLogInitDone As Boolean
Private g_debugLogFailed As Boolean
Private Const PI As Double = 3.14159265358979
'====================================================================================
' ENTRY POINT
'====================================================================================
Public Sub main()
On Error GoTo EH
Set g_swApp = Application.SldWorks
Set g_swDrwModel = g_swApp.ActiveDoc
Set g_tempViewNames = New Collection
Set g_keepTempViewNames = CreateObject("Scripting.Dictionary")
InitDebugLog
LogDivider "MACRO START"
LogInfo "START | " & MACRO_TITLE & " | revision=" & MACRO_REVISION
LogStage "ENTRY", "main entry reached; dispatcher=main; legacyPath=False"
LogKeyValue "ENTRY", "solidWorksAppAvailable", BoolWord(Not g_swApp Is Nothing)
LogKeyValue "ENTRY", "activeDocAvailable", BoolWord(Not g_swDrwModel Is Nothing)
'--- guards ----------------------------------------------------------------------
If g_swDrwModel Is Nothing Then
LogError "ENTRY | no active document; terminating before drawing validation"
MsgBox "No active document. Open a drawing and try again.", vbExclamation
GoTo TidyUp
End If
LogKeyValue "ENTRY", "activeDocTitle", ModelTitleSafe(g_swDrwModel)
LogKeyValue "ENTRY", "activeDocPath", ModelPathSafe(g_swDrwModel)
LogKeyValue "ENTRY", "activeDocType", DocumentTypeNameSafe(g_swDrwModel.GetType)
LogKeyValue "ENTRY", "activeDocSaved", BoolWord(IsModelSavedSafe(g_swDrwModel))
If g_swDrwModel.GetType <> swDocumentTypes_e.swDocDRAWING Then
LogError "ENTRY | active document type is not drawing | type=" & DocumentTypeNameSafe(g_swDrwModel.GetType)
MsgBox "Active document is not a drawing (.SLDDRW).", vbExclamation
GoTo TidyUp
End If
Set g_swDraw = g_swDrwModel
LogStage "DRAWING", "active drawing document accepted"
'--- reference view --------------------------------------------------------------
LogStage "REFERENCE_VIEW", "resolving selected or first model drawing view"
Set g_refView = GetReferenceDrawingView(g_swDraw, g_swDrwModel)
If g_refView Is Nothing Then
LogError "REFERENCE_VIEW | no source model view found on active drawing"
MsgBox "No model drawing view found." & vbCrLf & _
"Select a drawing view on the source sheet, then run again.", vbExclamation
GoTo TidyUp
End If
g_modelPath = SafeStr(g_refView.GetReferencedModelName)
g_refCfgRaw = Trim$(SafeStr(g_refView.ReferencedConfiguration))
LogInfo "Ref view=" & ViewGetNameSafe(g_refView) & _
" | model=" & g_modelPath & _
" | rawCfg=" & g_refCfgRaw
LogKeyValue "REFERENCE_VIEW", "viewName", ViewGetNameSafe(g_refView)
LogKeyValue "REFERENCE_VIEW", "referencedModelPath", g_modelPath
LogKeyValue "REFERENCE_VIEW", "rawReferencedConfiguration", g_refCfgRaw
If Len(g_modelPath) = 0 Then
LogError "REFERENCE_VIEW | referenced model path is blank"
MsgBox "Cannot resolve model path from selected view.", vbExclamation
GoTo TidyUp
End If
'--- open referenced part --------------------------------------------------------
LogStage "MODEL_OPEN", "opening referenced model"
' Open without forcing the possibly-bad drawing config token.
If Not EnsureModelOpen(g_refView, g_modelPath, "", _
g_refModel, g_openedModel, g_openedModelTitle) Then
LogError "MODEL_OPEN | failed to open referenced model | path=" & g_modelPath
MsgBox "Failed to open referenced model: " & g_modelPath, vbExclamation
GoTo TidyUp
End If
If g_refModel.GetType <> swDocumentTypes_e.swDocPART Then
LogError "MODEL_OPEN | referenced model is not a part | title=" & ModelTitleSafe(g_refModel) & _
" | type=" & DocumentTypeNameSafe(g_refModel.GetType)
MsgBox "Referenced model is not a Part. Weldment part required.", vbExclamation
GoTo TidyUp
End If
LogKeyValue "MODEL_OPEN", "openedModelTitle", ModelTitleSafe(g_refModel)
LogKeyValue "MODEL_OPEN", "openedModelPath", ModelPathSafe(g_refModel)
LogKeyValue "MODEL_OPEN", "openedByMacro", BoolWord(g_openedModel)
'--- resolve source configuration robustly ---------------------------------------
LogStage "CONFIG", "resolving source configuration"
g_refCfg = ResolvePreferredReferencedConfiguration(g_refModel, g_refCfgRaw)
If Len(g_refCfg) = 0 Then
LogError "CONFIG | failed to resolve valid configuration | raw=" & g_refCfgRaw
MsgBox "Could not resolve a valid model configuration from the source view." & vbCrLf & _
"Raw source configuration: " & g_refCfgRaw, vbExclamation
GoTo TidyUp
End If
LogInfo "Resolved configuration | raw=" & g_refCfgRaw & " | final=" & g_refCfg
LogKeyValue "CONFIG", "resolvedConfiguration", g_refCfg
' Activate the resolved config in the model before making views.
If Not ActivateModelConfigurationSafe(g_refModel, g_refCfg) Then
LogWarn "Proceeding even though ActivateModelConfigurationSafe returned False | cfg=" & g_refCfg
End If
LogStage "TEMP_VIEW_CLEANUP", "deferred stale macro-owned model view cleanup until output sheet reset is complete"
'--- prepare output sheet --------------------------------------------------------
LogStage "SHEET", "preparing output sheet"
Dim templateSheet As SldWorks.Sheet
Set templateSheet = g_swDraw.GetCurrentSheet
If Not templateSheet Is Nothing Then
LogKeyValue "SHEET", "templateSheetName", SafeStr(templateSheet.GetName)
LogKeyValue "SHEET", "templatePath", SafeStr(templateSheet.GetTemplateName)
End If
If RESET_OUTPUT_SHEET Then
If SheetExists(g_swDraw, OUTPUT_SHEET_NAME) Then
On Error Resume Next
g_swDraw.DeleteSheet OUTPUT_SHEET_NAME
On Error GoTo 0
End If
EnsureSheetExistsCopyProps g_swDraw, templateSheet, OUTPUT_SHEET_NAME
Else
If Not SheetExists(g_swDraw, OUTPUT_SHEET_NAME) Then
EnsureSheetExistsCopyProps g_swDraw, templateSheet, OUTPUT_SHEET_NAME
End If
End If
g_swDraw.ActivateSheet OUTPUT_SHEET_NAME
ForceSheetContext
LogKeyValue "SHEET", "activeOutputSheet", OUTPUT_SHEET_NAME
LogStage "TEMP_VIEW_CLEANUP", "removing stale macro-owned model views after output sheet reset"
CleanupMacroTempModelViews g_refModel, "startup"
'--- exact sheet bounds ----------------------------------------------------------
LogStage "SHEET_BOUNDS", "reading exact sheet outline"
Dim sx0 As Double, sy0 As Double, sx1 As Double, sy1 As Double
If Not GetSheetBoundsExact(g_swDraw, sx0, sy0, sx1, sy1) Then
LogError "SHEET_BOUNDS | failed to read exact sheet bounds from sheet view"
MsgBox "Failed to read exact sheet bounds from sheet view outline.", vbExclamation
GoTo TidyUp
End If
Dim sheetW As Double, sheetH As Double
sheetW = sx1 - sx0
sheetH = sy1 - sy0
LogInfo "SheetBounds | xmin=" & Fmt(sx0) & " ymin=" & Fmt(sy0) & _
" xmax=" & Fmt(sx1) & " ymax=" & Fmt(sy1) & _
" | W=" & Fmt(sheetW) & " H=" & Fmt(sheetH)
'--- permitted placement rectangle -----------------------------------------------
Dim px0 As Double, py0 As Double, px1 As Double, py1 As Double
px0 = sx0 + MARGIN_LEFT
px1 = sx1 - MARGIN_RIGHT
py0 = sy0 + MARGIN_BOTTOM
py1 = sy1 - MARGIN_TOP
If px1 <= px0 Or py1 <= py0 Then
LogError "PLACEMENT_ZONE | invalid permitted rectangle | px0=" & Fmt(px0) & " px1=" & Fmt(px1) & _
" py0=" & Fmt(py0) & " py1=" & Fmt(py1)
MsgBox "Invalid permitted placement rectangle (margins too large).", vbExclamation
GoTo TidyUp
End If
LogInfo "PermRect | x=[" & Fmt(px0) & "," & Fmt(px1) & "] y=[" & Fmt(py0) & "," & Fmt(py1) & "]"
'--- cut-list items --------------------------------------------------------------
LogStage "CUTLIST", "starting cut-list/body discovery"
Dim items As Collection
Set items = GetCutListItems(g_refModel)
If items Is Nothing Or items.Count = 0 Then
LogError "CUTLIST | no cut-list or fallback solid-body items found"
MsgBox "No Cut List items found. Update weldment cut list and try again.", vbExclamation
GoTo TidyUp
End If
LogInfo "Cut-list items = " & items.Count
LogStage "CUTLIST", "DONE | cut-list/body discovery | itemCount=" & CStr(items.Count)
'--- sort by Part Number ascending -----------------------------------------------
LogStage "SORT", "sorting discovered items by PartNo and ItemNo"
Set items = SortCutListItemsByPartNo(items)
LogInfo "Sort | order = ASC PartNo"
'--- target scale (once) ---------------------------------------------------------
LogStage "SCALE", "resolving target drawing view scale"
Dim targetScale As Double
targetScale = ResolveTargetScale(g_refView)
LogInfo "Target scale = " & Fmt(targetScale)
LogKeyValue "SCALE", "targetScaleDecimal", Fmt(targetScale)
'--- staging coords --------------------------------------------------------------
Dim stagingX As Double, stagingY As Double
stagingX = sx1 + STAGING_OFFSET_X
stagingY = sy0 + (sheetH / 2#)
LogInfo "Staging | x=" & Fmt(stagingX) & " y=" & Fmt(stagingY)
'--- placement cursors -----------------------------------------------------------
Dim curLeft As Double, curTop As Double
Dim rowUsedH As Double
' Manual parking strip (for user manual placement later)
Dim parkX0 As Double, parkX1 As Double
parkX0 = sx0 + MARGIN_LEFT
parkX1 = parkX0 + PARK_STRIP_WRAP_WIDTH
If MANUAL_PARK_STRIP_MODE Then
curLeft = parkX0
curTop = sy0 - PARK_STRIP_OFFSET_BELOW_SHEET
rowUsedH = 0#
LogInfo "MANUAL PARK START | x0=" & Fmt(parkX0) & " x1=" & Fmt(parkX1) & _
" | curLeft=" & Fmt(curLeft) & " curTop=" & Fmt(curTop)
Else
curLeft = px0
curTop = py1
rowUsedH = 0#
LogInfo "FAST STACK START | curLeft=" & Fmt(curLeft) & " curTop=" & Fmt(curTop)
End If
'--- processing ------------------------------------------------------------------
Dim i As Long
Dim okCt As Long, failCt As Long, overflowCt As Long
Dim placedViews As New Collection
Dim placedItems As New Collection
okCt = 0: failCt = 0: overflowCt = 0
For i = 1 To items.Count
Dim item As Object
Set item = items(i)
LogDivider "ITEM " & CStr(i)
LogInfo "-- Item[" & i & "] | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & " | qty=" & SafeStr(item("Qty"))
LogKeyValue "ITEM", "index", CStr(i)
LogKeyValue "ITEM", "itemNo", SafeStr(item("ItemNo"))
LogKeyValue "ITEM", "partNo", SafeStr(item("PartNo"))
LogKeyValue "ITEM", "qty", SafeStr(item("Qty"))
LogKeyValue "ITEM", "bbox", Fmt(SafeCDbl(item("dx"))) & " x " & Fmt(SafeCDbl(item("dy"))) & " x " & Fmt(SafeCDbl(item("dz")))
ForceSheetContext
' Keep source model on intended config before creating each view.
Call ActivateModelConfigurationSafe(g_refModel, g_refCfg)
' 1) Create best prepared base view from standard/custom candidate competition.
' The 3D body analysis defines fabrication intent, but normal production
' placement uses existing model views rather than generated temp views.
LogStage "ITEM_ORIENTATION", "START | itemIdx=" & CStr(i) & _
" | strategy=standard/custom view scored by 3D body signature | generatedTempViews=" & BoolWord(ALLOW_GENERATED_BODY_FRAME_VIEWS)
Dim baseViewName As String
Dim swNewView As SldWorks.View
If Not CreatePreparedBestViewForItem(item, stagingX, stagingY, i, swNewView, baseViewName) Then
LogError "CreatePreparedBestViewForItem failed | itemIdx=" & i
failCt = failCt + 1
GoTo NextItem
End If
' 4) The accepted candidate has already been rotated by direct 3D-reference
' projection. This flag remains as a guarded legacy escape hatch only.
If AUTO_ROTATE_TO_HORIZONTAL Then
Call RotateViewToBestHorizontal(g_swDrwModel, swNewView, item, "Place itemIdx=" & CStr(i))
End If
' 5) Apply scale
LogStage "ITEM_SCALE", "applying target scale | itemIdx=" & CStr(i) & " | scale=" & Fmt(targetScale)
If Not ApplyViewScale(swNewView, targetScale) Then
LogError "ApplyViewScale failed | itemIdx=" & i
SafeDeleteView g_swDrwModel, swNewView
failCt = failCt + 1
GoTo NextItem
End If
' Re-assert config after scale / rebuild-sensitive changes
If Not EnsureViewUsesConfiguration(swNewView, g_refCfg, "post-scale itemIdx=" & CStr(i)) Then
LogWarn "EnsureViewUsesConfiguration failed after scale | itemIdx=" & i & _
" | continuing but bubble may not resolve"
End If
g_swDrwModel.EditRebuild3
' 6) Measure view at staging
Dim vW As Double, vH As Double
If Not GetViewWH(swNewView, vW, vH) Then
LogError "GetViewWH failed | itemIdx=" & i
SafeDeleteView g_swDrwModel, swNewView
failCt = failCt + 1
GoTo NextItem
End If
If vW <= 0# Or vH <= 0# Then
LogError "Invalid view size | itemIdx=" & i & " | w=" & Fmt(vW) & " h=" & Fmt(vH)
SafeDeleteView g_swDrwModel, swNewView
failCt = failCt + 1
GoTo NextItem
End If
LogKeyValue "ITEM_VIEW", "measuredSize", Fmt(vW) & " x " & Fmt(vH)
Dim itemBlockH As Double
itemBlockH = NOTE_BAND_H + NOTE_TO_VIEW_GAP + vH
' 7) wrap / parking logic
If MANUAL_PARK_STRIP_MODE Then
If PARK_STRIP_ALLOW_WRAP Then
If (curLeft + vW) > parkX1 Then
LogWarn "PLACEMENT | park strip wrap | itemIdx=" & CStr(i) & _
" | curLeft=" & Fmt(curLeft) & " | vW=" & Fmt(vW) & " | parkX1=" & Fmt(parkX1)
curLeft = parkX0
curTop = curTop - rowUsedH - PARK_STRIP_ROW_GAP
rowUsedH = 0#
LogInfo " park wrap row | new curLeft=" & Fmt(curLeft) & " curTop=" & Fmt(curTop)
End If
End If
Else
If STACK_WRAP_ROWS Then
If (curLeft + vW) > px1 Then
LogWarn "PLACEMENT | sheet row wrap | itemIdx=" & CStr(i) & _
" | curLeft=" & Fmt(curLeft) & " | vW=" & Fmt(vW) & " | px1=" & Fmt(px1)
curLeft = px0
curTop = curTop - rowUsedH - STACK_GAP_Y
rowUsedH = 0#
LogInfo " wrap row | new curLeft=" & Fmt(curLeft) & " curTop=" & Fmt(curTop)
End If
End If
' 8) bottom overflow (only for on-sheet mode)
Dim nextBottom As Double
nextBottom = curTop - itemBlockH
If nextBottom < py0 Then
overflowCt = overflowCt + 1
LogWarn " placement below permitted area | itemIdx=" & i & _
" | nextBottom=" & Fmt(nextBottom) & " < py0=" & Fmt(py0)
If Not ALLOW_VERTICAL_OVERFLOW Then
LogError "Stopping due to overflow policy."
SafeDeleteView g_swDrwModel, swNewView
failCt = failCt + 1
Exit For
End If
End If
End If
' 9) compute target positions
Dim slotCX As Double, viewY As Double
slotCX = curLeft + (vW / 2#)
viewY = curTop - NOTE_BAND_H - NOTE_TO_VIEW_GAP - (vH / 2#)
' 10) final position
LogStage "ITEM_PLACEMENT", "placing view | itemIdx=" & CStr(i) & _
" | targetCenter=(" & Fmt(slotCX) & "," & Fmt(viewY) & ")"
If Not ForceViewPosition(swNewView, slotCX, viewY, POS_TOL, POS_RETRY) Then
LogError "ForceViewPosition failed | itemIdx=" & i
SafeDeleteView g_swDrwModel, swNewView
failCt = failCt + 1
GoTo NextItem
End If
' Final config assertion before accepting placed view
If Not EnsureViewUsesConfiguration(swNewView, g_refCfg, "final-place itemIdx=" & CStr(i)) Then
LogWarn "Final configuration validation failed | itemIdx=" & i & _
" | cfg=" & g_refCfg & " | current=" & SafeStr(swNewView.ReferencedConfiguration)
End If
' 11) rename
On Error Resume Next
swNewView.SetName2 "COPE_" & Format$(i, "0000")
On Error GoTo 0
placedViews.Add swNewView
placedItems.Add item
' 12) advance cursor
curLeft = curLeft + vW + STACK_GAP_X
If itemBlockH > rowUsedH Then rowUsedH = itemBlockH
okCt = okCt + 1
LogInfo " placed OK | view=" & ViewGetNameSafe(swNewView) & _
" | base=" & baseViewName & _
" | cfg=" & SafeStr(swNewView.ReferencedConfiguration) & _
" | size=" & Fmt(vW) & "x" & Fmt(vH) & _
" | pos=(" & Fmt(slotCX) & "," & Fmt(viewY) & ")"
LogStage "ITEM_COMPLETE", "DONE | placed item | itemIdx=" & CStr(i) & _
" | view=" & ViewGetNameSafe(swNewView)
NextItem:
ForceSheetContext
DoEvents
Next i
' Final rebuild once
g_swDrwModel.EditRebuild3
ForceSheetContext
' Pre-balloon config normalization pass
If placedViews.Count > 0 Then
Call NormalizePlacedViewConfigurations(placedViews, g_refCfg)
End If
' Post-pass: insert BOM balloons per view
If ADD_BOM_BALLOON_AFTER_PLACE Then
LogStage "BALLOONS", "starting BOM balloon insertion | viewCount=" & CStr(placedViews.Count)
Dim balloonCt As Long
balloonCt = AddBOMBalloonsForPlacedViews(placedViews, placedItems)
LogInfo "BOM balloons inserted = " & CStr(balloonCt) & " / " & CStr(placedViews.Count)
End If
LogStage "SAVE", "drawing save not performed by this macro iteration; currentDrawingPath=" & ModelPathSafe(g_swDrwModel)
' Summary
If failCt > 0 Or overflowCt > 0 Then
LogWarn "DONE WITH WARNINGS | OK=" & okCt & " FAIL=" & failCt & " OVERFLOW=" & overflowCt
MsgBox "Completed (FAST STACK)." & vbCrLf & _
"OK = " & okCt & vbCrLf & _
"FAIL = " & failCt & vbCrLf & _
"Overflow placements = " & overflowCt & vbCrLf & _
"See Immediate Window (Ctrl+G) for details.", vbExclamation
Else
LogInfo "DONE | OK=" & okCt & " FAIL=" & failCt & " OVERFLOW=" & overflowCt
End If
LogStage "MACRO_END", "normal completion reached | OK=" & CStr(okCt) & _
" | FAIL=" & CStr(failCt) & " | OVERFLOW=" & CStr(overflowCt)
LogDivider "MACRO END"
TidyUp:
LogStage "TIDYUP", "starting cleanup"
If Not g_refModel Is Nothing Then
CleanupMacroTempModelViews g_refModel, "tidyup_keep_accepted"
End If
If g_openedModel And Len(g_openedModelTitle) > 0 Then
On Error Resume Next
If ProtectedTempModelViewCount() > 0 Then
LogWarn "TIDYUP | leaving model open because accepted drawing views still depend on temporary named views | title=" & _
g_openedModelTitle & " | keptTempViews=" & CStr(ProtectedTempModelViewCount())
Else
LogStage "TIDYUP", "closing model opened by macro | title=" & g_openedModelTitle
g_swApp.CloseDoc g_openedModelTitle
End If
On Error GoTo 0
End If
LogStage "TIDYUP", "clearing module globals"
Set g_refModel = Nothing
Set g_refView = Nothing
Set g_tempViewNames = Nothing
Set g_keepTempViewNames = Nothing
Set g_swDraw = Nothing
Set g_swDrwModel = Nothing
Set g_swApp = Nothing
LogStage "TIDYUP", "cleanup complete"
CloseDebugLog
Exit Sub
EH:
LogError "EXCEPTION | " & Err.Number & " | " & Err.Description
LogError "FATAL | main terminated by top-level error | errNumber=" & CStr(Err.Number) & _
" | errDescription=" & Err.Description
MsgBox "Macro error: " & Err.Description, vbExclamation
Resume TidyUp
End Sub
'====================================================================================
' SCALE RESOLUTION
'====================================================================================
Private Function ResolveTargetScale(ByVal refV As SldWorks.View) As Double
On Error GoTo EH
Dim s As Double
s = DETAIL_SCALE_DECIMAL
If s <= 0# Then
s = 1#
On Error Resume Next
s = refV.ScaleDecimal
On Error GoTo 0
If s <= 0# Then s = 1#
End If
If MIN_SCALE_DECIMAL > 0# Then If s < MIN_SCALE_DECIMAL Then s = MIN_SCALE_DECIMAL
If MAX_SCALE_DECIMAL > 0# Then If s > MAX_SCALE_DECIMAL Then s = MAX_SCALE_DECIMAL
If s <= 0# Then s = 1#
ResolveTargetScale = s
Exit Function
EH:
ResolveTargetScale = 1#
End Function
Private Function BuildBodyOrientationCandidates(ByVal item As Object) As Collection
On Error GoTo EH
Dim outCol As New Collection
Set BuildBodyOrientationCandidates = outCol
If item Is Nothing Then Exit Function
Call EnsureItemCategoryAnalysis(item)
Dim swBody As SldWorks.Body2
Set swBody = Nothing
On Error Resume Next
Set swBody = item("RepBody_Model")
On Error GoTo EH
If swBody Is Nothing Then Exit Function
Dim axisX As Double, axisY As Double, axisZ As Double
If Not GetItemPrimaryAxis(item, axisX, axisY, axisZ) Then
axisX = 1#: axisY = 0#: axisZ = 0#
End If
Dim seen As Object
Set seen = CreateObject("Scripting.Dictionary")
Dim catName As String
catName = UCase$(SafeStr(item("BodyCategory")))
Dim faceIdx As Long
For faceIdx = 1 To 6
Dim nx As Double, ny As Double, nz As Double
Dim faceArea As Double
nx = SafeCDbl(item("Sig_FaceDir" & CStr(faceIdx) & "X"))
ny = SafeCDbl(item("Sig_FaceDir" & CStr(faceIdx) & "Y"))
nz = SafeCDbl(item("Sig_FaceDir" & CStr(faceIdx) & "Z"))
faceArea = SafeCDbl(item("Sig_FaceDir" & CStr(faceIdx) & "Area"))
If faceArea > 0# And NormalizeVector3(nx, ny, nz) Then
Dim dotLen As Double
dotLen = Abs(Dot3(axisX, axisY, axisZ, nx, ny, nz))
If catName = UCase$(CAT_NAME_SHEET_PLATE) Or dotLen <= BODY_ORIENT_FACE_DOT_LEN_MAX Then
Dim px As Double, py As Double, pz As Double
px = axisX: py = axisY: pz = axisZ
If Not ProjectVectorOffAxis(px, py, pz, nx, ny, nz) Then
If Not GetBestPerpendicularWorldAxis(nx, ny, nz, px, py, pz) Then
px = 1#: py = 0#: pz = 0#
End If
End If
Dim baseScore As Double
baseScore = (faceArea * 100000000#) + (SafeCDbl(item("Sig_PrimaryDirLen")) * 1000#) - (dotLen * 1000000#)
If catName = UCase$(CAT_NAME_SHEET_PLATE) Then baseScore = baseScore + 5000000#
If faceIdx = 1 Then baseScore = baseScore + 2500000#
AddBodyOrientationCandidate outCol, seen, item, _
"FACE_NORMAL_" & CStr(faceIdx) & "_A", _
px, py, pz, nx, ny, nz, baseScore, _
"planar face family rank=" & CStr(faceIdx) & " area=" & Fmt(faceArea) & " dotLength=" & Fmt(dotLen)
AddBodyOrientationCandidate outCol, seen, item, _
"FACE_NORMAL_" & CStr(faceIdx) & "_B", _
px, py, pz, -nx, -ny, -nz, baseScore - 1#, _
"opposite planar face family rank=" & CStr(faceIdx) & " area=" & Fmt(faceArea) & " dotLength=" & Fmt(dotLen)
End If
End If
Next faceIdx
Dim fx As Double, fy As Double, fz As Double
If GetBestPerpendicularWorldAxis(axisX, axisY, axisZ, fx, fy, fz) Then
AddBodyOrientationCandidate outCol, seen, item, _
"AXIS_PERP_WORLD_A", _
axisX, axisY, axisZ, fx, fy, fz, 1000#, _
"fallback perpendicular world axis"
AddBodyOrientationCandidate outCol, seen, item, _
"AXIS_PERP_WORLD_B", _
axisX, axisY, axisZ, -fx, -fy, -fz, 999#, _
"fallback opposite perpendicular world axis"
End If
Dim sx As Double, sy As Double, sz As Double
sx = SafeCDbl(item("Sig_SecondaryDirX"))
sy = SafeCDbl(item("Sig_SecondaryDirY"))
sz = SafeCDbl(item("Sig_SecondaryDirZ"))
If NormalizeVector3(sx, sy, sz) Then
If Abs(Dot3(axisX, axisY, axisZ, sx, sy, sz)) <= 0.8 Then
AddBodyOrientationCandidate outCol, seen, item, _
"AXIS_PERP_SECONDARY", _
axisX, axisY, axisZ, sx, sy, sz, 800#, _
"fallback secondary direction"
End If
End If
LogInfo "BodyOrientation | built candidates | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | count=" & CStr(outCol.Count)
Exit Function
EH:
LogError "BuildBodyOrientationCandidates exception | " & Err.Number & " | " & Err.Description & _
" | itemNo=" & SafeStr(item("ItemNo"))
Set BuildBodyOrientationCandidates = New Collection
End Function
Private Sub AddBodyOrientationCandidate(ByVal outCol As Collection, _
ByVal seen As Object, _
ByVal item As Object, _
ByVal kind As String, _
ByVal axisX As Double, ByVal axisY As Double, ByVal axisZ As Double, _
ByVal viewX As Double, ByVal viewY As Double, ByVal viewZ As Double, _
ByVal baseScore As Double, _
ByVal reason As String)
On Error GoTo EH
If outCol Is Nothing Then Exit Sub
If seen Is Nothing Then Exit Sub
If Not NormalizeVector3(axisX, axisY, axisZ) Then Exit Sub
If Not NormalizeVector3(viewX, viewY, viewZ) Then Exit Sub
If Not ProjectVectorOffAxis(axisX, axisY, axisZ, viewX, viewY, viewZ) Then Exit Sub
Dim upX As Double, upY As Double, upZ As Double
Cross3 viewX, viewY, viewZ, axisX, axisY, axisZ, upX, upY, upZ
If Not NormalizeVector3(upX, upY, upZ) Then Exit Sub
' Rebuild X from Y/Z so the final triad is cleanly orthonormal.
Cross3 upX, upY, upZ, viewX, viewY, viewZ, axisX, axisY, axisZ
If Not NormalizeVector3(axisX, axisY, axisZ) Then Exit Sub
Dim key As String
key = MakeOrientationCandidateKey(axisX, axisY, axisZ, viewX, viewY, viewZ)
If Len(key) = 0 Then Exit Sub
If seen.Exists(key) Then Exit Sub
seen.Add key, True
Dim xSpan As Double, ySpan As Double, zSpan As Double
Call GetBodyFrameExtentMetrics(item, axisX, axisY, axisZ, upX, upY, upZ, viewX, viewY, viewZ, xSpan, ySpan, zSpan)
Dim cand As Object
Set cand = CreateObject("Scripting.Dictionary")
cand("Kind") = kind
cand("Score") = baseScore + (ySpan * 100000#) - (zSpan * 1000#)
cand("Reason") = reason & " | modelSpanXYZ=" & Fmt(xSpan) & "/" & Fmt(ySpan) & "/" & Fmt(zSpan)
cand("Xx") = axisX: cand("Xy") = axisY: cand("Xz") = axisZ
cand("Yx") = upX: cand("Yy") = upY: cand("Yz") = upZ
cand("Zx") = viewX: cand("Zy") = viewY: cand("Zz") = viewZ
cand("ModelXSpan") = xSpan
cand("ModelYSpan") = ySpan
cand("ModelZSpan") = zSpan
InsertCandidateSorted outCol, cand
If outCol.Count > BODY_ORIENT_MAX_CANDIDATES Then outCol.Remove outCol.Count
Exit Sub
EH:
LogWarn "AddBodyOrientationCandidate exception | " & Err.Number & " | " & Err.Description & _
" | kind=" & kind & " | itemNo=" & SafeStr(item("ItemNo"))
End Sub
Private Sub InsertCandidateSorted(ByVal outCol As Collection, ByVal cand As Object)
On Error GoTo EH
If outCol Is Nothing Then Exit Sub
If cand Is Nothing Then Exit Sub
Dim i As Long
For i = 1 To outCol.Count
If SafeCDbl(cand("Score")) > SafeCDbl(outCol(i)("Score")) Then
outCol.Add cand, , i
Exit Sub
End If
Next i
outCol.Add cand
Exit Sub
EH:
LogWarn "InsertCandidateSorted exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function MakeOrientationCandidateKey(ByVal xx As Double, ByVal xy As Double, ByVal xz As Double, _
ByVal zx As Double, ByVal zy As Double, ByVal zz As Double) As String
On Error GoTo EH
MakeOrientationCandidateKey = Format$(xx, "0.000") & "|" & Format$(xy, "0.000") & "|" & Format$(xz, "0.000") & "|" & _
Format$(zx, "0.000") & "|" & Format$(zy, "0.000") & "|" & Format$(zz, "0.000")
Exit Function
EH:
MakeOrientationCandidateKey = ""
End Function
Private Function GetItemPrimaryAxis(ByVal item As Object, _
ByRef axisX As Double, _
ByRef axisY As Double, _
ByRef axisZ As Double) As Boolean
On Error GoTo EH
axisX = SafeCDbl(item("Sig_PrimaryDirX"))
axisY = SafeCDbl(item("Sig_PrimaryDirY"))
axisZ = SafeCDbl(item("Sig_PrimaryDirZ"))
If NormalizeVector3(axisX, axisY, axisZ) Then
GetItemPrimaryAxis = True
Exit Function
End If
Dim dx As Double, dy As Double, dz As Double
dx = SafeCDbl(item("dx"))
dy = SafeCDbl(item("dy"))
dz = SafeCDbl(item("dz"))
If dx >= dy And dx >= dz Then
axisX = 1#: axisY = 0#: axisZ = 0#
ElseIf dy >= dx And dy >= dz Then
axisX = 0#: axisY = 1#: axisZ = 0#
Else
axisX = 0#: axisY = 0#: axisZ = 1#
End If
GetItemPrimaryAxis = True
Exit Function
EH:
axisX = 1#: axisY = 0#: axisZ = 0#
GetItemPrimaryAxis = True
End Function
Private Function TryGetBodyFabricationFrame(ByVal item As Object, _
ByRef primaryX As Double, _
ByRef primaryY As Double, _
ByRef primaryZ As Double, _
ByRef secondaryX As Double, _
ByRef secondaryY As Double, _
ByRef secondaryZ As Double, _
ByRef hasSecondary As Boolean, _
ByRef frameReason As String) As Boolean
On Error GoTo EH
TryGetBodyFabricationFrame = False
primaryX = 0#: primaryY = 0#: primaryZ = 0#
secondaryX = 0#: secondaryY = 0#: secondaryZ = 0#
hasSecondary = False
frameReason = ""
If item Is Nothing Then Exit Function
Call EnsureItemCategoryAnalysis(item)
Dim primaryLen As Double
primaryLen = SafeCDbl(item("Sig_PrimaryDirLen"))
primaryX = SafeCDbl(item("Sig_PrimaryDirX"))
primaryY = SafeCDbl(item("Sig_PrimaryDirY"))
primaryZ = SafeCDbl(item("Sig_PrimaryDirZ"))
Dim primaryReason As String
If NormalizeVector3(primaryX, primaryY, primaryZ) And primaryLen > 0# Then
primaryReason = "strongest straight-edge direction family | len=" & Fmt(primaryLen)
ElseIf GetItemPrimaryAxis(item, primaryX, primaryY, primaryZ) Then
primaryReason = "fallback item primary axis/bbox axis"
Else
frameReason = "no usable primary length axis"
Exit Function
End If
Dim secondaryReason As String
hasSecondary = TryChooseFabricationSecondaryAxis(item, primaryX, primaryY, primaryZ, _
secondaryX, secondaryY, secondaryZ, secondaryReason)
Dim secondaryFrameReason As String
If hasSecondary Then
secondaryFrameReason = secondaryReason
Else
secondaryFrameReason = "not available"
End If
frameReason = "primary=" & primaryReason & _
" | secondary=" & secondaryFrameReason
LogInfo "RotationBasis3D | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | primary=(" & Fmt(primaryX) & "," & Fmt(primaryY) & "," & Fmt(primaryZ) & ")" & _
" | secondary=(" & Fmt(secondaryX) & "," & Fmt(secondaryY) & "," & Fmt(secondaryZ) & ")" & _
" | hasSecondary=" & BoolWord(hasSecondary) & _
" | reason=" & frameReason
TryGetBodyFabricationFrame = True
Exit Function
EH:
frameReason = "TryGetBodyFabricationFrame exception | " & Err.Number & " | " & Err.Description
LogWarn frameReason & " | itemNo=" & SafeStr(item("ItemNo"))
TryGetBodyFabricationFrame = False
End Function
Private Function TryChooseFabricationSecondaryAxis(ByVal item As Object, _
ByVal primaryX As Double, _
ByVal primaryY As Double, _
ByVal primaryZ As Double, _
ByRef secondaryX As Double, _
ByRef secondaryY As Double, _
ByRef secondaryZ As Double, _
ByRef secondaryReason As String) As Boolean
On Error GoTo EH
TryChooseFabricationSecondaryAxis = False
secondaryX = 0#: secondaryY = 0#: secondaryZ = 0#
secondaryReason = ""
If item Is Nothing Then Exit Function
If Not NormalizeVector3(primaryX, primaryY, primaryZ) Then Exit Function
Dim bestScore As Double
Dim bestIdx As Long
Dim bestDot As Double
bestScore = -1#
bestIdx = 0
bestDot = 1#
Dim faceIdx As Long
For faceIdx = 1 To 6
Dim nx As Double, ny As Double, nz As Double
Dim faceArea As Double
nx = SafeCDbl(item("Sig_FaceDir" & CStr(faceIdx) & "X"))
ny = SafeCDbl(item("Sig_FaceDir" & CStr(faceIdx) & "Y"))
nz = SafeCDbl(item("Sig_FaceDir" & CStr(faceIdx) & "Z"))
faceArea = SafeCDbl(item("Sig_FaceDir" & CStr(faceIdx) & "Area"))
If faceArea > 0# And NormalizeVector3(nx, ny, nz) Then
Dim dotLen As Double
dotLen = Abs(Dot3(primaryX, primaryY, primaryZ, nx, ny, nz))
If dotLen < 0.95 Then
Dim tx As Double, ty As Double, tz As Double
tx = nx: ty = ny: tz = nz
If ProjectVectorOffAxis(tx, ty, tz, primaryX, primaryY, primaryZ) Then
Dim score As Double
score = (faceArea * (1# - dotLen)) + (0.000001 * CDbl(7 - faceIdx))
If score > bestScore Then
bestScore = score
bestIdx = faceIdx
bestDot = dotLen
secondaryX = tx: secondaryY = ty: secondaryZ = tz
End If
End If
End If
End If
Next faceIdx
If bestIdx > 0 Then
TryChooseFabricationSecondaryAxis = True
secondaryReason = "planar face family " & CStr(bestIdx) & _
" projected off primary | score=" & Fmt(bestScore) & _
" | dotPrimary=" & Fmt(bestDot)
Exit Function
End If
If TryGetItemDirectionFamilyOffPrimary(item, "Sig_SecondaryDir", primaryX, primaryY, primaryZ, _
secondaryX, secondaryY, secondaryZ, secondaryReason) Then
TryChooseFabricationSecondaryAxis = True
Exit Function
End If
If TryGetItemDirectionFamilyOffPrimary(item, "Sig_TertiaryDir", primaryX, primaryY, primaryZ, _
secondaryX, secondaryY, secondaryZ, secondaryReason) Then
TryChooseFabricationSecondaryAxis = True
Exit Function
End If
Exit Function
EH:
secondaryReason = "TryChooseFabricationSecondaryAxis exception | " & Err.Number & " | " & Err.Description
LogWarn secondaryReason & " | itemNo=" & SafeStr(item("ItemNo"))
TryChooseFabricationSecondaryAxis = False
End Function
Private Function TryGetItemDirectionFamilyOffPrimary(ByVal item As Object, _
ByVal keyPrefix As String, _
ByVal primaryX As Double, _
ByVal primaryY As Double, _
ByVal primaryZ As Double, _
ByRef outX As Double, _
ByRef outY As Double, _
ByRef outZ As Double, _
ByRef reasonText As String) As Boolean
On Error GoTo EH
TryGetItemDirectionFamilyOffPrimary = False
outX = SafeCDbl(item(keyPrefix & "X"))
outY = SafeCDbl(item(keyPrefix & "Y"))
outZ = SafeCDbl(item(keyPrefix & "Z"))
Dim famLen As Double
famLen = SafeCDbl(item(keyPrefix & "Len"))
If famLen <= 0# Then Exit Function
If Not NormalizeVector3(outX, outY, outZ) Then Exit Function
Dim dotLen As Double
dotLen = Abs(Dot3(primaryX, primaryY, primaryZ, outX, outY, outZ))
If dotLen >= 0.9 Then Exit Function
If Not ProjectVectorOffAxis(outX, outY, outZ, primaryX, primaryY, primaryZ) Then Exit Function
reasonText = keyPrefix & " projected off primary | len=" & Fmt(famLen) & _
" | dotPrimary=" & Fmt(dotLen)
TryGetItemDirectionFamilyOffPrimary = True
Exit Function
EH:
TryGetItemDirectionFamilyOffPrimary = False
End Function
Private Function GetBestPerpendicularWorldAxis(ByVal nx As Double, ByVal ny As Double, ByVal nz As Double, _
ByRef outX As Double, ByRef outY As Double, ByRef outZ As Double) As Boolean
On Error GoTo EH
If Not NormalizeVector3(nx, ny, nz) Then Exit Function
Dim ax As Double, ay As Double, az As Double
ax = 1#: ay = 0#: az = 0#
If Abs(Dot3(nx, ny, nz, ax, ay, az)) > 0.85 Then
ax = 0#: ay = 1#: az = 0#
End If
If Abs(Dot3(nx, ny, nz, ax, ay, az)) > 0.85 Then
ax = 0#: ay = 0#: az = 1#
End If
outX = ax: outY = ay: outZ = az
GetBestPerpendicularWorldAxis = ProjectVectorOffAxis(outX, outY, outZ, nx, ny, nz)
Exit Function
EH:
GetBestPerpendicularWorldAxis = False
End Function
Private Function ProjectVectorOffAxis(ByRef vx As Double, ByRef vy As Double, ByRef vz As Double, _
ByVal nx As Double, ByVal ny As Double, ByVal nz As Double) As Boolean
On Error GoTo EH
If Not NormalizeVector3(nx, ny, nz) Then Exit Function
Dim d As Double
d = Dot3(vx, vy, vz, nx, ny, nz)
vx = vx - (d * nx)
vy = vy - (d * ny)
vz = vz - (d * nz)
ProjectVectorOffAxis = NormalizeVector3(vx, vy, vz)
Exit Function
EH:
ProjectVectorOffAxis = False
End Function
Private Function CreatePreparedBodyCandidateView(ByVal item As Object, _
ByVal cand As Object, _
ByVal stagingX As Double, _
ByVal stagingY As Double, _
ByVal itemIdx As Long, _
ByVal candIdx As Long, _
ByRef swOutView As SldWorks.View, _
ByRef tempViewName As String) As Boolean
On Error GoTo EH
CreatePreparedBodyCandidateView = False
Set swOutView = Nothing
tempViewName = ""
ForceSheetContext
Call ActivateModelConfigurationSafe(g_refModel, g_refCfg)
tempViewName = TEMP_MODEL_VIEW_PREFIX & Format$(itemIdx, "0000") & "_" & Format$(candIdx, "0000") & "_" & Format$(Timer * 1000#, "00000000")
If Not CreateTemporaryModelViewFromCandidate(cand, tempViewName) Then
LogWarn "CreatePreparedBodyCandidateView | temp model view failed | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & " | name=" & tempViewName
RestoreDrawingDocument "temp view create failed"
Exit Function
End If
RestoreDrawingDocument "create body candidate drawing view"
ForceSheetContext
Set swOutView = g_swDraw.CreateDrawViewFromModelView3(g_modelPath, tempViewName, stagingX, stagingY, 0#)
If swOutView Is Nothing Then
LogWarn "CreatePreparedBodyCandidateView | CreateDrawViewFromModelView3 failed | itemIdx=" & CStr(itemIdx) & _
" | tempView=" & tempViewName
Exit Function
End If
On Error Resume Next
swOutView.PositionLocked = False
swOutView.SetName2 "COPE_CAND_" & Format$(itemIdx, "0000") & "_" & Format$(candIdx, "0000")
On Error GoTo EH
If Not EnsureViewUsesConfiguration(swOutView, g_refCfg, "body-cand post-create itemIdx=" & CStr(itemIdx) & " view=" & tempViewName) Then
LogWarn "CreatePreparedBodyCandidateView | EnsureViewUsesConfiguration failed post-create | itemIdx=" & CStr(itemIdx) & _
" | tempView=" & tempViewName & " | cfg=" & g_refCfg
SafeDeleteView g_swDrwModel, swOutView
Set swOutView = Nothing
Exit Function
End If
If Not IsolateBodyFast(swOutView, item) Then
LogWarn "CreatePreparedBodyCandidateView | IsolateBodyFast failed | itemIdx=" & CStr(itemIdx) & _
" | tempView=" & tempViewName
SafeDeleteView g_swDrwModel, swOutView
Set swOutView = Nothing
Exit Function
End If
g_swDrwModel.EditRebuild3
ForceSheetContext
CreatePreparedBodyCandidateView = True
Exit Function
EH:
LogError "CreatePreparedBodyCandidateView exception | " & Err.Number & " | " & Err.Description & _
" | itemIdx=" & CStr(itemIdx) & " | tempView=" & tempViewName
If Not swOutView Is Nothing Then SafeDeleteView g_swDrwModel, swOutView
Set swOutView = Nothing
CreatePreparedBodyCandidateView = False
End Function
Private Function CreateTemporaryModelViewFromCandidate(ByVal cand As Object, ByVal tempViewName As String) As Boolean
On Error GoTo EH
CreateTemporaryModelViewFromCandidate = False
Dim swView As SldWorks.ModelView
Dim originalOrientation As SldWorks.MathTransform
Dim didChangeModelView As Boolean
If cand Is Nothing Then Exit Function
If Len(Trim$(tempViewName)) = 0 Then Exit Function
If g_refModel Is Nothing Then Exit Function
If Not ActivateModelDocumentForViewSetup("CreateTemporaryModelViewFromCandidate") Then Exit Function
On Error Resume Next
g_refModel.DeleteNamedView tempViewName
Err.Clear
On Error GoTo EH
Set swView = g_refModel.ActiveView
If swView Is Nothing Then
LogWarn "CreateTemporaryModelViewFromCandidate | model ActiveView is Nothing | name=" & tempViewName
Exit Function
End If
On Error Resume Next
Set originalOrientation = swView.Orientation3
If Err.Number <> 0 Then
LogWarn "CreateTemporaryModelViewFromCandidate | could not capture original model view orientation | " & _
Err.Number & " | " & Err.Description & " | name=" & tempViewName
Err.Clear
Else
LogInfo "TempViewCreate | captured original model view orientation | name=" & tempViewName & _
" | ok=" & BoolWord(Not (originalOrientation Is Nothing))
End If
g_refModel.ClearSelection2 True
On Error GoTo EH
Dim swXf As SldWorks.MathTransform
Set swXf = CreateOrientationTransformFromFrame(SafeCDbl(cand("Xx")), SafeCDbl(cand("Xy")), SafeCDbl(cand("Xz")), _
SafeCDbl(cand("Yx")), SafeCDbl(cand("Yy")), SafeCDbl(cand("Yz")), _
SafeCDbl(cand("Zx")), SafeCDbl(cand("Zy")), SafeCDbl(cand("Zz")))
If swXf Is Nothing Then
LogWarn "CreateTemporaryModelViewFromCandidate | transform is Nothing | name=" & tempViewName
Exit Function
End If
swView.Orientation3 = swXf
didChangeModelView = True
On Error Resume Next
' SOLIDWORKS stores the named view camera extents. Zoom-to-fit is required here;
' otherwise drawing views created from this temporary named view can appear empty.
g_refModel.ViewZoomtofit2
If Err.Number <> 0 Then
LogWarn "TempViewCreate | ViewZoomtofit2 failed before NameView | name=" & tempViewName & _
" | " & Err.Number & " | " & Err.Description
Err.Clear
Else
LogInfo "TempViewCreate | zoom-to-fit applied before NameView | name=" & tempViewName
End If
g_refModel.GraphicsRedraw2
On Error GoTo EH
g_refModel.NameView tempViewName
TrackTempModelView tempViewName
CreateTemporaryModelViewFromCandidate = ModelViewNameExists(g_refModel, tempViewName)
LogInfo "TempViewCreate | name=" & tempViewName & _
" | ok=" & BoolWord(CreateTemporaryModelViewFromCandidate)
RestoreModelViewStateAfterTemporaryView swView, originalOrientation, didChangeModelView, tempViewName, "normal"
Exit Function
EH:
LogError "CreateTemporaryModelViewFromCandidate exception | " & Err.Number & " | " & Err.Description & _
" | name=" & tempViewName
RestoreModelViewStateAfterTemporaryView swView, originalOrientation, didChangeModelView, tempViewName, "error"
CreateTemporaryModelViewFromCandidate = False
End Function
Private Sub RestoreModelViewStateAfterTemporaryView(ByVal swView As SldWorks.ModelView, _
ByVal originalOrientation As SldWorks.MathTransform, _
ByVal didChangeModelView As Boolean, _
ByVal tempViewName As String, _
ByVal tag As String)
On Error Resume Next
If Not didChangeModelView Then Exit Sub
If Not swView Is Nothing And Not originalOrientation Is Nothing Then
Err.Clear
swView.Orientation3 = originalOrientation
If Err.Number <> 0 Then
LogWarn "TempViewCreate | failed to restore original model view orientation | tag=" & tag & _
" | name=" & tempViewName & " | " & Err.Number & " | " & Err.Description
Err.Clear
Else
LogInfo "TempViewCreate | restored original model view orientation | tag=" & tag & _
" | name=" & tempViewName
End If
Else
LogWarn "TempViewCreate | original model view orientation unavailable; display may remain changed until redraw/reopen | tag=" & tag & _
" | name=" & tempViewName
End If
If Not g_refModel Is Nothing Then
g_refModel.ClearSelection2 True
g_refModel.GraphicsRedraw2
End If
On Error GoTo 0
End Sub
Private Function CreateOrientationTransformFromFrame(ByVal xx As Double, ByVal xy As Double, ByVal xz As Double, _
ByVal yx As Double, ByVal yy As Double, ByVal yz As Double, _
ByVal zx As Double, ByVal zy As Double, ByVal zz As Double) As SldWorks.MathTransform
On Error GoTo EH
If Not NormalizeVector3(xx, xy, xz) Then Exit Function
If Not NormalizeVector3(yx, yy, yz) Then Exit Function
If Not NormalizeVector3(zx, zy, zz) Then Exit Function
Dim swMu As SldWorks.MathUtility
Set swMu = g_swApp.GetMathUtility
If swMu Is Nothing Then Exit Function
Dim vx As SldWorks.MathVector
Dim vy As SldWorks.MathVector
Dim vz As SldWorks.MathVector
Dim vOrigin As SldWorks.MathVector
Dim swOriginPt As SldWorks.MathPoint
Dim swXf As SldWorks.MathTransform
Set vx = CreateMathVector3(swMu, xx, xy, xz)
Set vy = CreateMathVector3(swMu, yx, yy, yz)
' SOLIDWORKS model-view orientation expects the composed Z vector inverted before inverse.
Set vz = CreateMathVector3(swMu, -zx, -zy, -zz)
Set swOriginPt = CreateMathPoint3(swMu, 0#, 0#, 0#)
If swOriginPt Is Nothing Then Exit Function
Set vOrigin = swOriginPt.ConvertToVector
If vx Is Nothing Or vy Is Nothing Or vz Is Nothing Or vOrigin Is Nothing Then Exit Function
Set swXf = swMu.ComposeTransform(vx, vy, vz, vOrigin, 1#)
If swXf Is Nothing Then Exit Function
Set CreateOrientationTransformFromFrame = swXf.Inverse
Exit Function
EH:
LogWarn "CreateOrientationTransformFromFrame exception | " & Err.Number & " | " & Err.Description
Set CreateOrientationTransformFromFrame = Nothing
End Function
Private Function CreateMathVector3(ByVal swMu As SldWorks.MathUtility, _
ByVal x As Double, ByVal y As Double, ByVal z As Double) As SldWorks.MathVector
On Error GoTo EH
Dim v(0 To 2) As Double
v(0) = x: v(1) = y: v(2) = z
Set CreateMathVector3 = swMu.CreateVector(v)
Exit Function
EH:
Set CreateMathVector3 = Nothing
End Function
Private Function CreateMathPoint3(ByVal swMu As SldWorks.MathUtility, _
ByVal x As Double, ByVal y As Double, ByVal z As Double) As SldWorks.MathPoint
On Error GoTo EH
Dim p(0 To 2) As Double
p(0) = x: p(1) = y: p(2) = z
Set CreateMathPoint3 = swMu.CreatePoint(p)
Exit Function
EH:
Set CreateMathPoint3 = Nothing
End Function
Private Function ActivateModelDocumentForViewSetup(ByVal tag As String) As Boolean
On Error GoTo EH
ActivateModelDocumentForViewSetup = False
If g_swApp Is Nothing Then Exit Function
If g_refModel Is Nothing Then Exit Function
Dim errs As Long
Dim title As String
title = g_refModel.GetTitle
If Len(title) = 0 Then Exit Function
Dim actDoc As SldWorks.ModelDoc2
Set actDoc = g_swApp.ActivateDoc3(title, False, 0, errs)
ActivateModelDocumentForViewSetup = Not (actDoc Is Nothing)
LogInfo "ActivateModelDocumentForViewSetup | tag=" & tag & _
" | title=" & title & _
" | errs=" & CStr(errs) & _
" | ok=" & BoolWord(ActivateModelDocumentForViewSetup)
Exit Function
EH:
LogWarn "ActivateModelDocumentForViewSetup exception | " & Err.Number & " | " & Err.Description & _
" | tag=" & tag
ActivateModelDocumentForViewSetup = False
End Function
Private Sub RestoreDrawingDocument(ByVal tag As String)
On Error Resume Next
If Not g_swApp Is Nothing And Not g_swDrwModel Is Nothing Then
Dim errs As Long
g_swApp.ActivateDoc3 g_swDrwModel.GetTitle, False, 0, errs
If Not g_swDraw Is Nothing Then g_swDraw.ActivateSheet OUTPUT_SHEET_NAME
ForceSheetContext
LogInfo "RestoreDrawingDocument | tag=" & tag & " | errs=" & CStr(errs)
End If
On Error GoTo 0
End Sub
Private Sub TrackTempModelView(ByVal tempViewName As String)
On Error Resume Next
If g_tempViewNames Is Nothing Then Set g_tempViewNames = New Collection
If Len(Trim$(tempViewName)) > 0 Then g_tempViewNames.Add tempViewName
On Error GoTo 0
End Sub
Private Sub ProtectTempModelView(ByVal tempViewName As String)
On Error Resume Next
If Len(Trim$(tempViewName)) = 0 Then Exit Sub
If g_keepTempViewNames Is Nothing Then Set g_keepTempViewNames = CreateObject("Scripting.Dictionary")
Dim key As String
key = UCase$(Trim$(tempViewName))
If Not g_keepTempViewNames.Exists(key) Then
g_keepTempViewNames.Add key, tempViewName
LogInfo "TempViewKeep | accepted drawing view still depends on temp named view | name=" & tempViewName
End If
On Error GoTo 0
End Sub
Private Function ShouldKeepTempModelView(ByVal tempViewName As String, ByVal tag As String) As Boolean
On Error GoTo EH
ShouldKeepTempModelView = False
If Len(Trim$(tempViewName)) = 0 Then Exit Function
If InStr(1, tag, "keep_accepted", vbTextCompare) = 0 Then Exit Function
If g_keepTempViewNames Is Nothing Then Exit Function
ShouldKeepTempModelView = g_keepTempViewNames.Exists(UCase$(Trim$(tempViewName)))
Exit Function
EH:
ShouldKeepTempModelView = False
End Function
Private Function ProtectedTempModelViewCount() As Long
On Error GoTo EH
ProtectedTempModelViewCount = 0
If g_keepTempViewNames Is Nothing Then Exit Function
ProtectedTempModelViewCount = CLng(g_keepTempViewNames.Count)
Exit Function
EH:
ProtectedTempModelViewCount = 0
End Function
Private Function ModelViewNameExists(ByVal swModel As SldWorks.ModelDoc2, ByVal viewName As String) As Boolean
On Error GoTo EH
Dim vNames As Variant
vNames = GetModelViewNamesSafe(swModel)
If Not IsArray(vNames) Then Exit Function
Dim i As Long
For i = LBound(vNames) To UBound(vNames)
If StrComp(SafeStr(vNames(i)), viewName, vbTextCompare) = 0 Then
ModelViewNameExists = True
Exit Function
End If
Next i
Exit Function
EH:
ModelViewNameExists = False
End Function
Private Sub CleanupMacroTempModelViews(ByVal swModel As SldWorks.ModelDoc2, ByVal tag As String)
On Error GoTo EH
If swModel Is Nothing Then Exit Sub
Dim namesToDelete As Object
Set namesToDelete = CreateObject("Scripting.Dictionary")
Dim vNames As Variant
vNames = GetModelViewNamesSafe(swModel)
If IsArray(vNames) Then
Dim i As Long
For i = LBound(vNames) To UBound(vNames)
Dim nm As String
nm = SafeStr(vNames(i))
If Left$(UCase$(nm), Len(TEMP_MODEL_VIEW_PREFIX)) = UCase$(TEMP_MODEL_VIEW_PREFIX) Then
If Not namesToDelete.Exists(UCase$(nm)) Then namesToDelete.Add UCase$(nm), nm
End If
Next i
End If
If Not g_tempViewNames Is Nothing Then
Dim j As Long
For j = 1 To g_tempViewNames.Count
nm = SafeStr(g_tempViewNames(j))
If Len(nm) > 0 Then
If Not namesToDelete.Exists(UCase$(nm)) Then namesToDelete.Add UCase$(nm), nm
End If
Next j
End If
Dim key As Variant
For Each key In namesToDelete.Keys
nm = SafeStr(namesToDelete(key))
If Len(nm) > 0 Then
If ShouldKeepTempModelView(nm, tag) Then
LogInfo "TempViewCleanup | keeping accepted temp named view because drawing view depends on it | tag=" & tag & _
" | name=" & nm
GoTo NextNameToDelete
End If
Dim ok As Boolean
On Error Resume Next
ok = swModel.DeleteNamedView(nm)
If Err.Number <> 0 Then
LogWarn "TempViewCleanup | delete error | tag=" & tag & _
" | name=" & nm & _
" | " & Err.Number & " | " & Err.Description
Err.Clear
Else
LogInfo "TempViewCleanup | tag=" & tag & " | name=" & nm & " | ok=" & BoolWord(ok)
End If
On Error GoTo EH
End If
NextNameToDelete:
Next key
If InStr(1, tag, "keep_accepted", vbTextCompare) = 0 Then
Set g_tempViewNames = New Collection
End If
Exit Sub
EH:
LogWarn "CleanupMacroTempModelViews exception | " & Err.Number & " | " & Err.Description & _
" | tag=" & tag
End Sub
Private Function StrictValidatePreparedBodyView(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal cand As Object, _
ByRef validationDetail As String) As Boolean
On Error GoTo EH
StrictValidatePreparedBodyView = False
validationDetail = ""
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
If cand Is Nothing Then Exit Function
Dim bodyCt As Long
bodyCt = GetViewBodyCountSafe(swView)
Dim axisMag As Double
Dim axisAngRad As Double
Dim axisProjectionOk As Boolean
Dim axisProjectionSource As String
axisProjectionOk = TryProjectModelDirectionToView(swView, SafeCDbl(cand("Xx")), SafeCDbl(cand("Xy")), SafeCDbl(cand("Xz")), axisMag, axisAngRad)
If axisProjectionOk Then
axisProjectionSource = "ModelToViewTransform"
Else
' The view was created directly from this model-view basis. If SOLIDWORKS has not
' exposed a usable transform yet, keep validating body isolation and readable profile
' instead of rejecting a potentially correct fabrication view only because transform
' projection was unavailable.
axisMag = 0#
axisAngRad = 0#
axisProjectionSource = "CandidateBasisFallback"
LogWarn "StrictValidate | model-to-view axis projection unavailable; using candidate-frame fallback | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | kind=" & SafeStr(cand("Kind")) & " | bodyCt=" & CStr(bodyCt)
End If
Dim axisRemainDeg As Double
axisRemainDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(axisAngRad)))
Dim xSpan As Double, ySpan As Double, zSpan As Double
Call GetBodyFrameExtentMetrics(item, SafeCDbl(cand("Xx")), SafeCDbl(cand("Xy")), SafeCDbl(cand("Xz")), _
SafeCDbl(cand("Yx")), SafeCDbl(cand("Yy")), SafeCDbl(cand("Yz")), _
SafeCDbl(cand("Zx")), SafeCDbl(cand("Zy")), SafeCDbl(cand("Zz")), _
xSpan, ySpan, zSpan)
Dim profileRatio As Double
If xSpan > 0# Then profileRatio = ySpan / xSpan
Dim minProfile As Double
Dim catName As String
catName = UCase$(SafeStr(item("BodyCategory")))
If catName = UCase$(CAT_NAME_SHEET_PLATE) Then
minProfile = MaxD(STRICT_MIN_PROFILE_ABS, xSpan * STRICT_PLATE_PROFILE_RATIO_MIN)
ElseIf catName = UCase$(CAT_NAME_LINEAR_STRUCTURAL) Then
minProfile = MaxD(STRICT_MIN_PROFILE_ABS, xSpan * STRICT_STRUCT_PROFILE_RATIO_MIN)
Else
minProfile = STRICT_MIN_PROFILE_ABS
End If
Dim broadReadable As Boolean
broadReadable = (ySpan >= minProfile)
Dim bodyOk As Boolean
bodyOk = (bodyCt = 1)
Dim axisOk As Boolean
axisOk = ((Not axisProjectionOk) Or (axisRemainDeg <= STRICT_AXIS_HORIZONTAL_TOL_DEG))
validationDetail = "bodyCt=" & CStr(bodyCt) & _
" | axisRemainDeg=" & Format$(axisRemainDeg, "0.000") & _
" | axisMag=" & Fmt(axisMag) & _
" | axisProjection=" & axisProjectionSource & _
" | modelSpanXYZ=" & Fmt(xSpan) & "/" & Fmt(ySpan) & "/" & Fmt(zSpan) & _
" | profileRatio=" & Fmt(profileRatio) & _
" | minProfile=" & Fmt(minProfile) & _
" | bodyOk=" & BoolWord(bodyOk) & _
" | axisOk=" & BoolWord(axisOk) & _
" | readable=" & BoolWord(broadReadable) & _
" | kind=" & SafeStr(cand("Kind"))
LogInfo "StrictValidate | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | " & validationDetail
StrictValidatePreparedBodyView = (bodyOk And axisOk And broadReadable)
Exit Function
EH:
validationDetail = "StrictValidate exception | " & Err.Number & " | " & Err.Description
LogWarn validationDetail & " | view=" & ViewGetNameSafe(swView)
StrictValidatePreparedBodyView = False
End Function
Private Function ValidateHybridCandidateNotEmpty(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef validationDetail As String) As Boolean
On Error GoTo EH
ValidateHybridCandidateNotEmpty = False
validationDetail = ""
If swView Is Nothing Then
validationDetail = "view is Nothing"
Exit Function
End If
If item Is Nothing Then
validationDetail = "item is Nothing"
Exit Function
End If
Dim bodyCt As Long
bodyCt = GetViewBodyCountSafe(swView)
Dim outlineW As Double, outlineH As Double
Dim outlineOk As Boolean
outlineOk = TryGetViewOutlineWH(swView, outlineW, outlineH)
Dim edgeCt As Long, vertexCt As Long, faceCt As Long
GetVisibleEntityCountsInView swView, edgeCt, vertexCt, faceCt
Dim ptCt As Long
Dim spanLen As Double, spanAng As Double
Dim cloudW As Double, cloudH As Double, cloudArea As Double, cloudDetail As String
Call GetBodyProjectedPointCloudMetrics(swView, item, ptCt, spanLen, spanAng, cloudW, cloudH, cloudArea, cloudDetail)
Dim pcPtCt As Long
Dim pcMajor As Double, pcMajorAng As Double, pcMinor As Double, pcMinorAng As Double, pcRatio As Double, pcDetail As String
Call GetBodyProjectedPrincipalMetrics(swView, item, pcPtCt, pcMajor, pcMajorAng, pcMinor, pcMinorAng, pcRatio, pcDetail)
Dim evidenceCt As Long
evidenceCt = edgeCt + vertexCt + faceCt + ptCt + pcPtCt
validationDetail = "bodyCt=" & CStr(bodyCt) & _
" | outlineOk=" & BoolWord(outlineOk) & _
" | outline=" & Fmt(outlineW) & "x" & Fmt(outlineH) & _
" | visibleEdges=" & CStr(edgeCt) & _
" | visibleVertices=" & CStr(vertexCt) & _
" | visibleFaces=" & CStr(faceCt) & _
" | projectedPts=" & CStr(ptCt) & _
" | principalPts=" & CStr(pcPtCt) & _
" | cloud=" & Fmt(cloudW) & "x" & Fmt(cloudH) & _
" | cloudArea=" & Fmt(cloudArea) & _
" | pcMajor=" & Fmt(pcMajor) & _
" | pcMinor=" & Fmt(pcMinor) & _
" | evidenceCt=" & CStr(evidenceCt)
If bodyCt <> 1 Then
validationDetail = validationDetail & " | reject=body isolation count is not exactly one"
Exit Function
End If
If Not outlineOk Or outlineW <= 0.0000001 Or outlineH <= 0.0000001 Then
validationDetail = validationDetail & " | reject=invalid or zero drawing outline"
Exit Function
End If
If evidenceCt <= 0 Then
validationDetail = validationDetail & " | reject=no visible/projected body evidence"
Exit Function
End If
ValidateHybridCandidateNotEmpty = True
validationDetail = validationDetail & " | ok=True"
Exit Function
EH:
validationDetail = "ValidateHybridCandidateNotEmpty exception | " & Err.Number & " | " & Err.Description
LogWarn validationDetail & " | view=" & ViewGetNameSafe(swView)
ValidateHybridCandidateNotEmpty = False
End Function
Private Function ApplyRoundStockProjectedOutlineFallback(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef ptCt As Long, _
ByRef spanLen As Double, _
ByRef cloudW As Double, _
ByRef cloudH As Double, _
ByRef cloudArea As Double, _
ByRef pcPtCt As Long, _
ByRef pcMajor As Double, _
ByRef pcMajorAng As Double, _
ByRef pcMinor As Double, _
ByRef pcMinorAng As Double, _
ByRef pcRatio As Double, _
ByRef detail As String) As Boolean
On Error GoTo EH
ApplyRoundStockProjectedOutlineFallback = False
detail = ""
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
Dim outlineW As Double, outlineH As Double
outlineW = 0#: outlineH = 0#
If Not TryGetViewOutlineWH(swView, outlineW, outlineH) Then Exit Function
If outlineW <= 0.0000001 Or outlineH <= 0.0000001 Then Exit Function
Dim majorLen As Double, minorLen As Double
Dim majorAng As Double, minorAng As Double
If outlineW >= outlineH Then
majorLen = outlineW
minorLen = outlineH
majorAng = 0#
minorAng = PI / 2#
Else
majorLen = outlineH
minorLen = outlineW
majorAng = PI / 2#
minorAng = 0#
End If
If majorLen <= 0.0000001 Then Exit Function
If pcMajor <= 0# Then pcMajor = majorLen
If pcMinor <= 0# Then pcMinor = minorLen
If pcMajorAng = 0# And pcMinorAng = 0# Then
pcMajorAng = majorAng
pcMinorAng = minorAng
End If
If pcMajor > 0# And pcRatio <= 0# Then pcRatio = pcMinor / pcMajor
If cloudW <= 0# Then cloudW = outlineW
If cloudH <= 0# Then cloudH = outlineH
If cloudArea <= 0# Then cloudArea = outlineW * outlineH
If spanLen <= 0# Then spanLen = Sqr((outlineW * outlineW) + (outlineH * outlineH))
detail = "round-stock outline fallback | outline=" & Fmt(outlineW) & "x" & Fmt(outlineH) & _
" | major=" & Fmt(pcMajor) & _
" | minor=" & Fmt(pcMinor) & _
" | ratio=" & Fmt(pcRatio)
ApplyRoundStockProjectedOutlineFallback = True
Exit Function
EH:
LogWarn "ApplyRoundStockProjectedOutlineFallback exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
ApplyRoundStockProjectedOutlineFallback = False
End Function
Private Function ValidateHybridCandidateReadablePreRotation(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal cand As Object, _
ByRef validationScore As Double, _
ByRef validationDetail As String) As Boolean
On Error GoTo EH
ValidateHybridCandidateReadablePreRotation = False
validationScore = -1E+30
validationDetail = ""
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
Call EnsureItemCategoryAnalysis(item)
Dim catName As String
catName = UCase$(SafeStr(item("BodyCategory")))
Dim subtypeName As String
subtypeName = UCase$(SafeStr(item("BodySubtype")))
Dim famBest As Double, famAng As Double, famSecond As Double, famDetail As String
Dim spanLen As Double, spanAng As Double, cloudW As Double, cloudH As Double, cloudArea As Double, cloudDetail As String
Dim ptCt As Long
Dim pcPtCt As Long, pcMajor As Double, pcMajorAng As Double, pcMinor As Double, pcMinorAng As Double, pcRatio As Double, pcDetail As String
Dim profileMetric As Double, faceMetric As Double
Dim minReadable As Double
Dim readable As Boolean
Dim rejectReason As String
Call GetProjectedDominantDirectionMetrics(swView, item, famBest, famAng, famSecond, famDetail)
Call GetBodyProjectedPointCloudMetrics(swView, item, ptCt, spanLen, spanAng, cloudW, cloudH, cloudArea, cloudDetail)
Call GetBodyProjectedPrincipalMetrics(swView, item, pcPtCt, pcMajor, pcMajorAng, pcMinor, pcMinorAng, pcRatio, pcDetail)
Dim edgeCt As Long, vertexCt As Long, faceCt As Long
GetVisibleEntityCountsInView swView, edgeCt, vertexCt, faceCt
Dim roundFallbackDetail As String
roundFallbackDetail = ""
If pcMajor <= 0# And Not cand Is Nothing Then
If UCase$(SafeStr(cand("Source"))) = "BODY_FRAME" Then
pcMajor = SafeCDbl(cand("ModelXSpan"))
pcMinor = SafeCDbl(cand("ModelYSpan"))
pcRatio = 0#
If pcMajor > 0# Then pcRatio = pcMinor / pcMajor
pcDetail = "body-frame span fallback because projected principal metrics unavailable"
End If
End If
If catName = UCase$(CAT_NAME_ROUND_STOCK) Then
If (pcMajor <= 0# Or spanLen <= 0#) And (edgeCt > 0 Or faceCt > 0) Then
If ApplyRoundStockProjectedOutlineFallback(swView, item, ptCt, spanLen, cloudW, cloudH, cloudArea, _
pcPtCt, pcMajor, pcMajorAng, pcMinor, pcMinorAng, pcRatio, _
roundFallbackDetail) Then
LogInfo "RoundStockFallback | pre-rotation readability metrics restored from outline | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | detail={" & roundFallbackDetail & "}"
End If
End If
End If
profileMetric = MaxD(pcMinor, famSecond)
faceMetric = pcMajor * pcMinor
readable = False
rejectReason = ""
Select Case subtypeName
Case CAT_SUBTYPE_CHANNEL
minReadable = MaxD(CAT_SECTION_PROFILE_ABS_MIN, pcMajor * CAT_CHANNEL_PROFILE_RATIO_MIN)
readable = (pcMajor > 0# And profileMetric >= minReadable And pcMajor >= (profileMetric * 1.1))
validationScore = (pcMajor * 1200000#) + (profileMetric * 1800000#) + _
(famSecond * 1200000#) + (faceMetric * 600000#) + _
(CDbl(edgeCt) * 25#) + (CDbl(faceCt) * 100#)
If Not readable Then rejectReason = "channel view does not show readable web/open-leg profile; side/edge projection rejected"
Case CAT_SUBTYPE_ANGLE
minReadable = MaxD(CAT_SECTION_PROFILE_ABS_MIN, pcMajor * CAT_ANGLE_PROFILE_RATIO_MIN)
readable = (pcMajor > 0# And profileMetric >= minReadable And pcMajor >= (profileMetric * 1.05))
validationScore = (pcMajor * 1250000#) + (profileMetric * 1700000#) + _
(famSecond * 1400000#) + (faceMetric * 500000#) + _
(CDbl(edgeCt) * 25#) + (CDbl(faceCt) * 100#)
If Not readable Then rejectReason = "angle view does not preserve L/profile relationship with one leg on sheet and projecting leg visible"
Case Else
Select Case catName
Case UCase$(CAT_NAME_SHEET_PLATE)
minReadable = MaxD(CAT_PLATE_FACE_ABS_MIN, pcMajor * CAT_PLATE_FACE_RATIO_MIN)
readable = (pcMajor > 0# And pcMinor >= minReadable)
validationScore = (faceMetric * 2500000#) + (pcMinor * 1200000#) + (cloudArea * 250000#) + (spanLen * 50000#)
If Not readable Then rejectReason = "sheet/plate broad face is edge-on or unreadable"
Case UCase$(CAT_NAME_LINEAR_STRUCTURAL)
minReadable = MaxD(CAT_LINEAR_PROFILE_ABS_MIN, pcMajor * CAT_LINEAR_PROFILE_RATIO_MIN)
readable = (pcMajor > 0# And profileMetric >= minReadable)
validationScore = (pcMajor * 1000000#) + (profileMetric * 800000#) + (cloudArea * 150000#) + (famBest * 100000#)
If Not readable Then rejectReason = "linear member profile/detail face is edge-on or unreadable"
Case UCase$(CAT_NAME_CURVED_STRUCTURAL), UCase$(CAT_NAME_ROUND_STOCK), UCase$(CAT_NAME_IRREGULAR)
readable = (pcMajor > 0# Or famBest > 0# Or spanLen > 0#)
validationScore = (pcMajor * 700000#) + (pcMinor * 250000#) + (famBest * 200000#) + (cloudArea * 100000#)
If Not readable Then rejectReason = "no usable projected geometry for category"
Case Else
readable = (pcMajor > 0# Or famBest > 0# Or spanLen > 0#)
validationScore = (pcMajor * 500000#) + (pcMinor * 200000#) + (cloudArea * 100000#)
If Not readable Then rejectReason = "no usable projected geometry"
End Select
End Select
validationDetail = "cat=" & SafeStr(item("BodyCategory")) & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | readable=" & BoolWord(readable) & _
" | minReadable=" & Fmt(minReadable) & _
" | pcMajor=" & Fmt(pcMajor) & "@ang=" & Format$(RadToDeg(pcMajorAng), "0.000") & _
" | pcMinor=" & Fmt(pcMinor) & _
" | pcRatio=" & Fmt(pcRatio) & _
" | profileMetric=" & Fmt(profileMetric) & _
" | faceMetric=" & Fmt(faceMetric) & _
" | famBest=" & Fmt(famBest) & _
" | famSecond=" & Fmt(famSecond) & _
" | spanLen=" & Fmt(spanLen) & _
" | cloud=" & Fmt(cloudW) & "x" & Fmt(cloudH) & _
" | cloudArea=" & Fmt(cloudArea) & _
" | pts=" & CStr(ptCt) & _
" | principalPts=" & CStr(pcPtCt) & _
" | visibleEdges=" & CStr(edgeCt) & _
" | visibleFaces=" & CStr(faceCt) & _
" | score=" & Format$(validationScore, "0.000")
If Len(roundFallbackDetail) > 0 Then
validationDetail = validationDetail & " | fallback={" & roundFallbackDetail & "}"
End If
If Not readable Then
validationDetail = validationDetail & " | reject=" & rejectReason
Exit Function
End If
ValidateHybridCandidateReadablePreRotation = True
Exit Function
EH:
validationDetail = "ValidateHybridCandidateReadablePreRotation exception | " & Err.Number & " | " & Err.Description
LogWarn validationDetail & " | view=" & ViewGetNameSafe(swView)
ValidateHybridCandidateReadablePreRotation = False
End Function
Private Function RotateHybridCandidateAfterFaceValidation(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal tag As String, _
ByRef rotateDetail As String) As Boolean
On Error GoTo EH
RotateHybridCandidateAfterFaceValidation = False
rotateDetail = ""
If swView Is Nothing Then
rotateDetail = "view is Nothing"
Exit Function
End If
Dim beforeAngle As Double
Dim afterAngle As Double
Dim beforeScore As Double
Dim beforeDetail As String
Dim beforeValid As Boolean
Dim subtypeName As String
subtypeName = UCase$(SafeStr(item("BodySubtype")))
beforeAngle = swView.Angle
beforeValid = ValidateOrientationResultByCategory(swView, item, beforeScore, beforeDetail)
If beforeValid Then
If subtypeName = CAT_SUBTYPE_ANGLE Then
Dim alreadyEdgeDetail As String
If Not IsAngleProjectedEdgeFamilyHorizontal(swView, item, alreadyEdgeDetail) Then
LogWarn "RotationEdgeValidation | angle projected model edge is not exactly horizontal; overriding point-cloud-valid state | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | before={" & beforeDetail & "} | edge={" & alreadyEdgeDetail & "}"
Else
rotateDetail = "already valid horizontal | angle projected edge confirmed | angleDeg=" & Format$(RadToDeg(beforeAngle), "0.000") & _
" | before={" & beforeDetail & "} | edge={" & alreadyEdgeDetail & "}"
Exit Function
End If
Else
rotateDetail = "already valid horizontal | angleDeg=" & Format$(RadToDeg(beforeAngle), "0.000") & _
" | before={" & beforeDetail & "}"
Exit Function
End If
End If
Dim rotOk As Boolean
Dim fabDetail As String
Dim edgeFamilyDetail As String
Dim edgeFamilyAvailable As Boolean
Dim fallbackDetail As String
Dim flipDetail As String
Dim usedFallback As Boolean
rotOk = False
fabDetail = "not used"
edgeFamilyDetail = "not used"
edgeFamilyAvailable = False
fallbackDetail = "not used"
flipDetail = "not used"
usedFallback = False
If subtypeName = CAT_SUBTYPE_ANGLE Then
rotOk = TryRotateAngleViewByProjectedEdgeFamily(g_swDrwModel, swView, item, _
tag & " | angle projected model edge-family rotation", _
edgeFamilyDetail, edgeFamilyAvailable)
fabDetail = edgeFamilyDetail
If Not rotOk And edgeFamilyAvailable Then
LogWarn "RotationFallback | blocked legacy fallback because angle model edge-family existed but failed strict validation | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | detail={" & edgeFamilyDetail & "}"
fallbackDetail = "blocked; angle edge-family existed but did not validate"
GoTo BuildRotateDetail
End If
If Not rotOk Then
LogWarn "RotationFallback | angle projected edge-family unavailable; allowing older fallback paths only as last resort | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | detail={" & edgeFamilyDetail & "}"
End If
End If
If Not rotOk Then
rotOk = TryRotateViewByFabricationFrame(g_swDrwModel, swView, item, tag & " | primary 3D fabrication frame", fabDetail)
End If
If Not rotOk Then
usedFallback = True
LogWarn "RotateHybridCandidateAfterFaceValidation | deterministic fabrication-frame rotation did not validate; using legacy category fallback | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | detail={" & fabDetail & "}"
rotOk = TryRotateViewByCategoryReferenceAlignment(g_swDrwModel, swView, item, tag & " | legacy category fallback")
fallbackDetail = "method=legacy-category-fallback | ok=" & BoolWord(rotOk)
' Point-cloud mass flipping is now only a legacy fallback polarity aid. The primary
' deterministic path chooses thetaA/thetaB from a 3D secondary/profile vector.
If ApplySubtypePresentationFlipIfNeeded(g_swDrwModel, swView, item, tag & " | legacy fallback polarity", flipDetail) Then
rotOk = True
End If
End If
BuildRotateDetail:
afterAngle = swView.Angle
RotateHybridCandidateAfterFaceValidation = (Abs(NormalizeAngleRad(afterAngle - beforeAngle)) > DegToRad(0.01))
Dim afterScore As Double
Dim afterDetail As String
Dim afterValid As Boolean
afterValid = ValidateOrientationResultByCategory(swView, item, afterScore, afterDetail)
rotateDetail = "rotOk=" & BoolWord(rotOk) & _
" | rotated=" & BoolWord(RotateHybridCandidateAfterFaceValidation) & _
" | beforeAngleDeg=" & Format$(RadToDeg(beforeAngle), "0.000") & _
" | afterAngleDeg=" & Format$(RadToDeg(afterAngle), "0.000") & _
" | beforeValid=" & BoolWord(beforeValid) & _
" | afterValid=" & BoolWord(afterValid) & _
" | usedFallback=" & BoolWord(usedFallback) & _
" | angleEdgeFamily={" & edgeFamilyDetail & "}" & _
" | fab={" & fabDetail & "}" & _
" | fallback={" & fallbackDetail & "}" & _
" | legacyFlip={" & flipDetail & "}" & _
" | before={" & beforeDetail & "}" & _
" | after={" & afterDetail & "}"
Exit Function
EH:
rotateDetail = "RotateHybridCandidateAfterFaceValidation exception | " & Err.Number & " | " & Err.Description
LogWarn rotateDetail & " | view=" & ViewGetNameSafe(swView)
RotateHybridCandidateAfterFaceValidation = False
End Function
Private Function ApplySubtypePresentationFlipIfNeeded(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal tag As String, _
ByRef flipDetail As String) As Boolean
On Error GoTo EH
ApplySubtypePresentationFlipIfNeeded = False
flipDetail = "not required"
If swDrawModel Is Nothing Then Exit Function
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
Dim subtypeName As String
subtypeName = UCase$(SafeStr(item("BodySubtype")))
' Angle fabrication convention for this workflow:
' one leg reads on the sheet and the other leg projects toward the viewer,
' preferably to the bottom side. A 180-degree flip preserves length
' horizontality while moving an upward-biased L/profile to the bottom.
If subtypeName <> CAT_SUBTYPE_ANGLE Then
flipDetail = "subtype=" & subtypeName & " | no presentation flip rule"
Exit Function
End If
Dim pts As Collection
Set pts = New Collection
If Not CollectProjectedBodySamplePoints(swView, item, pts) Then
flipDetail = "subtype=ANGLE | no projected point cloud for bottom-leg decision"
Exit Function
End If
If pts.Count < 3 Then
flipDetail = "subtype=ANGLE | insufficient projected points=" & CStr(pts.Count)
Exit Function
End If
Dim minY As Double, maxY As Double
Dim firstPt As Variant
firstPt = pts(1)
minY = CDbl(firstPt(1))
maxY = CDbl(firstPt(1))
Dim i As Long
For i = 1 To pts.Count
Dim pv As Variant
pv = pts(i)
If CDbl(pv(1)) < minY Then minY = CDbl(pv(1))
If CDbl(pv(1)) > maxY Then maxY = CDbl(pv(1))
Next i
Dim spanY As Double
spanY = maxY - minY
If spanY <= 0.0000001 Then
flipDetail = "subtype=ANGLE | no vertical profile span"
Exit Function
End If
Dim centerY As Double
centerY = (minY + maxY) / 2#
Dim aboveScore As Double, belowScore As Double
aboveScore = 0#: belowScore = 0#
For i = 1 To pts.Count
pv = pts(i)
Dim dy As Double
dy = CDbl(pv(1)) - centerY
If dy > 0# Then
aboveScore = aboveScore + dy
Else
belowScore = belowScore + Abs(dy)
End If
Next i
Dim shouldFlip As Boolean
shouldFlip = (aboveScore > (belowScore * 1.15)) And ((aboveScore - belowScore) > (spanY * 0.05))
If shouldFlip Then
Dim beforeDeg As Double
Dim targetAngle As Double
beforeDeg = RadToDeg(swView.Angle)
targetAngle = NormalizeAngleRad(swView.Angle + PI)
SetViewAngleAndRefresh swDrawModel, swView, targetAngle, tag & " | angle bottom-leg 180 flip"
ApplySubtypePresentationFlipIfNeeded = True
flipDetail = "subtype=ANGLE | applied=True | reason=profile mass above center; prefer projecting leg/bottom side" & _
" | beforeDeg=" & Format$(beforeDeg, "0.000") & _
" | afterDeg=" & Format$(RadToDeg(swView.Angle), "0.000") & _
" | aboveScore=" & Fmt(aboveScore) & _
" | belowScore=" & Fmt(belowScore) & _
" | spanY=" & Fmt(spanY)
LogInfo "AnglePresentationFlip | view=" & ViewGetNameSafe(swView) & " | " & flipDetail
Else
flipDetail = "subtype=ANGLE | applied=False | bottom-side profile already acceptable or ambiguous" & _
" | aboveScore=" & Fmt(aboveScore) & _
" | belowScore=" & Fmt(belowScore) & _
" | spanY=" & Fmt(spanY)
LogInfo "AnglePresentationFlip | view=" & ViewGetNameSafe(swView) & " | " & flipDetail
End If
Exit Function
EH:
flipDetail = "ApplySubtypePresentationFlipIfNeeded exception | " & Err.Number & " | " & Err.Description
LogWarn flipDetail & " | view=" & ViewGetNameSafe(swView)
ApplySubtypePresentationFlipIfNeeded = False
End Function
Private Function ValidateHybridFinalCandidate(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal cand As Object, _
ByRef validationScore As Double, _
ByRef validationDetail As String) As Boolean
On Error GoTo EH
ValidateHybridFinalCandidate = False
validationScore = -1E+30
validationDetail = ""
If ValidateOrientationResultByCategory(swView, item, validationScore, validationDetail) Then
validationDetail = "method=projected-category | " & validationDetail
ValidateHybridFinalCandidate = True
Exit Function
End If
If Not cand Is Nothing Then
If UCase$(SafeStr(cand("Source"))) = "BODY_FRAME" Then
Dim strictDetail As String
If StrictValidatePreparedBodyView(swView, item, cand, strictDetail) Then
validationScore = 500000# + SafeCDbl(cand("Score"))
validationDetail = "method=body-frame-strict-fallback | " & strictDetail
ValidateHybridFinalCandidate = True
Exit Function
End If
validationDetail = "projected-category failed; body-frame strict fallback failed | projected={" & validationDetail & "} | strict={" & strictDetail & "}"
Exit Function
End If
End If
validationDetail = "projected-category failed | " & validationDetail
Exit Function
EH:
validationDetail = "ValidateHybridFinalCandidate exception | " & Err.Number & " | " & Err.Description
LogWarn validationDetail & " | view=" & ViewGetNameSafe(swView)
ValidateHybridFinalCandidate = False
End Function
Private Function HybridCandidateFinalScore(ByVal sourceName As String, _
ByVal preScore As Double, _
ByVal readableScore As Double, _
ByVal finalValidationScore As Double, _
ByVal rotateApplied As Boolean) As Double
On Error GoTo EH
Dim sourceBonus As Double
Select Case UCase$(Trim$(sourceName))
Case "BODY_FRAME"
If ALLOW_GENERATED_BODY_FRAME_VIEWS Then
sourceBonus = -25000#
Else
sourceBonus = -100000000#
End If
Case "CUSTOM_VIEW"
sourceBonus = 52500#
Case "STANDARD_VIEW"
sourceBonus = 55000#
Case Else
sourceBonus = 0#
End Select
HybridCandidateFinalScore = finalValidationScore + (readableScore * 0.25) + (preScore * 0.05) + sourceBonus
If rotateApplied Then HybridCandidateFinalScore = HybridCandidateFinalScore - 250#
Exit Function
EH:
HybridCandidateFinalScore = finalValidationScore
End Function
Private Sub GetVisibleEntityCountsInView(ByVal swView As SldWorks.View, _
ByRef edgeCt As Long, _
ByRef vertexCt As Long, _
ByRef faceCt As Long)
On Error GoTo EH
edgeCt = 0
vertexCt = 0
faceCt = 0
If swView Is Nothing Then Exit Sub
Dim vVisComps As Variant
On Error Resume Next
vVisComps = swView.GetVisibleComponents
On Error GoTo EH
If IsArray(vVisComps) Then
Dim i As Long
For i = LBound(vVisComps) To UBound(vVisComps)
AddVisibleEntityCountsFromComp swView, vVisComps(i), edgeCt, vertexCt, faceCt
Next i
End If
AddVisibleEntityCountsFromComp swView, Nothing, edgeCt, vertexCt, faceCt
Exit Sub
EH:
LogWarn "GetVisibleEntityCountsInView exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
End Sub
Private Sub AddVisibleEntityCountsFromComp(ByVal swView As SldWorks.View, _
ByVal visComp As Variant, _
ByRef edgeCt As Long, _
ByRef vertexCt As Long, _
ByRef faceCt As Long)
On Error GoTo EH
edgeCt = edgeCt + CountVisibleEntitiesByType(swView, visComp, swViewEntityType_e.swViewEntityType_Edge)
vertexCt = vertexCt + CountVisibleEntitiesByType(swView, visComp, swViewEntityType_e.swViewEntityType_Vertex)
faceCt = faceCt + CountVisibleEntitiesByType(swView, visComp, swViewEntityType_e.swViewEntityType_Face)
Exit Sub
EH:
LogWarn "AddVisibleEntityCountsFromComp exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
End Sub
Private Function CountVisibleEntitiesByType(ByVal swView As SldWorks.View, _
ByVal visComp As Variant, _
ByVal entType As Long) As Long
On Error GoTo EH
CountVisibleEntitiesByType = 0
If swView Is Nothing Then Exit Function
Dim vEnts As Variant
On Error Resume Next
vEnts = swView.GetVisibleEntities2(visComp, entType)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
If IsArray(vEnts) Then CountVisibleEntitiesByType = SafeArrayCount(vEnts)
Exit Function
EH:
CountVisibleEntitiesByType = 0
End Function
Private Sub GetBodyFrameExtentMetrics(ByVal item As Object, _
ByVal xx As Double, ByVal xy As Double, ByVal xz As Double, _
ByVal yx As Double, ByVal yy As Double, ByVal yz As Double, _
ByVal zx As Double, ByVal zy As Double, ByVal zz As Double, _
ByRef xSpan As Double, _
ByRef ySpan As Double, _
ByRef zSpan As Double)
On Error GoTo EH
xSpan = 0#: ySpan = 0#: zSpan = 0#
If item Is Nothing Then Exit Sub
Dim swBody As SldWorks.Body2
Set swBody = Nothing
On Error Resume Next
Set swBody = item("RepBody_Model")
On Error GoTo EH
If swBody Is Nothing Then Exit Sub
xSpan = GetBodyExtentAlongDirection(swBody, xx, xy, xz)
ySpan = GetBodyExtentAlongDirection(swBody, yx, yy, yz)
zSpan = GetBodyExtentAlongDirection(swBody, zx, zy, zz)
Exit Sub
EH:
LogWarn "GetBodyFrameExtentMetrics exception | " & Err.Number & " | " & Err.Description
xSpan = 0#: ySpan = 0#: zSpan = 0#
End Sub
Private Function GetBodyExtentAlongDirection(ByVal swBody As SldWorks.Body2, _
ByVal ux As Double, ByVal uy As Double, ByVal uz As Double) As Double
On Error GoTo EH
GetBodyExtentAlongDirection = 0#
If swBody Is Nothing Then Exit Function
If Not NormalizeVector3(ux, uy, uz) Then Exit Function
Dim gotAny As Boolean
Dim minP As Double, maxP As Double
Dim vEdges As Variant
vEdges = swBody.GetEdges
If IsArray(vEdges) Then
Dim i As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim swEdge As SldWorks.Edge
Set swEdge = vEdges(i)
If Not swEdge Is Nothing Then
Dim swV1 As SldWorks.Vertex
Dim swV2 As SldWorks.Vertex
Set swV1 = swEdge.GetStartVertex
Set swV2 = swEdge.GetEndVertex
AccumVertexProjection swV1, ux, uy, uz, gotAny, minP, maxP
AccumVertexProjection swV2, ux, uy, uz, gotAny, minP, maxP
End If
Next i
End If
If gotAny Then
GetBodyExtentAlongDirection = maxP - minP
Exit Function
End If
GetBodyExtentAlongDirection = GetBodyBoxExtentAlongDirection(swBody, ux, uy, uz)
Exit Function
EH:
LogWarn "GetBodyExtentAlongDirection exception | " & Err.Number & " | " & Err.Description
GetBodyExtentAlongDirection = 0#
End Function
Private Sub AccumVertexProjection(ByVal swVtx As SldWorks.Vertex, _
ByVal ux As Double, ByVal uy As Double, ByVal uz As Double, _
ByRef gotAny As Boolean, _
ByRef minP As Double, _
ByRef maxP As Double)
On Error GoTo EH
If swVtx Is Nothing Then Exit Sub
Dim p As Variant
p = swVtx.GetPoint
If Not IsArray(p) Then Exit Sub
Dim d As Double
d = (CDbl(p(0)) * ux) + (CDbl(p(1)) * uy) + (CDbl(p(2)) * uz)
If Not gotAny Then
minP = d: maxP = d: gotAny = True
Else
If d < minP Then minP = d
If d > maxP Then maxP = d
End If
Exit Sub
EH:
LogWarn "AccumVertexProjection exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function GetBodyBoxExtentAlongDirection(ByVal swBody As SldWorks.Body2, _
ByVal ux As Double, ByVal uy As Double, ByVal uz As Double) As Double
On Error GoTo EH
GetBodyBoxExtentAlongDirection = 0#
Dim bb As Variant
bb = swBody.GetBodyBox
If Not IsArray(bb) Then Exit Function
Dim xs(0 To 1) As Double
Dim ys(0 To 1) As Double
Dim zs(0 To 1) As Double
xs(0) = CDbl(bb(0)): xs(1) = CDbl(bb(3))
ys(0) = CDbl(bb(1)): ys(1) = CDbl(bb(4))
zs(0) = CDbl(bb(2)): zs(1) = CDbl(bb(5))
Dim gotAny As Boolean
Dim minP As Double, maxP As Double
Dim ix As Long, iy As Long, iz As Long
For ix = 0 To 1
For iy = 0 To 1
For iz = 0 To 1
Dim d As Double
d = (xs(ix) * ux) + (ys(iy) * uy) + (zs(iz) * uz)
If Not gotAny Then
minP = d: maxP = d: gotAny = True
Else
If d < minP Then minP = d
If d > maxP Then maxP = d
End If
Next iz
Next iy
Next ix
If gotAny Then GetBodyBoxExtentAlongDirection = maxP - minP
Exit Function
EH:
GetBodyBoxExtentAlongDirection = 0#
End Function
'====================================================================================
' SORT CUT-LIST ITEMS BY PART NUMBER ASCENDING
'====================================================================================
Private Function SortCutListItemsByPartNo(ByVal src As Collection) As Collection
On Error GoTo EH
Dim outCol As New Collection
If src Is Nothing Then
Set SortCutListItemsByPartNo = outCol
Exit Function
End If
If src.Count <= 1 Then
Dim k As Long
For k = 1 To src.Count
outCol.Add src(k)
Next k
Set SortCutListItemsByPartNo = outCol
Exit Function
End If
Dim arr() As Object
ReDim arr(1 To src.Count)
Dim i As Long, j As Long
For i = 1 To src.Count
Set arr(i) = src(i)
Next i
' Insertion sort
For i = 2 To UBound(arr)
Dim tmp As Object
Set tmp = arr(i)
j = i - 1
Do While j >= 1
If CompareItemsByPartNo(arr(j), tmp) > 0 Then
Set arr(j + 1) = arr(j)
j = j - 1
Else
Exit Do
End If
Loop
Set arr(j + 1) = tmp
Next i
For i = 1 To UBound(arr)
outCol.Add arr(i)
LogInfo "Sort[" & i & "] | pn=" & SafeStr(arr(i)("PartNo")) & " | itemNo=" & SafeStr(arr(i)("ItemNo"))
Next i
Set SortCutListItemsByPartNo = outCol
Exit Function
EH:
LogWarn "SortCutListItemsByPartNo exception | " & Err.Number & " | " & Err.Description & " | using unsorted order"
Set SortCutListItemsByPartNo = src
End Function
Private Function CompareItemsByPartNo(ByVal a As Object, ByVal b As Object) As Long
On Error GoTo EH
Dim pa As String, pb As String
pa = Trim$(SafeStr(a("PartNo")))
pb = Trim$(SafeStr(b("PartNo")))
If Len(pa) = 0 Then pa = "~"
If Len(pb) = 0 Then pb = "~"
CompareItemsByPartNo = ComparePartNoSmart(pa, pb)
If CompareItemsByPartNo <> 0 Then Exit Function
CompareItemsByPartNo = CompareItemNo(a, b)
If CompareItemsByPartNo <> 0 Then Exit Function
CompareItemsByPartNo = StrComp(SafeStr(a("Qty")), SafeStr(b("Qty")), vbTextCompare)
Exit Function
EH:
CompareItemsByPartNo = 0
End Function
Private Function ComparePartNoSmart(ByVal s1 As String, ByVal s2 As String) As Long
On Error GoTo EH
Dim stem1 As String, stem2 As String
Dim n1 As Double, n2 As Double
Dim hasNum1 As Boolean, hasNum2 As Boolean
ParseTrailingNumber s1, stem1, n1, hasNum1
ParseTrailingNumber s2, stem2, n2, hasNum2
ComparePartNoSmart = StrComp(UCase$(stem1), UCase$(stem2), vbTextCompare)
If ComparePartNoSmart <> 0 Then Exit Function
If hasNum1 And hasNum2 Then
If n1 < n2 Then
ComparePartNoSmart = -1
ElseIf n1 > n2 Then
ComparePartNoSmart = 1
Else
ComparePartNoSmart = 0
End If
Exit Function
End If
ComparePartNoSmart = StrComp(UCase$(s1), UCase$(s2), vbTextCompare)
Exit Function
EH:
ComparePartNoSmart = StrComp(UCase$(s1), UCase$(s2), vbTextCompare)
End Function
Private Sub ParseTrailingNumber(ByVal s As String, _
ByRef stem As String, _
ByRef numVal As Double, _
ByRef hasNum As Boolean)
On Error GoTo EH
Dim i As Long
Dim t As String
t = Trim$(s)
hasNum = False
numVal = 0#
stem = t
If Len(t) = 0 Then Exit Sub
i = Len(t)
Do While i >= 1
Dim ch As String
ch = Mid$(t, i, 1)
If (ch >= "0" And ch <= "9") Then
i = i - 1
Else
Exit Do
End If
Loop
If i < Len(t) Then
Dim tail As String
tail = Mid$(t, i + 1)
If Len(tail) > 0 And IsNumeric(tail) Then
hasNum = True
numVal = CDbl(tail)
stem = Left$(t, i)
Exit Sub
End If
End If
Exit Sub
EH:
hasNum = False
numVal = 0#
stem = s
End Sub
Private Function CompareItemNo(ByVal a As Object, ByVal b As Object) As Long
On Error GoTo EH
Dim sa As String, sb As String
sa = Trim$(SafeStr(a("ItemNo")))
sb = Trim$(SafeStr(b("ItemNo")))
If IsNumeric(sa) And IsNumeric(sb) Then
Dim da As Double, db As Double
da = CDbl(sa): db = CDbl(sb)
If da < db Then
CompareItemNo = -1
ElseIf da > db Then
CompareItemNo = 1
Else
CompareItemNo = 0
End If
Else
CompareItemNo = StrComp(sa, sb, vbTextCompare)
End If
Exit Function
EH:
CompareItemNo = 0
End Function
'====================================================================================
' CANDIDATE VIEW SELECTION (standard first, then user custom views)
'====================================================================================
Private Function CreatePreparedBestViewForItem(ByVal item As Object, _
ByVal stagingX As Double, _
ByVal stagingY As Double, _
ByVal itemIdx As Long, _
ByRef swBestView As SldWorks.View, _
ByRef bestViewName As String) As Boolean
On Error GoTo EH
CreatePreparedBestViewForItem = False
Set swBestView = Nothing
bestViewName = ""
Call EnsureItemCategoryAnalysis(item)
Dim catName As String
catName = SafeStr(item("BodyCategory"))
Dim subtypeName As String
subtypeName = UCase$(SafeStr(item("BodySubtype")))
Dim cands As Collection
Set cands = BuildHybridOrientationCandidates(item)
If cands Is Nothing Or cands.Count = 0 Then
LogError "HybridOrientation | no candidates | itemIdx=" & CStr(itemIdx) & _
" | itemNo=" & SafeStr(item("ItemNo")) & " | cat=" & catName & _
" | subtype=" & subtypeName
Exit Function
End If
Dim candIdx As Long
Dim bestScore As Double
Dim bestDetail As String
Dim bestSource As String
Dim bestKind As String
Dim bestTransportName As String
Dim bestNeedsProtect As Boolean
bestScore = -1E+300
For candIdx = 1 To cands.Count
Dim cand As Object
Set cand = cands(candIdx)
LogHybridCandidate itemIdx, candIdx, item, cand
Dim swCandView As SldWorks.View
Set swCandView = Nothing
Dim transportName As String
Dim createdOk As Boolean
Dim needsProtect As Boolean
Dim sourceName As String
Dim kindName As String
transportName = ""
sourceName = UCase$(SafeStr(cand("Source")))
kindName = SafeStr(cand("Kind"))
needsProtect = False
If sourceName = "BODY_FRAME" And Not ALLOW_GENERATED_BODY_FRAME_VIEWS Then
LogWarn "HybridCandidateResult | REJECT_GENERATED_VIEW_DISABLED | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | kind=" & kindName
GoTo NextHybridCandidate
End If
If sourceName = "BODY_FRAME" Then
createdOk = CreatePreparedBodyCandidateView(item, cand, stagingX, stagingY, itemIdx, candIdx, swCandView, transportName)
needsProtect = True
Else
transportName = SafeStr(cand("ViewName"))
createdOk = CreatePreparedCandidateView(item, stagingX, stagingY, itemIdx, candIdx, transportName, swCandView)
End If
If Not createdOk Then
LogWarn "HybridCandidateResult | CREATE_FAILED | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | source=" & sourceName & _
" | kind=" & kindName & _
" | transport=" & transportName
GoTo NextHybridCandidate
End If
Dim emptyDetail As String
If Not ValidateHybridCandidateNotEmpty(swCandView, item, emptyDetail) Then
LogWarn "HybridCandidateResult | REJECT_EMPTY | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | source=" & sourceName & _
" | kind=" & kindName & _
" | transport=" & transportName & _
" | detail=" & emptyDetail
SafeDeleteView g_swDrwModel, swCandView
GoTo NextHybridCandidate
End If
Dim readableDetail As String
Dim readableScore As Double
If Not ValidateHybridCandidateReadablePreRotation(swCandView, item, cand, readableScore, readableDetail) Then
LogWarn "HybridCandidateResult | REJECT_FACE | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | source=" & sourceName & _
" | kind=" & kindName & _
" | transport=" & transportName & _
" | empty={" & emptyDetail & "}" & _
" | detail=" & readableDetail
SafeDeleteView g_swDrwModel, swCandView
GoTo NextHybridCandidate
End If
Dim rotateApplied As Boolean
Dim rotateDetail As String
rotateApplied = RotateHybridCandidateAfterFaceValidation(swCandView, item, "hybrid itemIdx=" & CStr(itemIdx) & " candIdx=" & CStr(candIdx), rotateDetail)
Dim postEmptyDetail As String
If Not ValidateHybridCandidateNotEmpty(swCandView, item, postEmptyDetail) Then
LogWarn "HybridCandidateResult | REJECT_EMPTY_AFTER_ROTATE | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | source=" & sourceName & _
" | kind=" & kindName & _
" | transport=" & transportName & _
" | rotateApplied=" & BoolWord(rotateApplied) & _
" | detail=" & postEmptyDetail
SafeDeleteView g_swDrwModel, swCandView
GoTo NextHybridCandidate
End If
Dim finalValidationScore As Double
Dim finalValidationDetail As String
If Not ValidateHybridFinalCandidate(swCandView, item, cand, finalValidationScore, finalValidationDetail) Then
LogWarn "HybridCandidateResult | REJECT_FINAL | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | source=" & sourceName & _
" | kind=" & kindName & _
" | transport=" & transportName & _
" | rotateApplied=" & BoolWord(rotateApplied) & _
" | rotate={" & rotateDetail & "}" & _
" | pre={" & readableDetail & "}" & _
" | final=" & finalValidationDetail
SafeDeleteView g_swDrwModel, swCandView
GoTo NextHybridCandidate
End If
Dim candidateScore As Double
Dim trustAdjustment As Double
candidateScore = HybridCandidateFinalScore(sourceName, SafeCDbl(cand("Score")), readableScore, finalValidationScore, rotateApplied)
trustAdjustment = HybridCandidateTrustAdjustment(sourceName, item, rotateDetail, finalValidationDetail)
candidateScore = candidateScore + trustAdjustment
LogInfo "HybridCandidateResult | VALID | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | source=" & sourceName & _
" | kind=" & kindName & _
" | transport=" & transportName & _
" | view=" & ViewGetNameSafe(swCandView) & _
" | rotateApplied=" & BoolWord(rotateApplied) & _
" | trustAdj=" & Format$(trustAdjustment, "0.000") & _
" | score=" & Format$(candidateScore, "0.000") & _
" | empty={" & postEmptyDetail & "}" & _
" | pre={" & readableDetail & "}" & _
" | rotate={" & rotateDetail & "}" & _
" | final={" & finalValidationDetail & "}"
If swBestView Is Nothing Or candidateScore > bestScore Then
If Not swBestView Is Nothing Then SafeDeleteView g_swDrwModel, swBestView
Set swBestView = swCandView
bestScore = candidateScore
bestViewName = transportName
bestTransportName = transportName
bestSource = sourceName
bestKind = kindName
bestNeedsProtect = needsProtect
bestDetail = "score=" & Format$(candidateScore, "0.000") & _
" | rotateApplied=" & BoolWord(rotateApplied) & _
" | rotate={" & rotateDetail & "}" & _
" | final={" & finalValidationDetail & "}"
Else
SafeDeleteView g_swDrwModel, swCandView
End If
If ShouldStopHybridCandidateSearchAfterValid(item, candIdx, cands.Count, bestSource, bestKind, bestDetail) Then
LogInfo "HybridCandidateSearch | EARLY_STOP | itemIdx=" & CStr(itemIdx) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | candIdx=" & CStr(candIdx) & _
" | totalCandidates=" & CStr(cands.Count) & _
" | winnerSource=" & bestSource & _
" | winnerKind=" & bestKind & _
" | reason=angle front/back projected model edge-family candidate already produced a valid fabrication view"
Exit For
End If
NextHybridCandidate:
ForceSheetContext
DoEvents
Next candIdx
If Not swBestView Is Nothing Then
If bestNeedsProtect And ALLOW_GENERATED_BODY_FRAME_VIEWS Then ProtectTempModelView bestTransportName
LogInfo "HybridOrientationWinner | itemIdx=" & CStr(itemIdx) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | source=" & bestSource & _
" | kind=" & bestKind & _
" | transport=" & bestTransportName & _
" | view=" & ViewGetNameSafe(swBestView) & _
" | " & bestDetail
CreatePreparedBestViewForItem = True
Exit Function
End If
LogError "HybridOrientation | all candidates failed validation | itemIdx=" & CStr(itemIdx) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | cat=" & catName & _
" | candidateCount=" & CStr(cands.Count)
Exit Function
EH:
LogError "CreatePreparedBestViewForItem exception | " & Err.Number & " | " & Err.Description & _
" | itemIdx=" & CStr(itemIdx)
If Not swBestView Is Nothing Then SafeDeleteView g_swDrwModel, swBestView
Set swBestView = Nothing
CreatePreparedBestViewForItem = False
End Function
Private Function ShouldStopHybridCandidateSearchAfterValid(ByVal item As Object, _
ByVal candIdx As Long, _
ByVal totalCandidates As Long, _
ByVal bestSource As String, _
ByVal bestKind As String, _
ByVal bestDetail As String) As Boolean
On Error GoTo EH
ShouldStopHybridCandidateSearchAfterValid = False
If item Is Nothing Then Exit Function
Dim subtypeName As String
subtypeName = UCase$(SafeStr(item("BodySubtype")))
' Keep custom/user views in the competition when they exist. For the common
' standard-only angle case, front/back are the two likely profile views; once
' both have been tested and one is valid by projected model edge-family rotation,
' the remaining top/bottom/left/right candidates mostly add runtime without
' improving fabrication intent. Never early-stop on the legacy point-cloud path.
If subtypeName = CAT_SUBTYPE_ANGLE Then
If totalCandidates = 6 And candIdx >= 2 Then
If Len(bestSource) > 0 Then
If InStr(1, bestDetail, "method=model-edge-family", vbTextCompare) > 0 And _
InStr(1, bestDetail, "valid=True", vbTextCompare) > 0 And _
InStr(1, bestDetail, "usedFallback=True", vbTextCompare) = 0 Then
ShouldStopHybridCandidateSearchAfterValid = True
End If
End If
End If
End If
Exit Function
EH:
ShouldStopHybridCandidateSearchAfterValid = False
End Function
Private Function CreatePreparedCandidateView(ByVal item As Object, _
ByVal stagingX As Double, _
ByVal stagingY As Double, _
ByVal itemIdx As Long, _
ByVal candSeq As Long, _
ByVal viewName As String, _
ByRef swOutView As SldWorks.View) As Boolean
On Error GoTo EH
CreatePreparedCandidateView = False
Set swOutView = Nothing
ForceSheetContext
Call ActivateModelConfigurationSafe(g_refModel, g_refCfg)
Set swOutView = g_swDraw.CreateDrawViewFromModelView3(g_modelPath, viewName, stagingX, stagingY, 0#)
If swOutView Is Nothing Then
LogWarn "CreatePreparedCandidateView | CreateDrawViewFromModelView3 failed | itemIdx=" & CStr(itemIdx) & _
" | viewName=" & viewName
Exit Function
End If
On Error Resume Next
swOutView.PositionLocked = False
swOutView.SetName2 "COPE_CAND_" & Format$(itemIdx, "0000") & "_" & Format$(candSeq, "0000")
On Error GoTo EH
If Not EnsureViewUsesConfiguration(swOutView, g_refCfg, "cand post-create itemIdx=" & CStr(itemIdx) & " view=" & viewName) Then
LogWarn "CreatePreparedCandidateView | EnsureViewUsesConfiguration failed post-create | itemIdx=" & CStr(itemIdx) & _
" | viewName=" & viewName & " | cfg=" & g_refCfg
SafeDeleteView g_swDrwModel, swOutView
Set swOutView = Nothing
Exit Function
End If
If Not IsolateBodyFast(swOutView, item) Then
LogWarn "CreatePreparedCandidateView | IsolateBodyFast failed | itemIdx=" & CStr(itemIdx) & _
" | viewName=" & viewName
SafeDeleteView g_swDrwModel, swOutView
Set swOutView = Nothing
Exit Function
End If
If Not EnsureViewUsesConfiguration(swOutView, g_refCfg, "cand post-isolate itemIdx=" & CStr(itemIdx) & " view=" & viewName) Then
LogWarn "CreatePreparedCandidateView | EnsureViewUsesConfiguration failed post-isolate | itemIdx=" & CStr(itemIdx) & _
" | viewName=" & viewName & " | cfg=" & g_refCfg
End If
g_swDrwModel.EditRebuild3
ForceSheetContext
CreatePreparedCandidateView = True
Exit Function
EH:
LogError "CreatePreparedCandidateView exception | " & Err.Number & " | " & Err.Description & _
" | itemIdx=" & CStr(itemIdx) & " | viewName=" & viewName
If Not swOutView Is Nothing Then SafeDeleteView g_swDrwModel, swOutView
Set swOutView = Nothing
CreatePreparedCandidateView = False
End Function
Private Function GetPrioritizedCandidateViewNames(ByVal swModel As SldWorks.ModelDoc2) As Collection
On Error GoTo EH
Dim outCol As New Collection
Dim seen As Object
Set seen = CreateObject("Scripting.Dictionary")
If ORIENT_TRY_ALL_STANDARD_VIEWS Then
AddCandidateViewName outCol, seen, "*Front"
AddCandidateViewName outCol, seen, "*Back"
AddCandidateViewName outCol, seen, "*Top"
AddCandidateViewName outCol, seen, "*Bottom"
AddCandidateViewName outCol, seen, "*Right"
AddCandidateViewName outCol, seen, "*Left"
End If
If ORIENT_INCLUDE_CUSTOM_MODEL_VIEWS Then
Dim vNames As Variant
vNames = GetModelViewNamesSafe(swModel)
If IsArray(vNames) Then
Dim i As Long
For i = LBound(vNames) To UBound(vNames)
Dim nm As String
nm = Trim$(SafeStr(vNames(i)))
If Len(nm) > 0 Then
If Not IsStandardCandidateViewName(nm) Then
' User-created named views typically do not start with "*".
If Left$(nm, 1) <> "*" Then
AddCandidateViewName outCol, seen, nm
End If
End If
End If
Next i
End If
End If
Set GetPrioritizedCandidateViewNames = outCol
Exit Function
EH:
LogError "GetPrioritizedCandidateViewNames exception | " & Err.Number & " | " & Err.Description
Set GetPrioritizedCandidateViewNames = New Collection
End Function
Private Sub AddCandidateViewName(ByVal outCol As Collection, ByVal seen As Object, ByVal nm As String)
On Error GoTo EH
Dim key As String
key = UCase$(Trim$(nm))
If Len(key) = 0 Then Exit Sub
If seen.Exists(key) Then Exit Sub
seen.Add key, True
outCol.Add nm
Exit Sub
EH:
LogWarn "AddCandidateViewName exception | " & Err.Number & " | " & Err.Description & " | name=" & nm
End Sub
Private Function IsStandardCandidateViewName(ByVal nm As String) As Boolean
Dim u As String
u = UCase$(Trim$(nm))
Select Case u
Case "*FRONT", "*BACK", "*TOP", "*BOTTOM", "*RIGHT", "*LEFT"
IsStandardCandidateViewName = True
Case Else
IsStandardCandidateViewName = False
End Select
End Function
Private Function BuildHybridOrientationCandidates(ByVal item As Object) As Collection
On Error GoTo EH
Dim outCol As New Collection
Set BuildHybridOrientationCandidates = outCol
If item Is Nothing Then Exit Function
Dim seen As Object
Set seen = CreateObject("Scripting.Dictionary")
Dim standardStartCt As Long
standardStartCt = outCol.Count
AddHybridNamedViewCandidate outCol, seen, "STANDARD_VIEW", "*Front", 600#, "standard orthographic candidate"
AddHybridNamedViewCandidate outCol, seen, "STANDARD_VIEW", "*Back", 590#, "standard orthographic candidate"
AddHybridNamedViewCandidate outCol, seen, "STANDARD_VIEW", "*Top", 580#, "standard orthographic candidate"
AddHybridNamedViewCandidate outCol, seen, "STANDARD_VIEW", "*Bottom", 570#, "standard orthographic candidate"
AddHybridNamedViewCandidate outCol, seen, "STANDARD_VIEW", "*Right", 560#, "standard orthographic candidate"
AddHybridNamedViewCandidate outCol, seen, "STANDARD_VIEW", "*Left", 550#, "standard orthographic candidate"
Dim standardCt As Long
standardCt = outCol.Count - standardStartCt
Dim customStartCt As Long
customStartCt = outCol.Count
Dim vNames As Variant
vNames = GetModelViewNamesSafe(g_refModel)
If IsArray(vNames) Then
Dim j As Long
For j = LBound(vNames) To UBound(vNames)
Dim nm As String
nm = Trim$(SafeStr(vNames(j)))
If Len(nm) > 0 Then
If Not IsStandardCandidateViewName(nm) Then
If Left$(nm, 1) <> "*" Then
If Not IsMacroTempModelViewName(nm) Then
AddHybridNamedViewCandidate outCol, seen, "CUSTOM_VIEW", nm, 700#, "user/custom named view candidate"
Else
LogInfo "HybridCandidatePool | skipped macro temp custom view | name=" & nm
End If
End If
End If
End If
Next j
End If
Dim customCt As Long
customCt = outCol.Count - customStartCt
Dim bodyCandCount As Long
bodyCandCount = 0
If ALLOW_GENERATED_BODY_FRAME_VIEWS Then
Dim bodyCands As Collection
Set bodyCands = BuildBodyOrientationCandidates(item)
If Not bodyCands Is Nothing Then
Dim i As Long
For i = 1 To bodyCands.Count
Dim bodyCand As Object
Set bodyCand = bodyCands(i)
If Not bodyCand Is Nothing Then
bodyCand("Source") = "BODY_FRAME"
bodyCand("ViewName") = ""
bodyCand("CandidateLabel") = SafeStr(bodyCand("Kind"))
outCol.Add bodyCand
bodyCandCount = bodyCandCount + 1
End If
Next i
End If
Else
LogInfo "HybridCandidatePool | generated body-frame named-view candidates disabled | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo"))
End If
LogInfo "HybridCandidatePool | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | standardCandidates=" & CStr(standardCt) & _
" | customCandidates=" & CStr(customCt) & _
" | bodyCandidates=" & CStr(bodyCandCount) & _
" | totalCandidates=" & CStr(outCol.Count)
Exit Function
EH:
LogError "BuildHybridOrientationCandidates exception | " & Err.Number & " | " & Err.Description & _
" | itemNo=" & SafeStr(item("ItemNo"))
Set BuildHybridOrientationCandidates = New Collection
End Function
Private Sub AddHybridNamedViewCandidate(ByVal outCol As Collection, _
ByVal seen As Object, _
ByVal sourceName As String, _
ByVal viewName As String, _
ByVal preScore As Double, _
ByVal reason As String)
On Error GoTo EH
If outCol Is Nothing Then Exit Sub
If seen Is Nothing Then Exit Sub
If Len(Trim$(viewName)) = 0 Then Exit Sub
Dim key As String
key = UCase$(Trim$(sourceName)) & "|" & UCase$(Trim$(viewName))
If seen.Exists(key) Then Exit Sub
seen.Add key, True
Dim cand As Object
Set cand = CreateObject("Scripting.Dictionary")
cand("Source") = UCase$(Trim$(sourceName))
cand("ViewName") = viewName
cand("Kind") = UCase$(Trim$(sourceName)) & ":" & viewName
cand("CandidateLabel") = viewName
cand("Score") = preScore
cand("Reason") = reason
outCol.Add cand
Exit Sub
EH:
LogWarn "AddHybridNamedViewCandidate exception | " & Err.Number & " | " & Err.Description & _
" | source=" & sourceName & " | viewName=" & viewName
End Sub
Private Function IsMacroTempModelViewName(ByVal viewName As String) As Boolean
IsMacroTempModelViewName = (Left$(UCase$(Trim$(viewName)), Len(TEMP_MODEL_VIEW_PREFIX)) = UCase$(TEMP_MODEL_VIEW_PREFIX))
End Function
Private Sub LogHybridCandidate(ByVal itemIdx As Long, ByVal candIdx As Long, ByVal item As Object, ByVal cand As Object)
On Error GoTo EH
If cand Is Nothing Then Exit Sub
Dim sourceName As String
sourceName = UCase$(SafeStr(cand("Source")))
If sourceName = "BODY_FRAME" Then
LogInfo "HybridCandidate | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | source=BODY_FRAME" & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | kind=" & SafeStr(cand("Kind")) & _
" | preScore=" & Format$(SafeCDbl(cand("Score")), "0.000") & _
" | x=(" & Fmt(SafeCDbl(cand("Xx"))) & "," & Fmt(SafeCDbl(cand("Xy"))) & "," & Fmt(SafeCDbl(cand("Xz"))) & ")" & _
" | y=(" & Fmt(SafeCDbl(cand("Yx"))) & "," & Fmt(SafeCDbl(cand("Yy"))) & "," & Fmt(SafeCDbl(cand("Yz"))) & ")" & _
" | z=(" & Fmt(SafeCDbl(cand("Zx"))) & "," & Fmt(SafeCDbl(cand("Zy"))) & "," & Fmt(SafeCDbl(cand("Zz"))) & ")" & _
" | reason=" & SafeStr(cand("Reason"))
Else
LogInfo "HybridCandidate | itemIdx=" & CStr(itemIdx) & _
" | candIdx=" & CStr(candIdx) & _
" | source=" & sourceName & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | viewName=" & SafeStr(cand("ViewName")) & _
" | kind=" & SafeStr(cand("Kind")) & _
" | preScore=" & Format$(SafeCDbl(cand("Score")), "0.000") & _
" | reason=" & SafeStr(cand("Reason"))
End If
Exit Sub
EH:
LogWarn "LogHybridCandidate exception | " & Err.Number & " | " & Err.Description & _
" | itemIdx=" & CStr(itemIdx) & " | candIdx=" & CStr(candIdx)
End Sub
Private Function GetModelViewNamesSafe(ByVal swModel As SldWorks.ModelDoc2) As Variant
On Error GoTo EH
GetModelViewNamesSafe = Empty
If swModel Is Nothing Then Exit Function
Dim vNames As Variant
Err.Clear
On Error Resume Next
vNames = CallByName(swModel, "GetModelViewNames", VbMethod)
If Err.Number <> 0 Then
LogWarn "GetModelViewNamesSafe | CallByName(GetModelViewNames) failed | " & Err.Number & " | " & Err.Description
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
If IsArray(vNames) Then
GetModelViewNamesSafe = vNames
Else
LogWarn "GetModelViewNamesSafe | returned non-array / empty result"
End If
Exit Function
EH:
LogWarn "GetModelViewNamesSafe exception | " & Err.Number & " | " & Err.Description
GetModelViewNamesSafe = Empty
End Function
Private Function EvaluateOrientationCandidateView(ByVal item As Object, _
ByVal swView As SldWorks.View, _
ByVal viewName As String, _
ByRef hasRef As Boolean, _
ByRef bestMetric As Double, _
ByRef absAngDeg As Double, _
ByRef outlineW As Double, _
ByRef outlineH As Double, _
ByRef outlineScore As Double, _
ByRef compositeScore As Double, _
ByRef detail As String) As Boolean
On Error GoTo EH
EvaluateOrientationCandidateView = False
hasRef = False
bestMetric = 0#
absAngDeg = 9999#
outlineW = 0#
outlineH = 0#
outlineScore = 0#
compositeScore = -1E+300
detail = ""
If swView Is Nothing Then Exit Function
Call EnsureItemCategoryAnalysis(item)
Dim catName As String
Dim reason As String
catName = SafeStr(item("BodyCategory"))
reason = SafeStr(item("BodyCategoryReason"))
Dim famBest As Double, famAng As Double, famSecond As Double, famDetail As String
Dim spanLen As Double, spanAng As Double, cloudW As Double, cloudH As Double, cloudArea As Double, cloudDetail As String
Dim ptCt As Long
Dim visLen As Double, visAng As Double, visDesc As String
Dim edgeCt As Long, lineCt As Long
Dim pcPtCt As Long
Dim pcMajor As Double, pcMajorAng As Double
Dim pcMinor As Double, pcMinorAng As Double
Dim pcRatio As Double, pcDetail As String
Dim profileMetric As Double
Dim faceMetric As Double
Dim penalty As Double
Dim rejectNote As String
Dim snapMetric As Double
Dim snapAngRad As Double
Dim snapQuality As Double
Dim snapDesc As String
Dim snapDeltaH As Double
Dim snapDeltaV As Double
Dim snapState As String
Dim snapRank As Long
Call GetProjectedDominantDirectionMetrics(swView, item, famBest, famAng, famSecond, famDetail)
Call GetBodyProjectedPointCloudMetrics(swView, item, ptCt, spanLen, spanAng, cloudW, cloudH, cloudArea, cloudDetail)
Call GetBodyProjectedPrincipalMetrics(swView, item, pcPtCt, pcMajor, pcMajorAng, pcMinor, pcMinorAng, pcRatio, pcDetail)
visLen = 0#: visAng = 0#: visDesc = ""
edgeCt = 0: lineCt = 0
Call GetBestVisibleLinearEdgeInView(swView, visLen, visAng, visDesc, edgeCt, lineCt)
If TryGetViewOutlineWH(swView, outlineW, outlineH) Then
outlineScore = HorizontalScoreWH(outlineW, outlineH)
Else
outlineScore = 0#
End If
profileMetric = MaxD(pcMinor, famSecond)
faceMetric = pcMajor * pcMinor
penalty = 0#
rejectNote = ""
Select Case UCase$(catName)
Case UCase$(CAT_NAME_LINEAR_STRUCTURAL)
If pcMajor > 0# Then
hasRef = True
bestMetric = pcMajor
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(pcMajorAng)))
ElseIf famBest > 0# Then
hasRef = True
bestMetric = famBest
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(famAng)))
ElseIf spanLen > 0# Then
hasRef = True
bestMetric = spanLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(spanAng)))
ElseIf visLen > 0# Then
hasRef = True
bestMetric = visLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(visAng)))
End If
compositeScore = (pcMajor * 1400000#) + _
(profileMetric * 900000#) + _
(famBest * 400000#) + _
(famSecond * 300000#) + _
(cloudArea * 150000#) + _
(spanLen * 100000#) + _
(visLen * 1000#) + _
(outlineScore * 0.02)
If pcMajor > 0# Then
If profileMetric < MaxD(CAT_LINEAR_PROFILE_ABS_MIN, pcMajor * CAT_LINEAR_PROFILE_RATIO_MIN) Then
penalty = penalty + CAT_REJECT_PENALTY
rejectNote = AppendRejectNote(rejectNote, "linear end-on/readability penalty")
End If
End If
Case UCase$(CAT_NAME_SHEET_PLATE)
If pcMajor > 0# Then
hasRef = True
bestMetric = pcMajor
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(pcMajorAng)))
ElseIf spanLen > 0# Then
hasRef = True
bestMetric = spanLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(spanAng)))
ElseIf famBest > 0# Then
hasRef = True
bestMetric = famBest
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(famAng)))
ElseIf visLen > 0# Then
hasRef = True
bestMetric = visLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(visAng)))
End If
compositeScore = (faceMetric * 2500000#) + _
(pcMinor * 1500000#) + _
(pcMajor * 500000#) + _
(cloudArea * 300000#) + _
(spanLen * 50000#) + _
(visLen * 500#) + _
(outlineScore * 0.02)
If pcMajor > 0# Then
If pcMinor < MaxD(CAT_PLATE_FACE_ABS_MIN, pcMajor * CAT_PLATE_FACE_RATIO_MIN) Then
penalty = penalty + CAT_REJECT_PENALTY
rejectNote = AppendRejectNote(rejectNote, "sheet edge-on penalty")
End If
End If
Case UCase$(CAT_NAME_CURVED_STRUCTURAL)
If pcMajor > 0# Then
hasRef = True
bestMetric = pcMajor
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(pcMajorAng)))
ElseIf spanLen > 0# Then
hasRef = True
bestMetric = spanLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(spanAng)))
ElseIf visLen > 0# Then
hasRef = True
bestMetric = visLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(visAng)))
ElseIf famBest > 0# Then
hasRef = True
bestMetric = famBest
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(famAng)))
End If
compositeScore = (pcMajor * 900000#) + _
(pcMinor * 400000#) + _
(cloudArea * 500000#) + _
(spanLen * 300000#) + _
(visLen * 500#) + _
(outlineScore * 0.02)
Case UCase$(CAT_NAME_ROUND_STOCK)
If famBest > 0# Then
hasRef = True
bestMetric = famBest
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(famAng)))
ElseIf pcMajor > 0# Then
hasRef = True
bestMetric = pcMajor
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(pcMajorAng)))
ElseIf spanLen > 0# Then
hasRef = True
bestMetric = spanLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(spanAng)))
ElseIf visLen > 0# Then
hasRef = True
bestMetric = visLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(visAng)))
End If
compositeScore = (famBest * 1000000#) + _
(pcMajor * 250000#) + _
(cloudArea * 100000#) + _
(visLen * 1000#) + _
(outlineScore * 0.02)
Case Else
If pcMajor > 0# Then
hasRef = True
bestMetric = pcMajor
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(pcMajorAng)))
ElseIf spanLen > 0# Then
hasRef = True
bestMetric = spanLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(spanAng)))
ElseIf famBest > 0# Then
hasRef = True
bestMetric = famBest
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(famAng)))
ElseIf visLen > 0# Then
hasRef = True
bestMetric = visLen
absAngDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(visAng)))
End If
compositeScore = (faceMetric * 500000#) + _
(pcMajor * 350000#) + _
(pcMinor * 250000#) + _
(cloudArea * 200000#) + _
(spanLen * 120000#) + _
(visLen * 1000#) + _
(outlineScore * 0.02)
End Select
If penalty > 0# Then compositeScore = compositeScore - penalty
snapMetric = 0#: snapAngRad = 0#: snapQuality = -1E+30: snapDesc = ""
snapDeltaH = 9999#: snapDeltaV = 9999#: snapState = "NO_REF": snapRank = 0
If GetSnapReferenceForView(swView, item, snapMetric, snapAngRad, snapQuality, snapDesc) Then
snapRank = GetOrientationSnapState(snapAngRad, ROT_SNAP_TOL_DEG, snapDeltaH, snapDeltaV, snapState)
If (penalty <= 0#) Or (penalty < CAT_REJECT_PENALTY) Then
Select Case snapRank
Case 2
compositeScore = compositeScore + ORIENT_SNAP_HORIZONTAL_BONUS
Case 1
compositeScore = compositeScore + ORIENT_SNAP_VERTICAL_BONUS
End Select
End If
If Not hasRef Then
hasRef = True
bestMetric = snapMetric
absAngDeg = MinD(snapDeltaH, snapDeltaV)
End If
End If
If Len(rejectNote) > 0 Then
detail = "reason=" & reason & _
" | famBest=" & Fmt(famBest) & _
" | famSecond=" & Fmt(famSecond) & _
" | spanLen=" & Fmt(spanLen) & _
" | cloud=" & Fmt(cloudW) & "x" & Fmt(cloudH) & _
" | cloudArea=" & Fmt(cloudArea) & _
" | pts=" & CStr(ptCt) & _
" | pcMajor=" & Fmt(pcMajor) & "@ang=" & Format$(RadToDeg(pcMajorAng), "0.0") & _
" | pcMinor=" & Fmt(pcMinor) & _
" | pcRatio=" & Fmt(pcRatio) & _
" | faceMetric=" & Fmt(faceMetric) & _
" | visLen=" & Fmt(visLen) & _
" | edgesScanned=" & CStr(edgeCt) & _
" | lineCandidates=" & CStr(lineCt) & _
" | snap=" & snapState & _
" | snapDeltaH=" & Format$(snapDeltaH, "0.000") & _
" | snapDeltaV=" & Format$(snapDeltaV, "0.000") & _
" | fam={" & famDetail & "}" & _
" | cloud={" & cloudDetail & "}" & _
" | pc={" & pcDetail & "}" & _
" | rejectHint=" & rejectNote
Else
detail = "reason=" & reason & _
" | famBest=" & Fmt(famBest) & _
" | famSecond=" & Fmt(famSecond) & _
" | spanLen=" & Fmt(spanLen) & _
" | cloud=" & Fmt(cloudW) & "x" & Fmt(cloudH) & _
" | cloudArea=" & Fmt(cloudArea) & _
" | pts=" & CStr(ptCt) & _
" | pcMajor=" & Fmt(pcMajor) & "@ang=" & Format$(RadToDeg(pcMajorAng), "0.0") & _
" | pcMinor=" & Fmt(pcMinor) & _
" | pcRatio=" & Fmt(pcRatio) & _
" | faceMetric=" & Fmt(faceMetric) & _
" | visLen=" & Fmt(visLen) & _
" | edgesScanned=" & CStr(edgeCt) & _
" | lineCandidates=" & CStr(lineCt) & _
" | snap=" & snapState & _
" | snapDeltaH=" & Format$(snapDeltaH, "0.000") & _
" | snapDeltaV=" & Format$(snapDeltaV, "0.000") & _
" | fam={" & famDetail & "}" & _
" | cloud={" & cloudDetail & "}" & _
" | pc={" & pcDetail & "}"
End If
EvaluateOrientationCandidateView = True
Exit Function
EH:
LogWarn "EvaluateOrientationCandidateView exception | " & Err.Number & " | " & Err.Description & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | cand=" & viewName
EvaluateOrientationCandidateView = False
End Function
Private Function IsOrientationCandidateBetter(ByVal candCompositeScore As Double, _
ByVal candIsStd As Boolean, _
ByVal candMetric As Double, _
ByVal candAbsAngDeg As Double, _
ByVal bestCompositeScore As Double, _
ByVal bestIsStd As Boolean, _
ByVal bestMetric As Double, _
ByVal bestAbsAngDeg As Double) As Boolean
On Error GoTo EH
IsOrientationCandidateBetter = False
If candCompositeScore > (bestCompositeScore + 0.0001) Then
IsOrientationCandidateBetter = True
Exit Function
End If
If bestCompositeScore > (candCompositeScore + 0.0001) Then
Exit Function
End If
If candIsStd And (Not bestIsStd) Then
IsOrientationCandidateBetter = True
Exit Function
End If
If bestIsStd And (Not candIsStd) Then
Exit Function
End If
If candMetric > (bestMetric + 0.0001) Then
IsOrientationCandidateBetter = True
Exit Function
End If
If bestMetric > (candMetric + 0.0001) Then
Exit Function
End If
If candAbsAngDeg < (bestAbsAngDeg - 0.05) Then
IsOrientationCandidateBetter = True
Exit Function
End If
Exit Function
EH:
IsOrientationCandidateBetter = False
End Function
Private Function ChooseBestStdViewFromBBoxFast(ByVal item As Object) As String
On Error GoTo EH
Dim dx As Double, dy As Double, dz As Double
dx = CDbl(item("dx"))
dy = CDbl(item("dy"))
dz = CDbl(item("dz"))
If dx <= 0# Or dy <= 0# Or dz <= 0# Then
ChooseBestStdViewFromBBoxFast = "*Front"
Exit Function
End If
Dim sFront As Double, sTopV As Double, sRight As Double
sFront = ScoreProjectedViewFastV1(dx, dy)
sTopV = ScoreProjectedViewFastV1(dx, dz)
sRight = ScoreProjectedViewFastV1(dy, dz)
If sFront >= sTopV And sFront >= sRight Then
ChooseBestStdViewFromBBoxFast = "*Front"
ElseIf sTopV >= sFront And sTopV >= sRight Then
ChooseBestStdViewFromBBoxFast = "*Top"
Else
ChooseBestStdViewFromBBoxFast = "*Right"
End If
Exit Function
EH:
ChooseBestStdViewFromBBoxFast = "*Front"
End Function
Private Function ScoreProjectedViewFastV1(ByVal a As Double, ByVal b As Double) As Double
On Error GoTo EH
Dim longD As Double, shortD As Double
Dim area As Double, ratio As Double
longD = a: shortD = b
If shortD > longD Then SwapD longD, shortD
area = a * b
If shortD > 0# Then
ratio = longD / shortD
Else
ratio = 1E+30
End If
ScoreProjectedViewFastV1 = (area * 1000#) - (ratio * 5#) + (longD * 25#) + (shortD * 10#)
Exit Function
EH:
ScoreProjectedViewFastV1 = 0#
End Function
'====================================================================================
' FAST BODY ISOLATION
'====================================================================================
Private Function IsolateBodyFast(ByVal swV As SldWorks.View, _
ByVal item As Object) As Boolean
On Error GoTo EH
Dim repB As SldWorks.Body2
Set repB = item("RepBody_Model")
If repB Is Nothing Then
LogError "IsolateBodyFast | RepBody_Model is Nothing | item=" & SafeStr(item("ItemNo"))
IsolateBodyFast = False
Exit Function
End If
LogInfo " IsolateBodyFast | start | item=" & SafeStr(item("ItemNo")) & _
" | view=" & ViewGetNameSafe(swV)
If TrySetSingleBodyInView(swV, repB, "direct") Then
LogInfo " IsolateBodyFast | direct OK | item=" & SafeStr(item("ItemNo"))
IsolateBodyFast = True
Exit Function
End If
LogWarn " IsolateBodyFast | direct path failed | trying fallback selection path"
IsolateBodyFast = IsolateBodyFallback(swV, item)
Exit Function
EH:
LogError "IsolateBodyFast exception | " & Err.Number & " | " & Err.Description
IsolateBodyFast = False
End Function
Private Function IsolateBodyFallback(ByVal swV As SldWorks.View, _
ByVal item As Object) As Boolean
On Error GoTo EH
Dim repB As SldWorks.Body2
Set repB = item("RepBody_Model")
If repB Is Nothing Then
LogError "IsolateBodyFallback | RepBody_Model is Nothing | item=" & SafeStr(item("ItemNo"))
IsolateBodyFallback = False
Exit Function
End If
Dim vName As String
vName = ViewGetNameSafe(swV)
g_swDrwModel.ClearSelection2 True
If Not g_swDrwModel.Extension.SelectByID2(vName, "DRAWINGVIEW", 0#, 0#, 0#, False, 0, Nothing, 0) Then
LogWarn " IsolateBodyFallback | failed to select drawing view | view=" & vName
Else
LogInfo " IsolateBodyFallback | selected drawing view | view=" & vName
End If
IsolateBodyFallback = TrySetSingleBodyInView(swV, repB, "fallback")
g_swDrwModel.ClearSelection2 True
LogInfo " IsolateBodyFallback | item=" & SafeStr(item("ItemNo")) & _
" | result=" & CStr(IsolateBodyFallback) & _
" | finalBodyCount=" & CStr(GetViewBodyCountSafe(swV))
Exit Function
EH:
LogError "IsolateBodyFallback exception | " & Err.Number & " | " & Err.Description
IsolateBodyFallback = False
End Function
Private Function TrySetSingleBodyInView(ByVal swV As SldWorks.View, _
ByVal repB As SldWorks.Body2, _
ByVal stageTag As String) As Boolean
On Error GoTo EH
Dim ct As Long
TrySetSingleBodyInView = False
If swV Is Nothing Then
LogError "TrySetSingleBodyInView | view is Nothing | stage=" & stageTag
Exit Function
End If
If repB Is Nothing Then
LogError "TrySetSingleBodyInView | body is Nothing | stage=" & stageTag
Exit Function
End If
Dim viewBody As SldWorks.Body2
Set viewBody = ResolveViewReferencedBody(swV, repB)
If viewBody Is Nothing Then
LogWarn " TrySetSingleBodyInView | could not resolve representative body against view referenced document | stage=" & stageTag & _
" | repBody=" & GetBodyNameSafe(repB)
Set viewBody = repB
End If
Dim bodyObjs(0) As Object
Dim bodiesIn As Variant
Set bodyObjs(0) = viewBody
bodiesIn = bodyObjs
' VBA requires an Object array variant here; a Variant() array can be
' accepted syntactically but leave the view showing every body.
Err.Clear
On Error Resume Next
swV.Bodies = (bodiesIn)
If Err.Number <> 0 Then
LogWarn " TrySetSingleBodyInView | Bodies property failed | stage=" & stageTag & _
" | " & Err.Number & " | " & Err.Description
Err.Clear
End If
swV.Update
On Error GoTo EH
g_swDrwModel.EditRebuild3
ct = GetViewBodyCountSafe(swV)
LogInfo " TrySetSingleBodyInView | after Bodies property | stage=" & stageTag & _
" | bodyCount=" & CStr(ct) & _
" | repBody=" & GetBodyNameSafe(repB) & _
" | viewBody=" & GetBodyNameSafe(viewBody)
If ct = 1 Then
TrySetSingleBodyInView = True
Exit Function
End If
LogWarn " TrySetSingleBodyInView | Bodies property did not isolate exactly one body; failing view instead of using unsupported alternate VBA body path | stage=" & stageTag & _
" | bodyCount=" & CStr(ct)
Exit Function
EH:
LogError "TrySetSingleBodyInView exception | " & Err.Number & " | " & Err.Description & _
" | stage=" & stageTag & " | view=" & ViewGetNameSafe(swV)
TrySetSingleBodyInView = False
End Function
Private Function ResolveViewReferencedBody(ByVal swV As SldWorks.View, _
ByVal repB As SldWorks.Body2) As SldWorks.Body2
On Error GoTo EH
Set ResolveViewReferencedBody = Nothing
If swV Is Nothing Then Exit Function
If repB Is Nothing Then Exit Function
Dim refDoc As SldWorks.ModelDoc2
Set refDoc = Nothing
On Error Resume Next
Set refDoc = swV.ReferencedDocument
On Error GoTo EH
If refDoc Is Nothing Then
Set ResolveViewReferencedBody = repB
Exit Function
End If
If refDoc.GetType <> swDocumentTypes_e.swDocPART Then
Set ResolveViewReferencedBody = repB
Exit Function
End If
Dim swPart As SldWorks.PartDoc
Set swPart = refDoc
If swPart Is Nothing Then
Set ResolveViewReferencedBody = repB
Exit Function
End If
Dim vBodies As Variant
vBodies = swPart.GetBodies2(swBodyType_e.swSolidBody, True)
If Not IsArray(vBodies) Then
Set ResolveViewReferencedBody = repB
Exit Function
End If
Dim repName As String
repName = UCase$(Trim$(GetBodyNameSafe(repB)))
If Len(repName) > 0 Then
Dim i As Long
For i = LBound(vBodies) To UBound(vBodies)
Dim byName As SldWorks.Body2
Set byName = vBodies(i)
If Not byName Is Nothing Then
If StrComp(UCase$(Trim$(GetBodyNameSafe(byName))), repName, vbTextCompare) = 0 Then
Set ResolveViewReferencedBody = byName
LogInfo "ResolveViewReferencedBody | matched by name | body=" & GetBodyNameSafe(byName)
Exit Function
End If
End If
Next i
End If
Dim rBox As Variant
rBox = Empty
On Error Resume Next
rBox = repB.GetBodyBox
If Err.Number <> 0 Then
Err.Clear
rBox = Empty
End If
On Error GoTo EH
Dim bestBody As SldWorks.Body2
Dim bestDelta As Double
bestDelta = 1E+30
For i = LBound(vBodies) To UBound(vBodies)
Dim candB As SldWorks.Body2
Set candB = vBodies(i)
If Not candB Is Nothing Then
Dim delta As Double
delta = GetBodyBoxArrayDelta(rBox, candB)
If delta < bestDelta Then
bestDelta = delta
Set bestBody = candB
End If
End If
Next i
If Not bestBody Is Nothing Then
Set ResolveViewReferencedBody = bestBody
LogInfo "ResolveViewReferencedBody | matched by bbox | rep=" & GetBodyNameSafe(repB) & _
" | resolved=" & GetBodyNameSafe(bestBody) & _
" | delta=" & Fmt(bestDelta)
Else
Set ResolveViewReferencedBody = repB
End If
Exit Function
EH:
LogWarn "ResolveViewReferencedBody exception | " & Err.Number & " | " & Err.Description
Set ResolveViewReferencedBody = repB
End Function
Private Function GetBodyBoxArrayDelta(ByVal refBox As Variant, ByVal candB As SldWorks.Body2) As Double
On Error GoTo EH
GetBodyBoxArrayDelta = 1E+30
If candB Is Nothing Then Exit Function
If Not IsArray(refBox) Then Exit Function
If UBound(refBox) - LBound(refBox) < 5 Then Exit Function
Dim candBox As Variant
candBox = candB.GetBodyBox
If Not IsArray(candBox) Then Exit Function
If UBound(candBox) - LBound(candBox) < 5 Then Exit Function
Dim i As Long
Dim d As Double
For i = 0 To 5
d = d + Abs(CDbl(refBox(i)) - CDbl(candBox(i)))
Next i
GetBodyBoxArrayDelta = d
Exit Function
EH:
GetBodyBoxArrayDelta = 1E+30
End Function
Private Function GetViewBodyCountSafe(ByVal swV As SldWorks.View) As Long
On Error GoTo EH
GetViewBodyCountSafe = -1
If swV Is Nothing Then Exit Function
On Error Resume Next
GetViewBodyCountSafe = swV.GetBodiesCount
If Err.Number <> 0 Then
LogWarn "GetViewBodyCountSafe | GetBodiesCount failed | " & Err.Number & " | " & Err.Description
Err.Clear
GetViewBodyCountSafe = -1
End If
On Error GoTo 0
Exit Function
EH:
LogError "GetViewBodyCountSafe exception | " & Err.Number & " | " & Err.Description
GetViewBodyCountSafe = -1
End Function
'====================================================================================
' ROTATION
'====================================================================================
Private Function RotateViewToBestHorizontal(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal tag As String) As Boolean
On Error GoTo EH
RotateViewToBestHorizontal = False
If swView Is Nothing Then Exit Function
Call EnsureItemCategoryAnalysis(item)
LogInfo "RotateViewToBestHorizontal | start | view=" & ViewGetNameSafe(swView) & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | tag=" & tag
If TryRotateViewByCategoryReferenceAlignment(swDrawModel, swView, item, tag & " | direct category first") Then
RotateViewToBestHorizontal = True
Exit Function
End If
LogInfo "RotateViewToBestHorizontal | direct category alignment did not finish orientation | view=" & ViewGetNameSafe(swView)
If TryApplySnapFirstOrientation(swDrawModel, swView, item, tag) Then
RotateViewToBestHorizontal = True
Exit Function
End If
LogInfo "RotateViewToBestHorizontal | snap-first did not finish orientation | continue guarded fallbacks | view=" & ViewGetNameSafe(swView)
If ROT_USE_STAGED_DISCRETE_SEARCH Then
If TryRotateViewByDiscreteHorizontalSearch(swDrawModel, swView, item, tag) Then
RotateViewToBestHorizontal = True
Exit Function
End If
LogWarn "RotateViewToBestHorizontal | staged discrete category search did not fully solve orientation | fallback=category direct align | view=" & ViewGetNameSafe(swView)
End If
If TryRotateViewByCategoryReferenceAlignment(swDrawModel, swView, item, tag) Then
RotateViewToBestHorizontal = True
Exit Function
End If
If ROT_USE_VISIBLE_LINEAR_EDGE_ALIGN Then
If TryRotateViewByLongestVisibleLinearEdge(swDrawModel, swView, tag) Then
RotateViewToBestHorizontal = True
Exit Function
End If
LogWarn "RotateViewToBestHorizontal | direct visible-edge align path did not produce a usable result | fallback=bbox sweep | view=" & ViewGetNameSafe(swView)
End If
LogWarn "RotateViewToBestHorizontal | no deterministic rotation reference succeeded; refusing bbox sweep rescue | view=" & ViewGetNameSafe(swView)
RotateViewToBestHorizontal = False
Exit Function
EH:
LogError "RotateViewToBestHorizontal exception | " & Err.Number & " | " & Err.Description & " | " & tag
RotateViewToBestHorizontal = False
End Function
Private Function TryRotateViewByDiscreteHorizontalSearch(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal tag As String) As Boolean
On Error GoTo EH
TryRotateViewByDiscreteHorizontalSearch = False
If swView Is Nothing Then Exit Function
Dim baseAngleRad As Double
baseAngleRad = swView.Angle
Dim tested As Object
Set tested = CreateObject("Scripting.Dictionary")
Dim stepList As Variant
stepList = Array(90#, 45#, 30#, 15#, 10#, 5#, 2#, 1#)
Dim stepVar As Variant
Dim anyFound As Boolean
Dim anyBestAngleRad As Double
Dim anyBestRemainDeg As Double
Dim anyBestMetric As Double
Dim anyBestQuality As Double
Dim anyBestDesc As String
Dim anyBestStepDeg As Double
anyBestRemainDeg = 1E+30
anyBestMetric = 0#
anyBestQuality = -1E+30
anyBestAngleRad = baseAngleRad
anyBestDesc = ""
For Each stepVar In stepList
Dim stepDeg As Double
stepDeg = CDbl(stepVar)
Dim grpFound As Boolean
Dim grpBestAngleRad As Double
Dim grpBestRemainDeg As Double
Dim grpBestMetric As Double
Dim grpBestQuality As Double
Dim grpBestDesc As String
If EvaluateDiscreteRotationGroup(swDrawModel, swView, item, baseAngleRad, stepDeg, tested, _
grpFound, grpBestAngleRad, grpBestRemainDeg, grpBestMetric, grpBestQuality, grpBestDesc, tag) Then
LogInfo "RotDiscrete | group summary | cat=" & SafeStr(item("BodyCategory")) & _
" | stepDeg=" & Format$(stepDeg, "0.###") & _
" | bestRemainDeg=" & Format$(grpBestRemainDeg, "0.000") & _
" | metric=" & Fmt(grpBestMetric) & _
" | quality=" & Format$(grpBestQuality, "0.000") & _
" | ref=" & grpBestDesc
If (Not anyFound) Or IsRotationCandidateBetter(grpBestRemainDeg, grpBestMetric, grpBestQuality, _
anyBestRemainDeg, anyBestMetric, anyBestQuality) Then
anyFound = True
anyBestAngleRad = grpBestAngleRad
anyBestRemainDeg = grpBestRemainDeg
anyBestMetric = grpBestMetric
anyBestQuality = grpBestQuality
anyBestDesc = grpBestDesc
anyBestStepDeg = stepDeg
End If
If grpFound And grpBestRemainDeg <= ROT_DISCRETE_SUCCESS_TOL_DEG Then
Dim succValid As Boolean
Dim succScore As Double
Dim succDetail As String
succValid = ValidateOrientationResultByCategory(swView, item, succScore, succDetail)
If succValid Then
LogInfo "RotDiscrete | SUCCESS | cat=" & SafeStr(item("BodyCategory")) & _
" | stepDeg=" & Format$(stepDeg, "0.###") & _
" | remainDeg=" & Format$(grpBestRemainDeg, "0.000") & _
" | metric=" & Fmt(grpBestMetric) & _
" | ref=" & grpBestDesc & _
" | verify=" & succDetail
TryRotateViewByDiscreteHorizontalSearch = True
Exit Function
Else
LogWarn "RotDiscrete | false-positive prevented by validation | cat=" & SafeStr(item("BodyCategory")) & _
" | stepDeg=" & Format$(stepDeg, "0.###") & _
" | remainDeg=" & Format$(grpBestRemainDeg, "0.000") & _
" | ref=" & grpBestDesc & _
" | verify=" & succDetail
End If
End If
End If
Next stepVar
If anyFound Then
SetViewAngleAndRefresh swDrawModel, swView, anyBestAngleRad, _
tag & " | best discrete cat=" & SafeStr(item("BodyCategory")) & _
" step=" & Format$(anyBestStepDeg, "0.###")
Dim finalValid As Boolean
Dim finalScore As Double
Dim finalDetail As String
Dim finalRefMetric As Double
Dim finalRefAng As Double
Dim finalRefQual As Double
Dim finalRefDesc As String
Dim finalRemain As Double
finalValid = ValidateOrientationResultByCategory(swView, item, finalScore, finalDetail)
If GetSnapReferenceForView(swView, item, finalRefMetric, finalRefAng, finalRefQual, finalRefDesc) Then
finalRemain = Abs(RadToDeg(NormalizeAngleToHorizontal(finalRefAng)))
Else
finalRemain = 9999#
End If
If finalValid And finalRemain <= ROT_DISCRETE_SUCCESS_TOL_DEG Then
LogInfo "RotDiscrete | final validated best | cat=" & SafeStr(item("BodyCategory")) & _
" | remainDeg=" & Format$(finalRemain, "0.000") & _
" | metric=" & Fmt(finalRefMetric) & _
" | verify=" & finalDetail
TryRotateViewByDiscreteHorizontalSearch = True
Exit Function
End If
LogWarn "RotDiscrete | best-effort only; validation failed or angle still off | cat=" & SafeStr(item("BodyCategory")) & _
" | remainDeg=" & Format$(finalRemain, "0.000") & _
" | metric=" & Fmt(anyBestMetric) & _
" | ref=" & anyBestDesc & _
" | verify=" & finalDetail
End If
Exit Function
EH:
LogError "TryRotateViewByDiscreteHorizontalSearch exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
TryRotateViewByDiscreteHorizontalSearch = False
End Function
Private Function EvaluateDiscreteRotationGroup(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal baseAngleRad As Double, _
ByVal stepDeg As Double, _
ByVal tested As Object, _
ByRef grpFound As Boolean, _
ByRef grpBestAngleRad As Double, _
ByRef grpBestRemainDeg As Double, _
ByRef grpBestMetric As Double, _
ByRef grpBestQuality As Double, _
ByRef grpBestDesc As String, _
ByVal tag As String) As Boolean
On Error GoTo EH
EvaluateDiscreteRotationGroup = False
grpFound = False
grpBestRemainDeg = 1E+30
grpBestMetric = 0#
grpBestQuality = -1E+30
grpBestAngleRad = baseAngleRad
grpBestDesc = ""
Dim angleList As Collection
Set angleList = BuildDiscreteAngleList(baseAngleRad, stepDeg)
Dim angVar As Variant
For Each angVar In angleList
Dim candAngRad As Double
candAngRad = CDbl(angVar)
Dim key As String
key = Format$(NormalizeDeg360(RadToDeg(candAngRad)), "0.000")
If tested.Exists(key) Then GoTo NextAngle
tested.Add key, True
SetViewAngleAndRefresh swDrawModel, swView, candAngRad, _
tag & " | discrete cat=" & SafeStr(item("BodyCategory")) & " step=" & Format$(stepDeg, "0.###")
Dim hasRef As Boolean
Dim refMetric As Double
Dim remainDeg As Double
Dim qualityScore As Double
Dim refDesc As String
Dim validNow As Boolean
Dim validScore As Double
Dim validDetail As String
If EvaluateRotationCandidateAtCurrentAngle(swView, item, hasRef, refMetric, remainDeg, qualityScore, refDesc) Then
validNow = ValidateOrientationResultByCategory(swView, item, validScore, validDetail)
If validNow Then
qualityScore = qualityScore + (CAT_REJECT_PENALTY / 2#)
Else
qualityScore = qualityScore - (CAT_REJECT_PENALTY / 4#)
End If
LogInfo "RotDiscreteCandidate | cat=" & SafeStr(item("BodyCategory")) & _
" | stepDeg=" & Format$(stepDeg, "0.###") & _
" | viewDeg=" & Format$(RadToDeg(candAngRad), "0.000") & _
" | hasRef=" & BoolWord(hasRef) & _
" | remainDeg=" & Format$(remainDeg, "0.000") & _
" | metric=" & Fmt(refMetric) & _
" | quality=" & Format$(qualityScore, "0.000") & _
" | valid=" & BoolWord(validNow) & _
" | valScore=" & Format$(validScore, "0.000") & _
" | ref=" & refDesc & _
" | verify=" & validDetail
If hasRef Then
If (Not grpFound) Or IsRotationCandidateBetter(remainDeg, refMetric, qualityScore, _
grpBestRemainDeg, grpBestMetric, grpBestQuality) Then
grpFound = True
grpBestAngleRad = candAngRad
grpBestRemainDeg = remainDeg
grpBestMetric = refMetric
grpBestQuality = qualityScore
grpBestDesc = refDesc & " | verify=" & validDetail
End If
If remainDeg <= ROT_DISCRETE_SUCCESS_TOL_DEG And validNow Then
EvaluateDiscreteRotationGroup = True
Exit Function
End If
End If
End If
NextAngle:
DoEvents
Next angVar
If grpFound Then
SetViewAngleAndRefresh swDrawModel, swView, grpBestAngleRad, _
tag & " | best in group cat=" & SafeStr(item("BodyCategory")) & " step=" & Format$(stepDeg, "0.###")
EvaluateDiscreteRotationGroup = True
Exit Function
End If
SetViewAngleAndRefresh swDrawModel, swView, baseAngleRad, _
tag & " | restore group start cat=" & SafeStr(item("BodyCategory")) & " step=" & Format$(stepDeg, "0.###")
EvaluateDiscreteRotationGroup = False
Exit Function
EH:
LogError "EvaluateDiscreteRotationGroup exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView) & " | stepDeg=" & Format$(stepDeg, "0.###")
EvaluateDiscreteRotationGroup = False
End Function
Private Function EvaluateRotationCandidateAtCurrentAngle(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef hasRef As Boolean, _
ByRef bestMetric As Double, _
ByRef remainDeg As Double, _
ByRef qualityScore As Double, _
ByRef bestDesc As String) As Boolean
On Error GoTo EH
EvaluateRotationCandidateAtCurrentAngle = False
hasRef = False
bestMetric = 0#
remainDeg = 9999#
qualityScore = -1E+30
bestDesc = ""
If swView Is Nothing Then Exit Function
Dim refAngRad As Double
If GetSnapReferenceForView(swView, item, bestMetric, refAngRad, qualityScore, bestDesc) Then
hasRef = True
remainDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(refAngRad)))
End If
If hasRef Then
EvaluateRotationCandidateAtCurrentAngle = True
End If
Exit Function
EH:
LogWarn "EvaluateRotationCandidateAtCurrentAngle exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
EvaluateRotationCandidateAtCurrentAngle = False
End Function
Private Function IsRotationCandidateBetter(ByVal candRemainDeg As Double, _
ByVal candMetric As Double, _
ByVal candQualityScore As Double, _
ByVal bestRemainDeg As Double, _
ByVal bestMetric As Double, _
ByVal bestQualityScore As Double) As Boolean
On Error GoTo EH
IsRotationCandidateBetter = False
If candRemainDeg < (bestRemainDeg - 0.05) Then
IsRotationCandidateBetter = True
Exit Function
End If
If bestRemainDeg < (candRemainDeg - 0.05) Then
Exit Function
End If
If candMetric > (bestMetric + 0.0001) Then
IsRotationCandidateBetter = True
Exit Function
End If
If bestMetric > (candMetric + 0.0001) Then
Exit Function
End If
If candQualityScore > (bestQualityScore + 0.5) Then
IsRotationCandidateBetter = True
Exit Function
End If
Exit Function
EH:
IsRotationCandidateBetter = False
End Function
Private Function NormalizeDeg360(ByVal degVal As Double) As Double
Do While degVal < 0#
degVal = degVal + 360#
Loop
Do While degVal >= 360#
degVal = degVal - 360#
Loop
NormalizeDeg360 = degVal
End Function
Private Function TryRotateViewByLongestVisibleLinearEdge(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal tag As String) As Boolean
On Error GoTo EH
TryRotateViewByLongestVisibleLinearEdge = False
If swView Is Nothing Then Exit Function
Dim bestLen As Double
Dim bestAngRad As Double
Dim bestDesc As String
Dim edgeCt As Long
Dim lineCt As Long
If Not GetBestVisibleLinearEdgeInView(swView, bestLen, bestAngRad, bestDesc, edgeCt, lineCt) Then
LogWarn "TryRotateViewByLongestVisibleLinearEdge | no visible linear edge found | edgesScanned=" & CStr(edgeCt) & _
" | lineCandidates=" & CStr(lineCt) & " | view=" & ViewGetNameSafe(swView)
Exit Function
End If
If bestLen < ROT_MIN_VISIBLE_EDGE_LEN Then
LogWarn "TryRotateViewByLongestVisibleLinearEdge | best edge below minimum usable length | len=" & Fmt(bestLen) & _
" | min=" & Fmt(ROT_MIN_VISIBLE_EDGE_LEN) & " | desc=" & bestDesc & " | view=" & ViewGetNameSafe(swView)
Exit Function
End If
Dim currentViewAngle As Double
Dim deltaToHorizontal As Double
Dim targetAngle As Double
currentViewAngle = swView.Angle
deltaToHorizontal = NormalizeAngleToHorizontal(bestAngRad)
targetAngle = NormalizeAngleRad(currentViewAngle - deltaToHorizontal)
LogInfo " RotEdgePick | pass=1 | view=" & ViewGetNameSafe(swView) & _
" | edgesScanned=" & CStr(edgeCt) & " | lineCandidates=" & CStr(lineCt) & _
" | bestLen=" & Fmt(bestLen) & " | bestAngDeg=" & Format$(RadToDeg(bestAngRad), "0.000") & _
" | deltaDeg=" & Format$(RadToDeg(deltaToHorizontal), "0.000") & _
" | currentViewDeg=" & Format$(RadToDeg(currentViewAngle), "0.000") & _
" | targetViewDeg=" & Format$(RadToDeg(targetAngle), "0.000") & _
" | edge=" & bestDesc
SetViewAngleAndRefresh swDrawModel, swView, targetAngle, tag & " edge pass1"
' Confirm after first pass. Visible edge order can change slightly after rotation.
Dim confirmLen As Double
Dim confirmAngRad As Double
Dim confirmDesc As String
Dim confirmEdgeCt As Long
Dim confirmLineCt As Long
Dim remainingDeg As Double
If GetBestVisibleLinearEdgeInView(swView, confirmLen, confirmAngRad, confirmDesc, confirmEdgeCt, confirmLineCt) Then
remainingDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(confirmAngRad)))
LogInfo " RotEdgeConfirm | pass=1 | view=" & ViewGetNameSafe(swView) & _
" | bestLen=" & Fmt(confirmLen) & " | bestAngDeg=" & Format$(RadToDeg(confirmAngRad), "0.000") & _
" | remainingDeg=" & Format$(remainingDeg, "0.000") & " | edge=" & confirmDesc
If remainingDeg > ROT_EDGE_CONFIRM_TOL_DEG Then
currentViewAngle = swView.Angle
deltaToHorizontal = NormalizeAngleToHorizontal(confirmAngRad)
targetAngle = NormalizeAngleRad(currentViewAngle - deltaToHorizontal)
LogInfo " RotEdgePick | pass=2 | view=" & ViewGetNameSafe(swView) & _
" | deltaDeg=" & Format$(RadToDeg(deltaToHorizontal), "0.000") & _
" | currentViewDeg=" & Format$(RadToDeg(currentViewAngle), "0.000") & _
" | targetViewDeg=" & Format$(RadToDeg(targetAngle), "0.000") & _
" | edge=" & confirmDesc
SetViewAngleAndRefresh swDrawModel, swView, targetAngle, tag & " edge pass2"
If GetBestVisibleLinearEdgeInView(swView, confirmLen, confirmAngRad, confirmDesc, confirmEdgeCt, confirmLineCt) Then
remainingDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(confirmAngRad)))
LogInfo " RotEdgeConfirm | pass=2 | view=" & ViewGetNameSafe(swView) & _
" | bestLen=" & Fmt(confirmLen) & " | bestAngDeg=" & Format$(RadToDeg(confirmAngRad), "0.000") & _
" | remainingDeg=" & Format$(remainingDeg, "0.000") & " | edge=" & confirmDesc
End If
End If
End If
TryRotateViewByLongestVisibleLinearEdge = True
Exit Function
EH:
LogError "TryRotateViewByLongestVisibleLinearEdge exception | " & Err.Number & " | " & Err.Description & " | " & tag
TryRotateViewByLongestVisibleLinearEdge = False
End Function
Private Function GetBestVisibleLinearEdgeInView(ByVal swView As SldWorks.View, _
ByRef bestLen As Double, _
ByRef bestAngRad As Double, _
ByRef bestDesc As String, _
ByRef edgeCt As Long, _
ByRef lineCt As Long) As Boolean
On Error GoTo EH
GetBestVisibleLinearEdgeInView = False
bestLen = 0#
bestAngRad = 0#
bestDesc = ""
edgeCt = 0
lineCt = 0
If swView Is Nothing Then Exit Function
Dim swXf As SldWorks.MathTransform
Set swXf = swView.ModelToViewTransform
If swXf Is Nothing Then
LogWarn "GetBestVisibleLinearEdgeInView | ModelToViewTransform is Nothing | view=" & ViewGetNameSafe(swView)
Exit Function
End If
Dim seen As Object
Set seen = CreateObject("Scripting.Dictionary")
Dim vVisComps As Variant
On Error Resume Next
vVisComps = swView.GetVisibleComponents
On Error GoTo EH
If IsArray(vVisComps) Then
Dim i As Long
For i = LBound(vVisComps) To UBound(vVisComps)
ScanVisibleLinearEdgesFromComponent swView, vVisComps(i), swXf, seen, bestLen, bestAngRad, bestDesc, edgeCt, lineCt
Next i
End If
' Fallback: some SW builds can still return entities with a Nothing component.
ScanVisibleLinearEdgesFromComponent swView, Nothing, swXf, seen, bestLen, bestAngRad, bestDesc, edgeCt, lineCt
If lineCt > 0 And bestLen > 0# Then
GetBestVisibleLinearEdgeInView = True
End If
Exit Function
EH:
LogError "GetBestVisibleLinearEdgeInView exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
GetBestVisibleLinearEdgeInView = False
End Function
Private Function GetBestVisibleLinearEdgeMatchingModelAxis(ByVal swView As SldWorks.View, _
ByVal axisX As Double, _
ByVal axisY As Double, _
ByVal axisZ As Double, _
ByRef bestLen As Double, _
ByRef bestAngRad As Double, _
ByRef bestDesc As String, _
ByRef edgeCt As Long, _
ByRef lineCt As Long, _
ByRef matchedCt As Long) As Boolean
On Error GoTo EH
GetBestVisibleLinearEdgeMatchingModelAxis = False
bestLen = 0#
bestAngRad = 0#
bestDesc = ""
edgeCt = 0
lineCt = 0
matchedCt = 0
If swView Is Nothing Then Exit Function
If Not NormalizeVector3(axisX, axisY, axisZ) Then Exit Function
Dim swXf As SldWorks.MathTransform
Set swXf = swView.ModelToViewTransform
If swXf Is Nothing Then Exit Function
Dim seen As Object
Set seen = CreateObject("Scripting.Dictionary")
Dim vVisComps As Variant
On Error Resume Next
vVisComps = swView.GetVisibleComponents
On Error GoTo EH
If IsArray(vVisComps) Then
Dim i As Long
For i = LBound(vVisComps) To UBound(vVisComps)
ScanVisibleLinearEdgesMatchingAxisFromComponent swView, vVisComps(i), swXf, seen, _
axisX, axisY, axisZ, bestLen, bestAngRad, bestDesc, _
edgeCt, lineCt, matchedCt
Next i
End If
ScanVisibleLinearEdgesMatchingAxisFromComponent swView, Nothing, swXf, seen, _
axisX, axisY, axisZ, bestLen, bestAngRad, bestDesc, _
edgeCt, lineCt, matchedCt
If matchedCt > 0 And bestLen > 0# Then
GetBestVisibleLinearEdgeMatchingModelAxis = True
End If
Exit Function
EH:
LogWarn "GetBestVisibleLinearEdgeMatchingModelAxis exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
GetBestVisibleLinearEdgeMatchingModelAxis = False
End Function
Private Sub ScanVisibleLinearEdgesMatchingAxisFromComponent(ByVal swView As SldWorks.View, _
ByVal visComp As Variant, _
ByVal swXf As SldWorks.MathTransform, _
ByVal seen As Object, _
ByVal axisX As Double, _
ByVal axisY As Double, _
ByVal axisZ As Double, _
ByRef bestLen As Double, _
ByRef bestAngRad As Double, _
ByRef bestDesc As String, _
ByRef edgeCt As Long, _
ByRef lineCt As Long, _
ByRef matchedCt As Long)
On Error GoTo EH
If swView Is Nothing Then Exit Sub
If seen Is Nothing Then Exit Sub
Dim vVisEnts As Variant
On Error Resume Next
vVisEnts = swView.GetVisibleEntities2(visComp, swViewEntityType_e.swViewEntityType_Edge)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo EH
Exit Sub
End If
On Error GoTo EH
If Not IsArray(vVisEnts) Then Exit Sub
Dim cosTol As Double
cosTol = Cos(DegToRad(CAT_FAMILY_ANGLE_TOL_DEG))
Dim i As Long
For i = LBound(vVisEnts) To UBound(vVisEnts)
Dim objEnt As Object
Set objEnt = Nothing
On Error Resume Next
Set objEnt = vVisEnts(i)
On Error GoTo EH
If Not objEnt Is Nothing Then
If TypeOf objEnt Is SldWorks.Edge Then
Dim swEdge As SldWorks.Edge
Set swEdge = objEnt
Dim edgeKey As String
edgeKey = CStr(ObjPtr(swEdge))
If Not seen.Exists(edgeKey) Then
seen.Add edgeKey, True
edgeCt = edgeCt + 1
Dim ux As Double, uy As Double, uz As Double, modelLen As Double
If TryGetModelLineEdgeDirection(swEdge, ux, uy, uz, modelLen) Then
lineCt = lineCt + 1
Dim dotAbs As Double
dotAbs = Abs(Dot3(axisX, axisY, axisZ, ux, uy, uz))
If dotAbs >= cosTol Then
Dim projectedLen As Double, angRad As Double, edgeDesc As String
If TryGetProjectedVisibleLinearEdgeData(swView, swEdge, swXf, projectedLen, angRad, edgeDesc) Then
matchedCt = matchedCt + 1
If projectedLen > bestLen Then
bestLen = projectedLen
bestAngRad = angRad
bestDesc = edgeDesc & _
" | modelLen=" & Fmt(modelLen) & _
" | dotPrimary=" & Fmt(dotAbs)
End If
End If
End If
End If
End If
End If
End If
Next i
Exit Sub
EH:
LogWarn "ScanVisibleLinearEdgesMatchingAxisFromComponent exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
End Sub
Private Sub ScanVisibleLinearEdgesFromComponent(ByVal swView As SldWorks.View, _
ByVal visComp As Variant, _
ByVal swXf As SldWorks.MathTransform, _
ByVal seen As Object, _
ByRef bestLen As Double, _
ByRef bestAngRad As Double, _
ByRef bestDesc As String, _
ByRef edgeCt As Long, _
ByRef lineCt As Long)
On Error GoTo EH
If swView Is Nothing Then Exit Sub
Dim vVisEnts As Variant
On Error Resume Next
vVisEnts = swView.GetVisibleEntities2(visComp, swViewEntityType_e.swViewEntityType_Edge)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo EH
Exit Sub
End If
On Error GoTo EH
If Not IsArray(vVisEnts) Then Exit Sub
Dim i As Long
For i = LBound(vVisEnts) To UBound(vVisEnts)
Dim objEnt As Object
Set objEnt = Nothing
On Error Resume Next
Set objEnt = vVisEnts(i)
On Error GoTo EH
If Not objEnt Is Nothing Then
If TypeOf objEnt Is SldWorks.Edge Then
Dim swEdge As SldWorks.Edge
Set swEdge = objEnt
Dim edgeKey As String
edgeKey = CStr(ObjPtr(swEdge))
If Not seen.Exists(edgeKey) Then
seen.Add edgeKey, True
edgeCt = edgeCt + 1
Dim edgeLen As Double
Dim edgeAngRad As Double
Dim edgeDesc As String
If TryGetProjectedVisibleLinearEdgeData(swView, swEdge, swXf, edgeLen, edgeAngRad, edgeDesc) Then
lineCt = lineCt + 1
If ROT_LOG_EDGE_CANDIDATES Then
LogInfo " RotEdgeCandidate | view=" & ViewGetNameSafe(swView) & _
" | len=" & Fmt(edgeLen) & " | angDeg=" & Format$(RadToDeg(edgeAngRad), "0.000") & _
" | edge=" & edgeDesc
End If
If edgeLen > bestLen Then
bestLen = edgeLen
bestAngRad = edgeAngRad
bestDesc = edgeDesc
End If
End If
End If
End If
End If
Next i
Exit Sub
EH:
LogWarn "ScanVisibleLinearEdgesFromComponent exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
End Sub
Private Function TryGetProjectedVisibleLinearEdgeData(ByVal swView As SldWorks.View, _
ByVal swEdge As SldWorks.Edge, _
ByVal swXf As SldWorks.MathTransform, _
ByRef projectedLen As Double, _
ByRef angRad As Double, _
ByRef edgeDesc As String) As Boolean
On Error GoTo EH
TryGetProjectedVisibleLinearEdgeData = False
projectedLen = 0#
angRad = 0#
edgeDesc = ""
If swView Is Nothing Then Exit Function
If swEdge Is Nothing Then Exit Function
If swXf Is Nothing Then Exit Function
Dim swCurve As SldWorks.Curve
Set swCurve = swEdge.GetCurve
If swCurve Is Nothing Then Exit Function
Dim isLine As Boolean
isLine = False
On Error Resume Next
isLine = swCurve.isLine
Err.Clear
On Error GoTo EH
If Not isLine Then Exit Function
Dim swStartVtx As SldWorks.Vertex
Dim swEndVtx As SldWorks.Vertex
Set swStartVtx = swEdge.GetStartVertex
Set swEndVtx = swEdge.GetEndVertex
If swStartVtx Is Nothing Or swEndVtx Is Nothing Then Exit Function
Dim vStart As Variant
Dim vEnd As Variant
vStart = swStartVtx.GetPoint
vEnd = swEndVtx.GetPoint
Dim x1 As Double, y1 As Double
Dim x2 As Double, y2 As Double
If Not TryTransformModelPointToViewXY(vStart, swXf, x1, y1) Then Exit Function
If Not TryTransformModelPointToViewXY(vEnd, swXf, x2, y2) Then Exit Function
Dim dx As Double, dy As Double
dx = x2 - x1
dy = y2 - y1
projectedLen = Sqr((dx * dx) + (dy * dy))
If projectedLen <= 0# Then Exit Function
angRad = Atn2Safe(dy, dx)
edgeDesc = "p1=(" & Fmt(x1) & "," & Fmt(y1) & ")" & _
" p2=(" & Fmt(x2) & "," & Fmt(y2) & ")" & _
" len=" & Fmt(projectedLen)
TryGetProjectedVisibleLinearEdgeData = True
Exit Function
EH:
LogWarn "TryGetProjectedVisibleLinearEdgeData exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
TryGetProjectedVisibleLinearEdgeData = False
End Function
Private Function TryTransformModelPointToViewXY(ByVal modelPt As Variant, _
ByVal swXf As SldWorks.MathTransform, _
ByRef x As Double, _
ByRef y As Double) As Boolean
On Error GoTo EH
TryTransformModelPointToViewXY = False
x = 0#: y = 0#
If IsEmpty(modelPt) Then Exit Function
If Not IsArray(modelPt) Then Exit Function
If swXf Is Nothing Then Exit Function
Dim swMu As SldWorks.MathUtility
Dim swPt As SldWorks.MathPoint
Dim swPtOut As SldWorks.MathPoint
Dim vOut As Variant
Set swMu = g_swApp.GetMathUtility
If swMu Is Nothing Then Exit Function
Set swPt = swMu.CreatePoint(modelPt)
If swPt Is Nothing Then Exit Function
Set swPtOut = swPt.MultiplyTransform(swXf)
If swPtOut Is Nothing Then Exit Function
vOut = swPtOut.ArrayData
If Not IsArray(vOut) Then Exit Function
If UBound(vOut) - LBound(vOut) < 1 Then Exit Function
x = CDbl(vOut(0))
y = CDbl(vOut(1))
TryTransformModelPointToViewXY = True
Exit Function
EH:
LogWarn "TryTransformModelPointToViewXY exception | " & Err.Number & " | " & Err.Description
TryTransformModelPointToViewXY = False
End Function
Private Function RotateViewToBestHorizontal_BBoxFallback(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal tag As String) As Boolean
On Error GoTo EH
RotateViewToBestHorizontal_BBoxFallback = False
If swView Is Nothing Then Exit Function
Dim bestScore As Double
Dim bestAngDeg As Double
Dim bestW As Double, bestH As Double
bestScore = -1E+30
bestAngDeg = 0#
Dim degVal As Double
Dim angRad As Double
Dim w As Double, h As Double
Dim sc As Double
' coarse sweep
For degVal = 0# To 179# Step ROT_SWEEP_COARSE_STEP_DEG
angRad = DegToRad(degVal)
SetViewAngleAndRefresh swDrawModel, swView, angRad, tag & " coarse " & Format$(degVal, "0")
If TryGetViewOutlineWH(swView, w, h) Then
sc = HorizontalScoreWH(w, h)
If sc > bestScore Then
bestScore = sc
bestAngDeg = degVal
bestW = w
bestH = h
End If
End If
Next degVal
' fine sweep around coarse winner
Dim fineStart As Double, fineEnd As Double
fineStart = MaxD(0#, bestAngDeg - ROT_SWEEP_COARSE_STEP_DEG)
fineEnd = MinD(179#, bestAngDeg + ROT_SWEEP_COARSE_STEP_DEG)
For degVal = fineStart To fineEnd Step ROT_SWEEP_FINE_STEP_DEG
angRad = DegToRad(degVal)
SetViewAngleAndRefresh swDrawModel, swView, angRad, tag & " fine " & Format$(degVal, "0.0")
If TryGetViewOutlineWH(swView, w, h) Then
sc = HorizontalScoreWH(w, h)
If sc > bestScore Then
bestScore = sc
bestAngDeg = degVal
bestW = w
bestH = h
End If
End If
Next degVal
angRad = DegToRad(bestAngDeg)
SetViewAngleAndRefresh swDrawModel, swView, angRad, tag & " final " & Format$(bestAngDeg, "0.0")
LogInfo " RotPickBBoxFallback | angle=" & Format$(bestAngDeg, "0.0") & _
"deg | w=" & Fmt(bestW) & " h=" & Fmt(bestH)
RotateViewToBestHorizontal_BBoxFallback = True
Exit Function
EH:
LogError "RotateViewToBestHorizontal_BBoxFallback exception | " & Err.Number & " | " & Err.Description & " | " & tag
RotateViewToBestHorizontal_BBoxFallback = False
End Function
Private Function HorizontalScoreWH(ByVal w As Double, ByVal h As Double) As Double
If w <= 0# Or h <= 0# Then
HorizontalScoreWH = -1E+30
Exit Function
End If
HorizontalScoreWH = ((w / h) * 10000#) + (w * 500#) - (h * 100#)
End Function
Private Sub SetViewAngleAndRefresh(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal angRad As Double, _
ByVal tag As String)
On Error GoTo EH
If swView Is Nothing Then Exit Sub
swView.Angle = angRad
On Error Resume Next
swView.Update
On Error GoTo 0
swDrawModel.EditRebuild3
LogInfo "SetViewAngleAndRefresh | " & tag & " | angle(rad)=" & Fmt(angRad)
Exit Sub
EH:
LogError "SetViewAngleAndRefresh | " & tag & " | " & Err.Number & " | " & Err.Description
End Sub
Private Function TryGetViewOutlineWH(ByVal swView As SldWorks.View, ByRef w As Double, ByRef h As Double) As Boolean
On Error GoTo EH
Dim o As Variant
TryGetViewOutlineWH = False
w = 0#: h = 0#
If swView Is Nothing Then Exit Function
o = swView.GetOutline
If IsEmpty(o) Then Exit Function
If Not IsArray(o) Then Exit Function
If UBound(o) - LBound(o) < 3 Then Exit Function
w = Abs(CDbl(o(2)) - CDbl(o(0)))
h = Abs(CDbl(o(3)) - CDbl(o(1)))
If w > 0# And h > 0# Then TryGetViewOutlineWH = True
Exit Function
EH:
LogError "TryGetViewOutlineWH | " & Err.Number & " | " & Err.Description
End Function
'====================================================================================
' VIEW POSITIONING
'====================================================================================
'====================================================================================
' CATEGORY-BASED BODY ANALYSIS / VIEW SELECTION / ROTATION REFERENCE
'====================================================================================
Private Sub EnsureItemCategoryAnalysis(ByVal item As Object)
On Error GoTo EH
If item Is Nothing Then Exit Sub
On Error Resume Next
If item.Exists("BodyCategory") And item.Exists("BodySubtype") Then Exit Sub
On Error GoTo EH
AnalyzeItemCategory item
Exit Sub
EH:
LogWarn "EnsureItemCategoryAnalysis exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub AnalyzeItemCategory(ByVal item As Object)
On Error GoTo EH
Dim swBody As SldWorks.Body2
Set swBody = Nothing
On Error Resume Next
Set swBody = item("RepBody_Model")
On Error GoTo EH
item("BodyCategory") = CAT_NAME_IRREGULAR
item("BodyCategoryReason") = "No representative body"
item("BodySubtype") = CAT_SUBTYPE_UNKNOWN
item("BodySubtypeReason") = "No representative body"
item("BodySubtypeHint") = ""
item("Sig_LineEdgeCt") = 0
item("Sig_CircleEdgeCt") = 0
item("Sig_OtherEdgeCt") = 0
item("Sig_PlanarFaceCt") = 0
item("Sig_CylFaceCt") = 0
item("Sig_OtherFaceCt") = 0
Call ResetDirectionFamilySlots(item)
Call ResetPlanarFaceFamilySlots(item)
If swBody Is Nothing Then Exit Sub
Dim fams As Collection
Set fams = New Collection
Dim lineEdgeCt As Long, circleEdgeCt As Long, otherEdgeCt As Long
Dim planarFaceCt As Long, cylFaceCt As Long, otherFaceCt As Long
AnalyzeBodyEdgesAndDirections swBody, fams, lineEdgeCt, circleEdgeCt, otherEdgeCt
AnalyzeBodyFaces swBody, planarFaceCt, cylFaceCt, otherFaceCt
AnalyzeBodyPlanarFaceFamilies swBody, item
CaptureTopDirectionFamiliesToItem item, fams
item("Sig_LineEdgeCt") = lineEdgeCt
item("Sig_CircleEdgeCt") = circleEdgeCt
item("Sig_OtherEdgeCt") = otherEdgeCt
item("Sig_PlanarFaceCt") = planarFaceCt
item("Sig_CylFaceCt") = cylFaceCt
item("Sig_OtherFaceCt") = otherFaceCt
Dim d1 As Double, d2 As Double, d3 As Double
d1 = Abs(CDbl(item("dx")))
d2 = Abs(CDbl(item("dy")))
d3 = Abs(CDbl(item("dz")))
Dim sMin As Double, sMid As Double, sMax As Double
Sort3Doubles d1, d2, d3, sMin, sMid, sMax
Dim thinRatio As Double
thinRatio = 0#
If sMax > 0# Then thinRatio = sMin / sMax
Dim primaryLen As Double, secondaryLen As Double
primaryLen = SafeCDbl(item("Sig_PrimaryDirLen"))
secondaryLen = SafeCDbl(item("Sig_SecondaryDirLen"))
Dim catName As String
Dim catReason As String
catName = CAT_NAME_IRREGULAR
catReason = "Fallback irregular"
Dim subtypeName As String
Dim subtypeReason As String
Dim subtypeHint As String
DetectBodySubtype item, swBody, subtypeName, subtypeReason, subtypeHint
If thinRatio > 0# And thinRatio <= CAT_PLATE_THIN_RATIO_MAX And planarFaceCt >= 2 Then
catName = CAT_NAME_SHEET_PLATE
catReason = "Thin ratio=" & Fmt(thinRatio) & " with planar faces"
ElseIf cylFaceCt >= 1 And circleEdgeCt >= 1 And lineEdgeCt <= (circleEdgeCt + 4) Then
catName = CAT_NAME_ROUND_STOCK
catReason = "Cylindrical faces dominate"
ElseIf (circleEdgeCt + otherEdgeCt) > 0 And lineEdgeCt > 0 Then
If (CDbl(circleEdgeCt + otherEdgeCt) / MaxD(1#, CDbl(lineEdgeCt + circleEdgeCt + otherEdgeCt))) >= CAT_CURVED_EDGE_RATIO_TRIGGER Then
catName = CAT_NAME_CURVED_STRUCTURAL
catReason = "Curved edges significant"
Else
catName = CAT_NAME_LINEAR_STRUCTURAL
catReason = "Straight edges still dominant"
End If
ElseIf lineEdgeCt >= 4 And primaryLen > 0# Then
catName = CAT_NAME_LINEAR_STRUCTURAL
catReason = "Straight-edge family detected"
ElseIf circleEdgeCt > 0 Or cylFaceCt > 0 Then
catName = CAT_NAME_CURVED_STRUCTURAL
catReason = "No strong straight family but curved geometry exists"
ElseIf primaryLen > 0# Then
catName = CAT_NAME_LINEAR_STRUCTURAL
catReason = "Projected direction family fallback"
End If
Select Case UCase$(subtypeName)
Case CAT_SUBTYPE_CHANNEL, CAT_SUBTYPE_ANGLE, CAT_SUBTYPE_RECT_MEMBER
If catName <> CAT_NAME_LINEAR_STRUCTURAL Then
catReason = catReason & "; subtype override to linear structural (" & subtypeName & ")"
End If
catName = CAT_NAME_LINEAR_STRUCTURAL
Case CAT_SUBTYPE_PLATE, CAT_SUBTYPE_GUSSET
If catName <> CAT_NAME_SHEET_PLATE And thinRatio > 0# And thinRatio <= (CAT_PLATE_THIN_RATIO_MAX * 1.5) Then
catReason = catReason & "; subtype override to sheet/plate (" & subtypeName & ")"
catName = CAT_NAME_SHEET_PLATE
End If
Case CAT_SUBTYPE_ROUND
If catName <> CAT_NAME_ROUND_STOCK Then
catReason = catReason & "; subtype override to round stock"
catName = CAT_NAME_ROUND_STOCK
End If
End Select
item("BodyCategory") = catName
item("BodyCategoryReason") = catReason
item("BodySubtype") = subtypeName
item("BodySubtypeReason") = subtypeReason
item("BodySubtypeHint") = subtypeHint
If CAT_LOG_ANALYSIS Then
LogInfo "CategoryDetect | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | cat=" & catName & _
" | subtype=" & subtypeName & _
" | reason=" & catReason & _
" | subtypeReason=" & subtypeReason & _
" | hint=" & subtypeHint & _
" | bbox=" & Fmt(d1) & "x" & Fmt(d2) & "x" & Fmt(d3) & _
" | thinRatio=" & Fmt(thinRatio) & _
" | edges L/C/O=" & CStr(lineEdgeCt) & "/" & CStr(circleEdgeCt) & "/" & CStr(otherEdgeCt) & _
" | faces P/C/O=" & CStr(planarFaceCt) & "/" & CStr(cylFaceCt) & "/" & CStr(otherFaceCt) & _
" | primaryDirLen=" & Fmt(primaryLen) & _
" | secondaryDirLen=" & Fmt(secondaryLen)
End If
Exit Sub
EH:
LogWarn "AnalyzeItemCategory exception | " & Err.Number & " | " & Err.Description & _
" | itemNo=" & SafeStr(item("ItemNo")) & " | pn=" & SafeStr(item("PartNo"))
End Sub
Private Sub DetectBodySubtype(ByVal item As Object, _
ByVal swBody As SldWorks.Body2, _
ByRef subtypeName As String, _
ByRef subtypeReason As String, _
ByRef hintText As String)
On Error GoTo EH
subtypeName = CAT_SUBTYPE_UNKNOWN
subtypeReason = "No section-family hint matched"
hintText = BuildSubtypeHintText(item, swBody)
Dim u As String
u = UCase$(hintText)
If InStr(1, u, "GUSSET", vbTextCompare) > 0 Then
subtypeName = CAT_SUBTYPE_GUSSET
subtypeReason = "Name hint contains GUSSET"
ElseIf LooksLikeChannelName(u) Then
subtypeName = CAT_SUBTYPE_CHANNEL
subtypeReason = "Name hint matches channel pattern (C/MC/channel)"
ElseIf LooksLikeAngleName(u) Then
subtypeName = CAT_SUBTYPE_ANGLE
subtypeReason = "Name hint matches angle pattern (L/angle)"
ElseIf LooksLikePlateName(u) Then
subtypeName = CAT_SUBTYPE_PLATE
subtypeReason = "Name hint matches plate pattern (PL/plate)"
ElseIf InStr(1, u, "ROUND", vbTextCompare) > 0 Or _
InStr(1, u, "ROD", vbTextCompare) > 0 Or _
InStr(1, u, "PIPE", vbTextCompare) > 0 Or _
InStr(1, u, "HSS ROUND", vbTextCompare) > 0 Then
subtypeName = CAT_SUBTYPE_ROUND
subtypeReason = "Name hint matches round/pipe/rod"
ElseIf InStr(1, u, "HSS", vbTextCompare) > 0 Or _
InStr(1, u, "TUBE", vbTextCompare) > 0 Or _
InStr(1, u, "RECT", vbTextCompare) > 0 Then
subtypeName = CAT_SUBTYPE_RECT_MEMBER
subtypeReason = "Name hint matches rectangular structural member"
End If
Exit Sub
EH:
subtypeName = CAT_SUBTYPE_UNKNOWN
subtypeReason = "DetectBodySubtype exception | " & Err.Number & " | " & Err.Description
hintText = ""
LogWarn subtypeReason
End Sub
Private Function BuildSubtypeHintText(ByVal item As Object, ByVal swBody As SldWorks.Body2) As String
On Error GoTo EH
Dim s As String
s = ""
s = AppendHintPart(s, DictValueString(item, "CutListFeatureName"))
s = AppendHintPart(s, DictValueString(item, "PartNo"))
s = AppendHintPart(s, DictValueString(item, "BodyName"))
s = AppendHintPart(s, DictValueString(item, "ItemNo"))
If Not swBody Is Nothing Then s = AppendHintPart(s, GetBodyNameSafe(swBody))
BuildSubtypeHintText = Trim$(s)
Exit Function
EH:
BuildSubtypeHintText = ""
End Function
Private Function AppendHintPart(ByVal baseText As String, ByVal addText As String) As String
addText = Trim$(addText)
If Len(addText) = 0 Then
AppendHintPart = baseText
ElseIf Len(Trim$(baseText)) = 0 Then
AppendHintPart = addText
Else
AppendHintPart = baseText & " | " & addText
End If
End Function
Private Function DictValueString(ByVal d As Object, ByVal keyName As String) As String
On Error GoTo EH
DictValueString = ""
If d Is Nothing Then Exit Function
If d.Exists(keyName) Then DictValueString = SafeStr(d(keyName))
Exit Function
EH:
DictValueString = ""
End Function
Private Function LooksLikeChannelName(ByVal u As String) As Boolean
On Error GoTo EH
If InStr(1, u, "CHANNEL", vbTextCompare) > 0 Then
LooksLikeChannelName = True
Exit Function
End If
Dim toks As Variant
toks = Split(TokenizedHintText(u), " ")
Dim i As Long
For i = LBound(toks) To UBound(toks)
Dim t As String
t = Trim$(SafeStr(toks(i)))
If Len(t) >= 2 Then
If Left$(t, 2) = "MC" Then
If Len(t) >= 3 Then
If IsDigitChar(Mid$(t, 3, 1)) Then
LooksLikeChannelName = True
Exit Function
End If
End If
ElseIf Left$(t, 1) = "C" Then
If IsDigitChar(Mid$(t, 2, 1)) Then
LooksLikeChannelName = True
Exit Function
End If
End If
End If
Next i
Exit Function
EH:
LooksLikeChannelName = False
End Function
Private Function LooksLikeAngleName(ByVal u As String) As Boolean
On Error GoTo EH
If InStr(1, u, "ANGLE", vbTextCompare) > 0 Then
LooksLikeAngleName = True
Exit Function
End If
Dim toks As Variant
toks = Split(TokenizedHintText(u), " ")
Dim i As Long
For i = LBound(toks) To UBound(toks)
Dim t As String
t = Trim$(SafeStr(toks(i)))
If Len(t) >= 2 Then
If Left$(t, 1) = "L" And IsDigitChar(Mid$(t, 2, 1)) Then
LooksLikeAngleName = True
Exit Function
End If
End If
Next i
Exit Function
EH:
LooksLikeAngleName = False
End Function
Private Function LooksLikePlateName(ByVal u As String) As Boolean
On Error GoTo EH
If InStr(1, u, "PLATE", vbTextCompare) > 0 Then
LooksLikePlateName = True
Exit Function
End If
Dim toks As Variant
toks = Split(TokenizedHintText(u), " ")
Dim i As Long
For i = LBound(toks) To UBound(toks)
Dim t As String
t = Trim$(SafeStr(toks(i)))
If t = "PL" Then
LooksLikePlateName = True
Exit Function
End If
If Len(t) >= 3 Then
If Left$(t, 2) = "PL" And IsDigitChar(Mid$(t, 3, 1)) Then
LooksLikePlateName = True
Exit Function
End If
End If
Next i
Exit Function
EH:
LooksLikePlateName = False
End Function
Private Function TokenizedHintText(ByVal s As String) As String
s = UCase$(s)
s = Replace(s, "|", " ")
s = Replace(s, "<", " ")
s = Replace(s, ">", " ")
s = Replace(s, "(", " ")
s = Replace(s, ")", " ")
s = Replace(s, "[", " ")
s = Replace(s, "]", " ")
s = Replace(s, "-", " ")
s = Replace(s, "_", " ")
s = Replace(s, ",", " ")
s = Replace(s, ";", " ")
TokenizedHintText = s
End Function
Private Function IsDigitChar(ByVal ch As String) As Boolean
If Len(ch) <> 1 Then
IsDigitChar = False
Else
IsDigitChar = (ch >= "0" And ch <= "9")
End If
End Function
Private Sub ResetDirectionFamilySlots(ByVal item As Object)
On Error Resume Next
item("Sig_PrimaryDirX") = 0#: item("Sig_PrimaryDirY") = 0#: item("Sig_PrimaryDirZ") = 0#: item("Sig_PrimaryDirLen") = 0#
item("Sig_SecondaryDirX") = 0#: item("Sig_SecondaryDirY") = 0#: item("Sig_SecondaryDirZ") = 0#: item("Sig_SecondaryDirLen") = 0#
item("Sig_TertiaryDirX") = 0#: item("Sig_TertiaryDirY") = 0#: item("Sig_TertiaryDirZ") = 0#: item("Sig_TertiaryDirLen") = 0#
End Sub
Private Sub ResetPlanarFaceFamilySlots(ByVal item As Object)
On Error Resume Next
Dim i As Long
For i = 1 To 6
item("Sig_FaceDir" & CStr(i) & "X") = 0#
item("Sig_FaceDir" & CStr(i) & "Y") = 0#
item("Sig_FaceDir" & CStr(i) & "Z") = 0#
item("Sig_FaceDir" & CStr(i) & "Area") = 0#
item("Sig_FaceDir" & CStr(i) & "Ct") = 0
Next i
End Sub
Private Sub AnalyzeBodyEdgesAndDirections(ByVal swBody As SldWorks.Body2, _
ByVal fams As Collection, _
ByRef lineEdgeCt As Long, _
ByRef circleEdgeCt As Long, _
ByRef otherEdgeCt As Long)
On Error GoTo EH
lineEdgeCt = 0
circleEdgeCt = 0
otherEdgeCt = 0
If swBody Is Nothing Then Exit Sub
Dim vEdges As Variant
vEdges = swBody.GetEdges
If IsEmpty(vEdges) Then Exit Sub
If Not IsArray(vEdges) Then Exit Sub
Dim i As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim swEdge As SldWorks.Edge
Set swEdge = vEdges(i)
If swEdge Is Nothing Then GoTo NextEdge
Dim swCurve As SldWorks.Curve
Set swCurve = Nothing
On Error Resume Next
Set swCurve = swEdge.GetCurve
On Error GoTo EH
If swCurve Is Nothing Then
otherEdgeCt = otherEdgeCt + 1
GoTo NextEdge
End If
Dim isLine As Boolean, isCircle As Boolean
isLine = False: isCircle = False
On Error Resume Next
isLine = swCurve.isLine
Err.Clear
isCircle = swCurve.isCircle
Err.Clear
On Error GoTo EH
If isLine Then
lineEdgeCt = lineEdgeCt + 1
Dim ux As Double, uy As Double, uz As Double, edgeLen As Double
If TryGetModelLineEdgeDirection(swEdge, ux, uy, uz, edgeLen) Then
If edgeLen >= CAT_MIN_LINE_LEN_MODEL Then
AddDirectionFamily fams, ux, uy, uz, edgeLen
End If
End If
ElseIf isCircle Then
circleEdgeCt = circleEdgeCt + 1
Else
otherEdgeCt = otherEdgeCt + 1
End If
NextEdge:
Next i
Exit Sub
EH:
LogWarn "AnalyzeBodyEdgesAndDirections exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub AnalyzeBodyFaces(ByVal swBody As SldWorks.Body2, _
ByRef planarFaceCt As Long, _
ByRef cylFaceCt As Long, _
ByRef otherFaceCt As Long)
On Error GoTo EH
planarFaceCt = 0
cylFaceCt = 0
otherFaceCt = 0
If swBody Is Nothing Then Exit Sub
Dim vFaces As Variant
vFaces = swBody.GetFaces
If IsEmpty(vFaces) Then Exit Sub
If Not IsArray(vFaces) Then Exit Sub
Dim i As Long
For i = LBound(vFaces) To UBound(vFaces)
Dim swFace As SldWorks.Face2
Set swFace = vFaces(i)
If swFace Is Nothing Then GoTo NextFace
Dim swSurf As SldWorks.Surface
Set swSurf = Nothing
On Error Resume Next
Set swSurf = swFace.GetSurface
On Error GoTo EH
If swSurf Is Nothing Then
otherFaceCt = otherFaceCt + 1
GoTo NextFace
End If
Dim isPlane As Boolean, isCyl As Boolean
isPlane = False: isCyl = False
On Error Resume Next
isPlane = swSurf.isPlane
Err.Clear
isCyl = swSurf.IsCylinder
Err.Clear
On Error GoTo EH
If isPlane Then
planarFaceCt = planarFaceCt + 1
ElseIf isCyl Then
cylFaceCt = cylFaceCt + 1
Else
otherFaceCt = otherFaceCt + 1
End If
NextFace:
Next i
Exit Sub
EH:
LogWarn "AnalyzeBodyFaces exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub AnalyzeBodyPlanarFaceFamilies(ByVal swBody As SldWorks.Body2, ByVal item As Object)
On Error GoTo EH
If swBody Is Nothing Then Exit Sub
If item Is Nothing Then Exit Sub
Dim fams As Collection
Set fams = New Collection
Dim vFaces As Variant
vFaces = swBody.GetFaces
If IsEmpty(vFaces) Then Exit Sub
If Not IsArray(vFaces) Then Exit Sub
Dim totalFaces As Long
Dim acceptedPlanarFaces As Long
Dim noSurfaceCt As Long
Dim notPlaneCt As Long
Dim normalFailCt As Long
Dim areaFailCt As Long
Dim otherRejectCt As Long
Dim normalFacePropCt As Long
Dim normalPlaneParamCt As Long
Dim areaNativeCt As Long
Dim areaProxyCt As Long
Dim i As Long
For i = LBound(vFaces) To UBound(vFaces)
Dim swFace As SldWorks.Face2
Set swFace = vFaces(i)
If swFace Is Nothing Then GoTo NextFace
totalFaces = totalFaces + 1
Dim nx As Double, ny As Double, nz As Double, faceArea As Double
Dim rejectReason As String
Dim normalSource As String
Dim areaSource As String
If TryGetPlanarFaceNormalAndArea(swFace, nx, ny, nz, faceArea, rejectReason, normalSource, areaSource) Then
acceptedPlanarFaces = acceptedPlanarFaces + 1
If UCase$(normalSource) = "FACE.NORMAL" Then
normalFacePropCt = normalFacePropCt + 1
ElseIf Left$(UCase$(normalSource), 11) = "PLANEPARAMS" Then
normalPlaneParamCt = normalPlaneParamCt + 1
End If
If UCase$(areaSource) = "GETAREA" Then
areaNativeCt = areaNativeCt + 1
ElseIf UCase$(areaSource) = "FACEBOX_PROXY" Then
areaProxyCt = areaProxyCt + 1
End If
If faceArea > 0# Then
AddPlanarFaceFamily fams, nx, ny, nz, faceArea
End If
Else
Select Case UCase$(rejectReason)
Case "NO_SURFACE"
noSurfaceCt = noSurfaceCt + 1
Case "NOT_PLANE"
notPlaneCt = notPlaneCt + 1
Case "NORMAL_FAIL"
normalFailCt = normalFailCt + 1
Case "AREA_FAIL"
areaFailCt = areaFailCt + 1
Case Else
otherRejectCt = otherRejectCt + 1
End Select
End If
NextFace:
Next i
CaptureTopPlanarFaceFamiliesToItem item, fams
If CAT_LOG_ANALYSIS Then
LogInfo "FaceFamilies | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | count=" & CStr(fams.Count) & _
" | f1Area=" & Fmt(SafeCDbl(item("Sig_FaceDir1Area"))) & _
" | f2Area=" & Fmt(SafeCDbl(item("Sig_FaceDir2Area"))) & _
" | f3Area=" & Fmt(SafeCDbl(item("Sig_FaceDir3Area")))
LogInfo "FaceFamiliesDetail | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | totalFaces=" & CStr(totalFaces) & _
" | acceptedPlanarFaces=" & CStr(acceptedPlanarFaces) & _
" | families=" & CStr(fams.Count) & _
" | noSurface=" & CStr(noSurfaceCt) & _
" | notPlane=" & CStr(notPlaneCt) & _
" | normalFail=" & CStr(normalFailCt) & _
" | areaFail=" & CStr(areaFailCt) & _
" | otherReject=" & CStr(otherRejectCt) & _
" | normalFaceProperty=" & CStr(normalFacePropCt) & _
" | normalPlaneParams=" & CStr(normalPlaneParamCt) & _
" | areaGetArea=" & CStr(areaNativeCt) & _
" | areaFaceBoxProxy=" & CStr(areaProxyCt) & _
" | f1=(" & Fmt(SafeCDbl(item("Sig_FaceDir1X"))) & "," & Fmt(SafeCDbl(item("Sig_FaceDir1Y"))) & "," & Fmt(SafeCDbl(item("Sig_FaceDir1Z"))) & ")" & _
" | f2=(" & Fmt(SafeCDbl(item("Sig_FaceDir2X"))) & "," & Fmt(SafeCDbl(item("Sig_FaceDir2Y"))) & "," & Fmt(SafeCDbl(item("Sig_FaceDir2Z"))) & ")" & _
" | f3=(" & Fmt(SafeCDbl(item("Sig_FaceDir3X"))) & "," & Fmt(SafeCDbl(item("Sig_FaceDir3Y"))) & "," & Fmt(SafeCDbl(item("Sig_FaceDir3Z"))) & ")"
End If
Exit Sub
EH:
LogWarn "AnalyzeBodyPlanarFaceFamilies exception | " & Err.Number & " | " & Err.Description & _
" | itemNo=" & SafeStr(item("ItemNo"))
End Sub
Private Function TryGetPlanarFaceNormalAndArea(ByVal swFace As SldWorks.Face2, _
ByRef nx As Double, _
ByRef ny As Double, _
ByRef nz As Double, _
ByRef faceArea As Double, _
ByRef rejectReason As String, _
ByRef normalSource As String, _
ByRef areaSource As String) As Boolean
On Error GoTo EH
TryGetPlanarFaceNormalAndArea = False
nx = 0#: ny = 0#: nz = 0#: faceArea = 0#
rejectReason = ""
normalSource = ""
areaSource = ""
If swFace Is Nothing Then
rejectReason = "NO_FACE"
Exit Function
End If
Dim swSurf As SldWorks.Surface
Set swSurf = swFace.GetSurface
If swSurf Is Nothing Then
rejectReason = "NO_SURFACE"
Exit Function
End If
Dim isPlane As Boolean
isPlane = False
On Error Resume Next
isPlane = swSurf.isPlane
Err.Clear
On Error GoTo EH
If Not TryGetPlanarFaceNormalVector(swFace, swSurf, nx, ny, nz, normalSource) Then
If Not isPlane Then
rejectReason = "NOT_PLANE"
Else
rejectReason = "NORMAL_FAIL"
End If
Exit Function
End If
' Some SOLIDWORKS versions/wrappers report IsPlane=False on faces that still
' expose valid plane parameters. Treat PlaneParams as the stronger evidence.
If Not isPlane Then
If Left$(UCase$(normalSource), 11) <> "PLANEPARAMS" Then
rejectReason = "NOT_PLANE"
Exit Function
End If
normalSource = normalSource & "+IsPlaneFalse"
End If
If Not NormalizeVector3(nx, ny, nz) Then
rejectReason = "NORMAL_FAIL"
Exit Function
End If
CanonicalizeVectorPositive nx, ny, nz
faceArea = GetPlanarFaceAreaOrProxy(swFace, areaSource)
If faceArea <= 0# Then
rejectReason = "AREA_FAIL"
Exit Function
End If
TryGetPlanarFaceNormalAndArea = True
Exit Function
EH:
rejectReason = "EXCEPTION"
LogWarn "TryGetPlanarFaceNormalAndArea exception | " & Err.Number & " | " & Err.Description
TryGetPlanarFaceNormalAndArea = False
End Function
Private Function TryGetPlanarFaceNormalVector(ByVal swFace As SldWorks.Face2, _
ByVal swSurf As SldWorks.Surface, _
ByRef nx As Double, _
ByRef ny As Double, _
ByRef nz As Double, _
ByRef normalSource As String) As Boolean
On Error GoTo EH
TryGetPlanarFaceNormalVector = False
normalSource = ""
nx = 0#: ny = 0#: nz = 0#
Dim vPlane As Variant
vPlane = Empty
On Error Resume Next
vPlane = swSurf.PlaneParams
If Err.Number <> 0 Then
Err.Clear
vPlane = Empty
End If
On Error GoTo EH
' PlaneParams is the most reliable proof that the surface is actually planar.
' It is normally root point XYZ followed by normal XYZ.
If TryReadVectorFromVariantArray(vPlane, 3, nx, ny, nz) Then
normalSource = "PlaneParams[3:5]"
TryGetPlanarFaceNormalVector = True
Exit Function
End If
' Some API wrappers expose plane normal first; keep this as a defensive fallback.
If TryReadVectorFromVariantArray(vPlane, 0, nx, ny, nz) Then
normalSource = "PlaneParams[0:2]"
TryGetPlanarFaceNormalVector = True
Exit Function
End If
Dim vNorm As Variant
vNorm = Empty
On Error Resume Next
vNorm = swFace.Normal
If Err.Number <> 0 Then
Err.Clear
vNorm = Empty
End If
On Error GoTo EH
If TryReadVectorFromVariantArray(vNorm, 0, nx, ny, nz) Then
normalSource = "Face.Normal"
TryGetPlanarFaceNormalVector = True
Exit Function
End If
Exit Function
EH:
TryGetPlanarFaceNormalVector = False
End Function
Private Function TryReadVectorFromVariantArray(ByVal vArr As Variant, _
ByVal startOffset As Long, _
ByRef x As Double, _
ByRef y As Double, _
ByRef z As Double) As Boolean
On Error GoTo EH
TryReadVectorFromVariantArray = False
x = 0#: y = 0#: z = 0#
If Not IsArray(vArr) Then Exit Function
Dim lb As Long, ub As Long
lb = LBound(vArr)
ub = UBound(vArr)
If ub < lb + startOffset + 2 Then Exit Function
x = CDbl(vArr(lb + startOffset))
y = CDbl(vArr(lb + startOffset + 1))
z = CDbl(vArr(lb + startOffset + 2))
TryReadVectorFromVariantArray = NormalizeVector3(x, y, z)
Exit Function
EH:
TryReadVectorFromVariantArray = False
End Function
Private Function GetPlanarFaceAreaOrProxy(ByVal swFace As SldWorks.Face2, ByRef areaSource As String) As Double
On Error GoTo EH
GetPlanarFaceAreaOrProxy = 0#
areaSource = ""
If swFace Is Nothing Then Exit Function
On Error Resume Next
GetPlanarFaceAreaOrProxy = CDbl(swFace.GetArea)
If Err.Number <> 0 Then
Err.Clear
GetPlanarFaceAreaOrProxy = 0#
End If
On Error GoTo EH
If GetPlanarFaceAreaOrProxy > 0# Then
areaSource = "GetArea"
Exit Function
End If
Dim vBox As Variant
vBox = Empty
On Error Resume Next
vBox = swFace.GetBox
If Err.Number <> 0 Then
Err.Clear
vBox = Empty
End If
On Error GoTo EH
If IsArray(vBox) Then
Dim lb As Long, ub As Long
lb = LBound(vBox)
ub = UBound(vBox)
If ub >= lb + 5 Then
Dim dx As Double, dy As Double, dz As Double
Dim sMin As Double, sMid As Double, sMax As Double
dx = Abs(CDbl(vBox(lb + 3)) - CDbl(vBox(lb)))
dy = Abs(CDbl(vBox(lb + 4)) - CDbl(vBox(lb + 1)))
dz = Abs(CDbl(vBox(lb + 5)) - CDbl(vBox(lb + 2)))
Sort3Doubles dx, dy, dz, sMin, sMid, sMax
GetPlanarFaceAreaOrProxy = sMid * sMax
If GetPlanarFaceAreaOrProxy > 0# Then areaSource = "FaceBox_Proxy"
End If
End If
Exit Function
EH:
GetPlanarFaceAreaOrProxy = 0#
End Function
Private Sub AddPlanarFaceFamily(ByVal fams As Collection, _
ByVal nx As Double, _
ByVal ny As Double, _
ByVal nz As Double, _
ByVal addArea As Double)
On Error GoTo EH
If fams Is Nothing Then Exit Sub
If addArea <= 0# Then Exit Sub
If Not NormalizeVector3(nx, ny, nz) Then Exit Sub
CanonicalizeVectorPositive nx, ny, nz
Dim cosTol As Double
cosTol = Cos(DegToRad(CAT_FAMILY_ANGLE_TOL_DEG))
Dim i As Long
For i = 1 To fams.Count
Dim fd As Object
Set fd = fams(i)
Dim dotAbs As Double
dotAbs = Abs((SafeCDbl(fd("x")) * nx) + (SafeCDbl(fd("y")) * ny) + (SafeCDbl(fd("z")) * nz))
If dotAbs >= cosTol Then
Dim oldArea As Double
oldArea = SafeCDbl(fd("area"))
Dim vx As Double, vy As Double, vz As Double
vx = (SafeCDbl(fd("x")) * oldArea) + (nx * addArea)
vy = (SafeCDbl(fd("y")) * oldArea) + (ny * addArea)
vz = (SafeCDbl(fd("z")) * oldArea) + (nz * addArea)
If NormalizeVector3(vx, vy, vz) Then
CanonicalizeVectorPositive vx, vy, vz
fd("x") = vx
fd("y") = vy
fd("z") = vz
End If
fd("area") = oldArea + addArea
fd("ct") = CLng(SafeCDbl(fd("ct"))) + 1
Exit Sub
End If
Next i
Dim fdNew As Object
Set fdNew = CreateObject("Scripting.Dictionary")
fdNew("x") = nx
fdNew("y") = ny
fdNew("z") = nz
fdNew("area") = addArea
fdNew("ct") = 1
fams.Add fdNew
Exit Sub
EH:
LogWarn "AddPlanarFaceFamily exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub CaptureTopPlanarFaceFamiliesToItem(ByVal item As Object, ByVal fams As Collection)
On Error GoTo EH
Call ResetPlanarFaceFamilySlots(item)
If item Is Nothing Then Exit Sub
If fams Is Nothing Then Exit Sub
If fams.Count = 0 Then Exit Sub
Dim picked(1 To 6) As Long
Dim pickedArea(1 To 6) As Double
Dim i As Long, slot As Long
For i = 1 To fams.Count
Dim fd As Object
Set fd = fams(i)
Dim area As Double
area = SafeCDbl(fd("area"))
For slot = 1 To 6
If area > pickedArea(slot) Then
Dim moveSlot As Long
For moveSlot = 6 To slot + 1 Step -1
pickedArea(moveSlot) = pickedArea(moveSlot - 1)
picked(moveSlot) = picked(moveSlot - 1)
Next moveSlot
pickedArea(slot) = area
picked(slot) = i
Exit For
End If
Next slot
Next i
For slot = 1 To 6
If picked(slot) > 0 Then
WritePlanarFaceFamilyToItem item, slot, fams(picked(slot))
End If
Next slot
Exit Sub
EH:
LogWarn "CaptureTopPlanarFaceFamiliesToItem exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub WritePlanarFaceFamilyToItem(ByVal item As Object, ByVal slot As Long, ByVal fd As Object)
On Error Resume Next
If slot < 1 Or slot > 6 Then Exit Sub
item("Sig_FaceDir" & CStr(slot) & "X") = SafeCDbl(fd("x"))
item("Sig_FaceDir" & CStr(slot) & "Y") = SafeCDbl(fd("y"))
item("Sig_FaceDir" & CStr(slot) & "Z") = SafeCDbl(fd("z"))
item("Sig_FaceDir" & CStr(slot) & "Area") = SafeCDbl(fd("area"))
item("Sig_FaceDir" & CStr(slot) & "Ct") = CLng(SafeCDbl(fd("ct")))
End Sub
Private Sub CaptureTopDirectionFamiliesToItem(ByVal item As Object, ByVal fams As Collection)
On Error GoTo EH
Call ResetDirectionFamilySlots(item)
If fams Is Nothing Then Exit Sub
If fams.Count = 0 Then Exit Sub
Dim idx1 As Long, idx2 As Long, idx3 As Long
Dim len1 As Double, len2 As Double, len3 As Double
idx1 = 0: idx2 = 0: idx3 = 0
len1 = -1#: len2 = -1#: len3 = -1#
Dim i As Long
For i = 1 To fams.Count
Dim fd As Object
Set fd = fams(i)
Dim curLen As Double
curLen = SafeCDbl(fd("len"))
If curLen > len1 Then
len3 = len2: idx3 = idx2
len2 = len1: idx2 = idx1
len1 = curLen: idx1 = i
ElseIf curLen > len2 Then
len3 = len2: idx3 = idx2
len2 = curLen: idx2 = i
ElseIf curLen > len3 Then
len3 = curLen: idx3 = i
End If
Next i
If idx1 > 0 Then WriteDirectionFamilyToItem item, "Sig_PrimaryDir", fams(idx1)
If idx2 > 0 Then WriteDirectionFamilyToItem item, "Sig_SecondaryDir", fams(idx2)
If idx3 > 0 Then WriteDirectionFamilyToItem item, "Sig_TertiaryDir", fams(idx3)
Exit Sub
EH:
LogWarn "CaptureTopDirectionFamiliesToItem exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub WriteDirectionFamilyToItem(ByVal item As Object, ByVal keyPrefix As String, ByVal fd As Object)
On Error Resume Next
item(keyPrefix & "X") = SafeCDbl(fd("x"))
item(keyPrefix & "Y") = SafeCDbl(fd("y"))
item(keyPrefix & "Z") = SafeCDbl(fd("z"))
item(keyPrefix & "Len") = SafeCDbl(fd("len"))
End Sub
Private Sub AddDirectionFamily(ByVal fams As Collection, _
ByVal ux As Double, _
ByVal uy As Double, _
ByVal uz As Double, _
ByVal addLen As Double)
On Error GoTo EH
If addLen <= 0# Then Exit Sub
If Not NormalizeVector3(ux, uy, uz) Then Exit Sub
CanonicalizeVectorPositive ux, uy, uz
Dim cosTol As Double
cosTol = Cos(DegToRad(CAT_FAMILY_ANGLE_TOL_DEG))
Dim i As Long
For i = 1 To fams.Count
Dim fd As Object
Set fd = fams(i)
Dim dotAbs As Double
dotAbs = Abs((SafeCDbl(fd("x")) * ux) + (SafeCDbl(fd("y")) * uy) + (SafeCDbl(fd("z")) * uz))
If dotAbs >= cosTol Then
Dim oldLen As Double
oldLen = SafeCDbl(fd("len"))
Dim nx As Double, ny As Double, nz As Double
nx = (SafeCDbl(fd("x")) * oldLen) + (ux * addLen)
ny = (SafeCDbl(fd("y")) * oldLen) + (uy * addLen)
nz = (SafeCDbl(fd("z")) * oldLen) + (uz * addLen)
If NormalizeVector3(nx, ny, nz) Then
CanonicalizeVectorPositive nx, ny, nz
fd("x") = nx
fd("y") = ny
fd("z") = nz
End If
fd("len") = oldLen + addLen
fd("ct") = CLng(SafeCDbl(fd("ct"))) + 1
Exit Sub
End If
Next i
Dim fdNew As Object
Set fdNew = CreateObject("Scripting.Dictionary")
fdNew("x") = ux
fdNew("y") = uy
fdNew("z") = uz
fdNew("len") = addLen
fdNew("ct") = 1
fams.Add fdNew
Exit Sub
EH:
LogWarn "AddDirectionFamily exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function TryGetModelLineEdgeDirection(ByVal swEdge As SldWorks.Edge, _
ByRef ux As Double, _
ByRef uy As Double, _
ByRef uz As Double, _
ByRef edgeLen As Double) As Boolean
On Error GoTo EH
TryGetModelLineEdgeDirection = False
ux = 0#: uy = 0#: uz = 0#: edgeLen = 0#
If swEdge Is Nothing Then Exit Function
Dim swStartVtx As SldWorks.Vertex
Dim swEndVtx As SldWorks.Vertex
Set swStartVtx = swEdge.GetStartVertex
Set swEndVtx = swEdge.GetEndVertex
If swStartVtx Is Nothing Or swEndVtx Is Nothing Then Exit Function
Dim vStart As Variant
Dim vEnd As Variant
vStart = swStartVtx.GetPoint
vEnd = swEndVtx.GetPoint
If Not IsArray(vStart) Or Not IsArray(vEnd) Then Exit Function
ux = CDbl(vEnd(0)) - CDbl(vStart(0))
uy = CDbl(vEnd(1)) - CDbl(vStart(1))
uz = CDbl(vEnd(2)) - CDbl(vStart(2))
edgeLen = Sqr((ux * ux) + (uy * uy) + (uz * uz))
If edgeLen <= 0# Then Exit Function
ux = ux / edgeLen
uy = uy / edgeLen
uz = uz / edgeLen
CanonicalizeVectorPositive ux, uy, uz
TryGetModelLineEdgeDirection = True
Exit Function
EH:
LogWarn "TryGetModelLineEdgeDirection exception | " & Err.Number & " | " & Err.Description
TryGetModelLineEdgeDirection = False
End Function
Private Function NormalizeVector3(ByRef x As Double, ByRef y As Double, ByRef z As Double) As Boolean
Dim m As Double
m = Sqr((x * x) + (y * y) + (z * z))
NormalizeVector3 = False
If m <= 0# Then Exit Function
x = x / m
y = y / m
z = z / m
NormalizeVector3 = True
End Function
Private Function Dot3(ByVal ax As Double, ByVal ay As Double, ByVal az As Double, _
ByVal bx As Double, ByVal by As Double, ByVal bz As Double) As Double
Dot3 = (ax * bx) + (ay * by) + (az * bz)
End Function
Private Sub Cross3(ByVal ax As Double, ByVal ay As Double, ByVal az As Double, _
ByVal bx As Double, ByVal by As Double, ByVal bz As Double, _
ByRef ox As Double, ByRef oy As Double, ByRef oz As Double)
ox = (ay * bz) - (az * by)
oy = (az * bx) - (ax * bz)
oz = (ax * by) - (ay * bx)
End Sub
Private Sub CanonicalizeVectorPositive(ByRef x As Double, ByRef y As Double, ByRef z As Double)
Const EPS As Double = 0.000000001
If x < -EPS Then
x = -x: y = -y: z = -z
ElseIf Abs(x) <= EPS And y < -EPS Then
x = -x: y = -y: z = -z
ElseIf Abs(x) <= EPS And Abs(y) <= EPS And z < -EPS Then
x = -x: y = -y: z = -z
End If
End Sub
Private Sub Sort3Doubles(ByVal a As Double, ByVal b As Double, ByVal c As Double, _
ByRef sMin As Double, ByRef sMid As Double, ByRef sMax As Double)
sMin = a: sMid = b: sMax = c
If sMin > sMid Then SwapD sMin, sMid
If sMid > sMax Then SwapD sMid, sMax
If sMin > sMid Then SwapD sMin, sMid
End Sub
Private Sub SwapD(ByRef a As Double, ByRef b As Double)
Dim t As Double
t = a
a = b
b = t
End Sub
Private Sub GetProjectedDominantDirectionMetrics(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef bestWeightedLen As Double, _
ByRef bestAngRad As Double, _
ByRef secondWeightedLen As Double, _
ByRef detail As String)
On Error GoTo EH
bestWeightedLen = 0#
bestAngRad = 0#
secondWeightedLen = 0#
detail = ""
If swView Is Nothing Then Exit Sub
If item Is Nothing Then Exit Sub
Dim names As Variant
names = Array("Sig_PrimaryDir", "Sig_SecondaryDir", "Sig_TertiaryDir")
Dim i As Long
For i = LBound(names) To UBound(names)
Dim pfx As String
pfx = CStr(names(i))
Dim ux As Double, uy As Double, uz As Double, famLen As Double
ux = SafeCDbl(item(pfx & "X"))
uy = SafeCDbl(item(pfx & "Y"))
uz = SafeCDbl(item(pfx & "Z"))
famLen = SafeCDbl(item(pfx & "Len"))
If famLen > 0# Then
Dim projMag As Double, projAngRad As Double
If TryProjectModelDirectionToView(swView, ux, uy, uz, projMag, projAngRad) Then
Dim weightedLen As Double
weightedLen = famLen * projMag
If weightedLen > bestWeightedLen Then
secondWeightedLen = bestWeightedLen
bestWeightedLen = weightedLen
bestAngRad = projAngRad
ElseIf weightedLen > secondWeightedLen Then
secondWeightedLen = weightedLen
End If
If Len(detail) > 0 Then detail = detail & " ; "
detail = detail & pfx & "=" & Fmt(weightedLen) & "@ang=" & Format$(RadToDeg(projAngRad), "0.0")
End If
End If
Next i
Exit Sub
EH:
LogWarn "GetProjectedDominantDirectionMetrics exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function TryProjectModelDirectionToView(ByVal swView As SldWorks.View, _
ByVal ux As Double, _
ByVal uy As Double, _
ByVal uz As Double, _
ByRef projMag As Double, _
ByRef angRad As Double) As Boolean
On Error GoTo EH
TryProjectModelDirectionToView = False
projMag = 0#
angRad = 0#
Dim dx As Double, dy As Double
If Not TryProjectModelDirectionToViewXY(swView, ux, uy, uz, dx, dy, projMag, angRad) Then Exit Function
TryProjectModelDirectionToView = True
Exit Function
EH:
LogWarn "TryProjectModelDirectionToView exception | " & Err.Number & " | " & Err.Description
TryProjectModelDirectionToView = False
End Function
Private Function TryProjectModelDirectionToViewXY(ByVal swView As SldWorks.View, _
ByVal ux As Double, _
ByVal uy As Double, _
ByVal uz As Double, _
ByRef dx As Double, _
ByRef dy As Double, _
ByRef projMag As Double, _
ByRef angRad As Double) As Boolean
On Error GoTo EH
TryProjectModelDirectionToViewXY = False
dx = 0#: dy = 0#
projMag = 0#
angRad = 0#
If swView Is Nothing Then Exit Function
Dim vx As Double, vy As Double, vz As Double
vx = ux: vy = uy: vz = uz
If Not NormalizeVector3(vx, vy, vz) Then Exit Function
Dim o As Variant
Dim p As Variant
o = Array(0#, 0#, 0#)
p = Array(vx, vy, vz)
Dim x0 As Double, y0 As Double
Dim x1 As Double, y1 As Double
Dim swXf As SldWorks.MathTransform
Set swXf = swView.ModelToViewTransform
If swXf Is Nothing Then Exit Function
If Not TryTransformModelPointToViewXY(o, swXf, x0, y0) Then Exit Function
If Not TryTransformModelPointToViewXY(p, swXf, x1, y1) Then Exit Function
dx = x1 - x0
dy = y1 - y0
projMag = Sqr((dx * dx) + (dy * dy))
If projMag <= 0# Then Exit Function
angRad = Atn2Safe(dy, dx)
TryProjectModelDirectionToViewXY = True
Exit Function
EH:
LogWarn "TryProjectModelDirectionToViewXY exception | " & Err.Number & " | " & Err.Description
TryProjectModelDirectionToViewXY = False
End Function
Private Sub GetBodyProjectedPointCloudMetrics(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef ptCt As Long, _
ByRef spanLen As Double, _
ByRef spanAngRad As Double, _
ByRef boxW As Double, _
ByRef boxH As Double, _
ByRef boxArea As Double, _
ByRef detail As String)
On Error GoTo EH
ptCt = 0
spanLen = 0#
spanAngRad = 0#
boxW = 0#
boxH = 0#
boxArea = 0#
detail = ""
If swView Is Nothing Then Exit Sub
If item Is Nothing Then Exit Sub
Dim pts As Collection
Set pts = New Collection
If Not CollectProjectedBodySamplePoints(swView, item, pts) Then Exit Sub
ptCt = pts.Count
If ptCt = 0 Then Exit Sub
Dim minX As Double, minY As Double, maxX As Double, maxY As Double
Dim firstPt As Variant
firstPt = pts(1)
minX = CDbl(firstPt(0)): maxX = CDbl(firstPt(0))
minY = CDbl(firstPt(1)): maxY = CDbl(firstPt(1))
Dim i As Long
For i = 1 To pts.Count
Dim pv As Variant
pv = pts(i)
If CDbl(pv(0)) < minX Then minX = CDbl(pv(0))
If CDbl(pv(0)) > maxX Then maxX = CDbl(pv(0))
If CDbl(pv(1)) < minY Then minY = CDbl(pv(1))
If CDbl(pv(1)) > maxY Then maxY = CDbl(pv(1))
Next i
boxW = maxX - minX
boxH = maxY - minY
boxArea = boxW * boxH
Dim j As Long
For i = 1 To pts.Count - 1
Dim p1 As Variant
p1 = pts(i)
For j = i + 1 To pts.Count
Dim p2 As Variant
p2 = pts(j)
Dim dx As Double, dy As Double, d As Double
dx = CDbl(p2(0)) - CDbl(p1(0))
dy = CDbl(p2(1)) - CDbl(p1(1))
d = Sqr((dx * dx) + (dy * dy))
If d > spanLen Then
spanLen = d
spanAngRad = Atn2Safe(dy, dx)
End If
Next j
Next i
detail = "span=" & Fmt(spanLen) & "@ang=" & Format$(RadToDeg(spanAngRad), "0.0") & _
" | box=" & Fmt(boxW) & "x" & Fmt(boxH) & _
" | area=" & Fmt(boxArea) & _
" | pts=" & CStr(ptCt)
Exit Sub
EH:
LogWarn "GetBodyProjectedPointCloudMetrics exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function CollectProjectedBodySamplePoints(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef pts As Collection) As Boolean
On Error GoTo EH
CollectProjectedBodySamplePoints = False
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
Dim swBody As SldWorks.Body2
Set swBody = Nothing
On Error Resume Next
Set swBody = item("RepBody_Model")
On Error GoTo EH
If swBody Is Nothing Then Exit Function
Dim swXf As SldWorks.MathTransform
Set swXf = swView.ModelToViewTransform
If swXf Is Nothing Then Exit Function
Dim seen As Object
Set seen = CreateObject("Scripting.Dictionary")
Dim vEdges As Variant
vEdges = swBody.GetEdges
If IsArray(vEdges) Then
Dim i As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim swEdge As SldWorks.Edge
Set swEdge = vEdges(i)
If swEdge Is Nothing Then GoTo NextEdge
Dim swV1 As SldWorks.Vertex, swV2 As SldWorks.Vertex
Set swV1 = swEdge.GetStartVertex
Set swV2 = swEdge.GetEndVertex
Dim vP1 As Variant, vP2 As Variant
vP1 = Empty: vP2 = Empty
If Not swV1 Is Nothing Then
vP1 = swV1.GetPoint
AddProjectedVertexPoint swV1, swXf, pts, seen
End If
If Not swV2 Is Nothing Then
vP2 = swV2.GetPoint
AddProjectedVertexPoint swV2, swXf, pts, seen
End If
If IsArray(vP1) And IsArray(vP2) Then
Dim swCurve As SldWorks.Curve
Set swCurve = Nothing
On Error Resume Next
Set swCurve = swEdge.GetCurve
On Error GoTo EH
Dim isLine As Boolean
isLine = False
If Not swCurve Is Nothing Then
On Error Resume Next
isLine = swCurve.isLine
Err.Clear
On Error GoTo EH
End If
If isLine Then
Dim vQ1(0 To 2) As Double
Dim vMid(0 To 2) As Double
Dim vQ3(0 To 2) As Double
vQ1(0) = (CDbl(vP1(0)) * 0.75) + (CDbl(vP2(0)) * 0.25)
vQ1(1) = (CDbl(vP1(1)) * 0.75) + (CDbl(vP2(1)) * 0.25)
vQ1(2) = (CDbl(vP1(2)) * 0.75) + (CDbl(vP2(2)) * 0.25)
vMid(0) = (CDbl(vP1(0)) + CDbl(vP2(0))) / 2#
vMid(1) = (CDbl(vP1(1)) + CDbl(vP2(1))) / 2#
vMid(2) = (CDbl(vP1(2)) + CDbl(vP2(2))) / 2#
vQ3(0) = (CDbl(vP1(0)) * 0.25) + (CDbl(vP2(0)) * 0.75)
vQ3(1) = (CDbl(vP1(1)) * 0.25) + (CDbl(vP2(1)) * 0.75)
vQ3(2) = (CDbl(vP1(2)) * 0.25) + (CDbl(vP2(2)) * 0.75)
AddProjectedXYZPoint vQ1, swXf, pts, seen
AddProjectedXYZPoint vMid, swXf, pts, seen
AddProjectedXYZPoint vQ3, swXf, pts, seen
End If
End If
NextEdge:
Next i
End If
If pts.Count < 2 Then
Dim beforeCt As Long
beforeCt = pts.Count
AddProjectedBodyBoxCornerPoints swBody, swXf, pts, seen
If pts.Count > beforeCt Then
LogInfo "CollectProjectedBodySamplePoints | bbox-corner fallback added points | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | added=" & CStr(pts.Count - beforeCt) & _
" | total=" & CStr(pts.Count) & _
" | cat=" & SafeStr(item("BodyCategory"))
End If
End If
CollectProjectedBodySamplePoints = (pts.Count > 0)
Exit Function
EH:
LogWarn "CollectProjectedBodySamplePoints exception | " & Err.Number & " | " & Err.Description
CollectProjectedBodySamplePoints = False
End Function
Private Sub AddProjectedXYZPoint(ByVal vPt As Variant, _
ByVal swXf As SldWorks.MathTransform, _
ByVal pts As Collection, _
ByVal seen As Object)
On Error GoTo EH
If swXf Is Nothing Then Exit Sub
If IsEmpty(vPt) Then Exit Sub
If Not IsArray(vPt) Then Exit Sub
Dim key As String
key = MakePointKey3D(vPt)
If Len(key) = 0 Then Exit Sub
If seen.Exists(key) Then Exit Sub
Dim x As Double, y As Double
If Not TryTransformModelPointToViewXY(vPt, swXf, x, y) Then Exit Sub
pts.Add Array(x, y)
seen.Add key, True
Exit Sub
EH:
LogWarn "AddProjectedXYZPoint exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub GetBodyProjectedPrincipalMetrics(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef ptCt As Long, _
ByRef majorLen As Double, _
ByRef majorAngRad As Double, _
ByRef minorLen As Double, _
ByRef minorAngRad As Double, _
ByRef minorRatio As Double, _
ByRef detail As String)
On Error GoTo EH
ptCt = 0
majorLen = 0#
majorAngRad = 0#
minorLen = 0#
minorAngRad = 0#
minorRatio = 0#
detail = ""
Dim pts As Collection
Set pts = New Collection
If Not CollectProjectedBodySamplePoints(swView, item, pts) Then Exit Sub
ptCt = pts.Count
If ptCt < 2 Then Exit Sub
If ComputeProjectedPointCloudPrincipalMetrics(pts, majorLen, majorAngRad, minorLen, minorAngRad, minorRatio) Then
detail = "major=" & Fmt(majorLen) & "@ang=" & Format$(RadToDeg(majorAngRad), "0.0") & _
" | minor=" & Fmt(minorLen) & "@ang=" & Format$(RadToDeg(minorAngRad), "0.0") & _
" | ratio=" & Fmt(minorRatio) & _
" | pts=" & CStr(ptCt)
End If
Exit Sub
EH:
LogWarn "GetBodyProjectedPrincipalMetrics exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function ComputeProjectedPointCloudPrincipalMetrics(ByVal pts As Collection, _
ByRef majorLen As Double, _
ByRef majorAngRad As Double, _
ByRef minorLen As Double, _
ByRef minorAngRad As Double, _
ByRef minorRatio As Double) As Boolean
On Error GoTo EH
ComputeProjectedPointCloudPrincipalMetrics = False
majorLen = 0#
majorAngRad = 0#
minorLen = 0#
minorAngRad = 0#
minorRatio = 0#
If pts Is Nothing Then Exit Function
If pts.Count < 2 Then Exit Function
Dim i As Long
Dim meanX As Double, meanY As Double
For i = 1 To pts.Count
Dim p As Variant
p = pts(i)
meanX = meanX + CDbl(p(0))
meanY = meanY + CDbl(p(1))
Next i
meanX = meanX / CDbl(pts.Count)
meanY = meanY / CDbl(pts.Count)
Dim sxx As Double, syy As Double, sxy As Double
For i = 1 To pts.Count
Dim q As Variant
q = pts(i)
Dim dx As Double, dy As Double
dx = CDbl(q(0)) - meanX
dy = CDbl(q(1)) - meanY
sxx = sxx + (dx * dx)
syy = syy + (dy * dy)
sxy = sxy + (dx * dy)
Next i
majorAngRad = 0.5 * Atn2Safe(2# * sxy, sxx - syy)
minorAngRad = NormalizeAngleRad(majorAngRad + (PI / 2#))
Dim ux As Double, uy As Double
Dim vx As Double, vy As Double
ux = Cos(majorAngRad): uy = Sin(majorAngRad)
vx = Cos(minorAngRad): vy = Sin(minorAngRad)
Dim minU As Double, maxU As Double, minV As Double, maxV As Double
Dim first As Variant
first = pts(1)
minU = (CDbl(first(0)) * ux) + (CDbl(first(1)) * uy)
maxU = minU
minV = (CDbl(first(0)) * vx) + (CDbl(first(1)) * vy)
maxV = minV
For i = 2 To pts.Count
Dim r As Variant
r = pts(i)
Dim pu As Double, pv As Double
pu = (CDbl(r(0)) * ux) + (CDbl(r(1)) * uy)
pv = (CDbl(r(0)) * vx) + (CDbl(r(1)) * vy)
If pu < minU Then minU = pu
If pu > maxU Then maxU = pu
If pv < minV Then minV = pv
If pv > maxV Then maxV = pv
Next i
majorLen = maxU - minU
minorLen = maxV - minV
If minorLen > majorLen Then
SwapD majorLen, minorLen
SwapD majorAngRad, minorAngRad
End If
majorAngRad = NormalizeAngleRad(majorAngRad)
minorAngRad = NormalizeAngleRad(minorAngRad)
If majorLen > 0# Then minorRatio = minorLen / majorLen
ComputeProjectedPointCloudPrincipalMetrics = (majorLen > 0#)
Exit Function
EH:
LogWarn "ComputeProjectedPointCloudPrincipalMetrics exception | " & Err.Number & " | " & Err.Description
ComputeProjectedPointCloudPrincipalMetrics = False
End Function
Private Sub AddProjectedBodyBoxCornerPoints(ByVal swBody As SldWorks.Body2, _
ByVal swXf As SldWorks.MathTransform, _
ByVal pts As Collection, _
ByVal seen As Object)
On Error GoTo EH
If swBody Is Nothing Then Exit Sub
If swXf Is Nothing Then Exit Sub
If pts Is Nothing Then Exit Sub
If seen Is Nothing Then Exit Sub
Dim vBox As Variant
vBox = swBody.GetBodyBox
If Not IsArray(vBox) Then Exit Sub
If UBound(vBox) - LBound(vBox) < 5 Then Exit Sub
Dim x0 As Double, y0 As Double, z0 As Double
Dim x1 As Double, y1 As Double, z1 As Double
x0 = CDbl(vBox(0)): y0 = CDbl(vBox(1)): z0 = CDbl(vBox(2))
x1 = CDbl(vBox(3)): y1 = CDbl(vBox(4)): z1 = CDbl(vBox(5))
If x1 < x0 Then SwapD x0, x1
If y1 < y0 Then SwapD y0, y1
If z1 < z0 Then SwapD z0, z1
Dim p(0 To 2) As Double
Dim ix As Long, iy As Long, iz As Long
For ix = 0 To 1
For iy = 0 To 1
For iz = 0 To 1
If ix = 0 Then
p(0) = x0
Else
p(0) = x1
End If
If iy = 0 Then
p(1) = y0
Else
p(1) = y1
End If
If iz = 0 Then
p(2) = z0
Else
p(2) = z1
End If
AddProjectedXYZPoint p, swXf, pts, seen
Next iz
Next iy
Next ix
Exit Sub
EH:
LogWarn "AddProjectedBodyBoxCornerPoints exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub AddProjectedVertexPoint(ByVal swVtx As SldWorks.Vertex, _
ByVal swXf As SldWorks.MathTransform, _
ByVal pts As Collection, _
ByVal seen As Object)
On Error GoTo EH
If swVtx Is Nothing Then Exit Sub
If swXf Is Nothing Then Exit Sub
Dim vPt As Variant
vPt = swVtx.GetPoint
If Not IsArray(vPt) Then Exit Sub
Dim key As String
key = MakePointKey3D(vPt)
If seen.Exists(key) Then Exit Sub
Dim x As Double, y As Double
If Not TryTransformModelPointToViewXY(vPt, swXf, x, y) Then Exit Sub
pts.Add Array(x, y)
seen.Add key, True
Exit Sub
EH:
LogWarn "AddProjectedVertexPoint exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function MakePointKey3D(ByVal vPt As Variant) As String
On Error GoTo EH
MakePointKey3D = Format$(CDbl(vPt(0)), "0." & String$(CAT_POINT_KEY_DECIMALS, "0")) & "|" & _
Format$(CDbl(vPt(1)), "0." & String$(CAT_POINT_KEY_DECIMALS, "0")) & "|" & _
Format$(CDbl(vPt(2)), "0." & String$(CAT_POINT_KEY_DECIMALS, "0"))
Exit Function
EH:
MakePointKey3D = ""
End Function
Private Function GetCategoryOrientationReference(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef refMetric As Double, _
ByRef refAngRad As Double, _
ByRef qualityScore As Double, _
ByRef refDesc As String) As Boolean
On Error GoTo EH
GetCategoryOrientationReference = False
refMetric = 0#
refAngRad = 0#
qualityScore = -1E+30
refDesc = ""
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
Call EnsureItemCategoryAnalysis(item)
Dim catName As String
catName = SafeStr(item("BodyCategory"))
Dim subtypeName As String
subtypeName = UCase$(SafeStr(item("BodySubtype")))
Dim famBest As Double, famAng As Double, famSecond As Double, famDetail As String
Dim spanLen As Double, spanAng As Double, cloudW As Double, cloudH As Double, cloudArea As Double, cloudDetail As String
Dim ptCt As Long
Dim visLen As Double, visAng As Double, visDesc As String
Dim edgeCt As Long, lineCt As Long
Dim pcPtCt As Long
Dim pcMajor As Double, pcMajorAng As Double
Dim pcMinor As Double, pcMinorAng As Double
Dim pcRatio As Double, pcDetail As String
Dim faceMetric As Double
Dim profileMetric As Double
Dim penalty As Double
Call GetProjectedDominantDirectionMetrics(swView, item, famBest, famAng, famSecond, famDetail)
Call GetBodyProjectedPointCloudMetrics(swView, item, ptCt, spanLen, spanAng, cloudW, cloudH, cloudArea, cloudDetail)
Call GetBodyProjectedPrincipalMetrics(swView, item, pcPtCt, pcMajor, pcMajorAng, pcMinor, pcMinorAng, pcRatio, pcDetail)
Call GetBestVisibleLinearEdgeInView(swView, visLen, visAng, visDesc, edgeCt, lineCt)
faceMetric = pcMajor * pcMinor
profileMetric = MaxD(pcMinor, famSecond)
penalty = 0#
Select Case UCase$(catName)
Case UCase$(CAT_NAME_LINEAR_STRUCTURAL)
If famBest > 0# Then
Dim familyAgreesWithPrincipal As Boolean
Dim familyPrincipalDeltaDeg As Double
familyAgreesWithPrincipal = True
familyPrincipalDeltaDeg = 0#
If pcMajor > 0# Then
familyPrincipalDeltaDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(famAng - pcMajorAng)))
familyAgreesWithPrincipal = (familyPrincipalDeltaDeg <= 12#)
End If
If familyAgreesWithPrincipal Then
refMetric = famBest
refAngRad = famAng
qualityScore = (famBest * 1200000#) + (famSecond * 450000#) + (pcMajor * 150000#) + (cloudArea * 50000#)
refDesc = "Linear 3D direction-family axis | famBest=" & Fmt(famBest) & _
" | famSecond=" & Fmt(famSecond) & _
" | familyPrincipalDeltaDeg=" & Format$(familyPrincipalDeltaDeg, "0.000") & _
" | " & famDetail & " | pcDiag={" & pcDetail & "}"
ElseIf pcMajor > 0# Then
refMetric = pcMajor
refAngRad = pcMajorAng
qualityScore = (pcMajor * 900000#) + (profileMetric * 600000#) + (famBest * 100000#) + (cloudArea * 100000#)
refDesc = "Linear principal-axis fallback after 3D family mismatch | pcMajor=" & Fmt(pcMajor) & _
" | profile=" & Fmt(profileMetric) & _
" | pcRatio=" & Fmt(pcRatio) & _
" | familyPrincipalDeltaDeg=" & Format$(familyPrincipalDeltaDeg, "0.000") & _
" | " & famDetail & " | " & pcDetail
If profileMetric < MaxD(CAT_LINEAR_PROFILE_ABS_MIN, pcMajor * CAT_LINEAR_PROFILE_RATIO_MIN) Then
penalty = CAT_REJECT_PENALTY
refDesc = refDesc & " | rejectHint=linear end-on/readability penalty"
End If
End If
ElseIf pcMajor > 0# Then
refMetric = pcMajor
refAngRad = pcMajorAng
qualityScore = (pcMajor * 900000#) + (profileMetric * 600000#) + (cloudArea * 100000#)
refDesc = "Linear principal-axis fallback; no 3D direction family projected | pcMajor=" & Fmt(pcMajor) & _
" | profile=" & Fmt(profileMetric) & _
" | pcRatio=" & Fmt(pcRatio) & " | " & pcDetail
If profileMetric < MaxD(CAT_LINEAR_PROFILE_ABS_MIN, pcMajor * CAT_LINEAR_PROFILE_RATIO_MIN) Then
penalty = CAT_REJECT_PENALTY
refDesc = refDesc & " | rejectHint=linear end-on/readability penalty"
End If
ElseIf famBest > 0# Then
refMetric = famBest
refAngRad = famAng
qualityScore = (famBest * 700000#) + (famSecond * 300000#) + (cloudArea * 50000#)
refDesc = "Linear family fallback | famBest=" & Fmt(famBest) & " | famSecond=" & Fmt(famSecond) & " | " & famDetail
ElseIf spanLen > 0# Then
refMetric = spanLen
refAngRad = spanAng
qualityScore = (spanLen * 500000#) + (cloudArea * 50000#)
refDesc = "Linear span fallback | " & cloudDetail
ElseIf visLen > 0# Then
refMetric = visLen
refAngRad = visAng
qualityScore = (visLen * 300000#) + (cloudArea * 50000#)
refDesc = "Linear visible-edge fallback | len=" & Fmt(visLen) & " | " & visDesc
End If
Case UCase$(CAT_NAME_SHEET_PLATE)
If pcMajor > 0# Then
refMetric = pcMajor
refAngRad = pcMajorAng
qualityScore = (faceMetric * 2500000#) + (pcMinor * 1200000#) + (pcMajor * 500000#) + (cloudArea * 200000#)
refDesc = "Sheet broad-face principal axis | faceMetric=" & Fmt(faceMetric) & " | pcMajor=" & Fmt(pcMajor) & _
" | pcMinor=" & Fmt(pcMinor) & " | pcRatio=" & Fmt(pcRatio) & " | " & pcDetail
If pcMinor < MaxD(CAT_PLATE_FACE_ABS_MIN, pcMajor * CAT_PLATE_FACE_RATIO_MIN) Then
penalty = CAT_REJECT_PENALTY
refDesc = refDesc & " | rejectHint=sheet edge-on penalty"
End If
ElseIf spanLen > 0# Then
refMetric = spanLen
refAngRad = spanAng
qualityScore = (spanLen * 500000#) + (cloudArea * 150000#)
refDesc = "Sheet span fallback | " & cloudDetail
ElseIf famBest > 0# Then
refMetric = famBest
refAngRad = famAng
qualityScore = (famBest * 300000#) + (cloudArea * 50000#)
refDesc = "Sheet family fallback | " & famDetail
End If
Case UCase$(CAT_NAME_CURVED_STRUCTURAL)
If pcMajor > 0# Then
refMetric = pcMajor
refAngRad = pcMajorAng
qualityScore = (pcMajor * 800000#) + (pcMinor * 300000#) + (cloudArea * 200000#) + (spanLen * 150000#)
refDesc = "Curved principal chord/span | pcMajor=" & Fmt(pcMajor) & " | pcMinor=" & Fmt(pcMinor) & " | " & pcDetail
ElseIf spanLen > 0# Then
refMetric = spanLen
refAngRad = spanAng
qualityScore = (spanLen * 700000#) + (cloudArea * 150000#)
refDesc = "Curved span fallback | " & cloudDetail
ElseIf visLen > 0# Then
refMetric = visLen
refAngRad = visAng
qualityScore = (visLen * 500000#) + (cloudArea * 50000#)
refDesc = "Curved visible-edge fallback | " & visDesc
End If
Case UCase$(CAT_NAME_ROUND_STOCK)
If famBest > 0# Then
refMetric = famBest
refAngRad = famAng
qualityScore = (famBest * 800000#) + (pcMajor * 200000#) + (cloudArea * 50000#)
refDesc = "Round/rod dominant axis | famBest=" & Fmt(famBest) & " | " & famDetail
ElseIf pcMajor > 0# Then
refMetric = pcMajor
refAngRad = pcMajorAng
qualityScore = (pcMajor * 500000#) + (pcMinor * 100000#) + (cloudArea * 50000#)
refDesc = "Round/rod principal fallback | " & pcDetail
ElseIf spanLen > 0# Then
refMetric = spanLen
refAngRad = spanAng
qualityScore = (spanLen * 300000#) + (cloudArea * 50000#)
refDesc = "Round/rod span fallback | " & cloudDetail
End If
Case Else
If pcMajor > 0# Then
refMetric = pcMajor
refAngRad = pcMajorAng
qualityScore = (faceMetric * 500000#) + (pcMajor * 300000#) + (pcMinor * 200000#) + (cloudArea * 100000#)
refDesc = "Irregular principal axis | " & pcDetail
ElseIf spanLen > 0# Then
refMetric = spanLen
refAngRad = spanAng
qualityScore = (spanLen * 400000#) + (cloudArea * 150000#)
refDesc = "Irregular span axis | " & cloudDetail
ElseIf famBest > 0# Then
refMetric = famBest
refAngRad = famAng
qualityScore = (famBest * 250000#) + (cloudArea * 50000#)
refDesc = "Irregular family fallback | " & famDetail
ElseIf visLen > 0# Then
refMetric = visLen
refAngRad = visAng
qualityScore = (visLen * 200000#) + (cloudArea * 50000#)
refDesc = "Irregular visible-edge fallback | " & visDesc
End If
End Select
If penalty > 0# Then qualityScore = qualityScore - penalty
If refMetric > 0# Then
GetCategoryOrientationReference = True
End If
Exit Function
EH:
LogWarn "GetCategoryOrientationReference exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
GetCategoryOrientationReference = False
End Function
Private Function AppendRejectNote(ByVal baseText As String, ByVal addText As String) As String
If Len(baseText) = 0 Then
AppendRejectNote = addText
Else
AppendRejectNote = baseText & "; " & addText
End If
End Function
Private Function ValidateOrientationResultByCategory(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef validationScore As Double, _
ByRef validationDetail As String) As Boolean
On Error GoTo EH
ValidateOrientationResultByCategory = False
validationScore = -1E+30
validationDetail = ""
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
Call EnsureItemCategoryAnalysis(item)
Dim catName As String
catName = SafeStr(item("BodyCategory"))
Dim subtypeName As String
subtypeName = UCase$(SafeStr(item("BodySubtype")))
Dim famBest As Double, famAng As Double, famSecond As Double, famDetail As String
Dim spanLen As Double, spanAng As Double, cloudW As Double, cloudH As Double, cloudArea As Double, cloudDetail As String
Dim ptCt As Long
Dim pcPtCt As Long
Dim pcMajor As Double, pcMajorAng As Double
Dim pcMinor As Double, pcMinorAng As Double
Dim pcRatio As Double, pcDetail As String
Dim angleEdgeOk As Boolean
Dim angleEdgeMetric As Double
Dim angleEdgeAng As Double
Dim angleEdgeRemainDeg As Double
Dim angleEdgeDetail As String
Dim angleEdgeTopDetail As String
Dim angleEdgeCt As Long
Dim angleLineCt As Long
Dim angleFamilyCt As Long
Dim outlineW As Double, outlineH As Double
Dim majorRemainDeg As Double
Dim outlineRatio As Double
Dim faceMetric As Double
Dim profileMetric As Double
Dim valid As Boolean
Dim minReadable As Double
Dim angleHorizontalRemainDeg As Double
Call GetProjectedDominantDirectionMetrics(swView, item, famBest, famAng, famSecond, famDetail)
Call GetBodyProjectedPointCloudMetrics(swView, item, ptCt, spanLen, spanAng, cloudW, cloudH, cloudArea, cloudDetail)
Call GetBodyProjectedPrincipalMetrics(swView, item, pcPtCt, pcMajor, pcMajorAng, pcMinor, pcMinorAng, pcRatio, pcDetail)
Dim roundFallbackDetail As String
roundFallbackDetail = ""
Dim visEdgeCt As Long, visVertexCt As Long, visFaceCt As Long
visEdgeCt = 0: visVertexCt = 0: visFaceCt = 0
GetVisibleEntityCountsInView swView, visEdgeCt, visVertexCt, visFaceCt
If UCase$(catName) = UCase$(CAT_NAME_ROUND_STOCK) Then
If (pcMajor <= 0# Or spanLen <= 0#) And (visEdgeCt > 0 Or visFaceCt > 0) Then
If ApplyRoundStockProjectedOutlineFallback(swView, item, ptCt, spanLen, cloudW, cloudH, cloudArea, _
pcPtCt, pcMajor, pcMajorAng, pcMinor, pcMinorAng, pcRatio, _
roundFallbackDetail) Then
LogInfo "RoundStockFallback | final orientation metrics restored from outline | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | detail={" & roundFallbackDetail & "}"
End If
End If
End If
majorRemainDeg = 9999#
If pcMajor > 0# Then majorRemainDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(pcMajorAng)))
angleEdgeRemainDeg = 9999#
If subtypeName = CAT_SUBTYPE_ANGLE Then
angleEdgeOk = TryGetBestProjectedModelEdgeFamily(swView, item, angleEdgeMetric, angleEdgeAng, angleEdgeDetail, _
angleEdgeCt, angleLineCt, angleFamilyCt, angleEdgeTopDetail)
If angleEdgeOk Then angleEdgeRemainDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(angleEdgeAng)))
End If
outlineW = 0#: outlineH = 0#
If TryGetViewOutlineWH(swView, outlineW, outlineH) Then
If outlineH > 0# Then outlineRatio = outlineW / outlineH
End If
faceMetric = pcMajor * pcMinor
profileMetric = MaxD(pcMinor, famSecond)
valid = False
Select Case subtypeName
Case CAT_SUBTYPE_CHANNEL
minReadable = MaxD(CAT_SECTION_PROFILE_ABS_MIN, pcMajor * CAT_CHANNEL_PROFILE_RATIO_MIN)
If pcMajor > 0# Then
valid = (majorRemainDeg <= CAT_MAJOR_HORIZONTAL_TOL_DEG) And _
(profileMetric >= minReadable) And _
(pcMajor >= (profileMetric * 1.1))
validationScore = (pcMajor * 1200000#) + (profileMetric * 1700000#) + _
(famSecond * 1000000#) - (majorRemainDeg * 1000#)
If outlineRatio >= CAT_OUTLINE_HORIZONTAL_RATIO_MIN Then validationScore = validationScore + 500#
End If
Case CAT_SUBTYPE_ANGLE
minReadable = MaxD(CAT_SECTION_PROFILE_ABS_MIN, pcMajor * CAT_ANGLE_PROFILE_RATIO_MIN)
If pcMajor > 0# Then
angleHorizontalRemainDeg = majorRemainDeg
If angleEdgeOk Then angleHorizontalRemainDeg = angleEdgeRemainDeg
valid = (angleHorizontalRemainDeg <= CAT_MAJOR_HORIZONTAL_TOL_DEG) And _
(profileMetric >= minReadable) And _
(pcMajor >= (profileMetric * 1.05))
validationScore = (pcMajor * 1250000#) + (profileMetric * 1600000#) + _
(famSecond * 1200000#) - (angleHorizontalRemainDeg * 1000#)
If outlineRatio >= CAT_OUTLINE_HORIZONTAL_RATIO_MIN Then validationScore = validationScore + 500#
End If
Case Else
Select Case UCase$(catName)
Case UCase$(CAT_NAME_LINEAR_STRUCTURAL)
If pcMajor > 0# Then
minReadable = MaxD(CAT_LINEAR_PROFILE_ABS_MIN, pcMajor * CAT_LINEAR_PROFILE_RATIO_MIN)
valid = (majorRemainDeg <= CAT_MAJOR_HORIZONTAL_TOL_DEG) And _
(profileMetric >= minReadable)
validationScore = (pcMajor * 1000000#) + (profileMetric * 700000#) - (majorRemainDeg * 1000#)
If outlineRatio >= CAT_OUTLINE_HORIZONTAL_RATIO_MIN Then validationScore = validationScore + 500#
End If
Case UCase$(CAT_NAME_SHEET_PLATE)
If pcMajor > 0# Then
minReadable = MaxD(CAT_PLATE_FACE_ABS_MIN, pcMajor * CAT_PLATE_FACE_RATIO_MIN)
valid = (majorRemainDeg <= CAT_MAJOR_HORIZONTAL_TOL_DEG) And _
(pcMinor >= minReadable)
validationScore = (faceMetric * 2500000#) + (pcMinor * 1200000#) - (majorRemainDeg * 1000#)
If outlineRatio >= CAT_OUTLINE_HORIZONTAL_RATIO_MIN Then validationScore = validationScore + 500#
End If
Case UCase$(CAT_NAME_CURVED_STRUCTURAL)
If pcMajor > 0# Then
valid = (majorRemainDeg <= CAT_MAJOR_HORIZONTAL_TOL_DEG)
validationScore = (pcMajor * 800000#) + (pcMinor * 200000#) - (majorRemainDeg * 1000#)
End If
Case UCase$(CAT_NAME_ROUND_STOCK)
If famBest > 0# Then
valid = (Abs(RadToDeg(NormalizeAngleToHorizontal(famAng))) <= CAT_MAJOR_HORIZONTAL_TOL_DEG)
validationScore = (famBest * 700000#) - (Abs(RadToDeg(NormalizeAngleToHorizontal(famAng))) * 1000#)
ElseIf pcMajor > 0# Then
valid = (majorRemainDeg <= CAT_MAJOR_HORIZONTAL_TOL_DEG)
validationScore = (pcMajor * 400000#) - (majorRemainDeg * 1000#)
End If
Case Else
If pcMajor > 0# Then
valid = (majorRemainDeg <= CAT_MAJOR_HORIZONTAL_TOL_DEG)
validationScore = (faceMetric * 500000#) + (pcMajor * 300000#) - (majorRemainDeg * 1000#)
End If
End Select
End Select
validationDetail = "cat=" & catName & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | pcMajor=" & Fmt(pcMajor) & "@ang=" & Format$(RadToDeg(pcMajorAng), "0.000") & _
" | pcMinor=" & Fmt(pcMinor) & _
" | pcRatio=" & Fmt(pcRatio) & _
" | profileMetric=" & Fmt(profileMetric) & _
" | minReadable=" & Fmt(minReadable) & _
" | famBest=" & Fmt(famBest) & _
" | famSecond=" & Fmt(famSecond) & _
" | majorRemainDeg=" & Format$(majorRemainDeg, "0.000") & _
" | angleEdgeOk=" & BoolWord(angleEdgeOk) & _
" | angleEdgeRemainDeg=" & Format$(angleEdgeRemainDeg, "0.000") & _
" | angleEdgeMetric=" & Fmt(angleEdgeMetric) & _
" | angleEdge={" & angleEdgeDetail & "}" & _
" | outline=" & Fmt(outlineW) & "x" & Fmt(outlineH) & _
" | outlineRatio=" & Fmt(outlineRatio) & _
" | valid=" & BoolWord(valid)
If Len(roundFallbackDetail) > 0 Then
validationDetail = validationDetail & " | fallback={" & roundFallbackDetail & "}"
End If
ValidateOrientationResultByCategory = valid
Exit Function
EH:
LogWarn "ValidateOrientationResultByCategory exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
ValidateOrientationResultByCategory = False
End Function
Private Function IsAngleProjectedEdgeFamilyHorizontal(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef edgeDetail As String) As Boolean
On Error GoTo EH
IsAngleProjectedEdgeFamilyHorizontal = False
edgeDetail = ""
Dim bestMetric As Double
Dim bestAngRad As Double
Dim famDetail As String
Dim edgeCt As Long
Dim lineCt As Long
Dim familyCt As Long
Dim topDetail As String
If Not TryGetBestProjectedModelEdgeFamily(swView, item, bestMetric, bestAngRad, famDetail, _
edgeCt, lineCt, familyCt, topDetail) Then
edgeDetail = "edgeFamilyAvailable=False | edgeCt=" & CStr(edgeCt) & _
" | lineCt=" & CStr(lineCt) & _
" | familyCt=" & CStr(familyCt)
Exit Function
End If
Dim remainDeg As Double
remainDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(bestAngRad)))
edgeDetail = "edgeFamilyAvailable=True | remainDeg=" & Format$(remainDeg, "0.000") & _
" | tolDeg=" & Format$(ANGLE_EDGE_FAMILY_FINAL_TOL_DEG, "0.000") & _
" | selected={" & famDetail & "}" & _
" | top={" & topDetail & "}"
IsAngleProjectedEdgeFamilyHorizontal = (remainDeg <= ANGLE_EDGE_FAMILY_FINAL_TOL_DEG)
Exit Function
EH:
edgeDetail = "IsAngleProjectedEdgeFamilyHorizontal exception | " & Err.Number & " | " & Err.Description
LogWarn edgeDetail & " | view=" & ViewGetNameSafe(swView)
IsAngleProjectedEdgeFamilyHorizontal = False
End Function
Private Function TryRotateAngleViewByProjectedEdgeFamily(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal tag As String, _
ByRef edgeRotateDetail As String, _
ByRef edgeFamilyAvailable As Boolean) As Boolean
On Error GoTo EH
TryRotateAngleViewByProjectedEdgeFamily = False
edgeRotateDetail = ""
edgeFamilyAvailable = False
If swDrawModel Is Nothing Then
edgeRotateDetail = "method=model-edge-family | drawing model is Nothing"
Exit Function
End If
If swView Is Nothing Then
edgeRotateDetail = "method=model-edge-family | view is Nothing"
Exit Function
End If
If item Is Nothing Then
edgeRotateDetail = "method=model-edge-family | item is Nothing"
Exit Function
End If
If UCase$(SafeStr(item("BodySubtype"))) <> CAT_SUBTYPE_ANGLE Then
edgeRotateDetail = "method=model-edge-family | skipped; subtype=" & SafeStr(item("BodySubtype"))
Exit Function
End If
Dim basisDetail As String
basisDetail = DescribeViewProjectionBasis(swView)
LogInfo "ViewProjectionBasis | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | subtype=ANGLE" & _
" | basis={" & basisDetail & "}"
Dim bestMetric As Double
Dim bestAngRad As Double
Dim famDetail As String
Dim edgeCt As Long
Dim lineCt As Long
Dim familyCt As Long
Dim topDetail As String
If Not TryGetBestProjectedModelEdgeFamily(swView, item, bestMetric, bestAngRad, famDetail, _
edgeCt, lineCt, familyCt, topDetail) Then
edgeRotateDetail = "method=model-edge-family | edgeFamilyAvailable=False" & _
" | edgeCt=" & CStr(edgeCt) & _
" | lineCt=" & CStr(lineCt) & _
" | familyCt=" & CStr(familyCt) & _
" | basis={" & basisDetail & "}"
LogWarn "RotationFallback | no usable projected model edge family for angle | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | detail={" & edgeRotateDetail & "}"
Exit Function
End If
edgeFamilyAvailable = True
LogInfo "RotationEdgeFamily | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | source=MODEL_EDGE_FAMILY" & _
" | selected={" & famDetail & "}" & _
" | edgeCt=" & CStr(edgeCt) & _
" | lineCt=" & CStr(lineCt) & _
" | familyCt=" & CStr(familyCt) & _
" | top={" & topDetail & "}"
Dim baseAngle As Double
Dim thetaA As Double
Dim thetaB As Double
Dim selectedTheta As Double
Dim choiceReason As String
baseAngle = swView.Angle
thetaA = NormalizeAngleRad(baseAngle - NormalizeAngleToHorizontal(bestAngRad))
thetaB = NormalizeAngleRad(thetaA + PI)
selectedTheta = thetaA
choiceReason = "thetaA selected; no decisive polarity evidence"
Dim primaryX As Double, primaryY As Double, primaryZ As Double
Dim secondaryX As Double, secondaryY As Double, secondaryZ As Double
Dim hasSecondary As Boolean
Dim frameReason As String
Dim secondaryDetail As String
secondaryDetail = "secondary/profile polarity unavailable"
If TryGetBodyFabricationFrame(item, primaryX, primaryY, primaryZ, _
secondaryX, secondaryY, secondaryZ, _
hasSecondary, frameReason) Then
If hasSecondary Then
Dim secondaryDx As Double, secondaryDy As Double
Dim secondaryMag As Double, secondaryAng As Double
If TryProjectModelDirectionToViewXY(swView, secondaryX, secondaryY, secondaryZ, _
secondaryDx, secondaryDy, secondaryMag, secondaryAng) Then
Dim secA_X As Double, secA_Y As Double
Dim secB_X As Double, secB_Y As Double
Dim scoreA As Double, scoreB As Double
Rotate2DVector secondaryDx, secondaryDy, NormalizeAngleRad(thetaA - baseAngle), secA_X, secA_Y
Rotate2DVector secondaryDx, secondaryDy, NormalizeAngleRad(thetaB - baseAngle), secB_X, secB_Y
scoreA = ScoreRotationPolarityChoice(item, secA_X, secA_Y)
scoreB = ScoreRotationPolarityChoice(item, secB_X, secB_Y)
secondaryDetail = "secondaryProj=(" & Fmt(secondaryDx) & "," & Fmt(secondaryDy) & ")" & _
" | secondaryAngDeg=" & Format$(RadToDeg(secondaryAng), "0.000") & _
" | afterA=(" & Fmt(secA_X) & "," & Fmt(secA_Y) & ")" & _
" | afterB=(" & Fmt(secB_X) & "," & Fmt(secB_Y) & ")" & _
" | scoreA=" & Fmt(scoreA) & _
" | scoreB=" & Fmt(scoreB) & _
" | frame={" & frameReason & "}"
If scoreB > (scoreA + 0.000001) Then
selectedTheta = thetaB
choiceReason = "thetaB selected by angle secondary/profile bottom-side polarity"
ElseIf scoreA > (scoreB + 0.000001) Then
selectedTheta = thetaA
choiceReason = "thetaA selected by angle secondary/profile bottom-side polarity"
Else
selectedTheta = thetaA
choiceReason = "thetaA kept; angle secondary/profile polarity ambiguous"
End If
Else
secondaryDetail = "secondary/profile vector projected edge-on or transform failed | frame={" & frameReason & "}"
End If
Else
secondaryDetail = "fabrication frame found but no secondary/profile vector | frame={" & frameReason & "}"
End If
Else
secondaryDetail = "fabrication frame unavailable for polarity | frame={" & frameReason & "}"
End If
LogInfo "RotationChoice | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | subtype=ANGLE" & _
" | source=MODEL_EDGE_FAMILY" & _
" | refMetric=" & Fmt(bestMetric) & _
" | refAngDeg=" & Format$(RadToDeg(bestAngRad), "0.000") & _
" | thetaA=" & Format$(RadToDeg(thetaA), "0.000") & _
" | thetaB=" & Format$(RadToDeg(thetaB), "0.000") & _
" | selectedTheta=" & Format$(RadToDeg(selectedTheta), "0.000") & _
" | choiceReason=" & choiceReason & _
" | selectedFamily={" & famDetail & "}" & _
" | " & secondaryDetail & _
" | basis={" & basisDetail & "}"
SetViewAngleAndRefresh swDrawModel, swView, selectedTheta, tag & " | exact projected model edge-family align"
Dim confMetric As Double
Dim confAngRad As Double
Dim confDetail As String
Dim confEdgeCt As Long
Dim confLineCt As Long
Dim confFamilyCt As Long
Dim confTopDetail As String
Dim remainDeg As Double
Dim validNow As Boolean
Dim validationScore As Double
Dim validationDetail As String
remainDeg = 9999#
If TryGetBestProjectedModelEdgeFamily(swView, item, confMetric, confAngRad, confDetail, _
confEdgeCt, confLineCt, confFamilyCt, confTopDetail) Then
remainDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(confAngRad)))
Else
confDetail = "confirm edge-family unavailable | edgeCt=" & CStr(confEdgeCt) & _
" | lineCt=" & CStr(confLineCt) & _
" | familyCt=" & CStr(confFamilyCt)
End If
validNow = ValidateOrientationResultByCategory(swView, item, validationScore, validationDetail)
LogInfo "RotationEdgeValidation | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | source=MODEL_EDGE_FAMILY" & _
" | edgeRemainDeg=" & Format$(remainDeg, "0.000") & _
" | tolDeg=" & Format$(ANGLE_EDGE_FAMILY_FINAL_TOL_DEG, "0.000") & _
" | validCategory=" & BoolWord(validNow) & _
" | confirm={" & confDetail & "}" & _
" | validation={" & validationDetail & "}"
edgeRotateDetail = "method=model-edge-family" & _
" | edgeFamilyAvailable=True" & _
" | valid=" & BoolWord(validNow And (remainDeg <= ANGLE_EDGE_FAMILY_FINAL_TOL_DEG)) & _
" | edgeRemainDeg=" & Format$(remainDeg, "0.000") & _
" | refAngDeg=" & Format$(RadToDeg(bestAngRad), "0.000") & _
" | thetaA=" & Format$(RadToDeg(thetaA), "0.000") & _
" | thetaB=" & Format$(RadToDeg(thetaB), "0.000") & _
" | selectedDeg=" & Format$(RadToDeg(selectedTheta), "0.000") & _
" | choice=" & choiceReason & _
" | selected={" & famDetail & "}" & _
" | confirm={" & confDetail & "}" & _
" | validation={" & validationDetail & "}"
If validNow And remainDeg <= ANGLE_EDGE_FAMILY_FINAL_TOL_DEG Then
TryRotateAngleViewByProjectedEdgeFamily = True
Exit Function
End If
SetViewAngleAndRefresh swDrawModel, swView, baseAngle, tag & " | restore after failed projected edge-family rotation"
edgeRotateDetail = edgeRotateDetail & " | restoredBeforeFallback=True"
LogWarn "RotationEdgeValidation | projected model edge-family rotation failed validation; restored candidate | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | detail={" & edgeRotateDetail & "}"
Exit Function
EH:
edgeRotateDetail = "TryRotateAngleViewByProjectedEdgeFamily exception | " & Err.Number & " | " & Err.Description
LogWarn edgeRotateDetail & " | view=" & ViewGetNameSafe(swView)
TryRotateAngleViewByProjectedEdgeFamily = False
End Function
Private Function TryGetBestProjectedModelEdgeFamily(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef bestMetric As Double, _
ByRef bestAngRad As Double, _
ByRef bestDetail As String, _
ByRef edgeCt As Long, _
ByRef lineCt As Long, _
ByRef familyCt As Long, _
ByRef topFamiliesDetail As String) As Boolean
On Error GoTo EH
TryGetBestProjectedModelEdgeFamily = False
bestMetric = 0#
bestAngRad = 0#
bestDetail = ""
edgeCt = 0
lineCt = 0
familyCt = 0
topFamiliesDetail = ""
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
Dim swBody As SldWorks.Body2
Set swBody = Nothing
On Error Resume Next
Set swBody = item("RepBody_Model")
On Error GoTo EH
If swBody Is Nothing Then Exit Function
Dim swXf As SldWorks.MathTransform
Set swXf = swView.ModelToViewTransform
If swXf Is Nothing Then Exit Function
Dim vEdges As Variant
vEdges = swBody.GetEdges
If IsEmpty(vEdges) Then Exit Function
If Not IsArray(vEdges) Then Exit Function
Dim fams As Collection
Set fams = New Collection
Dim i As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim swEdge As SldWorks.Edge
Set swEdge = Nothing
On Error Resume Next
Set swEdge = vEdges(i)
On Error GoTo EH
If Not swEdge Is Nothing Then
edgeCt = edgeCt + 1
Dim projectedLen As Double
Dim edgeAngRad As Double
Dim modelLen As Double
Dim edgeDesc As String
If TryGetProjectedModelLineEdgeData(swEdge, swXf, projectedLen, edgeAngRad, modelLen, edgeDesc) Then
lineCt = lineCt + 1
If projectedLen >= ANGLE_EDGE_MIN_PROJECTED_LEN Then
AddProjectedEdgeFamily fams, edgeAngRad, projectedLen, modelLen, edgeDesc
End If
End If
End If
Next i
familyCt = fams.Count
If familyCt = 0 Then Exit Function
Dim bestIdx As Long
Dim bestScore As Double
bestScore = -1E+30
For i = 1 To fams.Count
Dim fd As Object
Set fd = fams(i)
Dim score As Double
score = ProjectedEdgeFamilyScore(fd)
If score > bestScore Then
bestScore = score
bestIdx = i
End If
Next i
If bestIdx <= 0 Then Exit Function
Dim bestFd As Object
Set bestFd = fams(bestIdx)
bestMetric = SafeCDbl(bestFd("totalLen"))
bestAngRad = SafeCDbl(bestFd("ang"))
bestDetail = FormatProjectedEdgeFamily(bestFd)
topFamiliesDetail = BuildTopProjectedEdgeFamiliesDetail(fams, ANGLE_EDGE_FAMILY_TOP_LOG_COUNT)
If bestMetric <= 0# Then Exit Function
TryGetBestProjectedModelEdgeFamily = True
Exit Function
EH:
LogWarn "TryGetBestProjectedModelEdgeFamily exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
TryGetBestProjectedModelEdgeFamily = False
End Function
Private Function TryGetProjectedModelLineEdgeData(ByVal swEdge As SldWorks.Edge, _
ByVal swXf As SldWorks.MathTransform, _
ByRef projectedLen As Double, _
ByRef angRad As Double, _
ByRef modelLen As Double, _
ByRef edgeDesc As String) As Boolean
On Error GoTo EH
TryGetProjectedModelLineEdgeData = False
projectedLen = 0#
angRad = 0#
modelLen = 0#
edgeDesc = ""
If swEdge Is Nothing Then Exit Function
If swXf Is Nothing Then Exit Function
Dim swCurve As SldWorks.Curve
Set swCurve = swEdge.GetCurve
If swCurve Is Nothing Then Exit Function
Dim isLine As Boolean
isLine = False
On Error Resume Next
isLine = swCurve.isLine
Err.Clear
On Error GoTo EH
If Not isLine Then Exit Function
Dim swStartVtx As SldWorks.Vertex
Dim swEndVtx As SldWorks.Vertex
Set swStartVtx = swEdge.GetStartVertex
Set swEndVtx = swEdge.GetEndVertex
If swStartVtx Is Nothing Or swEndVtx Is Nothing Then Exit Function
Dim vStart As Variant
Dim vEnd As Variant
vStart = swStartVtx.GetPoint
vEnd = swEndVtx.GetPoint
If Not IsArray(vStart) Or Not IsArray(vEnd) Then Exit Function
Dim modelDx As Double, modelDy As Double, modelDz As Double
modelDx = CDbl(vEnd(0)) - CDbl(vStart(0))
modelDy = CDbl(vEnd(1)) - CDbl(vStart(1))
modelDz = CDbl(vEnd(2)) - CDbl(vStart(2))
modelLen = Sqr((modelDx * modelDx) + (modelDy * modelDy) + (modelDz * modelDz))
If modelLen <= CAT_MIN_LINE_LEN_MODEL Then Exit Function
Dim x1 As Double, y1 As Double
Dim x2 As Double, y2 As Double
If Not TryTransformModelPointToViewXY(vStart, swXf, x1, y1) Then Exit Function
If Not TryTransformModelPointToViewXY(vEnd, swXf, x2, y2) Then Exit Function
Dim dx As Double, dy As Double
dx = x2 - x1
dy = y2 - y1
projectedLen = Sqr((dx * dx) + (dy * dy))
If projectedLen <= 0# Then Exit Function
angRad = NormalizeAngleToHorizontal(Atn2Safe(dy, dx))
edgeDesc = "modelLen=" & Fmt(modelLen) & _
" | projectedLen=" & Fmt(projectedLen) & _
" | angDeg=" & Format$(RadToDeg(angRad), "0.000") & _
" | p1=(" & Fmt(x1) & "," & Fmt(y1) & ")" & _
" | p2=(" & Fmt(x2) & "," & Fmt(y2) & ")"
TryGetProjectedModelLineEdgeData = True
Exit Function
EH:
LogWarn "TryGetProjectedModelLineEdgeData exception | " & Err.Number & " | " & Err.Description & _
" | viewEdgePtr=" & CStr(ObjPtr(swEdge))
TryGetProjectedModelLineEdgeData = False
End Function
Private Sub AddProjectedEdgeFamily(ByVal fams As Collection, _
ByVal edgeAngRad As Double, _
ByVal projectedLen As Double, _
ByVal modelLen As Double, _
ByVal edgeDesc As String)
On Error GoTo EH
If fams Is Nothing Then Exit Sub
If projectedLen <= 0# Then Exit Sub
edgeAngRad = NormalizeAngleToHorizontal(edgeAngRad)
Dim i As Long
For i = 1 To fams.Count
Dim fd As Object
Set fd = fams(i)
Dim famAng As Double
famAng = SafeCDbl(fd("ang"))
If Abs(RadToDeg(NormalizeAngleToHorizontal(edgeAngRad - famAng))) <= ANGLE_EDGE_FAMILY_TOL_DEG Then
fd("totalLen") = SafeCDbl(fd("totalLen")) + projectedLen
fd("modelLenTotal") = SafeCDbl(fd("modelLenTotal")) + modelLen
fd("ct") = CLng(SafeCDbl(fd("ct"))) + 1
fd("sumCos2") = SafeCDbl(fd("sumCos2")) + (Cos(2# * edgeAngRad) * projectedLen)
fd("sumSin2") = SafeCDbl(fd("sumSin2")) + (Sin(2# * edgeAngRad) * projectedLen)
fd("ang") = NormalizeAngleToHorizontal(0.5 * Atn2Safe(SafeCDbl(fd("sumSin2")), SafeCDbl(fd("sumCos2"))))
If projectedLen > SafeCDbl(fd("maxLen")) Then
fd("maxLen") = projectedLen
fd("sample") = edgeDesc
End If
Exit Sub
End If
Next i
Dim fdNew As Object
Set fdNew = CreateObject("Scripting.Dictionary")
fdNew("ang") = edgeAngRad
fdNew("totalLen") = projectedLen
fdNew("modelLenTotal") = modelLen
fdNew("maxLen") = projectedLen
fdNew("ct") = 1
fdNew("sumCos2") = Cos(2# * edgeAngRad) * projectedLen
fdNew("sumSin2") = Sin(2# * edgeAngRad) * projectedLen
fdNew("sample") = edgeDesc
fams.Add fdNew
Exit Sub
EH:
LogWarn "AddProjectedEdgeFamily exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function ProjectedEdgeFamilyScore(ByVal fd As Object) As Double
On Error GoTo EH
If fd Is Nothing Then Exit Function
ProjectedEdgeFamilyScore = (SafeCDbl(fd("totalLen")) * 1000000#) + _
(SafeCDbl(fd("maxLen")) * 500000#) + _
(SafeCDbl(fd("modelLenTotal")) * 1000#) + _
(SafeCDbl(fd("ct")) * 100#)
Exit Function
EH:
ProjectedEdgeFamilyScore = -1E+30
End Function
Private Function FormatProjectedEdgeFamily(ByVal fd As Object) As String
On Error GoTo EH
If fd Is Nothing Then
FormatProjectedEdgeFamily = "None"
Exit Function
End If
FormatProjectedEdgeFamily = "angDeg=" & Format$(RadToDeg(SafeCDbl(fd("ang"))), "0.000") & _
" | totalLen=" & Fmt(SafeCDbl(fd("totalLen"))) & _
" | maxLen=" & Fmt(SafeCDbl(fd("maxLen"))) & _
" | modelLenTotal=" & Fmt(SafeCDbl(fd("modelLenTotal"))) & _
" | count=" & CStr(CLng(SafeCDbl(fd("ct")))) & _
" | score=" & Format$(ProjectedEdgeFamilyScore(fd), "0.000") & _
" | sample={" & SafeStr(fd("sample")) & "}"
Exit Function
EH:
FormatProjectedEdgeFamily = "FormatProjectedEdgeFamily exception | " & Err.Number & " | " & Err.Description
End Function
Private Function BuildTopProjectedEdgeFamiliesDetail(ByVal fams As Collection, _
ByVal topN As Long) As String
On Error GoTo EH
BuildTopProjectedEdgeFamiliesDetail = ""
If fams Is Nothing Then Exit Function
If fams.Count = 0 Then Exit Function
If topN <= 0 Then topN = 1
Dim used As Object
Set used = CreateObject("Scripting.Dictionary")
Dim rank As Long
For rank = 1 To topN
Dim bestIdx As Long
Dim bestScore As Double
bestIdx = 0
bestScore = -1E+30
Dim i As Long
For i = 1 To fams.Count
If Not used.Exists(CStr(i)) Then
Dim score As Double
score = ProjectedEdgeFamilyScore(fams(i))
If score > bestScore Then
bestScore = score
bestIdx = i
End If
End If
Next i
If bestIdx <= 0 Then Exit For
used.Add CStr(bestIdx), True
If Len(BuildTopProjectedEdgeFamiliesDetail) > 0 Then BuildTopProjectedEdgeFamiliesDetail = BuildTopProjectedEdgeFamiliesDetail & " ; "
BuildTopProjectedEdgeFamiliesDetail = BuildTopProjectedEdgeFamiliesDetail & _
"#" & CStr(rank) & "={" & FormatProjectedEdgeFamily(fams(bestIdx)) & "}"
Next rank
Exit Function
EH:
BuildTopProjectedEdgeFamiliesDetail = "BuildTopProjectedEdgeFamiliesDetail exception | " & Err.Number & " | " & Err.Description
End Function
Private Function DescribeViewProjectionBasis(ByVal swView As SldWorks.View) As String
On Error GoTo EH
DescribeViewProjectionBasis = "viewAngleDeg=" & Format$(RadToDeg(swView.Angle), "0.000")
Dim dx As Double, dy As Double, mag As Double, ang As Double
If TryProjectModelDirectionToViewXY(swView, 1#, 0#, 0#, dx, dy, mag, ang) Then
DescribeViewProjectionBasis = DescribeViewProjectionBasis & _
" | modelXProj=(" & Fmt(dx) & "," & Fmt(dy) & ")" & _
"@" & Format$(RadToDeg(ang), "0.000") & "deg"
Else
DescribeViewProjectionBasis = DescribeViewProjectionBasis & " | modelXProj=edge-on"
End If
If TryProjectModelDirectionToViewXY(swView, 0#, 1#, 0#, dx, dy, mag, ang) Then
DescribeViewProjectionBasis = DescribeViewProjectionBasis & _
" | modelYProj=(" & Fmt(dx) & "," & Fmt(dy) & ")" & _
"@" & Format$(RadToDeg(ang), "0.000") & "deg"
Else
DescribeViewProjectionBasis = DescribeViewProjectionBasis & " | modelYProj=edge-on"
End If
If TryProjectModelDirectionToViewXY(swView, 0#, 0#, 1#, dx, dy, mag, ang) Then
DescribeViewProjectionBasis = DescribeViewProjectionBasis & _
" | modelZProj=(" & Fmt(dx) & "," & Fmt(dy) & ")" & _
"@" & Format$(RadToDeg(ang), "0.000") & "deg"
Else
DescribeViewProjectionBasis = DescribeViewProjectionBasis & " | modelZProj=edge-on"
End If
Exit Function
EH:
DescribeViewProjectionBasis = "DescribeViewProjectionBasis exception | " & Err.Number & " | " & Err.Description
End Function
Private Function TryRotateViewByFabricationFrame(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal tag As String, _
ByRef frameRotateDetail As String) As Boolean
On Error GoTo EH
TryRotateViewByFabricationFrame = False
frameRotateDetail = ""
If swDrawModel Is Nothing Then
frameRotateDetail = "drawing model is Nothing"
Exit Function
End If
If swView Is Nothing Then
frameRotateDetail = "view is Nothing"
Exit Function
End If
If item Is Nothing Then
frameRotateDetail = "item is Nothing"
Exit Function
End If
Dim primaryX As Double, primaryY As Double, primaryZ As Double
Dim secondaryX As Double, secondaryY As Double, secondaryZ As Double
Dim hasSecondary As Boolean
Dim frameReason As String
Dim usedPlateFrame As Boolean
Dim forcePrimaryPolarity As Boolean
usedPlateFrame = False
forcePrimaryPolarity = False
hasSecondary = False
frameReason = ""
If IsPlateLikeOrientationItem(item) Then
If TryGetPlateFabricationFrameFromBody(item, primaryX, primaryY, primaryZ, _
secondaryX, secondaryY, secondaryZ, _
hasSecondary, frameReason) Then
usedPlateFrame = True
forcePrimaryPolarity = True
LogInfo "RotationPlateFrame | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | reason={" & frameReason & "}"
Else
LogWarn "RotationPlateFrame | unavailable; falling back to generic fabrication frame | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | pn=" & SafeStr(item("PartNo")) & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | reason={" & frameReason & "}"
End If
End If
If Not usedPlateFrame Then
If Not TryGetBodyFabricationFrame(item, primaryX, primaryY, primaryZ, _
secondaryX, secondaryY, secondaryZ, _
hasSecondary, frameReason) Then
frameRotateDetail = "fabrication frame unavailable | " & frameReason
LogWarn "RotationBasis3D | unavailable | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & " | reason=" & frameRotateDetail
Exit Function
End If
End If
Dim primaryDx As Double, primaryDy As Double, primaryMag As Double, primaryAng As Double
If Not TryProjectModelDirectionToViewXY(swView, primaryX, primaryY, primaryZ, _
primaryDx, primaryDy, primaryMag, primaryAng) Then
frameRotateDetail = "primary 3D axis projects edge-on or transform failed | " & frameReason
LogWarn "RotationBasis3D | projection failed | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & " | reason=" & frameRotateDetail
Exit Function
End If
Dim refAng As Double
Dim refMetric As Double
Dim refSource As String
Dim refDetail As String
refAng = primaryAng
refMetric = primaryMag
If usedPlateFrame Then
refSource = "PLATE_FACE_CORNER_XDIR"
refDetail = "deterministic plate/sheet face-corner x direction"
Else
refSource = "PRIMARY_3D_AXIS"
refDetail = "projected primary vector"
End If
Dim edgeLen As Double, edgeAng As Double, edgeDesc As String
Dim edgeCt As Long, lineCt As Long, matchedCt As Long
If (Not usedPlateFrame) Then
If GetBestVisibleLinearEdgeMatchingModelAxis(swView, primaryX, primaryY, primaryZ, _
edgeLen, edgeAng, edgeDesc, edgeCt, lineCt, matchedCt) Then
Dim primaryEdgeDeltaDeg As Double
primaryEdgeDeltaDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(primaryAng - edgeAng)))
refAng = edgeAng
refMetric = edgeLen
refSource = "VISIBLE_EDGE_MATCH_3D_PRIMARY"
refDetail = "matched visible linear edge | primaryEdgeDeltaDeg=" & Format$(primaryEdgeDeltaDeg, "0.000") & _
" | edgeCt=" & CStr(edgeCt) & _
" | lineCt=" & CStr(lineCt) & _
" | matchedCt=" & CStr(matchedCt) & _
" | edge={" & edgeDesc & "}"
Else
refDetail = refDetail & " | no visible edge matched primary axis" & _
" | edgeCt=" & CStr(edgeCt) & _
" | lineCt=" & CStr(lineCt) & _
" | matchedCt=" & CStr(matchedCt)
End If
End If
Dim baseAngle As Double
Dim thetaA As Double, thetaB As Double
Dim selectedTheta As Double
Dim choiceReason As String
baseAngle = swView.Angle
thetaA = NormalizeAngleRad(baseAngle - NormalizeAngleToHorizontal(refAng))
thetaB = NormalizeAngleRad(thetaA + PI)
selectedTheta = thetaA
choiceReason = "default thetaA"
Dim secondaryDx As Double, secondaryDy As Double
Dim secondaryMag As Double, secondaryAng As Double
Dim secA_X As Double, secA_Y As Double
Dim secB_X As Double, secB_Y As Double
Dim scoreA As Double, scoreB As Double
Dim secondaryDetail As String
secondaryDx = 0#: secondaryDy = 0#
secondaryMag = 0#: secondaryAng = 0#
secondaryDetail = "secondary unavailable"
If forcePrimaryPolarity Then
selectedTheta = thetaA
choiceReason = "thetaA forced by deterministic plate face/corner polarity"
secondaryDetail = "secondary bypassed because plate x-direction sign is already deterministic"
ElseIf hasSecondary Then
If TryProjectModelDirectionToViewXY(swView, secondaryX, secondaryY, secondaryZ, _
secondaryDx, secondaryDy, secondaryMag, secondaryAng) Then
Rotate2DVector secondaryDx, secondaryDy, NormalizeAngleRad(thetaA - baseAngle), secA_X, secA_Y
Rotate2DVector secondaryDx, secondaryDy, NormalizeAngleRad(thetaB - baseAngle), secB_X, secB_Y
scoreA = ScoreRotationPolarityChoice(item, secA_X, secA_Y)
scoreB = ScoreRotationPolarityChoice(item, secB_X, secB_Y)
secondaryDetail = "secondaryProj=(" & Fmt(secondaryDx) & "," & Fmt(secondaryDy) & ")" & _
" | secondaryAngDeg=" & Format$(RadToDeg(secondaryAng), "0.000") & _
" | afterA=(" & Fmt(secA_X) & "," & Fmt(secA_Y) & ")" & _
" | afterB=(" & Fmt(secB_X) & "," & Fmt(secB_Y) & ")" & _
" | scoreA=" & Fmt(scoreA) & _
" | scoreB=" & Fmt(scoreB)
If scoreB > (scoreA + 0.000001) Then
selectedTheta = thetaB
choiceReason = "thetaB selected by secondary/profile polarity"
Else
selectedTheta = thetaA
choiceReason = "thetaA selected by secondary/profile polarity"
End If
Else
secondaryDetail = "secondary vector projected edge-on or transform failed"
End If
End If
LogInfo "RotationChoice | view=" & ViewGetNameSafe(swView) & _
" | itemNo=" & SafeStr(item("ItemNo")) & _
" | subtype=" & SafeStr(item("BodySubtype")) & _
" | source=" & refSource & _
" | refMetric=" & Fmt(refMetric) & _
" | refAngDeg=" & Format$(RadToDeg(refAng), "0.000") & _
" | thetaA=" & Format$(RadToDeg(thetaA), "0.000") & _
" | thetaB=" & Format$(RadToDeg(thetaB), "0.000") & _
" | selectedTheta=" & Format$(RadToDeg(selectedTheta), "0.000") & _
" | primaryProj=(" & Fmt(primaryDx) & "," & Fmt(primaryDy) & ")" & _
" | primaryProjMag=" & Fmt(primaryMag) & _
" | usedPlateFrame=" & BoolWord(usedPlateFrame) & _
" | " & secondaryDetail & _
" | choiceReason=" & choiceReason & _
" | refDetail={" & refDetail & "}" & _
" | frame={" & frameReason & "}"
SetViewAngleAndRefresh swDrawModel, swView, selectedTheta, tag & " | deterministic fabrication-frame rotation"
Dim validationScore As Double
Dim validationDetail As String
Dim validNow As Boolean
validNow = ValidateOrientationResultByCategory(swView, item, validationScore, validationDetail)
frameRotateDetail = "method=" & IIf(usedPlateFrame, "plate-face-corner", "fabrication-frame") & _
" | valid=" & BoolWord(validNow) & _
" | source=" & refSource & _
" | refAngDeg=" & Format$(RadToDeg(refAng), "0.000") & _
" | thetaA=" & Format$(RadToDeg(thetaA), "0.000") & _
" | thetaB=" & Format$(RadToDeg(thetaB), "0.000") & _
" | selectedDeg=" & Format$(RadToDeg(selectedTheta), "0.000") & _
" | choice=" & choiceReason & _
" | validation={" & validationDetail & "}"
If validNow Then
TryRotateViewByFabricationFrame = True
Exit Function
End If
SetViewAngleAndRefresh swDrawModel, swView, baseAngle, tag & " | restore after failed fabrication-frame rotation"
frameRotateDetail = frameRotateDetail & " | restoredBeforeFallback=True"
LogWarn "RotationChoice | deterministic fabrication-frame rotation failed validation; restored candidate | view=" & _
ViewGetNameSafe(swView) & " | itemNo=" & SafeStr(item("ItemNo")) & _
" | detail={" & frameRotateDetail & "}"
Exit Function
EH:
frameRotateDetail = "TryRotateViewByFabricationFrame exception | " & Err.Number & " | " & Err.Description
LogWarn frameRotateDetail & " | view=" & ViewGetNameSafe(swView)
TryRotateViewByFabricationFrame = False
End Function
Private Sub Rotate2DVector(ByVal x As Double, _
ByVal y As Double, _
ByVal angRad As Double, _
ByRef outX As Double, _
ByRef outY As Double)
Dim c As Double, s As Double
c = Cos(angRad)
s = Sin(angRad)
outX = (x * c) - (y * s)
outY = (x * s) + (y * c)
End Sub
Private Function ScoreRotationPolarityChoice(ByVal item As Object, _
ByVal secondaryX2D As Double, _
ByVal secondaryY2D As Double) As Double
On Error GoTo EH
Dim subtypeName As String
subtypeName = UCase$(SafeStr(item("BodySubtype")))
Select Case subtypeName
Case CAT_SUBTYPE_ANGLE
' Production convention confirmed by testing: an angle detail should read like
' an L/profile, with the projecting leg preferred on the bottom side of the view.
ScoreRotationPolarityChoice = (-secondaryY2D * 1000000#) + (Abs(secondaryX2D) * 1000#)
Case CAT_SUBTYPE_CHANNEL
' Channel candidates already passed profile readability. Use secondary polarity
' only to choose the equivalent 180-degree presentation, not to rescue a side view.
ScoreRotationPolarityChoice = (-secondaryY2D * 250000#) + (Abs(secondaryX2D) * 500#)
Case Else
ScoreRotationPolarityChoice = Abs(secondaryX2D)
End Select
Exit Function
EH:
ScoreRotationPolarityChoice = 0#
End Function
Private Function TryRotateViewByCategoryReferenceAlignment(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal tag As String) As Boolean
On Error GoTo EH
TryRotateViewByCategoryReferenceAlignment = False
If swView Is Nothing Then Exit Function
Dim refMetric As Double
Dim refAngRad As Double
Dim qualityScore As Double
Dim refDesc As String
If Not GetSnapReferenceForView(swView, item, refMetric, refAngRad, qualityScore, refDesc) Then
LogWarn "TryRotateViewByCategoryReferenceAlignment | no usable snap/category reference | view=" & ViewGetNameSafe(swView)
Exit Function
End If
Dim currentViewAngle As Double
Dim deltaToHorizontal As Double
Dim targetAngle As Double
currentViewAngle = swView.Angle
deltaToHorizontal = NormalizeAngleToHorizontal(refAngRad)
targetAngle = NormalizeAngleRad(currentViewAngle - deltaToHorizontal)
LogInfo "RotCategoryPick | view=" & ViewGetNameSafe(swView) & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | metric=" & Fmt(refMetric) & _
" | refAngDeg=" & Format$(RadToDeg(refAngRad), "0.000") & _
" | deltaDeg=" & Format$(RadToDeg(deltaToHorizontal), "0.000") & _
" | currentViewDeg=" & Format$(RadToDeg(currentViewAngle), "0.000") & _
" | targetViewDeg=" & Format$(RadToDeg(targetAngle), "0.000") & _
" | ref=" & refDesc
SetViewAngleAndRefresh swDrawModel, swView, targetAngle, tag & " | category/snap direct align"
Dim confMetric As Double
Dim confAngRad As Double
Dim confQuality As Double
Dim confDesc As String
If GetSnapReferenceForView(swView, item, confMetric, confAngRad, confQuality, confDesc) Then
Dim remainDeg As Double
Dim validNow As Boolean
Dim validScore As Double
Dim validDetail As String
remainDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(confAngRad)))
validNow = ValidateOrientationResultByCategory(swView, item, validScore, validDetail)
LogInfo "RotCategoryConfirm | view=" & ViewGetNameSafe(swView) & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | remainDeg=" & Format$(remainDeg, "0.000") & _
" | metric=" & Fmt(confMetric) & _
" | valid=" & BoolWord(validNow) & _
" | ref=" & confDesc & _
" | verify=" & validDetail
If remainDeg <= CAT_MAJOR_HORIZONTAL_TOL_DEG And validNow Then
TryRotateViewByCategoryReferenceAlignment = True
Exit Function
End If
End If
Exit Function
EH:
LogWarn "TryRotateViewByCategoryReferenceAlignment exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
TryRotateViewByCategoryReferenceAlignment = False
End Function
Private Function BuildDiscreteAngleList(ByVal baseAngleRad As Double, ByVal stepDeg As Double) As Collection
On Error GoTo EH
Dim outCol As New Collection
Dim seen As Object
Set seen = CreateObject("Scripting.Dictionary")
AddAngleIfMissing outCol, seen, baseAngleRad
AddAngleIfMissing outCol, seen, NormalizeAngleRad(baseAngleRad + DegToRad(stepDeg))
AddAngleIfMissing outCol, seen, NormalizeAngleRad(baseAngleRad - DegToRad(stepDeg))
AddAngleIfMissing outCol, seen, NormalizeAngleRad(baseAngleRad + DegToRad(stepDeg * 2#))
AddAngleIfMissing outCol, seen, NormalizeAngleRad(baseAngleRad - DegToRad(stepDeg * 2#))
AddAngleIfMissing outCol, seen, NormalizeAngleRad(baseAngleRad + DegToRad(stepDeg * 3#))
AddAngleIfMissing outCol, seen, NormalizeAngleRad(baseAngleRad - DegToRad(stepDeg * 3#))
AddAngleIfMissing outCol, seen, NormalizeAngleRad(baseAngleRad + DegToRad(stepDeg * 4#))
AddAngleIfMissing outCol, seen, NormalizeAngleRad(baseAngleRad - DegToRad(stepDeg * 4#))
Set BuildDiscreteAngleList = outCol
Exit Function
EH:
LogWarn "BuildDiscreteAngleList exception | " & Err.Number & " | " & Err.Description
Set BuildDiscreteAngleList = New Collection
End Function
Private Sub AddAngleIfMissing(ByVal outCol As Collection, ByVal seen As Object, ByVal angRad As Double)
Dim key As String
key = Format$(NormalizeDeg360(RadToDeg(angRad)), "0.000")
If Not seen.Exists(key) Then
seen.Add key, True
outCol.Add angRad
End If
End Sub
Private Function SafeCDbl(ByVal v As Variant) As Double
On Error Resume Next
SafeCDbl = CDbl(v)
If Err.Number <> 0 Then
SafeCDbl = 0#
Err.Clear
End If
End Function
Private Sub ForceSheetContext()
On Error Resume Next
g_swDrwModel.ActivateView ""
g_swDrwModel.ClearSelection2 True
On Error GoTo 0
End Sub
Private Function ForceViewPosition(ByVal v As SldWorks.View, _
ByVal x As Double, ByVal y As Double, _
ByVal tol As Double, _
ByVal retries As Long) As Boolean
On Error GoTo EH
Dim k As Long
For k = 1 To retries
ForceSheetContext
If Not SetViewPositionTyped(v, x, y) Then
LogWarn " FVP[" & k & "] SetViewPositionTyped=False | " & ViewGetNameSafe(v)
End If
On Error Resume Next
v.Update
On Error GoTo 0
g_swDrwModel.EditRebuild3
Dim ax As Double, ay As Double, gotPos As Boolean
gotPos = GetViewPositionXY(v, ax, ay)
Dim cx As Double, cy As Double, gotCtr As Boolean
gotCtr = GetViewOutlineCenter(v, cx, cy)
Dim vx As Double, vy As Double
If gotPos Then
vx = ax: vy = ay
ElseIf gotCtr Then
vx = cx: vy = cy
Else
LogWarn " FVP[" & k & "] no readable pos/outline | " & ViewGetNameSafe(v)
GoTo NextTry
End If
Dim dx As Double, dy As Double
dx = Abs(vx - x): dy = Abs(vy - y)
LogInfo " FVP[" & k & "] " & ViewGetNameSafe(v) & _
" | target=(" & Fmt(x) & "," & Fmt(y) & ")" & _
" | pos=(" & FmtIf(gotPos, ax) & "," & FmtIf(gotPos, ay) & ")" & _
" | ctr=(" & FmtIf(gotCtr, cx) & "," & FmtIf(gotCtr, cy) & ")" & _
" | d=(" & Fmt(dx) & "," & Fmt(dy) & ")"
If dx <= tol And dy <= tol Then
ForceViewPosition = True
Exit Function
End If
NextTry:
DoEvents
Next k
ForceViewPosition = False
Exit Function
EH:
LogError "ForceViewPosition exception | " & Err.Number & " | " & Err.Description
ForceViewPosition = False
End Function
Private Function SetViewPositionTyped(ByVal v As SldWorks.View, _
ByVal x As Double, ByVal y As Double) As Boolean
On Error GoTo EH
Dim pos(0 To 2) As Double
pos(0) = x
pos(1) = y
pos(2) = 0#
On Error Resume Next
v.PositionLocked = False
v.Position = pos
If Err.Number <> 0 Then
LogWarn "SetViewPositionTyped | setter error | " & Err.Number & " | " & Err.Description
Err.Clear
End If
On Error GoTo 0
SetViewPositionTyped = True
Exit Function
EH:
LogError "SetViewPositionTyped exception | " & Err.Number & " | " & Err.Description
SetViewPositionTyped = False
End Function
Private Function GetViewPositionXY(ByVal v As SldWorks.View, _
ByRef x As Double, ByRef y As Double) As Boolean
On Error GoTo EH
Dim p As Variant
p = v.Position
If Not IsArray(p) Then GoTo EH
x = CDbl(p(0))
y = CDbl(p(1))
GetViewPositionXY = True
Exit Function
EH:
x = 0#: y = 0#
GetViewPositionXY = False
End Function
Private Function GetViewOutlineCenter(ByVal v As SldWorks.View, _
ByRef cx As Double, ByRef cy As Double) As Boolean
On Error GoTo EH
Dim o As Variant
o = v.GetOutline
If Not IsArray(o) Then GoTo EH
cx = (CDbl(o(0)) + CDbl(o(2))) / 2#
cy = (CDbl(o(1)) + CDbl(o(3))) / 2#
GetViewOutlineCenter = True
Exit Function
EH:
cx = 0#: cy = 0#
GetViewOutlineCenter = False
End Function
'====================================================================================
' SCALE
'====================================================================================
Private Function ApplyViewScale(ByVal v As SldWorks.View, ByVal scaleDec As Double) As Boolean
On Error GoTo EH
If scaleDec <= 0# Then GoTo EH
On Error Resume Next
v.ScaleDecimal = scaleDec
v.Update
On Error GoTo 0
ApplyViewScale = True
Exit Function
EH:
LogError "ApplyViewScale exception | " & Err.Number & " | " & Err.Description
ApplyViewScale = False
End Function
'====================================================================================
' VIEW GEOMETRY
'====================================================================================
Private Function GetViewWH(ByVal swV As SldWorks.View, _
ByRef w As Double, ByRef h As Double) As Boolean
On Error GoTo EH
Dim vOut As Variant
vOut = swV.GetOutline
If Not IsArray(vOut) Then GoTo EH
w = Abs(CDbl(vOut(2)) - CDbl(vOut(0)))
h = Abs(CDbl(vOut(3)) - CDbl(vOut(1)))
GetViewWH = (w > 0# And h > 0#)
Exit Function
EH:
w = 0#: h = 0#
GetViewWH = False
End Function
Private Function GetViewRect(ByVal swV As SldWorks.View, _
ByRef x0 As Double, ByRef y0 As Double, _
ByRef x1 As Double, ByRef y1 As Double) As Boolean
On Error GoTo EH
Dim o As Variant
o = swV.GetOutline
If Not IsArray(o) Then GoTo EH
x0 = CDbl(o(0))
y0 = CDbl(o(1))
x1 = CDbl(o(2))
y1 = CDbl(o(3))
If x1 < x0 Then SwapD x0, x1
If y1 < y0 Then SwapD y0, y1
GetViewRect = (x1 > x0 And y1 > y0)
Exit Function
EH:
x0 = 0#: y0 = 0#: x1 = 0#: y1 = 0#
GetViewRect = False
End Function
'====================================================================================
' EXACT SHEET BOUNDS
'====================================================================================
Private Function GetSheetBoundsExact(ByVal drw As SldWorks.DrawingDoc, _
ByRef xmin As Double, ByRef ymin As Double, _
ByRef xmax As Double, ByRef ymax As Double) As Boolean
On Error GoTo EH
Dim sheetView As SldWorks.View
Set sheetView = drw.GetFirstView
If sheetView Is Nothing Then GoTo EH
Dim o As Variant
o = sheetView.GetOutline
If Not IsArray(o) Then GoTo EH
xmin = CDbl(o(0))
ymin = CDbl(o(1))
xmax = CDbl(o(2))
ymax = CDbl(o(3))
GetSheetBoundsExact = (xmax > xmin And ymax > ymin)
Exit Function
EH:
xmin = 0#: ymin = 0#: xmax = 0#: ymax = 0#
GetSheetBoundsExact = False
End Function
'====================================================================================
' CUT-LIST COLLECTION
'====================================================================================
Private Function GetCutListItems(ByVal swModel As SldWorks.ModelDoc2) As Collection
On Error GoTo EH
Dim items As New Collection
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FirstFeature
CollectCutListItemsFromFeatureTree swModel, swFeat, items
If items.Count = 0 Then
LogWarn "GetCutListItems | no weldment cut-list folders found; trying solid-body fallback"
AddFallbackSolidBodyItems swModel, items
End If
Set GetCutListItems = items
Exit Function
EH:
LogError "GetCutListItems exception | " & Err.Number & " | " & Err.Description
Set GetCutListItems = Nothing
End Function
Private Sub CollectCutListItemsFromFeatureTree(ByVal swModel As SldWorks.ModelDoc2, _
ByVal swFeat As SldWorks.Feature, _
ByVal items As Collection)
On Error GoTo EH
Dim seenFeatures As Object
Dim seenBodies As Object
Dim seenTopFeatures As Object
Set seenFeatures = CreateObject("Scripting.Dictionary")
Set seenBodies = CreateObject("Scripting.Dictionary")
Set seenTopFeatures = CreateObject("Scripting.Dictionary")
Dim scanCt As Long
Dim topCt As Long
Do While Not swFeat Is Nothing
topCt = topCt + 1
Dim topKey As String
topKey = FeatureVisitKey(swFeat)
If Len(topKey) > 0 Then
If seenTopFeatures.Exists(topKey) Then
LogWarn "CollectCutListItemsFromFeatureTree | top-level feature cycle detected; stopping | feat=" & FeatureNameSafe(swFeat)
Exit Do
End If
seenTopFeatures.Add topKey, True
End If
CollectCutListItemsFromFeatureBranch swModel, swFeat, items, seenFeatures, seenBodies, 0, scanCt
If scanCt >= CUTLIST_MAX_FEATURE_SCAN Then
LogWarn "CollectCutListItemsFromFeatureTree | scan cap reached; stopping feature traversal | scanCt=" & CStr(scanCt) & _
" | itemCount=" & CStr(items.Count)
Exit Do
End If
On Error Resume Next
Set swFeat = swFeat.GetNextFeature
If Err.Number <> 0 Then
LogWarn "CollectCutListItemsFromFeatureTree | GetNextFeature failed | " & Err.Number & " | " & Err.Description
Err.Clear
Set swFeat = Nothing
End If
On Error GoTo EH
Loop
LogInfo "CollectCutListItemsFromFeatureTree | done | topFeatures=" & CStr(topCt) & _
" | scanned=" & CStr(scanCt) & _
" | cutListItems=" & CStr(items.Count) & _
" | uniqueFeatures=" & CStr(seenFeatures.Count) & _
" | uniqueBodies=" & CStr(seenBodies.Count)
Exit Sub
EH:
LogWarn "CollectCutListItemsFromFeatureTree exception | " & Err.Number & " | " & Err.Description
End Sub
Private Sub CollectCutListItemsFromFeatureBranch(ByVal swModel As SldWorks.ModelDoc2, _
ByVal startFeat As SldWorks.Feature, _
ByVal items As Collection, _
ByVal seenFeatures As Object, _
ByVal seenBodies As Object, _
ByVal depth As Long, _
ByRef scanCt As Long)
On Error GoTo EH
If startFeat Is Nothing Then Exit Sub
If seenFeatures Is Nothing Then Exit Sub
If seenBodies Is Nothing Then Exit Sub
If scanCt >= CUTLIST_MAX_FEATURE_SCAN Then Exit Sub
If depth > CUTLIST_MAX_FEATURE_DEPTH Then
LogWarn "CollectCutListItemsFromFeatureBranch | depth cap reached | depth=" & CStr(depth) & _
" | feat=" & FeatureNameSafe(startFeat)
Exit Sub
End If
Dim swFeat As SldWorks.Feature
Set swFeat = startFeat
Do While Not swFeat Is Nothing
Dim featKey As String
featKey = FeatureVisitKey(swFeat)
If Len(featKey) > 0 Then
If seenFeatures.Exists(featKey) Then
Dim swSeenNext As SldWorks.Feature
Set swSeenNext = GetNextSubFeatureSafe(swFeat)
If swSeenNext Is Nothing Then Exit Do
If FeatureVisitKey(swSeenNext) = featKey Then Exit Do
Set swFeat = swSeenNext
GoTo ContinueLoop
End If
seenFeatures.Add featKey, True
End If
scanCt = scanCt + 1
If scanCt >= CUTLIST_MAX_FEATURE_SCAN Then Exit Do
If StrComp(SafeStr(swFeat.GetTypeName2), "CutListFolder", vbTextCompare) = 0 Then
AddCutListItemFromFeature swModel, swFeat, items, seenBodies
End If
Dim swChild As SldWorks.Feature
Set swChild = Nothing
On Error Resume Next
Set swChild = swFeat.GetFirstSubFeature
If Err.Number <> 0 Then
Err.Clear
Set swChild = Nothing
End If
On Error GoTo EH
If Not swChild Is Nothing Then
CollectCutListItemsFromFeatureBranch swModel, swChild, items, seenFeatures, seenBodies, depth + 1, scanCt
If scanCt >= CUTLIST_MAX_FEATURE_SCAN Then Exit Do
End If
Dim swNext As SldWorks.Feature
Set swNext = GetNextSubFeatureSafe(swFeat)
If swNext Is Nothing Then Exit Do
If FeatureVisitKey(swNext) = featKey Then Exit Do
Set swFeat = swNext
ContinueLoop:
Loop
Exit Sub
EH:
LogWarn "CollectCutListItemsFromFeatureBranch exception | " & Err.Number & " | " & Err.Description & _
" | depth=" & CStr(depth) & _
" | scanCt=" & CStr(scanCt)
End Sub
Private Sub AddCutListItemFromFeature(ByVal swModel As SldWorks.ModelDoc2, _
ByVal swFeat As SldWorks.Feature, _
ByVal items As Collection, _
ByVal seenBodies As Object)
On Error GoTo EH
If swFeat Is Nothing Then Exit Sub
If items Is Nothing Then Exit Sub
Dim bf As SldWorks.BodyFolder
Set bf = swFeat.GetSpecificFeature2
If bf Is Nothing Then Exit Sub
On Error Resume Next
bf.UpdateCutList
On Error GoTo EH
Dim vBodies As Variant
vBodies = bf.GetBodies
If IsArray(vBodies) And SafeArrayCount(vBodies) > 0 Then
Dim repB As SldWorks.Body2
Set repB = vBodies(LBound(vBodies))
If repB Is Nothing Then Exit Sub
Dim bodyKey As String
bodyKey = BodyVisitKey(repB)
If Len(bodyKey) > 0 Then
If Not seenBodies Is Nothing Then
If seenBodies.Exists(bodyKey) Then
LogInfo "CutListSkipDuplicate | feat=" & FeatureNameSafe(swFeat) & _
" | bodyKey=" & bodyKey
Exit Sub
End If
seenBodies.Add bodyKey, True
End If
End If
Dim dx As Double, dy As Double, dz As Double
GetBodyBBoxDims repB, dx, dy, dz
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Set d("RepBody_Model") = repB
d("dx") = dx
d("dy") = dy
d("dz") = dz
d("CutListFeatureName") = FeatureNameSafe(swFeat)
d("BodyName") = GetBodyNameSafe(repB)
d("ItemNo") = GetCLProp(swModel, swFeat, _
Array(PROP_ITEMNO_1, PROP_ITEMNO_2, PROP_ITEMNO_3, PROP_ITEMNO_4))
d("PartNo") = GetCLProp(swModel, swFeat, _
Array(PROP_PN_1, PROP_PN_2, PROP_PN_3, PROP_PN_4))
d("Qty") = GetCLProp(swModel, swFeat, _
Array(PROP_QTY_1, PROP_QTY_2, PROP_QTY_3))
If Len(SafeStr(d("ItemNo"))) = 0 Then d("ItemNo") = ParseItemFromName(swFeat.name)
If Len(SafeStr(d("PartNo"))) = 0 Then d("PartNo") = swFeat.name
If Len(SafeStr(d("Qty"))) = 0 Then d("Qty") = "?"
items.Add d
LogInfo "CutList | item=" & SafeStr(d("ItemNo")) & _
" | pn=" & SafeStr(d("PartNo")) & _
" | qty=" & SafeStr(d("Qty")) & _
" | bbox=" & Fmt(dx) & "x" & Fmt(dy) & "x" & Fmt(dz)
End If
Exit Sub
EH:
LogWarn "AddCutListItemFromFeature exception | " & Err.Number & " | " & Err.Description & _
" | feat=" & FeatureNameSafe(swFeat)
End Sub
Private Function GetNextSubFeatureSafe(ByVal swFeat As SldWorks.Feature) As SldWorks.Feature
On Error GoTo EH
Set GetNextSubFeatureSafe = Nothing
If swFeat Is Nothing Then Exit Function
Err.Clear
On Error Resume Next
Set GetNextSubFeatureSafe = CallByName(swFeat, "GetNextSubFeature", VbMethod)
If Err.Number <> 0 Then
Err.Clear
Set GetNextSubFeatureSafe = Nothing
End If
On Error GoTo EH
Exit Function
EH:
Set GetNextSubFeatureSafe = Nothing
End Function
Private Function FeatureVisitKey(ByVal swFeat As SldWorks.Feature) As String
On Error GoTo EH
If swFeat Is Nothing Then Exit Function
Dim nm As String
Dim typ As String
nm = UCase$(Trim$(FeatureNameSafe(swFeat)))
typ = UCase$(Trim$(SafeStr(swFeat.GetTypeName2)))
If Len(nm) > 0 Or Len(typ) > 0 Then
FeatureVisitKey = typ & "|" & nm
Else
FeatureVisitKey = CStr(ObjPtr(swFeat))
End If
Exit Function
EH:
FeatureVisitKey = ""
End Function
Private Function BodyVisitKey(ByVal swBody As SldWorks.Body2) As String
On Error GoTo EH
If swBody Is Nothing Then Exit Function
Dim nm As String
nm = UCase$(Trim$(GetBodyNameSafe(swBody)))
If Len(nm) > 0 Then
Dim dx As Double, dy As Double, dz As Double
GetBodyBBoxDims swBody, dx, dy, dz
BodyVisitKey = nm & "|" & Format$(dx, "0.000000") & "|" & Format$(dy, "0.000000") & "|" & Format$(dz, "0.000000")
Else
BodyVisitKey = CStr(ObjPtr(swBody))
End If
Exit Function
EH:
BodyVisitKey = ""
End Function
Private Function FeatureNameSafe(ByVal swFeat As SldWorks.Feature) As String
On Error Resume Next
FeatureNameSafe = ""
If swFeat Is Nothing Then Exit Function
FeatureNameSafe = SafeStr(swFeat.name)
If Err.Number <> 0 Then
Err.Clear
FeatureNameSafe = ""
End If
On Error GoTo 0
End Function
Private Sub AddFallbackSolidBodyItems(ByVal swModel As SldWorks.ModelDoc2, ByVal items As Collection)
On Error GoTo EH
If swModel Is Nothing Then Exit Sub
If items Is Nothing Then Exit Sub
If swModel.GetType <> swDocumentTypes_e.swDocPART Then Exit Sub
Dim swPart As SldWorks.PartDoc
Set swPart = swModel
If swPart Is Nothing Then Exit Sub
Dim vBodies As Variant
vBodies = swPart.GetBodies2(swBodyType_e.swSolidBody, True)
If Not IsArray(vBodies) Then Exit Sub
Dim i As Long
For i = LBound(vBodies) To UBound(vBodies)
Dim repB As SldWorks.Body2
Set repB = vBodies(i)
If repB Is Nothing Then GoTo NextBody
Dim dx As Double, dy As Double, dz As Double
GetBodyBBoxDims repB, dx, dy, dz
If dx <= 0# Or dy <= 0# Or dz <= 0# Then GoTo NextBody
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Set d("RepBody_Model") = repB
d("dx") = dx
d("dy") = dy
d("dz") = dz
d("ItemNo") = CStr(items.Count + 1)
d("PartNo") = GetBodyNameSafe(repB)
If Len(SafeStr(d("PartNo"))) = 0 Then d("PartNo") = swModel.GetTitle & "_BODY_" & CStr(items.Count + 1)
d("Qty") = "1"
d("CutListFeatureName") = "SOLID_BODY_FALLBACK"
d("BodyName") = GetBodyNameSafe(repB)
items.Add d
LogInfo "SolidBodyFallback | item=" & SafeStr(d("ItemNo")) & _
" | pn=" & SafeStr(d("PartNo")) & _
" | bbox=" & Fmt(dx) & "x" & Fmt(dy) & "x" & Fmt(dz)
NextBody:
Next i
Exit Sub
EH:
LogWarn "AddFallbackSolidBodyItems exception | " & Err.Number & " | " & Err.Description
End Sub
Private Function GetBodyNameSafe(ByVal swBody As SldWorks.Body2) As String
On Error Resume Next
GetBodyNameSafe = ""
If swBody Is Nothing Then Exit Function
GetBodyNameSafe = SafeStr(swBody.name)
If Err.Number <> 0 Then
Err.Clear
GetBodyNameSafe = ""
End If
On Error GoTo 0
End Function
Private Sub GetBodyBBoxDims(ByVal b As SldWorks.Body2, _
ByRef dx As Double, ByRef dy As Double, ByRef dz As Double)
dx = 0#: dy = 0#: dz = 0#
On Error Resume Next
Dim bb As Variant
bb = b.GetBodyBox
On Error GoTo 0
If IsArray(bb) Then
dx = Abs(CDbl(bb(3)) - CDbl(bb(0)))
dy = Abs(CDbl(bb(4)) - CDbl(bb(1)))
dz = Abs(CDbl(bb(5)) - CDbl(bb(2)))
End If
End Sub
Private Function GetCLProp(ByVal swModel As SldWorks.ModelDoc2, _
ByVal feat As SldWorks.Feature, _
ByVal names As Variant) As String
On Error GoTo EH
Dim cpm As SldWorks.CustomPropertyManager
On Error Resume Next
Set cpm = feat.CustomPropertyManager
On Error GoTo 0
If cpm Is Nothing Then
On Error Resume Next
Set cpm = swModel.Extension.CustomPropertyManager(feat.name)
On Error GoTo 0
End If
If cpm Is Nothing Then Exit Function
Dim i As Long
For i = LBound(names) To UBound(names)
Dim vOut As String, vRes As String
vOut = "": vRes = ""
On Error Resume Next
cpm.Get4 CStr(names(i)), False, vOut, vRes
On Error GoTo 0
Dim s As String
s = Trim$(SafeStr(vRes))
If Len(s) = 0 Then s = Trim$(SafeStr(vOut))
If Len(s) > 0 Then
GetCLProp = s
Exit Function
End If
Next i
Exit Function
EH:
GetCLProp = ""
End Function
Private Function ParseItemFromName(ByVal s As String) As String
Dim p1 As Long, p2 As Long
p1 = InStr(1, s, "<", vbTextCompare)
p2 = InStr(1, s, ">", vbTextCompare)
If p1 > 0 And p2 > p1 Then
ParseItemFromName = Mid$(s, p1 + 1, p2 - p1 - 1)
Else
ParseItemFromName = "?"
End If
End Function
'====================================================================================
' CONFIGURATION RESOLUTION / VALIDATION
'====================================================================================
Private Function ResolvePreferredReferencedConfiguration(ByVal swModel As SldWorks.ModelDoc2, _
ByVal rawViewCfg As String) As String
On Error GoTo EH
Dim rawCfg As String
Dim baseCfg As String
Dim activeCfg As String
Dim derivedCfg As String
Dim firstCfg As String
rawCfg = Trim$(rawViewCfg)
baseCfg = Trim$(StripDisplayState(rawCfg))
activeCfg = GetActiveConfigurationNameSafe(swModel)
firstCfg = GetFirstConfigurationNameSafe(swModel)
LogInfo "ResolvePreferredReferencedConfiguration | raw=" & rawCfg & _
" | base=" & baseCfg & _
" | active=" & activeCfg & _
" | first=" & firstCfg
' 1) Exact raw match
If Len(rawCfg) > 0 Then
If ModelHasConfiguration(swModel, rawCfg) Then
ResolvePreferredReferencedConfiguration = GetActualConfigurationCase(swModel, rawCfg)
LogInfo "ResolvePreferredReferencedConfiguration | using exact raw match=" & ResolvePreferredReferencedConfiguration
Exit Function
End If
End If
' 2) If raw/base missing but a derived config exists, prefer derived match
If Len(baseCfg) > 0 Then
derivedCfg = FindBestDerivedConfigurationByBaseName(swModel, baseCfg)
If Len(derivedCfg) > 0 Then
ResolvePreferredReferencedConfiguration = derivedCfg
LogInfo "ResolvePreferredReferencedConfiguration | using derived-from-base match=" & ResolvePreferredReferencedConfiguration
Exit Function
End If
End If
' 3) Plain base match
If Len(baseCfg) > 0 Then
If ModelHasConfiguration(swModel, baseCfg) Then
ResolvePreferredReferencedConfiguration = GetActualConfigurationCase(swModel, baseCfg)
LogInfo "ResolvePreferredReferencedConfiguration | using plain base match=" & ResolvePreferredReferencedConfiguration
Exit Function
End If
End If
' 4) If active config shares the base stem, prefer it
If Len(activeCfg) > 0 And Len(baseCfg) > 0 Then
If StrComp(Left$(UCase$(activeCfg), Len(baseCfg)), UCase$(baseCfg), vbTextCompare) = 0 Then
ResolvePreferredReferencedConfiguration = activeCfg
LogInfo "ResolvePreferredReferencedConfiguration | using active config matching base=" & ResolvePreferredReferencedConfiguration
Exit Function
End If
End If
' 5) Use active config
If Len(activeCfg) > 0 Then
ResolvePreferredReferencedConfiguration = activeCfg
LogInfo "ResolvePreferredReferencedConfiguration | using active config fallback=" & ResolvePreferredReferencedConfiguration
Exit Function
End If
' 6) Use first configuration
If Len(firstCfg) > 0 Then
ResolvePreferredReferencedConfiguration = firstCfg
LogInfo "ResolvePreferredReferencedConfiguration | using first config fallback=" & ResolvePreferredReferencedConfiguration
Exit Function
End If
ResolvePreferredReferencedConfiguration = ""
Exit Function
EH:
LogError "ResolvePreferredReferencedConfiguration exception | " & Err.Number & " | " & Err.Description
ResolvePreferredReferencedConfiguration = ""
End Function
Private Function ModelHasConfiguration(ByVal swModel As SldWorks.ModelDoc2, ByVal cfgName As String) As Boolean
On Error GoTo EH
Dim vNames As Variant
Dim i As Long
If swModel Is Nothing Then Exit Function
If Len(Trim$(cfgName)) = 0 Then Exit Function
vNames = swModel.GetConfigurationNames
If Not IsArray(vNames) Then Exit Function
For i = LBound(vNames) To UBound(vNames)
If StrComp(Trim$(SafeStr(vNames(i))), Trim$(cfgName), vbTextCompare) = 0 Then
ModelHasConfiguration = True
Exit Function
End If
Next i
Exit Function
EH:
ModelHasConfiguration = False
End Function
Private Function GetActualConfigurationCase(ByVal swModel As SldWorks.ModelDoc2, ByVal cfgName As String) As String
On Error GoTo EH
Dim vNames As Variant
Dim i As Long
If swModel Is Nothing Then Exit Function
If Len(Trim$(cfgName)) = 0 Then Exit Function
vNames = swModel.GetConfigurationNames
If Not IsArray(vNames) Then Exit Function
For i = LBound(vNames) To UBound(vNames)
If StrComp(Trim$(SafeStr(vNames(i))), Trim$(cfgName), vbTextCompare) = 0 Then
GetActualConfigurationCase = SafeStr(vNames(i))
Exit Function
End If
Next i
Exit Function
EH:
GetActualConfigurationCase = cfgName
End Function
Private Function FindBestDerivedConfigurationByBaseName(ByVal swModel As SldWorks.ModelDoc2, _
ByVal baseCfg As String) As String
On Error GoTo EH
Dim vNames As Variant
Dim i As Long
Dim nm As String
Dim best As String
Dim prefix As String
If swModel Is Nothing Then Exit Function
If Len(Trim$(baseCfg)) = 0 Then Exit Function
prefix = UCase$(Trim$(baseCfg)) & "<"
vNames = swModel.GetConfigurationNames
If Not IsArray(vNames) Then Exit Function
' Prefer As Machined if present
For i = LBound(vNames) To UBound(vNames)
nm = SafeStr(vNames(i))
If Left$(UCase$(nm), Len(prefix)) = prefix Then
If InStr(1, nm, "<As Machined>", vbTextCompare) > 0 Then
FindBestDerivedConfigurationByBaseName = nm
Exit Function
End If
End If
Next i
' Then prefer As Welded if present
For i = LBound(vNames) To UBound(vNames)
nm = SafeStr(vNames(i))
If Left$(UCase$(nm), Len(prefix)) = prefix Then
If InStr(1, nm, "<As Welded>", vbTextCompare) > 0 Then
FindBestDerivedConfigurationByBaseName = nm
Exit Function
End If
End If
Next i
' Else first derived match
For i = LBound(vNames) To UBound(vNames)
nm = SafeStr(vNames(i))
If Left$(UCase$(nm), Len(prefix)) = prefix Then
best = nm
Exit For
End If
Next i
FindBestDerivedConfigurationByBaseName = best
Exit Function
EH:
LogError "FindBestDerivedConfigurationByBaseName exception | " & Err.Number & " | " & Err.Description
FindBestDerivedConfigurationByBaseName = ""
End Function
Private Function GetActiveConfigurationNameSafe(ByVal swModel As SldWorks.ModelDoc2) As String
On Error GoTo EH
Dim cfg As SldWorks.Configuration
Set cfg = Nothing
If swModel Is Nothing Then Exit Function
On Error Resume Next
Set cfg = swModel.ConfigurationManager.ActiveConfiguration
On Error GoTo EH
If Not cfg Is Nothing Then
GetActiveConfigurationNameSafe = SafeStr(cfg.name)
End If
Exit Function
EH:
GetActiveConfigurationNameSafe = ""
End Function
Private Function GetFirstConfigurationNameSafe(ByVal swModel As SldWorks.ModelDoc2) As String
On Error GoTo EH
Dim vNames As Variant
If swModel Is Nothing Then Exit Function
vNames = swModel.GetConfigurationNames
If Not IsArray(vNames) Then Exit Function
If UBound(vNames) >= LBound(vNames) Then
GetFirstConfigurationNameSafe = SafeStr(vNames(LBound(vNames)))
End If
Exit Function
EH:
GetFirstConfigurationNameSafe = ""
End Function
Private Function ActivateModelConfigurationSafe(ByVal swModel As SldWorks.ModelDoc2, _
ByVal cfgName As String) As Boolean
On Error GoTo EH
ActivateModelConfigurationSafe = False
If swModel Is Nothing Then Exit Function
If Len(Trim$(cfgName)) = 0 Then Exit Function
If Not ModelHasConfiguration(swModel, cfgName) Then
LogWarn "ActivateModelConfigurationSafe | requested config not found | cfg=" & cfgName
Exit Function
End If
On Error Resume Next
ActivateModelConfigurationSafe = swModel.ShowConfiguration2(cfgName)
If Err.Number <> 0 Then
LogWarn "ActivateModelConfigurationSafe | ShowConfiguration2 error | " & Err.Number & " | " & Err.Description & _
" | cfg=" & cfgName
Err.Clear
End If
On Error GoTo EH
swModel.EditRebuild3
Dim activeNow As String
activeNow = GetActiveConfigurationNameSafe(swModel)
If StrComp(activeNow, cfgName, vbTextCompare) = 0 Then
ActivateModelConfigurationSafe = True
End If
LogInfo "ActivateModelConfigurationSafe | requested=" & cfgName & _
" | activeNow=" & activeNow & _
" | ok=" & CStr(ActivateModelConfigurationSafe)
Exit Function
EH:
LogError "ActivateModelConfigurationSafe exception | " & Err.Number & " | " & Err.Description & _
" | cfg=" & cfgName
ActivateModelConfigurationSafe = False
End Function
Private Function EnsureViewUsesConfiguration(ByVal swV As SldWorks.View, _
ByVal cfgName As String, _
ByVal stageTag As String) As Boolean
On Error GoTo EH
Dim k As Long
Dim curCfg As String
Dim vName As String
EnsureViewUsesConfiguration = False
If swV Is Nothing Then Exit Function
If Len(Trim$(cfgName)) = 0 Then Exit Function
vName = ViewGetNameSafe(swV)
For k = 1 To VIEW_CFG_RETRY_COUNT
ForceSheetContext
' Keep model active config aligned as well.
Call ActivateModelConfigurationSafe(g_refModel, cfgName)
On Error Resume Next
swV.ReferencedConfiguration = cfgName
If Err.Number <> 0 Then
LogWarn "EnsureViewUsesConfiguration | setter error | try=" & k & _
" | stage=" & stageTag & " | view=" & vName & _
" | " & Err.Number & " | " & Err.Description
Err.Clear
End If
On Error GoTo EH
On Error Resume Next
swV.Update
On Error GoTo EH
g_swDrwModel.EditRebuild3
DoEvents
curCfg = Trim$(SafeStr(swV.ReferencedConfiguration))
LogInfo "EnsureViewUsesConfiguration | try=" & k & _
" | stage=" & stageTag & _
" | view=" & vName & _
" | target=" & cfgName & _
" | current=" & curCfg
If StrComp(curCfg, cfgName, vbTextCompare) = 0 Then
EnsureViewUsesConfiguration = True
Exit Function
End If
Next k
Exit Function
EH:
LogError "EnsureViewUsesConfiguration exception | " & Err.Number & " | " & Err.Description & _
" | stage=" & stageTag & " | view=" & ViewGetNameSafe(swV) & " | cfg=" & cfgName
EnsureViewUsesConfiguration = False
End Function
Private Sub NormalizePlacedViewConfigurations(ByVal placedViews As Collection, ByVal cfgName As String)
On Error GoTo EH
Dim i As Long
If placedViews Is Nothing Then Exit Sub
If placedViews.Count = 0 Then Exit Sub
If Len(Trim$(cfgName)) = 0 Then Exit Sub
LogInfo "NormalizePlacedViewConfigurations | count=" & CStr(placedViews.Count) & " | cfg=" & cfgName
For i = 1 To placedViews.Count
Dim swV As SldWorks.View
Set swV = placedViews(i)
If Not swV Is Nothing Then
If Not EnsureViewUsesConfiguration(swV, cfgName, "normalize pass idx=" & CStr(i)) Then
LogWarn "NormalizePlacedViewConfigurations | failed | idx=" & i & _
" | view=" & ViewGetNameSafe(swV)
End If
End If
Next i
Exit Sub
EH:
LogError "NormalizePlacedViewConfigurations exception | " & Err.Number & " | " & Err.Description
End Sub
'====================================================================================
' BOM BALLOONS
'====================================================================================
Private Function AddBOMBalloonsForPlacedViews(ByVal placedViews As Collection, _
ByVal placedItems As Collection) As Long
On Error GoTo EH
AddBOMBalloonsForPlacedViews = 0
If Not ADD_BOM_BALLOON_AFTER_PLACE Then Exit Function
If placedViews Is Nothing Then Exit Function
If placedItems Is Nothing Then Exit Function
If placedViews.Count = 0 Then Exit Function
Dim i As Long
For i = 1 To placedViews.Count
Dim v As SldWorks.View
Set v = placedViews(i)
Dim item As Object
Set item = placedItems(i)
If Not v Is Nothing Then
' Make sure configuration is still correct before ballooning.
If Not EnsureViewUsesConfiguration(v, g_refCfg, "pre-balloon idx=" & CStr(i)) Then
LogWarn "AddBOMBalloonsForPlacedViews | view cfg not fully validated before balloon | idx=" & i & _
" | view=" & ViewGetNameSafe(v)
End If
If InsertOneBOMBalloonForView(v, item) Then
AddBOMBalloonsForPlacedViews = AddBOMBalloonsForPlacedViews + 1
Else
LogWarn "BOM balloon failed | view=" & ViewGetNameSafe(v) & _
" | pn=" & SafeStr(item("PartNo")) & " | itemNo=" & SafeStr(item("ItemNo"))
End If
End If
Next i
Exit Function
EH:
LogError "AddBOMBalloonsForPlacedViews exception | " & Err.Number & " | " & Err.Description
End Function
Private Function InsertOneBOMBalloonForView(ByVal v As SldWorks.View, _
ByVal item As Object) As Boolean
On Error GoTo EH
InsertOneBOMBalloonForView = False
If v Is Nothing Then Exit Function
Dim mdExt As SldWorks.ModelDocExtension
Set mdExt = g_swDrwModel.Extension
If mdExt Is Nothing Then
LogWarn "InsertOneBOMBalloonForView | ModelDocExtension is Nothing"
Exit Function
End If
Dim vName As String
vName = ViewGetNameSafe(v)
Dim tryN As Long
For tryN = 1 To BALLOON_RETRY_COUNT
ForceSheetContext
g_swDrwModel.ClearSelection2 True
' Anchor selection: entity in view (best), else fallback to selecting view
Dim anchorOk As Boolean
anchorOk = TrySelectBalloonAnchorEntityInView(v)
If Not anchorOk Then
LogWarn "InsertOneBOMBalloonForView | no visible entity anchor found, fallback=view selection | try=" & tryN & " | view=" & vName
anchorOk = g_swDrwModel.Extension.SelectByID2(vName, "DRAWINGVIEW", 0#, 0#, 0#, False, 0, Nothing, 0)
End If
If Not anchorOk Then
LogWarn "InsertOneBOMBalloonForView | anchor selection failed | try=" & tryN & " | view=" & vName
GoTo NextTry
End If
Dim bo As Object
Set bo = mdExt.CreateBalloonOptions
If bo Is Nothing Then
LogWarn "InsertOneBOMBalloonForView | CreateBalloonOptions returned Nothing"
GoTo NextTry
End If
ConfigureBalloonOptionsSafe bo
Dim n As Object
Set n = mdExt.InsertBOMBalloon2(bo)
If n Is Nothing Then
LogWarn "InsertOneBOMBalloonForView | InsertBOMBalloon2 returned Nothing | try=" & tryN & _
" | view=" & vName & " | pn=" & SafeStr(item("PartNo")) & " | itemNo=" & SafeStr(item("ItemNo"))
GoTo NextTry
End If
If PositionBalloonNearView(n, v) Then
LogInfo "BOM balloon OK | view=" & vName & _
" | pn=" & SafeStr(item("PartNo")) & " | itemNo=" & SafeStr(item("ItemNo"))
Else
LogWarn "BOM balloon inserted but reposition failed | view=" & vName
End If
g_swDrwModel.EditRebuild3
ForceSheetContext
InsertOneBOMBalloonForView = True
Exit Function
NextTry:
g_swDrwModel.ClearSelection2 True
DoEvents
Next tryN
ForceSheetContext
Exit Function
EH:
LogError "InsertOneBOMBalloonForView exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(v)
ForceSheetContext
InsertOneBOMBalloonForView = False
End Function
Private Sub ConfigureBalloonOptionsSafe(ByVal bo As Object)
On Error Resume Next
CallByName bo, "ShowQuantity", VbLet, False
On Error GoTo 0
End Sub
Private Function TrySelectBalloonAnchorEntityInView(ByVal v As SldWorks.View) As Boolean
On Error GoTo EH
TrySelectBalloonAnchorEntityInView = False
If v Is Nothing Then Exit Function
Dim vVisComps As Variant
On Error Resume Next
vVisComps = v.GetVisibleComponents
On Error GoTo EH
If IsArray(vVisComps) Then
Dim i As Long
' Prefer edges
For i = LBound(vVisComps) To UBound(vVisComps)
If TrySelectFirstVisibleEntityFromComp(v, vVisComps(i), swViewEntityType_e.swViewEntityType_Edge, "edge") Then
TrySelectBalloonAnchorEntityInView = True
Exit Function
End If
Next i
' Then vertices
For i = LBound(vVisComps) To UBound(vVisComps)
If TrySelectFirstVisibleEntityFromComp(v, vVisComps(i), swViewEntityType_e.swViewEntityType_Vertex, "vertex") Then
TrySelectBalloonAnchorEntityInView = True
Exit Function
End If
Next i
' Then faces
For i = LBound(vVisComps) To UBound(vVisComps)
If TrySelectFirstVisibleEntityFromComp(v, vVisComps(i), swViewEntityType_e.swViewEntityType_Face, "face") Then
TrySelectBalloonAnchorEntityInView = True
Exit Function
End If
Next i
End If
If TrySelectFirstVisibleEntityFromComp(v, Nothing, swViewEntityType_e.swViewEntityType_Edge, "edge(nil)") Then
TrySelectBalloonAnchorEntityInView = True
Exit Function
End If
If TrySelectFirstVisibleEntityFromComp(v, Nothing, swViewEntityType_e.swViewEntityType_Vertex, "vertex(nil)") Then
TrySelectBalloonAnchorEntityInView = True
Exit Function
End If
If TrySelectFirstVisibleEntityFromComp(v, Nothing, swViewEntityType_e.swViewEntityType_Face, "face(nil)") Then
TrySelectBalloonAnchorEntityInView = True
Exit Function
End If
Exit Function
EH:
LogWarn "TrySelectBalloonAnchorEntityInView exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(v)
TrySelectBalloonAnchorEntityInView = False
End Function
Private Function TrySelectFirstVisibleEntityFromComp(ByVal v As SldWorks.View, _
ByVal visComp As Variant, _
ByVal entType As Long, _
ByVal entTypeName As String) As Boolean
On Error GoTo EH
TrySelectFirstVisibleEntityFromComp = False
If v Is Nothing Then Exit Function
Dim vVisEnts As Variant
On Error Resume Next
vVisEnts = v.GetVisibleEntities2(visComp, entType)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
If Not IsArray(vVisEnts) Then Exit Function
Dim i As Long
For i = LBound(vVisEnts) To UBound(vVisEnts)
Dim swEnt As SldWorks.Entity
Set swEnt = Nothing
On Error Resume Next
Set swEnt = vVisEnts(i)
On Error GoTo EH
If Not swEnt Is Nothing Then
g_swDrwModel.ClearSelection2 True
If swEnt.Select4(False, Nothing) Then
LogInfo " Balloon anchor select OK | mode=Select4 | type=" & entTypeName & " | view=" & ViewGetNameSafe(v)
TrySelectFirstVisibleEntityFromComp = True
Exit Function
End If
g_swDrwModel.ClearSelection2 True
If v.SelectEntity(swEnt, False) Then
LogInfo " Balloon anchor select OK | mode=View.SelectEntity | type=" & entTypeName & " | view=" & ViewGetNameSafe(v)
TrySelectFirstVisibleEntityFromComp = True
Exit Function
End If
End If
Next i
Exit Function
EH:
LogWarn "TrySelectFirstVisibleEntityFromComp exception | " & Err.Number & " | " & Err.Description & _
" | type=" & entTypeName & " | view=" & ViewGetNameSafe(v)
TrySelectFirstVisibleEntityFromComp = False
End Function
Private Function PositionBalloonNearView(ByVal noteObj As Object, ByVal v As SldWorks.View) As Boolean
On Error GoTo EH
PositionBalloonNearView = False
If noteObj Is Nothing Then
LogWarn "PositionBalloonNearView | noteObj is Nothing"
Exit Function
End If
If v Is Nothing Then
LogWarn "PositionBalloonNearView | view is Nothing"
Exit Function
End If
Dim x0 As Double, y0 As Double, x1 As Double, y1 As Double
If Not GetViewRect(v, x0, y0, x1, y1) Then
LogWarn "PositionBalloonNearView | GetViewRect failed | view=" & ViewGetNameSafe(v)
Exit Function
End If
Dim ann As SldWorks.Annotation
Set ann = Nothing
If Not TryGetBalloonAnnotation(noteObj, ann) Then
LogWarn "PositionBalloonNearView | could not resolve annotation from balloon object | view=" & ViewGetNameSafe(v)
Exit Function
End If
Dim bx As Double, by As Double
bx = x1 + BALLOON_OFFSET_X
by = y1 + BALLOON_OFFSET_Y
On Error Resume Next
ann.SetPosition2 bx, by, 0#
If Err.Number <> 0 Then
LogWarn "PositionBalloonNearView | SetPosition2 failed | " & Err.Number & " | " & Err.Description & _
" | target=(" & Fmt(bx) & "," & Fmt(by) & ")"
Err.Clear
On Error GoTo EH
Exit Function
End If
On Error GoTo EH
LogInfo "PositionBalloonNearView | moved balloon | view=" & ViewGetNameSafe(v) & _
" | pos=(" & Fmt(bx) & "," & Fmt(by) & ")"
PositionBalloonNearView = True
Exit Function
EH:
LogWarn "PositionBalloonNearView exception | " & Err.Number & " | " & Err.Description
PositionBalloonNearView = False
End Function
Private Function TryGetBalloonAnnotation(ByVal noteObj As Object, _
ByRef ann As SldWorks.Annotation) As Boolean
On Error GoTo EH
TryGetBalloonAnnotation = False
Set ann = Nothing
If noteObj Is Nothing Then Exit Function
Err.Clear
On Error Resume Next
Set ann = noteObj.GetAnnotation
If Err.Number <> 0 Then
LogWarn "TryGetBalloonAnnotation | GetAnnotation failed | " & Err.Number & " | " & Err.Description
Err.Clear
End If
On Error GoTo EH
If ann Is Nothing Then
LogWarn "TryGetBalloonAnnotation | GetAnnotation returned Nothing"
Exit Function
End If
TryGetBalloonAnnotation = True
Exit Function
EH:
LogWarn "TryGetBalloonAnnotation exception | " & Err.Number & " | " & Err.Description
TryGetBalloonAnnotation = False
End Function
Private Function DegToRad(ByVal degVal As Double) As Double
DegToRad = degVal * PI / 180#
End Function
Private Function RadToDeg(ByVal radVal As Double) As Double
RadToDeg = radVal * 180# / PI
End Function
Private Function NormalizeAngleRad(ByVal angRad As Double) As Double
Do While angRad > PI
angRad = angRad - (2# * PI)
Loop
Do While angRad <= -PI
angRad = angRad + (2# * PI)
Loop
NormalizeAngleRad = angRad
End Function
Private Function NormalizeAngleToHorizontal(ByVal angRad As Double) As Double
angRad = NormalizeAngleRad(angRad)
Do While angRad > (PI / 2#)
angRad = angRad - PI
Loop
Do While angRad <= (-PI / 2#)
angRad = angRad + PI
Loop
NormalizeAngleToHorizontal = angRad
End Function
Private Function GetSnapReferenceForView(ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByRef refMetric As Double, _
ByRef refAngRad As Double, _
ByRef refQuality As Double, _
ByRef refDesc As String) As Boolean
On Error GoTo EH
GetSnapReferenceForView = False
refMetric = 0#
refAngRad = 0#
refQuality = -1E+30
refDesc = ""
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
If SNAP_REF_USE_VISIBLE_EDGE_FIRST Then
Dim visLen As Double
Dim visAng As Double
Dim visDesc As String
Dim edgeCt As Long
Dim lineCt As Long
visLen = 0#: visAng = 0#: visDesc = ""
edgeCt = 0: lineCt = 0
Call GetBestVisibleLinearEdgeInView(swView, visLen, visAng, visDesc, edgeCt, lineCt)
If visLen >= ROT_MIN_VISIBLE_EDGE_LEN Then
refMetric = visLen
refAngRad = visAng
refQuality = (visLen * 1000000#) + (CDbl(lineCt) * 100#) + (CDbl(edgeCt) * 10#)
refDesc = "Visible longest edge | len=" & Fmt(visLen) & " | " & visDesc
GetSnapReferenceForView = True
Exit Function
End If
End If
If GetCategoryOrientationReference(swView, item, refMetric, refAngRad, refQuality, refDesc) Then
refDesc = "CatRefFallback | " & refDesc
GetSnapReferenceForView = True
End If
Exit Function
EH:
LogWarn "GetSnapReferenceForView exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
GetSnapReferenceForView = False
End Function
Private Function GetOrientationSnapState(ByVal refAngRad As Double, _
ByVal tolDeg As Double, _
ByRef deltaHDeg As Double, _
ByRef deltaVDeg As Double, _
ByRef stateName As String) As Long
Dim absHorizDeg As Double
absHorizDeg = Abs(RadToDeg(NormalizeAngleToHorizontal(refAngRad)))
deltaHDeg = absHorizDeg
deltaVDeg = Abs(90# - absHorizDeg)
If deltaHDeg <= tolDeg Then
stateName = "HORIZONTAL_READY"
GetOrientationSnapState = 2
Exit Function
End If
If deltaVDeg <= tolDeg Then
stateName = "VERTICAL_READY_NEEDS_90"
GetOrientationSnapState = 1
Exit Function
End If
stateName = "UNSNAPPED"
GetOrientationSnapState = 0
End Function
Private Function TryApplySnapFirstOrientation(ByVal swDrawModel As SldWorks.ModelDoc2, _
ByVal swView As SldWorks.View, _
ByVal item As Object, _
ByVal tag As String) As Boolean
On Error GoTo EH
TryApplySnapFirstOrientation = False
If swDrawModel Is Nothing Then Exit Function
If swView Is Nothing Then Exit Function
If item Is Nothing Then Exit Function
Dim baseAngleRad As Double
baseAngleRad = swView.Angle
Dim refMetric As Double
Dim refAngRad As Double
Dim refQuality As Double
Dim refDesc As String
Dim deltaHDeg As Double
Dim deltaVDeg As Double
Dim snapState As String
Dim snapRank As Long
If Not GetSnapReferenceForView(swView, item, refMetric, refAngRad, refQuality, refDesc) Then Exit Function
snapRank = GetOrientationSnapState(refAngRad, ROT_SNAP_TOL_DEG, deltaHDeg, deltaVDeg, snapState)
LogInfo "SnapCheck | view=" & ViewGetNameSafe(swView) & _
" | cat=" & SafeStr(item("BodyCategory")) & _
" | state=" & snapState & _
" | refMetric=" & Fmt(refMetric) & _
" | refAngDeg=" & Format$(RadToDeg(refAngRad), "0.000") & _
" | deltaH=" & Format$(deltaHDeg, "0.000") & _
" | deltaV=" & Format$(deltaVDeg, "0.000") & _
" | ref=" & refDesc
If snapRank <= 0 Then Exit Function
Dim validNow As Boolean
Dim validScore As Double
Dim validDetail As String
If snapRank = 2 Then
validNow = ValidateOrientationResultByCategory(swView, item, validScore, validDetail)
LogInfo "SnapAction | chosen=keep | view=" & ViewGetNameSafe(swView) & _
" | deltaH=" & Format$(deltaHDeg, "0.000") & _
" | valid=" & BoolWord(validNow) & _
" | verify=" & validDetail
If validNow Then
TryApplySnapFirstOrientation = True
Exit Function
End If
Exit Function
End If
Dim targetAngle As Double
targetAngle = NormalizeAngleRad(baseAngleRad - NormalizeAngleToHorizontal(refAngRad))
SetViewAngleAndRefresh swDrawModel, swView, targetAngle, tag & " | snap-first rotate90"
Dim confMetric As Double
Dim confAngRad As Double
Dim confQuality As Double
Dim confDesc As String
Dim confDeltaHDeg As Double
Dim confDeltaVDeg As Double
Dim confState As String
Dim confRank As Long
confRank = 0
confDeltaHDeg = 9999#
confDeltaVDeg = 9999#
If GetSnapReferenceForView(swView, item, confMetric, confAngRad, confQuality, confDesc) Then
confRank = GetOrientationSnapState(confAngRad, ROT_SNAP_TOL_DEG, confDeltaHDeg, confDeltaVDeg, confState)
End If
validNow = ValidateOrientationResultByCategory(swView, item, validScore, validDetail)
LogInfo "SnapVerify | view=" & ViewGetNameSafe(swView) & _
" | state=" & confState & _
" | refMetric=" & Fmt(confMetric) & _
" | refAngDeg=" & Format$(RadToDeg(confAngRad), "0.000") & _
" | deltaH=" & Format$(confDeltaHDeg, "0.000") & _
" | deltaV=" & Format$(confDeltaVDeg, "0.000") & _
" | valid=" & BoolWord(validNow) & _
" | ref=" & confDesc & _
" | verify=" & validDetail
If validNow And confRank = 2 Then
TryApplySnapFirstOrientation = True
Exit Function
End If
SetViewAngleAndRefresh swDrawModel, swView, baseAngleRad, tag & " | snap-first restore"
Exit Function
EH:
LogWarn "TryApplySnapFirstOrientation exception | " & Err.Number & " | " & Err.Description & _
" | view=" & ViewGetNameSafe(swView)
On Error Resume Next
If Not swDrawModel Is Nothing Then
SetViewAngleAndRefresh swDrawModel, swView, swView.Angle, tag & " | snap-first exception"
End If
On Error GoTo 0
TryApplySnapFirstOrientation = False
End Function
Private Function Atn2Safe(ByVal y As Double, ByVal x As Double) As Double
If x > 0# Then
Atn2Safe = Atn(y / x)
ElseIf x < 0# Then
If y >= 0# Then
Atn2Safe = Atn(y / x) + PI
Else
Atn2Safe = Atn(y / x) - PI
End If
Else
If y > 0# Then
Atn2Safe = PI / 2#
ElseIf y < 0# Then
Atn2Safe = -PI / 2#
Else
Atn2Safe = 0#
End If
End If
End Function
Private Function MaxD(ByVal a As Double, ByVal b As Double) As Double
If a >= b Then MaxD = a Else MaxD = b
End Function
Private Function MinD(ByVal a As Double, ByVal b As Double) As Double
If a <= b Then MinD = a Else MinD = b
End Function
'====================================================================================
' SHEET HELPERS
'====================================================================================
Private Sub EnsureSheetExistsCopyProps(ByVal swDraw As SldWorks.DrawingDoc, _
ByVal src As SldWorks.Sheet, _
ByVal name As String)
If SheetExists(swDraw, name) Then Exit Sub
Dim p As Variant
p = src.GetProperties2
Dim ok As Boolean
ok = (False <> swDraw.NewSheet3(name, CLng(p(0)), CLng(p(1)), _
CDbl(p(2)), CDbl(p(3)), CBool(p(4)), _
src.GetTemplateName, CDbl(p(5)), CDbl(p(6)), "Default"))
If ok Then
LogInfo "Sheet created: " & name
Else
LogError "Sheet creation failed: " & name
End If
End Sub
Private Function SheetExists(ByVal swDraw As SldWorks.DrawingDoc, ByVal name As String) As Boolean
Dim vNames As Variant
vNames = swDraw.GetSheetNames
If Not IsArray(vNames) Then Exit Function
Dim i As Long
For i = LBound(vNames) To UBound(vNames)
If StrComp(SafeStr(vNames(i)), name, vbTextCompare) = 0 Then
SheetExists = True
Exit Function
End If
Next i
End Function
Private Sub SafeDeleteView(ByVal swModel As SldWorks.ModelDoc2, ByVal swV As SldWorks.View)
On Error Resume Next
Dim nm As String
nm = ViewGetNameSafe(swV)
swModel.ClearSelection2 True
swModel.Extension.SelectByID2 nm, "DRAWINGVIEW", 0#, 0#, 0#, False, 0, Nothing, 0
swModel.EditDelete
swModel.ClearSelection2 True
On Error GoTo 0
End Sub
'====================================================================================
' MODEL OPEN / REFERENCE VIEW
'====================================================================================
Private Function EnsureModelOpen(ByVal refView As SldWorks.View, _
ByVal modelPath As String, _
ByVal cfg As String, _
ByRef outModel As SldWorks.ModelDoc2, _
ByRef outOpened As Boolean, _
ByRef outTitle As String) As Boolean
On Error GoTo EH
outOpened = False
outTitle = ""
On Error Resume Next
Set outModel = refView.ReferencedDocument
On Error GoTo 0
If Not outModel Is Nothing Then
outTitle = outModel.GetTitle
LogInfo "Model already open | " & outTitle
EnsureModelOpen = True
Exit Function
End If
Dim errs As Long, warns As Long
Dim opts As Long
opts = swOpenDocOptions_e.swOpenDocOptions_Silent Or _
swOpenDocOptions_e.swOpenDocOptions_ReadOnly
' First attempt with requested cfg if supplied
If Len(Trim$(cfg)) > 0 Then
LogInfo "Opening model | preferred cfg=" & cfg & " | path=" & modelPath
Set outModel = g_swApp.OpenDoc6(modelPath, swDocumentTypes_e.swDocPART, opts, cfg, errs, warns)
LogInfo "OpenDoc6 attempt-1 | errs=" & errs & " warns=" & warns & " ok=" & CStr(Not outModel Is Nothing)
End If
' Second attempt without forcing cfg
If outModel Is Nothing Then
errs = 0: warns = 0
LogInfo "Opening model | fallback blank cfg | path=" & modelPath
Set outModel = g_swApp.OpenDoc6(modelPath, swDocumentTypes_e.swDocPART, opts, "", errs, warns)
LogInfo "OpenDoc6 attempt-2 | errs=" & errs & " warns=" & warns & " ok=" & CStr(Not outModel Is Nothing)
End If
outOpened = Not (outModel Is Nothing)
If outModel Is Nothing Then
EnsureModelOpen = False
Exit Function
End If
outTitle = outModel.GetTitle
EnsureModelOpen = True
Exit Function
EH:
LogError "EnsureModelOpen exception | " & Err.Number & " | " & Err.Description
EnsureModelOpen = False
End Function
Private Function GetReferenceDrawingView(ByVal drw As SldWorks.DrawingDoc, _
ByVal swDrwModel As SldWorks.ModelDoc2) As SldWorks.View
On Error GoTo EH
' Priority 1: user-selected drawing view
Dim mgr As SldWorks.SelectionMgr
Set mgr = swDrwModel.SelectionManager
If Not mgr Is Nothing Then
Dim ct As Long
ct = mgr.GetSelectedObjectCount2(-1)
Dim i As Long
For i = 1 To ct
If mgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelDRAWINGVIEWS Then
Dim vSel As Object
Set vSel = mgr.GetSelectedObject6(i, -1)
If Not vSel Is Nothing Then
Set GetReferenceDrawingView = vSel
Exit Function
End If
End If
Next i
End If
' Priority 2: first model view on active sheet
Dim sv As SldWorks.View
Set sv = drw.GetFirstView
If sv Is Nothing Then Exit Function
Set sv = sv.GetNextView
Do While Not sv Is Nothing
If Len(SafeStr(sv.GetReferencedModelName)) > 0 Then
Set GetReferenceDrawingView = sv
Exit Function
End If
Set sv = sv.GetNextView
Loop
Exit Function
EH:
Set GetReferenceDrawingView = Nothing
End Function
Private Function ViewGetNameSafe(ByVal v As SldWorks.View) As String
Dim s As String
On Error Resume Next
s = v.GetName2
On Error GoTo 0
If Len(Trim$(s)) = 0 Then
On Error Resume Next
s = v.name
On Error GoTo 0
End If
ViewGetNameSafe = s
End Function
Private Function StripDisplayState(ByVal cfg As String) As String
Dim p As Long
p = InStr(1, cfg, "<", vbTextCompare)
If p > 0 Then
StripDisplayState = Trim$(Left$(cfg, p - 1))
Else
StripDisplayState = Trim$(cfg)
End If
End Function
'====================================================================================
' UTILITIES
'====================================================================================
Private Function SafeArrayCount(ByVal vArr As Variant) As Long
On Error GoTo EH
SafeArrayCount = UBound(vArr) - LBound(vArr) + 1
Exit Function
EH:
SafeArrayCount = 0
End Function
Private Function SafeStr(ByVal v As Variant) As String
On Error Resume Next
SafeStr = CStr(v)
If Err.Number <> 0 Then
SafeStr = ""
Err.Clear
End If
End Function
Private Function BoolWord(ByVal v As Boolean) As String
If v Then
BoolWord = "True"
Else
BoolWord = "False"
End If
End Function
Private Function Fmt(ByVal d As Double) As String
Fmt = Format$(d, "0.0000")
End Function
Private Function FmtIf(ByVal cond As Boolean, ByVal d As Double) As String
If cond Then
FmtIf = Fmt(d)
Else
FmtIf = "n/a"
End If
End Function
'====================================================================================
' LOGGING
'====================================================================================
Private Sub InitDebugLog()
On Error GoTo EH
If g_debugLogInitDone Then Exit Sub
g_debugLogInitDone = True
g_debugLogEnabled = False
g_debugLogFailed = False
g_debugLogPath = ""
g_debugLogFileNo = 0
Dim logFolder As String
logFolder = DEBUG_LOG_FOLDER
If Not EnsureFolderExistsSafe(logFolder) Then
Dim tempFolder As String
tempFolder = Environ$("TEMP")
If Len(Trim$(tempFolder)) > 0 Then
logFolder = tempFolder
End If
End If
If Len(Trim$(logFolder)) = 0 Then
Debug.Print TimeStamp & " WARN | FILE_LOGGER | no usable log folder; file logging disabled"
g_debugLogFailed = True
Exit Sub
End If
g_debugLogPath = CombinePathSafe(logFolder, DEBUG_LOG_PREFIX & FileTimestamp() & ".log")
g_debugLogFileNo = FreeFile
Open g_debugLogPath For Append As #g_debugLogFileNo
g_debugLogEnabled = True
LogDivider "LOG HEADER"
LogKeyValue "HEADER", "macroName", "AUTO_COPE_DETAIL_GENERATO"
LogKeyValue "HEADER", "macroRevision", MACRO_REVISION
LogKeyValue "HEADER", "macroTitle", MACRO_TITLE
LogKeyValue "HEADER", "runDateTime", TimeStamp()
LogKeyValue "HEADER", "solidWorksVersion", GetSolidWorksVersionSafe()
LogKeyValue "HEADER", "activeDocumentTitle", ModelTitleSafe(g_swDrwModel)
LogKeyValue "HEADER", "activeDocumentFullPath", ModelPathSafe(g_swDrwModel)
If Not g_swDrwModel Is Nothing Then
LogKeyValue "HEADER", "activeDocumentType", DocumentTypeNameSafe(g_swDrwModel.GetType)
Else
LogKeyValue "HEADER", "activeDocumentType", "None"
End If
LogKeyValue "HEADER", "activeConfiguration", ActiveConfigurationNameForLog(g_swDrwModel)
LogKeyValue "HEADER", "requiredLogFolder", DEBUG_LOG_FOLDER
LogKeyValue "HEADER", "actualLogFilePath", g_debugLogPath
LogDivider "LOG HEADER END"
Exit Sub
EH:
Debug.Print TimeStamp & " WARN | FILE_LOGGER | InitDebugLog failed | " & Err.Number & " | " & Err.Description
On Error Resume Next
If g_debugLogFileNo <> 0 Then Close #g_debugLogFileNo
On Error GoTo 0
g_debugLogEnabled = False
g_debugLogFailed = True
End Sub
Private Sub CloseDebugLog()
On Error Resume Next
If g_debugLogEnabled Then
WriteDebugLogLine "INFO", "FILE_LOGGER | closing log | path=" & g_debugLogPath
Close #g_debugLogFileNo
End If
g_debugLogEnabled = False
g_debugLogFileNo = 0
On Error GoTo 0
End Sub
Private Sub LogLine(ByVal s As String)
WriteDebugLogLine "INFO", s
End Sub
Private Sub LogInfo(ByVal msg As String)
WriteDebugLogLine "INFO", msg
End Sub
Private Sub LogWarn(ByVal msg As String)
WriteDebugLogLine "WARN", msg
End Sub
Private Sub LogError(ByVal msg As String)
WriteDebugLogLine "ERROR", msg
End Sub
Private Sub LogStage(ByVal stageName As String, ByVal msg As String)
WriteDebugLogLine "STAGE", SafeLogText(stageName) & " | " & SafeLogText(msg)
End Sub
Private Sub LogKeyValue(ByVal scopeName As String, ByVal keyName As String, ByVal valueText As String)
WriteDebugLogLine "INFO", "KV | " & SafeLogText(scopeName) & " | " & SafeLogText(keyName) & "=" & SafeLogText(valueText)
End Sub
Private Sub LogDivider(Optional ByVal title As String = "")
Dim msg As String
If Len(Trim$(title)) > 0 Then
msg = String$(24, "=") & " " & SafeLogText(title) & " " & String$(24, "=")
Else
msg = String$(72, "=")
End If
WriteDebugLogLine "INFO", msg
End Sub
Private Sub WriteDebugLogLine(ByVal levelName As String, ByVal msg As String)
On Error Resume Next
Dim lineText As String
lineText = TimeStamp() & " " & PadLevelName(levelName) & " | " & SafeLogText(msg)
Debug.Print lineText
If g_debugLogEnabled Then
Print #g_debugLogFileNo, lineText
If Err.Number <> 0 Then
Debug.Print TimeStamp & " WARN | FILE_LOGGER | write failed; disabling file logging | " & Err.Number & " | " & Err.Description
Err.Clear
Close #g_debugLogFileNo
g_debugLogEnabled = False
g_debugLogFailed = True
End If
End If
On Error GoTo 0
End Sub
Private Function EnsureFolderExistsSafe(ByVal folderPath As String) As Boolean
On Error GoTo EH
EnsureFolderExistsSafe = False
folderPath = Trim$(folderPath)
If Len(folderPath) = 0 Then Exit Function
If Dir$(folderPath, vbDirectory) <> "" Then
EnsureFolderExistsSafe = True
Exit Function
End If
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso Is Nothing Then Exit Function
If Not fso.FolderExists(folderPath) Then
EnsureFolderExistsFso fso, folderPath
End If
EnsureFolderExistsSafe = fso.FolderExists(folderPath)
Exit Function
EH:
Debug.Print TimeStamp & " WARN | FILE_LOGGER | failed to create log folder | folder=" & folderPath & " | " & Err.Number & " | " & Err.Description
EnsureFolderExistsSafe = False
End Function
Private Sub EnsureFolderExistsFso(ByVal fso As Object, ByVal folderPath As String)
On Error GoTo EH
If fso Is Nothing Then Exit Sub
If Len(Trim$(folderPath)) = 0 Then Exit Sub
If fso.FolderExists(folderPath) Then Exit Sub
Dim parentPath As String
parentPath = fso.GetParentFolderName(folderPath)
If Len(parentPath) > 0 Then
If Not fso.FolderExists(parentPath) Then
EnsureFolderExistsFso fso, parentPath
End If
End If
If Not fso.FolderExists(folderPath) Then
fso.CreateFolder folderPath
End If
Exit Sub
EH:
Debug.Print TimeStamp & " WARN | FILE_LOGGER | EnsureFolderExistsFso failed | folder=" & folderPath & " | " & Err.Number & " | " & Err.Description
End Sub
Private Function CombinePathSafe(ByVal folderPath As String, ByVal fileName As String) As String
folderPath = Trim$(folderPath)
fileName = SanitizeFileName(fileName)
If Right$(folderPath, 1) = "\" Then
CombinePathSafe = folderPath & fileName
Else
CombinePathSafe = folderPath & "\" & fileName
End If
End Function
Private Function SanitizeFileName(ByVal fileName As String) As String
Dim badChars As Variant
badChars = Array("<", ">", ":", """", "/", "\", "|", "?", "*")
Dim i As Long
For i = LBound(badChars) To UBound(badChars)
fileName = Replace$(fileName, CStr(badChars(i)), "_")
Next i
SanitizeFileName = fileName
End Function
Private Function SafeLogText(ByVal msg As String) As String
msg = Replace$(msg, vbCrLf, " ")
msg = Replace$(msg, vbCr, " ")
msg = Replace$(msg, vbLf, " ")
SafeLogText = msg
End Function
Private Function PadLevelName(ByVal levelName As String) As String
levelName = UCase$(Trim$(levelName))
If Len(levelName) = 0 Then levelName = "INFO"
Do While Len(levelName) < 5
levelName = levelName & " "
Loop
PadLevelName = Left$(levelName, 5)
End Function
Private Function FileTimestamp() As String
FileTimestamp = Format$(Now, "yyyymmdd_hhnnss")
End Function
Private Function GetSolidWorksVersionSafe() As String
On Error Resume Next
GetSolidWorksVersionSafe = ""
If Not g_swApp Is Nothing Then GetSolidWorksVersionSafe = SafeStr(g_swApp.RevisionNumber)
If Len(GetSolidWorksVersionSafe) = 0 Then GetSolidWorksVersionSafe = "Unavailable"
If Err.Number <> 0 Then
Err.Clear
GetSolidWorksVersionSafe = "Unavailable"
End If
On Error GoTo 0
End Function
Private Function ModelTitleSafe(ByVal swModel As SldWorks.ModelDoc2) As String
On Error Resume Next
ModelTitleSafe = ""
If swModel Is Nothing Then
ModelTitleSafe = "None"
Else
ModelTitleSafe = SafeStr(swModel.GetTitle)
End If
If Len(ModelTitleSafe) = 0 Then ModelTitleSafe = "Untitled"
If Err.Number <> 0 Then
Err.Clear
ModelTitleSafe = "Unavailable"
End If
On Error GoTo 0
End Function
Private Function ModelPathSafe(ByVal swModel As SldWorks.ModelDoc2) As String
On Error Resume Next
ModelPathSafe = ""
If Not swModel Is Nothing Then ModelPathSafe = SafeStr(swModel.GetPathName)
If Err.Number <> 0 Then
Err.Clear
ModelPathSafe = ""
End If
If Len(ModelPathSafe) = 0 Then ModelPathSafe = "(unsaved)"
On Error GoTo 0
End Function
Private Function IsModelSavedSafe(ByVal swModel As SldWorks.ModelDoc2) As Boolean
On Error Resume Next
IsModelSavedSafe = False
If swModel Is Nothing Then Exit Function
IsModelSavedSafe = (Len(Trim$(SafeStr(swModel.GetPathName))) > 0)
If Err.Number <> 0 Then
Err.Clear
IsModelSavedSafe = False
End If
On Error GoTo 0
End Function
Private Function ActiveConfigurationNameForLog(ByVal swModel As SldWorks.ModelDoc2) As String
On Error Resume Next
ActiveConfigurationNameForLog = ""
If swModel Is Nothing Then
ActiveConfigurationNameForLog = "None"
Exit Function
End If
If swModel.GetType = swDocumentTypes_e.swDocDRAWING Then
ActiveConfigurationNameForLog = "(drawing document)"
Else
ActiveConfigurationNameForLog = GetActiveConfigurationNameSafe(swModel)
End If
If Len(ActiveConfigurationNameForLog) = 0 Then ActiveConfigurationNameForLog = "Unavailable"
If Err.Number <> 0 Then
Err.Clear
ActiveConfigurationNameForLog = "Unavailable"
End If
On Error GoTo 0
End Function
Private Function DocumentTypeNameSafe(ByVal docType As Long) As String
Select Case docType
Case swDocumentTypes_e.swDocPART
DocumentTypeNameSafe = "PART"
Case swDocumentTypes_e.swDocASSEMBLY
DocumentTypeNameSafe = "ASSEMBLY"
Case swDocumentTypes_e.swDocDRAWING
DocumentTypeNameSafe = "DRAWING"
Case Else
DocumentTypeNameSafe = "UNKNOWN(" & CStr(docType) & ")"
End Select
End Function
'====================================================================================
' PLATE / SHEET FACE-CORNER ORIENTATION HELPERS (V8.11)
'====================================================================================
Private Function HybridCandidateTrustAdjustment(ByVal sourceName As String, _
ByVal item As Object, _
ByVal rotateDetail As String, _
ByVal finalValidationDetail As String) As Double
On Error GoTo EH
HybridCandidateTrustAdjustment = 0#
If UCase$(Trim$(sourceName)) <> "CUSTOM_VIEW" Then Exit Function
If item Is Nothing Then Exit Function
If UCase$(SafeStr(item("BodySubtype"))) = CAT_SUBTYPE_ANGLE Then
If InStr(1, rotateDetail, "method=model-edge-family", vbTextCompare) > 0 And _
InStr(1, rotateDetail, "usedFallback=True", vbTextCompare) = 0 Then
HybridCandidateTrustAdjustment = 0#
Else
HybridCandidateTrustAdjustment = -PLATE_CUSTOM_VIEW_STRICT_PENALTY
End If
Exit Function
End If
If IsPlateLikeOrientationItem(item) Then
If InStr(1, rotateDetail, "method=plate-face-corner", vbTextCompare) > 0 Then
HybridCandidateTrustAdjustment = 0#
Else
HybridCandidateTrustAdjustment = -PLATE_CUSTOM_VIEW_STRICT_PENALTY
End If
Exit Function
End If
If InStr(1, finalValidationDetail, "method=projected-category", vbTextCompare) > 0 Then
HybridCandidateTrustAdjustment = -PLATE_CUSTOM_VIEW_PENALTY
End If
Exit Function
EH:
HybridCandidateTrustAdjustment = 0#
End Function
Private Function IsPlateLikeOrientationItem(ByVal item As Object) As Boolean
On Error GoTo EH
IsPlateLikeOrientationItem = False
If item Is Nothing Then Exit Function
Dim catName As String
Dim subtypeName As String
Dim thinRatio As Double
Dim dx As Double, dy As Double, dz As Double
Dim thick As Double
Dim spanA As Double, spanB As Double
catName = UCase$(SafeStr(item("BodyCategory")))
subtypeName = UCase$(SafeStr(item("BodySubtype")))
If catName = UCase$(CAT_NAME_SHEET_PLATE) Then
IsPlateLikeOrientationItem = True
Exit Function
End If
If subtypeName = CAT_SUBTYPE_PLATE Or subtypeName = CAT_SUBTYPE_GUSSET Then
IsPlateLikeOrientationItem = True
Exit Function
End If
dx = SafeCDbl(item("dx"))
dy = SafeCDbl(item("dy"))
dz = SafeCDbl(item("dz"))
thick = dx
If dy < thick Then thick = dy
If dz < thick Then thick = dz
spanA = dx
spanB = dy
If spanA < spanB Then
spanA = dy
spanB = dx
End If
If dz > spanA Then
spanB = spanA
spanA = dz
ElseIf dz > spanB Then
spanB = dz
End If
If spanA > 0# Then
thinRatio = thick / spanA
If thinRatio <= CAT_PLATE_THIN_RATIO_MAX Then
IsPlateLikeOrientationItem = True
Exit Function
End If
End If
Exit Function
EH:
IsPlateLikeOrientationItem = False
End Function
Private Function TryGetPlateFabricationFrameFromBody(ByVal item As Object, _
ByRef primaryX As Double, _
ByRef primaryY As Double, _
ByRef primaryZ As Double, _
ByRef secondaryX As Double, _
ByRef secondaryY As Double, _
ByRef secondaryZ As Double, _
ByRef hasSecondary As Boolean, _
ByRef frameReason As String) As Boolean
On Error GoTo EH
TryGetPlateFabricationFrameFromBody = False
primaryX = 0#: primaryY = 0#: primaryZ = 0#
secondaryX = 0#: secondaryY = 0#: secondaryZ = 0#
hasSecondary = False
frameReason = ""
If item Is Nothing Then
frameReason = "item is Nothing"
Exit Function
End If
Dim swBody As SldWorks.Body2
Set swBody = Nothing
On Error Resume Next
Set swBody = item("RepBody_Model")
On Error GoTo EH
If swBody Is Nothing Then
frameReason = "RepBody_Model is Nothing"
Exit Function
End If
Dim swFace As SldWorks.Face2
Set swFace = PlateGetLargestPlanarFaceOnBody(swBody)
If swFace Is Nothing Then
frameReason = "largest planar face not found"
Exit Function
End If
Dim faceNormal(0 To 2) As Double
If Not PlateTryGetStableFaceNormal(swFace, faceNormal) Then
frameReason = "stable face normal unavailable"
Exit Function
End If
If Not PlateFindHorizontalDirectionFromFace(swFace, faceNormal, primaryX, primaryY, primaryZ, frameReason) Then
frameReason = "horizontal direction unavailable | " & frameReason
Exit Function
End If
secondaryX = faceNormal(0)
secondaryY = faceNormal(1)
secondaryZ = faceNormal(2)
Dim inPlaneYx As Double, inPlaneYy As Double, inPlaneYz As Double
Cross3 secondaryX, secondaryY, secondaryZ, primaryX, primaryY, primaryZ, inPlaneYx, inPlaneYy, inPlaneYz
If Not NormalizeVector3(inPlaneYx, inPlaneYy, inPlaneYz) Then
Cross3 primaryX, primaryY, primaryZ, secondaryX, secondaryY, secondaryZ, inPlaneYx, inPlaneYy, inPlaneYz
If Not NormalizeVector3(inPlaneYx, inPlaneYy, inPlaneYz) Then
frameReason = "failed to derive in-plane secondary axis | " & frameReason
Exit Function
End If
End If
secondaryX = inPlaneYx
secondaryY = inPlaneYy
secondaryZ = inPlaneYz
hasSecondary = True
frameReason = frameReason & _
" | primary=(" & Fmt(primaryX) & "," & Fmt(primaryY) & "," & Fmt(primaryZ) & ")" & _
" | secondary=(" & Fmt(secondaryX) & "," & Fmt(secondaryY) & "," & Fmt(secondaryZ) & ")" & _
" | faceNormal=(" & Fmt(faceNormal(0)) & "," & Fmt(faceNormal(1)) & "," & Fmt(faceNormal(2)) & ")"
TryGetPlateFabricationFrameFromBody = True
Exit Function
EH:
frameReason = "TryGetPlateFabricationFrameFromBody exception | " & Err.Number & " | " & Err.Description
LogWarn frameReason & " | itemNo=" & SafeStr(item("ItemNo"))
TryGetPlateFabricationFrameFromBody = False
End Function
Private Function PlateGetLargestPlanarFaceOnBody(ByVal swBody As SldWorks.Body2) As SldWorks.Face2
On Error GoTo EH
Set PlateGetLargestPlanarFaceOnBody = Nothing
If swBody Is Nothing Then Exit Function
Dim vFaces As Variant
vFaces = swBody.GetFaces
If IsEmpty(vFaces) Then Exit Function
If Not IsArray(vFaces) Then Exit Function
Dim bestArea As Double
bestArea = -1#
Dim i As Long
For i = LBound(vFaces) To UBound(vFaces)
Dim swFace As SldWorks.Face2
Set swFace = Nothing
On Error Resume Next
Set swFace = vFaces(i)
On Error GoTo EH
If Not swFace Is Nothing Then
Dim swSurf As SldWorks.Surface
Set swSurf = swFace.GetSurface
If Not swSurf Is Nothing Then
If swSurf.isPlane Then
Dim areaVal As Double
areaVal = 0#
On Error Resume Next
areaVal = swFace.GetArea
On Error GoTo EH
If areaVal > bestArea Then
bestArea = areaVal
Set PlateGetLargestPlanarFaceOnBody = swFace
End If
End If
End If
End If
Next i
Exit Function
EH:
Set PlateGetLargestPlanarFaceOnBody = Nothing
End Function
Private Function PlateTryGetStableFaceNormal(ByVal swFace As SldWorks.Face2, ByRef n() As Double) As Boolean
On Error GoTo EH
PlateTryGetStableFaceNormal = False
If swFace Is Nothing Then Exit Function
If PlateTryGetNormalFromFaceVertices(swFace, n) Then
If NormalizeVector3(n(0), n(1), n(2)) Then
CanonicalizeVectorPositive n(0), n(1), n(2)
PlateTryGetStableFaceNormal = True
Exit Function
End If
End If
Dim vNorm As Variant
On Error Resume Next
vNorm = swFace.Normal
On Error GoTo EH
If PlateVariantHas3Numbers(vNorm) Then
n(0) = CDbl(vNorm(LBound(vNorm) + 0))
n(1) = CDbl(vNorm(LBound(vNorm) + 1))
n(2) = CDbl(vNorm(LBound(vNorm) + 2))
If NormalizeVector3(n(0), n(1), n(2)) Then
CanonicalizeVectorPositive n(0), n(1), n(2)
PlateTryGetStableFaceNormal = True
Exit Function
End If
End If
Dim swSurf As SldWorks.Surface
Set swSurf = swFace.GetSurface
If Not swSurf Is Nothing Then
Dim planeProps As Variant
On Error Resume Next
planeProps = swSurf.PlaneParams
On Error GoTo EH
If PlateVariantHasAtLeast6Numbers(planeProps) Then
n(0) = CDbl(planeProps(LBound(planeProps) + 3))
n(1) = CDbl(planeProps(LBound(planeProps) + 4))
n(2) = CDbl(planeProps(LBound(planeProps) + 5))
If NormalizeVector3(n(0), n(1), n(2)) Then
CanonicalizeVectorPositive n(0), n(1), n(2)
PlateTryGetStableFaceNormal = True
Exit Function
End If
End If
End If
Exit Function
EH:
PlateTryGetStableFaceNormal = False
End Function
Private Function PlateTryGetNormalFromFaceVertices(ByVal swFace As SldWorks.Face2, ByRef n() As Double) As Boolean
On Error GoTo EH
PlateTryGetNormalFromFaceVertices = False
If swFace Is Nothing Then Exit Function
Dim vEdges As Variant
vEdges = swFace.GetEdges
If IsEmpty(vEdges) Then Exit Function
If Not IsArray(vEdges) Then Exit Function
Dim pts() As Double
Dim ptCount As Long
ptCount = 0
Dim i As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim swEdge As SldWorks.Edge
Set swEdge = Nothing
On Error Resume Next
Set swEdge = vEdges(i)
On Error GoTo EH
If Not swEdge Is Nothing Then
Dim p0(0 To 2) As Double
Dim p1(0 To 2) As Double
If PlateGetEdgeEndPoints(swEdge, p0, p1) Then
PlateAddUniquePoint3 pts, ptCount, p0
PlateAddUniquePoint3 pts, ptCount, p1
End If
End If
Next i
If ptCount < 3 Then Exit Function
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 ax As Double, ay As Double, az As Double
Dim bx As Double, by As Double, bz As Double
ax = pts(0, i1) - pts(0, i0)
ay = pts(1, i1) - pts(1, i0)
az = pts(2, i1) - pts(2, i0)
bx = pts(0, i2) - pts(0, i0)
by = pts(1, i2) - pts(1, i0)
bz = pts(2, i2) - pts(2, i0)
Cross3 ax, ay, az, bx, by, bz, n(0), n(1), n(2)
If Sqr((n(0) * n(0)) + (n(1) * n(1)) + (n(2) * n(2))) > PLATE_FACE_NORMAL_EPS Then
PlateTryGetNormalFromFaceVertices = True
Exit Function
End If
Next i2
Next i1
Next i0
Exit Function
EH:
PlateTryGetNormalFromFaceVertices = False
End Function
Private Sub PlateAddUniquePoint3(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)) <= PLATE_POINT_TOL And _
Abs(pts(1, i) - p(1)) <= PLATE_POINT_TOL And _
Abs(pts(2, i) - p(2)) <= PLATE_POINT_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 PlateVariantHas3Numbers(ByVal v As Variant) As Boolean
On Error GoTo EH
PlateVariantHas3Numbers = 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 tmp As Double
tmp = CDbl(v(lb + 0))
tmp = CDbl(v(lb + 1))
tmp = CDbl(v(lb + 2))
PlateVariantHas3Numbers = True
Exit Function
EH:
PlateVariantHas3Numbers = False
End Function
Private Function PlateVariantHasAtLeast6Numbers(ByVal v As Variant) As Boolean
On Error GoTo EH
PlateVariantHasAtLeast6Numbers = 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
Dim tmp As Double
For i = 0 To 5
tmp = CDbl(v(lb + i))
Next i
PlateVariantHasAtLeast6Numbers = True
Exit Function
EH:
PlateVariantHasAtLeast6Numbers = False
End Function
Private Function PlateFindHorizontalDirectionFromFace(ByVal swFace As SldWorks.Face2, _
ByRef faceNormal() As Double, _
ByRef outX As Double, _
ByRef outY As Double, _
ByRef outZ As Double, _
ByRef detailText As String) As Boolean
On Error GoTo EH
PlateFindHorizontalDirectionFromFace = False
outX = 0#: outY = 0#: outZ = 0#
detailText = ""
If swFace Is Nothing Then
detailText = "face is Nothing"
Exit Function
End If
Dim sharedFound As Boolean
Dim virtualFound As Boolean
Dim sharedPrimaryLen As Double, sharedSecondaryLen As Double
Dim sharedX(0 To 2) As Double, sharedY(0 To 2) As Double, sharedCorner(0 To 2) As Double
Dim virtualPrimaryLen As Double, virtualSecondaryLen As Double
Dim virtualX(0 To 2) As Double, virtualY(0 To 2) As Double, virtualCorner(0 To 2) As Double
sharedFound = PlateGetBestSharedCornerOrientationCandidate(swFace, faceNormal, sharedPrimaryLen, sharedSecondaryLen, sharedX, sharedY, sharedCorner)
virtualFound = PlateGetBestVirtualCornerOrientationCandidate(swFace, faceNormal, virtualPrimaryLen, virtualSecondaryLen, virtualX, virtualY, virtualCorner)
If sharedFound Then
If virtualFound Then
If PlateIsPairLengthBetter(virtualPrimaryLen, virtualSecondaryLen, sharedPrimaryLen, sharedSecondaryLen) Then
outX = virtualX(0): outY = virtualX(1): outZ = virtualX(2)
detailText = "mode=virtual-corner override | primaryLen=" & Fmt(virtualPrimaryLen) & _
" | secondaryLen=" & Fmt(virtualSecondaryLen)
Else
outX = sharedX(0): outY = sharedX(1): outZ = sharedX(2)
detailText = "mode=shared-corner | primaryLen=" & Fmt(sharedPrimaryLen) & _
" | secondaryLen=" & Fmt(sharedSecondaryLen)
End If
CanonicalizeVectorPositive outX, outY, outZ
PlateFindHorizontalDirectionFromFace = NormalizeVector3(outX, outY, outZ)
Exit Function
Else
outX = sharedX(0): outY = sharedX(1): outZ = sharedX(2)
CanonicalizeVectorPositive outX, outY, outZ
detailText = "mode=shared-corner | primaryLen=" & Fmt(sharedPrimaryLen) & _
" | secondaryLen=" & Fmt(sharedSecondaryLen)
PlateFindHorizontalDirectionFromFace = NormalizeVector3(outX, outY, outZ)
Exit Function
End If
End If
If virtualFound Then
outX = virtualX(0): outY = virtualX(1): outZ = virtualX(2)
CanonicalizeVectorPositive outX, outY, outZ
detailText = "mode=virtual-corner fallback | primaryLen=" & Fmt(virtualPrimaryLen) & _
" | secondaryLen=" & Fmt(virtualSecondaryLen)
PlateFindHorizontalDirectionFromFace = NormalizeVector3(outX, outY, outZ)
Exit Function
End If
Dim vEdges As Variant
vEdges = swFace.GetEdges
Dim bestLen As Double
bestLen = -1#
Dim bestVec(0 To 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 swEdge As SldWorks.Edge
Set swEdge = Nothing
On Error Resume Next
Set swEdge = vEdges(i)
On Error GoTo EH
If Not swEdge Is Nothing Then
If PlateEdgeIsLinear(swEdge) Then
Dim p0(0 To 2) As Double, p1(0 To 2) As Double
If PlateGetEdgeEndPoints(swEdge, p0, p1) Then
Dim vx As Double, vy As Double, vz As Double
vx = p1(0) - p0(0)
vy = p1(1) - p0(1)
vz = p1(2) - p0(2)
PlateProjectVectorOntoPlane vx, vy, vz, faceNormal(0), faceNormal(1), faceNormal(2)
Dim L As Double
L = Sqr((vx * vx) + (vy * vy) + (vz * vz))
If L > PLATE_FACE_NORMAL_EPS Then
vx = vx / L: vy = vy / L: vz = vz / L
CanonicalizeVectorPositive vx, vy, vz
Dim trueLen As Double
trueLen = PlateDistance3(p0, p1)
If (trueLen > bestLen + PLATE_FACE_NORMAL_EPS) Or _
(Abs(trueLen - bestLen) <= PLATE_FACE_NORMAL_EPS And PlateCompareVectorLex(vx, vy, vz, bestVec(0), bestVec(1), bestVec(2)) > 0) Then
bestLen = trueLen
bestVec(0) = vx: bestVec(1) = vy: bestVec(2) = vz
foundLine = True
End If
End If
End If
End If
End If
Next i
End If
End If
If foundLine Then
outX = bestVec(0): outY = bestVec(1): outZ = bestVec(2)
detailText = "mode=longest-linear-edge fallback | length=" & Fmt(bestLen)
PlateFindHorizontalDirectionFromFace = True
Exit Function
End If
PlateChooseFallbackXAxis faceNormal(0), faceNormal(1), faceNormal(2), outX, outY, outZ
detailText = "mode=world-axis fallback"
PlateFindHorizontalDirectionFromFace = NormalizeVector3(outX, outY, outZ)
Exit Function
EH:
detailText = "PlateFindHorizontalDirectionFromFace exception | " & Err.Number & " | " & Err.Description
PlateFindHorizontalDirectionFromFace = False
End Function
Private Function PlateGetBestSharedCornerOrientationCandidate(ByVal swFace 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
PlateGetBestSharedCornerOrientationCandidate = False
If swFace Is Nothing Then Exit Function
Dim vEdges As Variant
vEdges = swFace.GetEdges
If IsEmpty(vEdges) Then Exit Function
If Not IsArray(vEdges) Then Exit Function
bestPrimaryLen = -1#
bestSecondaryLen = -1#
Dim foundPair As Boolean
foundPair = False
Dim i As Long, j As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim ed1 As SldWorks.Edge
Set ed1 = Nothing
On Error Resume Next
Set ed1 = vEdges(i)
On Error GoTo EH
If Not ed1 Is Nothing Then
If PlateEdgeIsLinear(ed1) Then
Dim e1p0(0 To 2) As Double, e1p1(0 To 2) As Double
If PlateGetEdgeEndPoints(ed1, e1p0, e1p1) Then
For j = i + 1 To UBound(vEdges)
Dim ed2 As SldWorks.Edge
Set ed2 = Nothing
On Error Resume Next
Set ed2 = vEdges(j)
On Error GoTo EH
If Not ed2 Is Nothing Then
If PlateEdgeIsLinear(ed2) Then
Dim e2p0(0 To 2) As Double, e2p1(0 To 2) As Double
If PlateGetEdgeEndPoints(ed2, e2p0, e2p1) Then
Dim corner(0 To 2) As Double
Dim far1(0 To 2) As Double
Dim far2(0 To 2) As Double
If PlateTryGetSharedCornerFromEdgeEndpoints(e1p0, e1p1, e2p0, e2p1, corner, far1, far2) Then
Dim vx1 As Double, vy1 As Double, vz1 As Double
Dim vx2 As Double, vy2 As Double, vz2 As Double
vx1 = far1(0) - corner(0): vy1 = far1(1) - corner(1): vz1 = far1(2) - corner(2)
vx2 = far2(0) - corner(0): vy2 = far2(1) - corner(1): vz2 = far2(2) - corner(2)
PlateProjectVectorOntoPlane vx1, vy1, vz1, faceNormal(0), faceNormal(1), faceNormal(2)
PlateProjectVectorOntoPlane vx2, vy2, vz2, faceNormal(0), faceNormal(1), faceNormal(2)
Dim len1 As Double, len2 As Double
len1 = Sqr((vx1 * vx1) + (vy1 * vy1) + (vz1 * vz1))
len2 = Sqr((vx2 * vx2) + (vy2 * vy2) + (vz2 * vz2))
If len1 > PLATE_FACE_NORMAL_EPS And len2 > PLATE_FACE_NORMAL_EPS Then
vx1 = vx1 / len1: vy1 = vy1 / len1: vz1 = vz1 / len1
vx2 = vx2 / len2: vy2 = vy2 / len2: vz2 = vz2 / len2
Dim dotVal As Double
dotVal = Abs(Dot3(vx1, vy1, vz1, vx2, vy2, vz2))
If dotVal <= PLATE_PERP_DOT_TOL Then
Dim candPrimaryLen As Double, candSecondaryLen As Double
Dim candX(0 To 2) As Double, candY(0 To 2) As Double
If len1 >= len2 Then
candPrimaryLen = len1
candSecondaryLen = len2
candX(0) = vx1: candX(1) = vy1: candX(2) = vz1
candY(0) = vx2: candY(1) = vy2: candY(2) = vz2
Else
candPrimaryLen = len2
candSecondaryLen = len1
candX(0) = vx2: candX(1) = vy2: candX(2) = vz2
candY(0) = vx1: candY(1) = vy1: candY(2) = vz1
End If
If (Not foundPair) Or PlateIsPairLengthBetter(candPrimaryLen, candSecondaryLen, bestPrimaryLen, bestSecondaryLen) Then
bestPrimaryLen = candPrimaryLen
bestSecondaryLen = candSecondaryLen
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
PlateGetBestSharedCornerOrientationCandidate = foundPair
Exit Function
EH:
PlateGetBestSharedCornerOrientationCandidate = False
End Function
Private Function PlateGetBestVirtualCornerOrientationCandidate(ByVal swFace 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
PlateGetBestVirtualCornerOrientationCandidate = False
If swFace Is Nothing Then Exit Function
Dim vEdges As Variant
vEdges = swFace.GetEdges
If IsEmpty(vEdges) Then Exit Function
If Not IsArray(vEdges) Then Exit Function
bestPrimaryLen = -1#
bestSecondaryLen = -1#
Dim foundPair As Boolean
foundPair = False
Dim i As Long, j As Long
For i = LBound(vEdges) To UBound(vEdges)
Dim ed1 As SldWorks.Edge
Set ed1 = Nothing
On Error Resume Next
Set ed1 = vEdges(i)
On Error GoTo EH
If Not ed1 Is Nothing Then
If PlateEdgeIsLinear(ed1) Then
Dim e1p0(0 To 2) As Double, e1p1(0 To 2) As Double
If PlateGetEdgeEndPoints(ed1, e1p0, e1p1) Then
For j = i + 1 To UBound(vEdges)
Dim ed2 As SldWorks.Edge
Set ed2 = Nothing
On Error Resume Next
Set ed2 = vEdges(j)
On Error GoTo EH
If Not ed2 Is Nothing Then
If PlateEdgeIsLinear(ed2) Then
Dim e2p0(0 To 2) As Double, e2p1(0 To 2) As Double
If PlateGetEdgeEndPoints(ed2, e2p0, e2p1) Then
Dim sharedCorner(0 To 2) As Double
Dim sharedFar1(0 To 2) As Double
Dim sharedFar2(0 To 2) As Double
If Not PlateTryGetSharedCornerFromEdgeEndpoints(e1p0, e1p1, e2p0, e2p1, sharedCorner, sharedFar1, sharedFar2) Then
Dim corner(0 To 2) As Double
Dim far1(0 To 2) As Double
Dim far2(0 To 2) As Double
If PlateBuildVirtualCornerFromEdges(e1p0, e1p1, e2p0, e2p1, corner, far1, far2) Then
Dim vx1 As Double, vy1 As Double, vz1 As Double
Dim vx2 As Double, vy2 As Double, vz2 As Double
vx1 = far1(0) - corner(0): vy1 = far1(1) - corner(1): vz1 = far1(2) - corner(2)
vx2 = far2(0) - corner(0): vy2 = far2(1) - corner(1): vz2 = far2(2) - corner(2)
PlateProjectVectorOntoPlane vx1, vy1, vz1, faceNormal(0), faceNormal(1), faceNormal(2)
PlateProjectVectorOntoPlane vx2, vy2, vz2, faceNormal(0), faceNormal(1), faceNormal(2)
Dim len1 As Double, len2 As Double
len1 = Sqr((vx1 * vx1) + (vy1 * vy1) + (vz1 * vz1))
len2 = Sqr((vx2 * vx2) + (vy2 * vy2) + (vz2 * vz2))
If len1 > PLATE_FACE_NORMAL_EPS And len2 > PLATE_FACE_NORMAL_EPS Then
vx1 = vx1 / len1: vy1 = vy1 / len1: vz1 = vz1 / len1
vx2 = vx2 / len2: vy2 = vy2 / len2: vz2 = vz2 / len2
Dim dotVal As Double
dotVal = Abs(Dot3(vx1, vy1, vz1, vx2, vy2, vz2))
If dotVal <= PLATE_PERP_DOT_TOL Then
Dim candPrimaryLen As Double, candSecondaryLen As Double
Dim candX(0 To 2) As Double, candY(0 To 2) As Double
If len1 >= len2 Then
candPrimaryLen = len1
candSecondaryLen = len2
candX(0) = vx1: candX(1) = vy1: candX(2) = vz1
candY(0) = vx2: candY(1) = vy2: candY(2) = vz2
Else
candPrimaryLen = len2
candSecondaryLen = len1
candX(0) = vx2: candX(1) = vy2: candX(2) = vz2
candY(0) = vx1: candY(1) = vy1: candY(2) = vz1
End If
If (Not foundPair) Or PlateIsPairLengthBetter(candPrimaryLen, candSecondaryLen, bestPrimaryLen, bestSecondaryLen) Then
bestPrimaryLen = candPrimaryLen
bestSecondaryLen = candSecondaryLen
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
End If
Next j
End If
End If
End If
Next i
PlateGetBestVirtualCornerOrientationCandidate = foundPair
Exit Function
EH:
PlateGetBestVirtualCornerOrientationCandidate = False
End Function
Private Function PlateBuildVirtualCornerFromEdges(ByRef e1p0() As Double, _
ByRef e1p1() As Double, _
ByRef e2p0() As Double, _
ByRef e2p1() As Double, _
ByRef corner() As Double, _
ByRef far1() As Double, _
ByRef far2() As Double) As Boolean
On Error GoTo EH
PlateBuildVirtualCornerFromEdges = False
Dim bestD As Double
Dim choice As Long
bestD = 1E+100
choice = 0
Dim d As Double
d = PlateDistance3(e1p0, e2p0)
If d < bestD Then bestD = d: choice = 1
d = PlateDistance3(e1p0, e2p1)
If d < bestD Then bestD = d: choice = 2
d = PlateDistance3(e1p1, e2p0)
If d < bestD Then bestD = d: choice = 3
d = PlateDistance3(e1p1, e2p1)
If d < bestD Then bestD = d: choice = 4
If choice = 0 Then Exit Function
Select Case choice
Case 1
corner(0) = (e1p0(0) + e2p0(0)) / 2#
corner(1) = (e1p0(1) + e2p0(1)) / 2#
corner(2) = (e1p0(2) + e2p0(2)) / 2#
far1(0) = e1p1(0): far1(1) = e1p1(1): far1(2) = e1p1(2)
far2(0) = e2p1(0): far2(1) = e2p1(1): far2(2) = e2p1(2)
Case 2
corner(0) = (e1p0(0) + e2p1(0)) / 2#
corner(1) = (e1p0(1) + e2p1(1)) / 2#
corner(2) = (e1p0(2) + e2p1(2)) / 2#
far1(0) = e1p1(0): far1(1) = e1p1(1): far1(2) = e1p1(2)
far2(0) = e2p0(0): far2(1) = e2p0(1): far2(2) = e2p0(2)
Case 3
corner(0) = (e1p1(0) + e2p0(0)) / 2#
corner(1) = (e1p1(1) + e2p0(1)) / 2#
corner(2) = (e1p1(2) + e2p0(2)) / 2#
far1(0) = e1p0(0): far1(1) = e1p0(1): far1(2) = e1p0(2)
far2(0) = e2p1(0): far2(1) = e2p1(1): far2(2) = e2p1(2)
Case 4
corner(0) = (e1p1(0) + e2p1(0)) / 2#
corner(1) = (e1p1(1) + e2p1(1)) / 2#
corner(2) = (e1p1(2) + e2p1(2)) / 2#
far1(0) = e1p0(0): far1(1) = e1p0(1): far1(2) = e1p0(2)
far2(0) = e2p0(0): far2(1) = e2p0(1): far2(2) = e2p0(2)
End Select
PlateBuildVirtualCornerFromEdges = True
Exit Function
EH:
PlateBuildVirtualCornerFromEdges = False
End Function
Private Function PlateTryGetSharedCornerFromEdgeEndpoints(ByRef e1p0() As Double, _
ByRef e1p1() As Double, _
ByRef e2p0() As Double, _
ByRef e2p1() As Double, _
ByRef sharedCorner() As Double, _
ByRef far1() As Double, _
ByRef far2() As Double) As Boolean
On Error GoTo EH
PlateTryGetSharedCornerFromEdgeEndpoints = False
If PlatePointsEqual3(e1p0, e2p0) Then
sharedCorner(0) = e1p0(0): sharedCorner(1) = e1p0(1): sharedCorner(2) = e1p0(2)
far1(0) = e1p1(0): far1(1) = e1p1(1): far1(2) = e1p1(2)
far2(0) = e2p1(0): far2(1) = e2p1(1): far2(2) = e2p1(2)
PlateTryGetSharedCornerFromEdgeEndpoints = True
Exit Function
End If
If PlatePointsEqual3(e1p0, e2p1) Then
sharedCorner(0) = e1p0(0): sharedCorner(1) = e1p0(1): sharedCorner(2) = e1p0(2)
far1(0) = e1p1(0): far1(1) = e1p1(1): far1(2) = e1p1(2)
far2(0) = e2p0(0): far2(1) = e2p0(1): far2(2) = e2p0(2)
PlateTryGetSharedCornerFromEdgeEndpoints = True
Exit Function
End If
If PlatePointsEqual3(e1p1, e2p0) Then
sharedCorner(0) = e1p1(0): sharedCorner(1) = e1p1(1): sharedCorner(2) = e1p1(2)
far1(0) = e1p0(0): far1(1) = e1p0(1): far1(2) = e1p0(2)
far2(0) = e2p1(0): far2(1) = e2p1(1): far2(2) = e2p1(2)
PlateTryGetSharedCornerFromEdgeEndpoints = True
Exit Function
End If
If PlatePointsEqual3(e1p1, e2p1) Then
sharedCorner(0) = e1p1(0): sharedCorner(1) = e1p1(1): sharedCorner(2) = e1p1(2)
far1(0) = e1p0(0): far1(1) = e1p0(1): far1(2) = e1p0(2)
far2(0) = e2p0(0): far2(1) = e2p0(1): far2(2) = e2p0(2)
PlateTryGetSharedCornerFromEdgeEndpoints = True
Exit Function
End If
Exit Function
EH:
PlateTryGetSharedCornerFromEdgeEndpoints = False
End Function
Private Function PlatePointsEqual3(ByRef p1() As Double, ByRef p2() As Double) As Boolean
PlatePointsEqual3 = (Abs(p1(0) - p2(0)) <= PLATE_POINT_TOL) And _
(Abs(p1(1) - p2(1)) <= PLATE_POINT_TOL) And _
(Abs(p1(2) - p2(2)) <= PLATE_POINT_TOL)
End Function
Private Function PlateIsPairLengthBetter(ByVal primaryA As Double, _
ByVal secondaryA As Double, _
ByVal primaryB As Double, _
ByVal secondaryB As Double) As Boolean
If primaryA > (primaryB + PLATE_FACE_NORMAL_EPS) Then
PlateIsPairLengthBetter = True
ElseIf Abs(primaryA - primaryB) <= PLATE_FACE_NORMAL_EPS Then
PlateIsPairLengthBetter = (secondaryA > (secondaryB + PLATE_FACE_NORMAL_EPS))
Else
PlateIsPairLengthBetter = False
End If
End Function
Private Function PlateEdgeIsLinear(ByVal swEdge As SldWorks.Edge) As Boolean
On Error GoTo EH
PlateEdgeIsLinear = False
If swEdge Is Nothing Then Exit Function
Dim swCurve As SldWorks.Curve
Set swCurve = swEdge.GetCurve
If swCurve Is Nothing Then Exit Function
On Error Resume Next
PlateEdgeIsLinear = swCurve.isLine
On Error GoTo EH
Exit Function
EH:
PlateEdgeIsLinear = False
End Function
Private Function PlateGetEdgeEndPoints(ByVal swEdge As SldWorks.Edge, _
ByRef p0() As Double, _
ByRef p1() As Double) As Boolean
On Error GoTo EH
PlateGetEdgeEndPoints = False
If swEdge Is Nothing Then Exit Function
Dim swStartVtx As SldWorks.Vertex
Dim swEndVtx As SldWorks.Vertex
Set swStartVtx = swEdge.GetStartVertex
Set swEndVtx = swEdge.GetEndVertex
If swStartVtx Is Nothing Or swEndVtx Is Nothing Then Exit Function
Dim v0 As Variant
Dim v1 As Variant
v0 = swStartVtx.GetPoint
v1 = swEndVtx.GetPoint
If Not IsArray(v0) Or Not IsArray(v1) Then Exit Function
p0(0) = CDbl(v0(0)): p0(1) = CDbl(v0(1)): p0(2) = CDbl(v0(2))
p1(0) = CDbl(v1(0)): p1(1) = CDbl(v1(1)): p1(2) = CDbl(v1(2))
PlateGetEdgeEndPoints = True
Exit Function
EH:
PlateGetEdgeEndPoints = False
End Function
Private Sub PlateProjectVectorOntoPlane(ByRef vx As Double, _
ByRef vy As Double, _
ByRef vz As Double, _
ByVal nx As Double, _
ByVal ny As Double, _
ByVal nz As Double)
Dim d As Double
d = Dot3(vx, vy, vz, nx, ny, nz)
vx = vx - (d * nx)
vy = vy - (d * ny)
vz = vz - (d * nz)
End Sub
Private Sub PlateChooseFallbackXAxis(ByVal nx As Double, ByVal ny As Double, ByVal nz As Double, _
ByRef outX As Double, ByRef outY As Double, ByRef outZ As Double)
outX = 1#: outY = 0#: outZ = 0#
PlateProjectVectorOntoPlane outX, outY, outZ, nx, ny, nz
If Not NormalizeVector3(outX, outY, outZ) Then
outX = 0#: outY = 1#: outZ = 0#
PlateProjectVectorOntoPlane outX, outY, outZ, nx, ny, nz
If Not NormalizeVector3(outX, outY, outZ) Then
outX = 0#: outY = 0#: outZ = 1#
PlateProjectVectorOntoPlane outX, outY, outZ, nx, ny, nz
Call NormalizeVector3(outX, outY, outZ)
End If
End If
CanonicalizeVectorPositive outX, outY, outZ
End Sub
Private Function PlateDistance3(ByRef p0() As Double, ByRef p1() As Double) As Double
Dim dx As Double, dy As Double, dz As Double
dx = p1(0) - p0(0)
dy = p1(1) - p0(1)
dz = p1(2) - p0(2)
PlateDistance3 = Sqr((dx * dx) + (dy * dy) + (dz * dz))
End Function
Private Function PlateCompareVectorLex(ByVal ax As Double, ByVal ay As Double, ByVal az As Double, _
ByVal bx As Double, ByVal by As Double, ByVal bz As Double) As Long
If ax > (bx + PLATE_FACE_NORMAL_EPS) Then
PlateCompareVectorLex = 1
ElseIf ax < (bx - PLATE_FACE_NORMAL_EPS) Then
PlateCompareVectorLex = -1
ElseIf ay > (by + PLATE_FACE_NORMAL_EPS) Then
PlateCompareVectorLex = 1
ElseIf ay < (by - PLATE_FACE_NORMAL_EPS) Then
PlateCompareVectorLex = -1
ElseIf az > (bz + PLATE_FACE_NORMAL_EPS) Then
PlateCompareVectorLex = 1
ElseIf az < (bz - PLATE_FACE_NORMAL_EPS) Then
PlateCompareVectorLex = -1
Else
PlateCompareVectorLex = 0
End If
End Function
Private Function TimeStamp() As String
TimeStamp = Format$(Now, "yyyy-mm-dd hh:nn:ss")
End Function
Procedure index · 253 declarations
File checksum
SHA-256: 719cabad617ccb2d6a3829f66f490aa0509fbbb50721506c4210256d1604414d