'This example shows how to add an ordinate dimension.

'------------------------------------------

' Preconditions:

'          1) Drawing document is open.

'          2) Eine zeichenansicht ist angewählt

'

' Postconditions: Ordinate dimensions added.

'-------------------------------------------

Option Explicit

    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems


Dim swApp As SldWorks.SldWorks

Dim swModel As SldWorks.ModelDoc2

Dim SelMgr As Object

Dim boolstatus As Boolean

    Dim swView                  As SldWorks.View




Public Enum swAddOrdinateDims_e

    swOrdinate = 1

    swVerticalOrdinate = 2

    swHorizontalOrdinate = 3

End Enum

Public Enum swCreateOrdDimError_e

    swCreateOrdDimErr_Undefined = -1            '  If encountered, report as SPR.

    swCreateOrdDimErr_Success = 0

    swCreateOrdDimErr_GenFailure = 1            '  MSG_SDIM_BAD_DIM

    swCreateOrdDimErr_GenNoInternalDims = 2     '  MSG_NO_INTERNAL_DIMS_IN_DSKETCH

    swCreateOrdDimErr_GenBadSel = 3             '  MSG_DIM_REF_NOCREATE

    swCreateOrdDimErr_GenNeedModelLoaded = 4    '  MSG_CANNOT_DIM_GHOST_IN3D

    swCreateOrdDimErr_GenSamePartOnly = 5       '  MSG_DIM_EDIT_PART

    swCreateOrdDimErr_GenExtraSelection = 6     '  MSG_DIM_TOO_MANY_SELECT

    swCreateOrdDimErr_OrdFailure = 7            '  MSG_BAD_ORDINATE_DIM0

    swCreateOrdDimErr_OrdDupInGroup = 8         '  MSG_BAD_ORDINATE_DIM1

    swCreateOrdDimErr_OrdBadDir = 9             '  MSG_BAD_ORDINATE_DIM2

End Enum

Sub main()
Debug.Print ("---------------------------------------------")
Debug.Print ("start: ") & Now


    Dim swApp                   As SldWorks.SldWorks

    Dim swModel                 As SldWorks.ModelDoc2

    Dim swdrawing                  As SldWorks.DrawingDoc

    Dim nRetval                 As Long
    
    Dim boolstatus              As Boolean
    
    Dim part                    As Object
    
     Dim vPos                 As Variant
     Dim vOutline                  As Variant
    
    Dim swModelDocExt           As SldWorks.ModelDocExtension

    Dim nNumView                    As Long
    
    Dim swSelMgr As SldWorks.SelectionMgr
    
    Dim swSketchPt As Variant
    
    Dim NumSelects As Long
    
    Dim status As Boolean
    Dim selmark As Variant
    Dim ret As Long

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swModelDocExt = swModel.Extension

    Set part = swModel
    Set swdrawing = swModel
        
    Set swView = swdrawing.ActiveDrawingView
    
    Dim swSheet As Sheet
    Set swSheet = swdrawing.GetCurrentSheet
       
    Dim vSheetProps As Variant
    vSheetProps = swSheet.GetProperties

    Dim SheetScale As Double
    SheetScale = vSheetProps(3) / vSheetProps(2)
    Debug.Print "aktueller maßstab: " & SheetScale
    
    Dim params As Variant
    Dim selfils(2) As Long
    
    'bereite Listen für die Bemaßungspunkte vor
    Dim coll As Object
    Set coll = CreateObject("system.collections.arraylist")
    Dim removelist As Object
    Set removelist = CreateObject("system.collections.arraylist")
    Dim LstPickPoint As Object
    Set LstPickPoint = CreateObject("system.collections.arraylist")
    Dim LstXValues As Object
    Set LstXValues = CreateObject("system.collections.arraylist")
    Dim LstyValues As Object
    Set LstyValues = CreateObject("system.collections.arraylist")
    
    Dim roundvalue As Integer
    roundvalue = 3
    
    vPos = swView.Position
    vOutline = swView.GetOutline
    
    
    'Position der zeichenansicht-Mitte bestimmen
    'quelle: http://help.solidworks.com/2013/English/api/sldworksapi/Reposition_Drawing_Views_to_Avoid_Overlap_Example_VB.htm
    Debug.Print swView.GetName2
    Debug.Print ("  Pos x = " & vPos(0) & " mm")
    Debug.Print ("  Pos y = " & vPos(1) & " mm")
    

        Debug.Print "  Min = (" & vOutline(0) * 1000# & ", " & vOutline(1) * 1000# & ") mm"

        Debug.Print "  Max = (" & vOutline(2) * 1000# & ", " & vOutline(3) * 1000# & ") mm"
    
boolstatus = part.ActivateSheet("Blatt1")  'um die globalen Koordinaten für die Ansicht zu verwenden. Wenn die Ansicht aktiviert bliebe, würden die Koordinaten beim Nullpunkt der Ansicht beziehen


'Clear all existing selection filters
params = swApp.GetSelectionFilters
swApp.SetSelectionFilters params, False
params = swApp.GetSelectionFilters

