Projekt: Nummern lasern

Option Explicit

Const STANDARD_PROPERTY_TO_USE As String = "Dateiname"
Const STANDARD_FONT_TO_USE As String = "Courier Std"
Const STANDARD_LETTER_SIZE_IN_MM As Double = 10
Const STANDARD_LASER_DEPTH As Double = 0.2


Private Sub btn_add_letter_b_Click()
    If InStr(tbx_file_info.Text, "-b") > 0 Then
        tbx_file_info.Text = Replace(tbx_file_info.Text, "-b", "")
    Else
        tbx_file_info.Text = tbx_file_info.Text & "-b"
    End If
End Sub

Private Sub btn_add_letter_l_Click()
    If InStr(tbx_file_info.Text, "-l") > 0 Then
        tbx_file_info.Text = Replace(tbx_file_info.Text, "-l", "")
    Else
        tbx_file_info.Text = tbx_file_info.Text & "-l"
    End If
End Sub

Private Sub btn_add_letter_s_Click()
    If InStr(tbx_file_info.Text, "-s") > 0 Then
        tbx_file_info.Text = Replace(tbx_file_info.Text, "-s", "")
    Else
        tbx_file_info.Text = tbx_file_info.Text & "-s"
    End If
End Sub

Private Sub btn_run_program_Click()
    If IsNumeric(tbx_schnitttiefe) = False Then
        MsgBox "Schnitttiefe ist keine Zahl."
        Exit Sub
    End If
    If IsNumeric(tbx_letter_height) = False Then
        MsgBox "Zeichenhöhenangabe ist keine Zahl."
        Exit Sub
    End If
    modTextLasern.RunProgram
End Sub

Private Sub InitFontTypeList()
    cbx_font_type.AddItem ("Consolas")
    cbx_font_type.AddItem ("Comic Sans MS")
    cbx_font_type.AddItem ("Courier Std")
    cbx_font_type.AddItem ("Lucida Console")
    cbx_font_type.AddItem ("SWIsop1")
    cbx_font_type.AddItem ("Freestyle Script")
End Sub

Private Sub cbx_custom_property_name_Change()
    tbx_file_info.Text = modSwx.GetCustomProperty(modSwx.GetActiveModel(Part), cbx_custom_property_name.Value, False)
End Sub

Private Sub UserForm_Initialize()
    tbx_schnitttiefe.Text = STANDARD_LASER_DEPTH
    tbx_letter_height.Text = STANDARD_LETTER_SIZE_IN_MM
    Dim prop As Variant
    For Each prop In modSwx.GetAllCustomPropertyNames
        cbx_custom_property_name.AddItem prop
    Next
    cbx_custom_property_name.Value = STANDARD_PROPERTY_TO_USE
    InitFontTypeList
    cbx_font_type.Value = STANDARD_FONT_TO_USE
End Sub

Option Explicit

Enum Filetype_e
    Part
    Assembly
    Drawing
    PartAndAssembly
    All
End Enum

Option Explicit

Dim swApp As SldWorks.SldWorks

Function GetCustomProperty(model As ModelDoc2, propertyName As String, Optional infoToUser As Boolean = True) As String
    Dim swModelDocExtension As ModelDocExtension: Set swModelDocExtension = model.Extension
    Dim swCustomPropertyManager As CustomPropertyManager
    Set swCustomPropertyManager = swModelDocExtension.CustomPropertyManager("")
    Dim valOut As String
    Dim resolvedValOut As String
    Dim resultCode As Long: resultCode = swCustomPropertyManager.Get6(propertyName, False, valOut, resolvedValOut, True, False)
    Select Case resultCode
        Case swCustomInfoGetResult_e.swCustomInfoGetResult_NotPresent
            If infoToUser Then swApp.SendMsgToUser ("Die Dateieigenschaft " & propertyName & " wurde nicht gefunden.")
            resultCode = swCustomPropertyManager.Add3(propertyName, swCustomInfoType_e.swCustomInfoText, "", swCustomPropertyAddOption_e.swCustomPropertyOnlyIfNew)
            GetCustomProperty = ""
        Case swCustomInfoGetResult_e.swCustomInfoGetResult_CachedValue
            If infoToUser Then swApp.SendMsgToUser ("Es wurde nur der Cache Wert geladen.")
            GetCustomProperty = valOut
        Case swCustomInfoGetResult_e.swCustomInfoGetResult_ResolvedValue
            GetCustomProperty = resolvedValOut
        Case Else
            GetCustomProperty = ""
    End Select
End Function

