Untitled

Option Explicit

Dim swApp       As SldWorks.SldWorks
Dim swModel     As SldWorks.ModelDoc2
Dim swSketchMgr As SldWorks.SketchManager
Dim swSketch    As SldWorks.Sketch
Dim swFeat      As SldWorks.Feature

Dim report      As String
Dim issues      As String
Dim issueCount  As Long

Sub Main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        MsgBox "ERROR: No document open!", vbCritical
        Exit Sub
    End If
    
    Set swSketchMgr = swModel.SketchManager
    Set swSketch = swSketchMgr.ActiveSketch
    
    If swSketch Is Nothing Then
        MsgBox "ERROR: No active sketch!" & vbCrLf & vbCrLf & _
               "Double-click the sketch (with (-) symbol) in the FeatureManager to edit it first.", vbCritical
        Exit Sub
    End If
    
    Set swFeat = swSketch.GetFeature
    
    ' Initialize report
    report = String(60, "=") & vbCrLf
    report = report & " SOLIDWORKS SKETCH DIAGNOSTIC REPORT" & vbCrLf
    report = report & " Sketch: " & swFeat.Name & vbCrLf
    report = report & String(60, "=") & vbCrLf & vbCrLf
    
    issues = ""
    issueCount = 0
    
    ' Run diagnostics
    CheckOverallStatus
    CheckSegmentsAndEndpoints
    CheckStandalonePoints
    CheckConstructionGeometry
    CheckSketchPatterns
    CheckTinyOrDegenerateGeometry
    CheckRelationsAndAnchoring
    
    ' Final diagnosis
    report = report & String(60, "=") & vbCrLf
    report = report & " FINAL DIAGNOSIS & RECOMMENDATIONS" & vbCrLf
    report = report & String(60, "=") & vbCrLf & vbCrLf
    
    If issueCount = 0 Then
        report = report & "NO ISSUES DETECTED BY API CHECKS" & vbCrLf & vbCrLf
        report = report & "The 'Under Defined' status / (-) symbol is most likely a cosmetic UI glitch." & vbCrLf & vbCrLf
        report = report & "Recommended next steps:" & vbCrLf
        report = report & " 1. Press Ctrl+Q (Force full rebuild)" & vbCrLf
        report = report & " 2. Exit and re-enter the sketch" & vbCrLf
        report = report & " 3. Copy all entities (Ctrl+A → Ctrl+C), create new sketch, paste (Ctrl+V), delete old" & vbCrLf
        report = report & " 4. Close and reopen the part file" & vbCrLf
    Else
        report = report & "FOUND " & issueCount & " POTENTIAL ISSUE(S)" & vbCrLf & vbCrLf
        report = report & issues & vbCrLf
        report = report & "SUGGESTED FIXES:" & vbCrLf
        report = report & " - Constrain any listed loose points/endpoints to the origin" & vbCrLf
        report = report & " - Add Horizontal/Vertical or angle dimension to patterns" & vbCrLf
        report = report & " - Delete or merge tiny/degenerate geometry" & vbCrLf
        report = report & " - Run 'Fully Define Sketch' on selected entities only" & vbCrLf
    End If
    
    ' Output
    Debug.Print report
    MsgBox report, vbInformation, "Sketch Diagnostic Complete"
    
    SaveReportToFile report
    
    ' Optional: Force rebuild to refresh UI
    swModel.ForceRebuild3 True
End Sub

' =====================================================
' 1. Overall Sketch Status (most reliable check)
' =====================================================
Private Sub CheckOverallStatus()
    report = report & "[1] OVERALL SKETCH STATUS (API)" & vbCrLf
    report = report & String(50, "-") & vbCrLf
    
    Dim underCount As Long: underCount = swSketch.GetUnderDefinedCount
    Dim dof        As Long: dof        = swSketch.GetDegreesOfFreedom
    
    report = report & "Under-defined entities (API): " & underCount & vbCrLf
    report = report & "Degrees of freedom remaining: " & dof & vbCrLf & vbCrLf
    
    If underCount = 0 And dof = 0 Then
        report = report & "API says: Sketch is FULLY DEFINED." & vbCrLf
        report = report & "→ UI glitch is very likely." & vbCrLf
    Else
        issueCount = issueCount + 1
        issues = issues & "- API reports " & underCount & " under-defined item(s) and " & dof & " DOF remaining." & vbCrLf
    End If
    report = report & vbCrLf
End Sub