'Define filters to select

'selfils(0) = 1 'Edge

'selfils(1) = 2 'Face

selfils(2) = 3 'Vertex

'selfils(1) = 28 'Centermarks


swApp.SetSelectionFilters (selfils), True

    
    ' Horizontal ordinate ignores X placement
    part.ClearSelection2 True
    
    'gesamte Ansicht auswählen
   boolstatus = part.Extension.SketchBoxSelect(vOutline(0) * SheetScale, vOutline(1) * SheetScale, 0#, vOutline(2) * SheetScale, vOutline(3) * SheetScale, 0#)
    


    Set swSelMgr = swdrawing.SelectionManager
    
'    Koordinaten der Punkte bestimmen
    Dim myswPOINT As Object 'SldWorks.Edge

    Dim swVertex As SldWorks.Vertex

    Dim swPt1 As Variant, swPt2 As Variant, swPt3 As Variant, swPt4 As Variant


    Dim i As Long
    For i = 1 To swSelMgr.GetSelectedObjectCount
    If swSelMgr.GetSelectedObjectType3(i, -1) = swSelectType_e.swSelVERTICES Then
        Set swVertex = swSelMgr.GetSelectedObject6(i, 0)
        Dim PickPt     As Variant
        PickPt = swVertex.GetPoint
        Debug.Print "PickPt: " & PickPt(0) & ":" & PickPt(1) & ":" & PickPt(2)
        swPt4 = CoordinateInDrawingView(PickPt, swView)
        coll.Add swPt4
    End If
    Next

'Toggle the selection filter
boolstatus = swApp.GetApplySelectionFilter

If boolstatus = False Then

    swApp.SetApplySelectionFilter True

Else

    swApp.SetApplySelectionFilter False

End If

Dim item As Variant
Dim xitem As Variant
Dim yitem As Variant



For Each item In coll
    Debug.Print item(0) * 1000 & ";" & item(1) * 1000 & ";" & item(2) * 1000
Next


' horizontale Punkte aussortieren
Dim j As Long
Dim k As Long
Dim curCoord As Variant
'On Error Resume Next
Dim count As Long

count = 0

    'erstmal alle x-Werte in eine Liste schreiben
    LstXValues.Clear
    Dim xvalue As Double
    Debug.Print "x-Werte ermitteln"
    
    Dim check As Boolean
    For i = 0 To coll.count - 1
        check = False
        xvalue = coll(i)(0)
        For j = 0 To LstXValues.count - 1
            If Round(LstXValues(j), roundvalue) = Round(xvalue, roundvalue) Then
                check = True
            End If
        Next
        If check = False Then
            LstXValues.Add (xvalue)
        End If
    
    Next
    LstXValues.Sort
    
    
    Debug.Print "x-Werte: "
    For i = 0 To LstXValues.count - 1
        Debug.Print LstXValues(i)
        
    Next
    LstPickPoint.Clear
    
    Debug.Print "Minimal Werte suchen: "
    'jetzt die Hauptliste durchgehen und minimum für die X-Werte suchen
    For i = 0 To LstXValues.count - 1 'gehe stückweise die möglichen x-Werte durch
       xitem = LstXValues(i)
        Debug.Print "zu vergleichende Koordinate: " & xitem
        For j = 0 To coll.count - 1 'prüfe die X-Werte gegen jeden Wert der Punktliste
            item = coll(j)
        
            Debug.Print "   Prüfkoordinate: " & item(0) & ";" & item(1)
            If Round(item(0), roundvalue) = Round(xitem, roundvalue) Then 'wenn der aktuell zu prüfende Wert ein möglicher X-Werst ist
                Debug.Print "     x-Werte sind gleich"
            
            
            'prüfe ob in pickpointliste vorhanden
                    check = False
                    For k = 0 To LstPickPoint.count - 1
                    Debug.Print ("wenn: " & LstPickPoint(k)(0) & "=" & item(0) & " And " & LstPickPoint(k)(1) & "<" & item(1))
                        If Round(LstPickPoint(k)(0), roundvalue) = Round(item(0), roundvalue) Then '
                            check = True
                        End If
                    Next
                    If check = False Then
                        LstPickPoint.Add (item)
                    Else
                    For k = 0 To LstPickPoint.count - 1
                        If Round(LstPickPoint(k)(0), roundvalue) = Round(item(0), roundvalue) And Round(LstPickPoint(k)(1), roundvalue) < Round(item(1), roundvalue) Then '
                            LstPickPoint(k) = item
                        End If
                    Next
                    
                End If
            End If
        Next
    Next
part.ClearSelection2 True
Debug.Print ("Pickpointliste")
 For i = 0 To LstPickPoint.count - 1
        'item = LstPickPoint(i)
    Debug.Print "auszuwählender Punkt: " & LstPickPoint(i)(0) & LstPickPoint(i)(1) & LstPickPoint(i)(2)
     status = swModelDocExt.SelectByID2("", "VERTEX", LstPickPoint(i)(0), LstPickPoint(i)(1), LstPickPoint(i)(2), True, 0, Nothing, 0)
 
 Next
nRetval = swdrawing.AddOrdinateDimension(swHorizontalOrdinate, vOutline(0) - 0.1, vOutline(3) + 0.015, 0#)
swdrawing.SetPickMode 'Auswahl beenden

part.ClearSelection2 True

'***vertikale Bemaßung*****************

' horizontale Punkte aussortieren
count = 0

    'erstmal alle y-Werte in eine Liste schreiben
    LstyValues.Clear
    Dim yvalue As Double
    Debug.Print "y-Werte ermitteln"
    
    'Dim check As Boolean
    'jeden Wert nur einmal in die Liste schreiben
    For i = 0 To coll.count - 1
        check = False
        yvalue = coll(i)(1)
        For j = 0 To LstyValues.count - 1
            If Round(LstyValues(j), roundvalue) = Round(yvalue, roundvalue) Then
                check = True
            End If
        Next
        If check = False Then
            LstyValues.Add (yvalue)
        End If
    
    Next
    LstyValues.Sort
    
    'Liste ausbeben
    Debug.Print "y-Werte: "
    For i = 0 To LstyValues.count - 1
        Debug.Print LstyValues(i)
        
    Next
    LstPickPoint.Clear
    
    Debug.Print "Maximal Werte suchen: "
    'jetzt die Hauptliste durchgehen und maximum für die y-Werte suchen
    For i = 0 To LstyValues.count - 1 'gehe stückweise die möglichen y-Werte durch
       yitem = LstyValues(i)
        Debug.Print "zu vergleichende Koordinate: " & yitem
        For j = 0 To coll.count - 1 'prüfe die X-Werte gegen jeden Wert der Punktliste
            item = coll(j)
        
            Debug.Print "   Prüfkoordinate: " & item(0) & ";" & item(1)
            If Round(item(1), roundvalue) = Round(yitem, roundvalue) Then 'wenn der aktuell zu prüfende Wert ein möglicher y-Werst ist
                Debug.Print "     y-Werte sind gleich"
            
            
                    'prüfe ob in pickpointliste vorhanden
                    check = False
                    For k = 0 To LstPickPoint.count - 1 'prüfe o
                        Debug.Print ("wenn: " & LstPickPoint(k)(0) & ">" & item(0) & " And " & LstPickPoint(k)(1) & "=" & item(1))
                        If Round(LstPickPoint(k)(1), roundvalue) = Round(item(1), roundvalue) Then 'wenn der y-Wert bereits vorhanden ist
                            check = True 'check true, wird nicht hinzugefügt
                        End If
                    Next
                    'füge hinzu oder nicht
                    If check = False Then
                        LstPickPoint.Add (item)
                    Else
                    For k = 0 To LstPickPoint.count - 1
                        If Round(LstPickPoint(k)(1), roundvalue) = Round(item(1), roundvalue) And Round(LstPickPoint(k)(0), roundvalue) > Round(item(0), roundvalue) Then '
                            LstPickPoint(k) = item
                        End If
                    Next
                    
                End If
            End If
        Next
    Next
part.ClearSelection2 True

Debug.Print ("Pickpointliste")
 For i = LstPickPoint.count - 1 To 0 Step -1
    Debug.Print "auszuwählender Punkt: " & LstPickPoint(i)(0) & LstPickPoint(i)(1) & LstPickPoint(i)(2)
     status = swModelDocExt.SelectByID2("", "VERTEX", LstPickPoint(i)(0), LstPickPoint(i)(1), LstPickPoint(i)(2), True, 0, Nothing, 0)
 Next
nRetval = swdrawing.AddOrdinateDimension2(swVerticalOrdinate, vOutline(0) - 0.01, vOutline(1) + 0.015, 0#)

swdrawing.SetPickMode 'Auswahl beenden

End Sub
Function CoordinateInDrawingView(ByVal subPoint As Variant, ByVal subView As SldWorks.View) As Variant
'Quelle: https://forum.solidworks.com/thread/224812
   Dim swApp                   As SldWorks.SldWorks
   Set swApp = Application.SldWorks
    Dim swMathUtils As SldWorks.MathUtility

    Dim swXform As SldWorks.MathTransform

    Dim swMathPt As SldWorks.MathPoint

    Set swMathUtils = swApp.GetMathUtility

    Set swXform = subView.ModelToViewTransform

    Debug.Print "  Model   coordinates: " & subPoint(0) * 1000 & " " & subPoint(1) * 1000 & " " & subPoint(2) * 1000

    ' transform absolute coordinate to view coordinate

    Set swMathPt = swMathUtils.CreatePoint(subPoint)

    Set swMathPt = swMathPt.MultiplyTransform(swXform)

    subPoint = swMathPt.ArrayData

    Debug.Print "  Drawing coordinates: " & subPoint(0) * 1000 & " " & subPoint(1) * 1000 & " " & subPoint(2) * 1000

    CoordinateInDrawingView = subPoint

End Function