Function GetAllCustomPropertyNames() As Variant
    Dim swModel As ModelDoc2: Set swModel = GetActiveModel(Filetype_e.Part)
    Dim swCustomPropertyManager As CustomPropertyManager
    Set swCustomPropertyManager = swModel.Extension.CustomPropertyManager("")
    Dim propNames As Variant
    Dim propTypes As Variant
    Dim propValues As Variant
    Dim propResolved As Variant
    Dim propLink As Variant
    Dim numberOfProperties As Long
    numberOfProperties = swCustomPropertyManager.GetAll3(propNames, propTypes, propValues, propResolved, propLink)
    If numberOfProperties < 1 Then
        GetAllCustomPropertyNames = Array("")
        Exit Function
    End If
    GetAllCustomPropertyNames = propNames
End Function

Function GetActiveModel(fileType As Filetype_e, Optional infoToUser As Boolean = True) As ModelDoc2
    Set swApp = Application.SldWorks
    Dim swModel As ModelDoc2: Set swModel = swApp.ActiveDoc
    
    If swModel Is Nothing Then
        swApp.SendMsgToUser "Kein Modell geladen."
        End
    End If
    
    Dim docType As swDocumentTypes_e: docType = swModel.GetType()
    
    Select Case fileType
        Case Filetype_e.All
            If docType = swDocumentTypes_e.swDocASSEMBLY Or _
               docType = swDocumentTypes_e.swDocPART Or _
               docType = swDocumentTypes_e.swDocDRAWING Then
              Set GetActiveModel = swModel
              Exit Function
            End If
        Case Filetype_e.Assembly
            If docType = swDocumentTypes_e.swDocASSEMBLY Then
              Set GetActiveModel = swModel
              Exit Function
            End If
        Case Filetype_e.Part
            If docType = swDocumentTypes_e.swDocPART Then
              Set GetActiveModel = swModel
              Exit Function
            End If
        Case Filetype_e.PartAndAssembly
            If docType = swDocumentTypes_e.swDocASSEMBLY Or _
               docType = swDocumentTypes_e.swDocPART Then
              Set GetActiveModel = swModel
              Exit Function
            End If
        Case Filetype_e.Drawing
            If docType = swDocumentTypes_e.swDocDRAWING Then
              Set GetActiveModel = swModel
              Exit Function
            End If
    End Select
    
    If infoToUser Then
        swApp.SendMsgToUser2 "Auf diesen Dokumenttyp kann diese Funktion nicht angewendet werden.", swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk
    End If
    End
End Function

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swSelectionManager As SelectionMgr

Dim LaseredString As String

Dim EdgePositionInSelection As Long
Dim PointPositionInSelection As Long

Sub RunProgram()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If CheckSelection = False Then End
    LaseredString = MainForm.tbx_file_info.Text
    If LaseredString = "" Then
        swApp.SendMsgToUser "Zeichenkette ist leer."
        Exit Sub
    End If
    LaserFeature
    End
End Sub