' =====================================================
' 2. Segments + Endpoints (most common hidden cause)
' =====================================================
Private Sub CheckSegmentsAndEndpoints()
    report = report & "[2] SEGMENTS & ENDPOINTS ANALYSIS" & vbCrLf
    report = report & String(50, "-") & vbCrLf
    
    Dim vSegs As Variant: vSegs = swSketch.GetSketchSegments
    If IsEmpty(vSegs) Then
        report = report & "No segments found." & vbCrLf & vbCrLf
        Exit Sub
    End If
    
    Dim i As Long, underSegs As Long, underEnds As Long
    Dim swSeg As SldWorks.SketchSegment
    Dim swPt As SldWorks.SketchPoint
    
    underSegs = 0: underEnds = 0
    
    For i = 0 To UBound(vSegs)
        Set swSeg = vSegs(i)
        Dim segType As String: segType = GetSegmentTypeName(swSeg.GetType)
        Dim constr   As String: constr   = IIf(swSeg.ConstructionGeometry, " [CONSTRUCTION]", "")
        
        ' Segment status
        If swSeg.Status = swUnderDefined Then
            underSegs = underSegs + 1
            issueCount = issueCount + 1
            report = report & "  Under-defined " & segType & constr & vbCrLf
            issues = issues & "- Under-defined " & segType & constr & vbCrLf
        End If
        
        ' Check endpoints
        Set swPt = swSeg.GetStartPoint2
        If Not swPt Is Nothing Then
            If swPt.GetRelationsCount = 0 Then
                underEnds = underEnds + 1
                issueCount = issueCount + 1
                Dim coords As String: coords = FormatPoint(swPt)
                report = report & "    → START point unconstrained: " & coords & constr & vbCrLf
                issues = issues & "- Unconstrained start point of " & segType & " at " & coords & vbCrLf
            End If
        End If
        
        Set swPt = swSeg.GetEndPoint2
        If Not swPt Is Nothing Then
            If swPt.GetRelationsCount = 0 Then
                underEnds = underEnds + 1
                issueCount = issueCount + 1
                coords = FormatPoint(swPt)
                report = report & "    → END point unconstrained: " & coords & constr & vbCrLf
                issues = issues & "- Unconstrained end point of " & segType & " at " & coords & vbCrLf
            End If
        End If
    Next i
    
    report = report & vbCrLf & "Summary: " & underSegs & " under-defined segments, " & underEnds & " unconstrained endpoints" & vbCrLf & vbCrLf
End Sub

' =====================================================
' 3. Standalone Points
' =====================================================
Private Sub CheckStandalonePoints()
    report = report & "[3] STANDALONE SKETCH POINTS" & vbCrLf
    report = report & String(50, "-") & vbCrLf
    
    Dim vPts As Variant: vPts = swSketch.GetSketchPoints2
    If IsEmpty(vPts) Then
        report = report & "No standalone points." & vbCrLf & vbCrLf
        Exit Sub
    End If
    
    Dim i As Long, underPts As Long
    Dim swPt As SldWorks.SketchPoint
    
    underPts = 0
    
    For i = 0 To UBound(vPts)
        Set swPt = vPts(i)
        If swPt.GetRelationsCount = 0 Then
            underPts = underPts + 1
            issueCount = issueCount + 1
            Dim coords As String: coords = FormatPoint(swPt)
            report = report & "  Unconstrained point: " & coords & vbCrLf
            issues = issues & "- Standalone point unconstrained at " & coords & vbCrLf
        End If
    Next i
    
    report = report & vbCrLf & underPts & " of " & (UBound(vPts) + 1) & " points have no relations" & vbCrLf & vbCrLf
End Sub

' =====================================================
' Helpers
' =====================================================
Private Function GetSegmentTypeName(segType As Long) As String
    Select Case segType
        Case 0: GetSegmentTypeName = "Line"
        Case 1: GetSegmentTypeName = "Arc"
        Case 2: GetSegmentTypeName = "Ellipse"
        Case 3: GetSegmentTypeName = "Elliptical Arc"
        Case 4: GetSegmentTypeName = "Spline"
        Case 5: GetSegmentTypeName = "Text"
        Case 6: GetSegmentTypeName = "Parabola"
        Case Else: GetSegmentTypeName = "Unknown (" & segType & ")"
    End Select
End Function

Private Function FormatPoint(pt As SldWorks.SketchPoint) As String
    FormatPoint = "(" & Round(pt.X * 1000, 3) & ", " & Round(pt.Y * 1000, 3) & ") mm"
End Function

Private Sub SaveReportToFile(text As String)
    On Error Resume Next
    Dim fso As Object, ts As Object
    Dim path As String
    
    path = Environ("USERPROFILE") & "\Desktop\Sketch_Diagnostic_" & Format(Now, "yyyymmdd_hhmmss") & ".txt"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.CreateTextFile(path, True)
    ts.Write text
    ts.Close
    
    If Err.Number = 0 Then
        report = report & vbCrLf & "Full report saved to: " & path & vbCrLf
    End If
    On Error GoTo 0
End Sub

' =====================================================
' Remaining checks (placeholders – add your preferred logic)
' =====================================================
Private Sub CheckConstructionGeometry()
    ' Similar logic to segments, filter on .ConstructionGeometry = True
    report = report & "[4] CONSTRUCTION GEOMETRY" & vbCrLf & String(50, "-") & vbCrLf
    ' ... implement if needed ...
    report = report & " (Implement detailed check here if desired)" & vbCrLf & vbCrLf
End Sub

Private Sub CheckSketchPatterns()
    report = report & "[5] SKETCH PATTERNS" & vbCrLf & String(50, "-") & vbCrLf
    ' Check segments with .IsPatternInstance
    report = report & " (Add pattern detection logic here)" & vbCrLf & vbCrLf
End Sub

Private Sub CheckTinyOrDegenerateGeometry()
    report = report & "[6] TINY/DEGENERATE GEOMETRY" & vbCrLf & String(50, "-") & vbCrLf
    ' Your original tiny length check logic can go here
    report = report & " (Add tiny geometry check here)" & vbCrLf & vbCrLf
End Sub

Private Sub CheckRelationsAndAnchoring()
    report = report & "[7] RELATIONS & ANCHORING" & vbCrLf & String(50, "-") & vbCrLf
    report = report & "Total relations: " & swSketch.GetConstraintsCount & vbCrLf
    report = report & "Tip: Ensure at least one point is Coincident with origin." & vbCrLf & vbCrLf
End Sub