Private Sub LaserFeature()
    Dim swMathUtility As MathUtility
    Set swMathUtility = swApp.GetMathUtility

    Dim swSelectedFace As Face2
    Set swSelectedFace = swSelectionManager.GetSelectedObject6(PointPositionInSelection, -1)

    Dim swSelectedEdge As Edge
    Set swSelectedEdge = swSelectionManager.GetSelectedObject6(EdgePositionInSelection, -1)

    Dim swCurveOfSelectedEdge As Curve
    Set swCurveOfSelectedEdge = swSelectedEdge.GetCurve
    If swCurveOfSelectedEdge.IsLine = False Then
        swApp.SendMsgToUser ("Gewählte Kante ist keine Gerade.")
        End
    End If

    Dim normal As Variant
    normal = swSelectedFace.normal

    Dim swNormalVectorOfSelectedFace As MathVector
    Set swNormalVectorOfSelectedFace = swMathUtility.CreateVector(normal)

    Dim lineParamsOfCurve As Variant: lineParamsOfCurve = swCurveOfSelectedEdge.LineParams
    Dim directionValuesOfCurve(2) As Double
    directionValuesOfCurve(0) = ReduceDecimalPlaces(lineParamsOfCurve(3))
    directionValuesOfCurve(1) = ReduceDecimalPlaces(lineParamsOfCurve(4))
    directionValuesOfCurve(2) = ReduceDecimalPlaces(lineParamsOfCurve(5))
    Dim swDirectionVectorOfCurve As MathVector
    Set swDirectionVectorOfCurve = swMathUtility.CreateVector(directionValuesOfCurve)
    Set swDirectionVectorOfCurve = swDirectionVectorOfCurve.Normalise
    
    Dim clickedPoint As Variant
    clickedPoint = swSelectionManager.GetSelectionPoint2(PointPositionInSelection, -1)
    
    Dim PointCoords(2) As Double
    PointCoords(0) = ReduceDecimalPlaces(clickedPoint(0))
    PointCoords(1) = ReduceDecimalPlaces(clickedPoint(1))
    PointCoords(2) = ReduceDecimalPlaces(clickedPoint(2))
    Dim swClickedPoint As MathPoint
    Set swClickedPoint = swMathUtility.CreatePoint(PointCoords)

    Dim closestPointOnSelectedEdge As Variant
    closestPointOnSelectedEdge = swSelectedEdge.GetClosestPointOn(swClickedPoint.ArrayData(0), swClickedPoint.ArrayData(1), swClickedPoint.ArrayData(2))
    Dim closestPointOnSelectedEdgeArray(2) As Double
    closestPointOnSelectedEdgeArray(0) = ReduceDecimalPlaces(closestPointOnSelectedEdge(0))
    closestPointOnSelectedEdgeArray(1) = ReduceDecimalPlaces(closestPointOnSelectedEdge(1))
    closestPointOnSelectedEdgeArray(2) = ReduceDecimalPlaces(closestPointOnSelectedEdge(2))
    Dim swClosestPointOnEdge As MathPoint
    Set swClosestPointOnEdge = swMathUtility.CreatePoint(closestPointOnSelectedEdgeArray)
    
    Dim swSupportVectorClickedPoint As MathVector
    Set swSupportVectorClickedPoint = swMathUtility.CreateVector(swClickedPoint.ArrayData)
    
    Dim swVectorClosestPointOnEdge As MathVector
    Set swVectorClosestPointOnEdge = swMathUtility.CreateVector(swClosestPointOnEdge.ArrayData)
    
    Dim swVectorFromEdgepointToClickedpoint As MathVector
    Set swVectorFromEdgepointToClickedpoint = swSupportVectorClickedPoint.Subtract(swVectorClosestPointOnEdge)
    Set swVectorFromEdgepointToClickedpoint = swVectorFromEdgepointToClickedpoint.Normalise

    Dim swSketchManager As SketchManager
    Set swSketchManager = swModel.SketchManager

    swSketchManager.InsertSketch True

    Dim swSketch As Sketch
    Set swSketch = swSketchManager.ActiveSketch

    Dim swModelToSketchTransform As MathTransform
    Set swModelToSketchTransform = swSketch.ModelToSketchTransform

    Dim swSketchLevelClickedPoint As MathPoint
    Set swSketchLevelClickedPoint = swClickedPoint.MultiplyTransform(swModelToSketchTransform)
    Set swVectorFromEdgepointToClickedpoint = swVectorFromEdgepointToClickedpoint.MultiplyTransform(swModelToSketchTransform)

    Dim angle As Double
    angle = FinalAngle(swMathUtility, swVectorFromEdgepointToClickedpoint)

    Dim letters As Integer
    letters = Len(MainForm.tbx_file_info.Text)
    
    Dim letterspace As Double
    letterspace = MainForm.tbx_letter_height.Text
    
    Dim x_value As Double
    Dim y_value As Double
    x_value = ReduceDecimalPlaces(Cos(angle) * (letters * letterspace / 1000))
    y_value = ReduceDecimalPlaces(Sin(angle) * (letters * letterspace / 1000))
    
    swSketchManager.AddToDB = True
    Dim swSketchSegment As SketchSegment
    Set swSketchSegment = swSketchManager.CreateLine(swSketchLevelClickedPoint.ArrayData(0), _
                                                     swSketchLevelClickedPoint.ArrayData(1), _
                                                     0, _
                                                     swSketchLevelClickedPoint.ArrayData(0) + x_value, _
                                                     swSketchLevelClickedPoint.ArrayData(1) + y_value, _
                                                     0)
    swSketchSegment.ConstructionGeometry = True
    swSketchManager.AddToDB = False
    
    Dim swSelectData As SelectData
    Set swSelectData = swSelectionManager.CreateSelectData
    swSketchSegment.Select4 False, swSelectData
    
    Dim swSelEdgeEntity As Entity
    Set swSelEdgeEntity = swSelectedEdge
    swSelEdgeEntity.Select4 True, Nothing

    swModel.SketchAddConstraints "sgPARALLEL"

    swSelectData.Mark = 1
    swSketchSegment.Select4 False, swSelectData
    
    Dim swSketchText As SketchText
    Set swSketchText = swModel.InsertSketchText(0, 0, 0, LaseredString, 0, 0, 0, 100, 100)
    
    Dim swTextFormat As TextFormat
    Set swTextFormat = swSketchText.GetTextFormat
    swTextFormat.TypeFaceName = MainForm.cbx_font_type.value
    swTextFormat.CharHeight = MainForm.tbx_letter_height.Text / 1000 ' Size of characters in meter, therefor divided by 1000
    
    swSketchText.SetTextFormat False, swTextFormat
    
    swSketchManager.InsertSketch True

    Dim swFeatureManager As FeatureManager
    Set swFeatureManager = swModel.FeatureManager

    Dim swFeature As Feature
    Set swFeature = swFeatureManager.FeatureCut4(True, _
                                                 False, _
                                                 False, _
                                                 swEndConditions_e.swEndCondBlind, _
                                                 swEndConditions_e.swEndCondBlind, _
                                                 MainForm.tbx_schnitttiefe / 1000, _
                                                 0, _
                                                 False, False, False, False, _
                                                 0, _
                                                 0, _
                                                 False, False, False, False, False, False, True, False, True, True, _
                                                 swStartConditions_e.swStartSketchPlane, _
                                                 0, _
                                                 0, _
                                                 False)

End Sub

Private Function FinalAngle(swMathUtility As MathUtility, targetVector As MathVector) As Double
    
    ' Create variable for the reference vector of the y-axis and assign it.
    Dim yVector(2) As Double
    yVector(0) = 0#
    yVector(1) = 1#
    yVector(2) = 0#
    Dim swReferenceVectorInYDirection As MathVector
    Set swReferenceVectorInYDirection = swMathUtility.CreateVector(yVector)

    ' Create a variable for the DOT value and assign it.
    Dim dotValue As Double
    dotValue = swReferenceVectorInYDirection.Dot(targetVector)

    ' Create a variable for the interim result and calculate it.
    Dim interimResult As Double
    interimResult = dotValue / (swReferenceVectorInYDirection.GetLength * targetVector.GetLength)

    ' Create a variable for the RAD value of the angle and assign it.
    Dim angleRad As Double
    angleRad = Arccos(interimResult)

    ' Check target vector direction and calculate for full circle. Return that value.
    If targetVector.ArrayData(0) >= 0 Then
        FinalAngle = 2 * Pi - angleRad
    Else
        FinalAngle = angleRad
    End If

End Function

Private Function Pi() As Double
    Pi = 4 * Atn(1)
End Function

Private Function ReduceDecimalPlaces(ByVal value As Double) As Double
    ReduceDecimalPlaces = Round(value, 8)
End Function

Private Function CheckSelection() As Boolean
    Set swSelectionManager = swModel.SelectionManager
    
    Dim numberOfSelectedObjects As Long
    numberOfSelectedObjects = swSelectionManager.GetSelectedObjectCount2(-1)
    
    EdgePositionInSelection = -1
    PointPositionInSelection = -1
    
    Select Case numberOfSelectedObjects
        Case 2
            Dim counter As Long
            For counter = 1 To numberOfSelectedObjects
                If swSelectionManager.GetSelectedObjectType3(counter, -1) = swSelectType_e.swSelEDGES Then
                    EdgePositionInSelection = counter
                End If
                If swSelectionManager.GetSelectedObjectType3(counter, -1) = swSelectType_e.swSelFACES Then
                    PointPositionInSelection = counter
                End If
            Next
            If EdgePositionInSelection = -1 Or PointPositionInSelection = -1 Then
                swApp.SendMsgToUser "Keine Fläche UND Kante gewählt."
                CheckSelection = False
                Exit Function
            End If
            Dim selectedFace As Face2
            Set selectedFace = swSelectionManager.GetSelectedObject6(PointPositionInSelection, -1)
            Dim selectedEdge As Edge
            Set selectedEdge = swSelectionManager.GetSelectedObject6(EdgePositionInSelection, -1)
            Dim edgeList As Variant
            edgeList = selectedFace.GetEdges
            Dim edgeCount As Long
            edgeCount = selectedFace.GetEdgeCount
            Dim edgeObj As Edge
            For counter = 0 To edgeCount - 1
                Set edgeObj = edgeList(counter)
                If swApp.IsSame(edgeObj, selectedEdge) = swObjectEquality.swObjectSame Then
                    CheckSelection = True
                    Exit Function
                End If
            Next
            swApp.SendMsgToUser "Die Kante muss an der ausgewählten Fläche liegen."
            CheckSelection = False
            Exit Function
            
        Case 0
            swApp.SendMsgToUser "Keine Auswahl. Fläche und Kante auswählen."
            CheckSelection = False
            Exit Function
        
        Case 1
            swApp.SendMsgToUser "Die Auswahl muss zwei Objekte beinhalten." + vbCrLf + _
                                "Es wurde nur ein Objekt ausgewählt."
            CheckSelection = False
            Exit Function
            
        Case Else
            swApp.SendMsgToUser "Die Auswahl darf nur zwei Objekte beinhalten." + vbCrLf + _
                                "Es wurden " + CStr(numberOfSelectedObjects) + " Objekte ausgewählt."
            CheckSelection = False
            Exit Function
            
    End Select
    
    CheckSelection = False
End Function