Folge 30 – ListBox Inhalt ändern und zurück schreiben

Option Explicit
Private Sub eingabe_auswerten(ByVal wert As String, ByVal adresse As String)
    If IsNumeric(wert) Then
        If CDbl(wert) > 0 Then
            mod_swx.schreiben adresse, CDbl(wert)
        Else
            MsgBox ("Die Zahl darf nicht kleiner oder gleich 0 sein.")
        End If
    Else
        MsgBox ("Der Inhalt konnte nicht in eine Zahl umgewandelt werden." & vbCrLf & "Der Inhalt ist: " & wert)
    End If
End Sub
Private Sub buttonAuslesen_Click()
    lb_dimensions.Clear
    Dim entry As Variant
    For Each entry In mod_swx.auslesen
        lb_dimensions.AddItem
        lb_dimensions.List(lb_dimensions.ListCount - 1, 0) = entry(0)
        lb_dimensions.List(lb_dimensions.ListCount - 1, 1) = entry(1)
        lb_dimensions.List(lb_dimensions.ListCount - 1, 2) = entry(2)
        lb_dimensions.List(lb_dimensions.ListCount - 1, 3) = entry(3)
    Next
End Sub
Private Sub buttonSchreiben_Click()
    Dim index As Integer
    For index = 0 To lb_dimensions.ListCount - 1
        eingabe_auswerten lb_dimensions.Column(3, index), _
                          lb_dimensions.Column(0, index) & "@" & _
                          lb_dimensions.Column(1, index) & "@" & _
                          lb_dimensions.Column(2, index)
    Next index
End Sub
Private Sub lb_dimensions_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If lb_dimensions.ListIndex > -1 Then
        lbl_fullname.Caption = lb_dimensions.Column(0, lb_dimensions.ListIndex) & "@" & _
                               lb_dimensions.Column(1, lb_dimensions.ListIndex) & "@" & _
                               lb_dimensions.Column(2, lb_dimensions.ListIndex)
        tb_value.Text = lb_dimensions.Column(3, lb_dimensions.ListIndex)
    End If
End Sub
Private Sub tb_value_Change()
    If lb_dimensions.ListIndex > -1 Then lb_dimensions.List(lb_dimensions.ListIndex, 3) = tb_value.Text
End Sub
Private Sub UserForm_Initialize()
    mod_swx.check
End Sub

Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Sub check()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        swApp.SendMsgToUser2 "Keine Datei geöffnet.", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
        End
    End If
End Sub
Function auslesen() As Variant
    Dim swFeatureManager As FeatureManager
    Dim featureArray As Variant
    Dim listCounter As Long
    Dim vFeature As Variant
    Dim swFeature As Feature
    Dim swDisplayDimension As DisplayDimension
    Dim swDimension As Dimension
    Dim values As Variant
    Dim splitFullname As Variant
    Dim returnArray() As Variant
    
    Set swFeatureManager = swModel.FeatureManager
    featureArray = swFeatureManager.GetFeatures(True)
    listCounter = 0
    For Each vFeature In featureArray
        Set swFeature = vFeature
        If swFeature.GetTypeName2 = "Extrusion" Or swFeature.GetTypeName2 = "ICE" Then
            Set swDisplayDimension = swFeature.GetFirstDisplayDimension
            Do While Not swDisplayDimension Is Nothing
                Set swDimension = swDisplayDimension.GetDimension2(0)
                values = swDimension.GetValue3(swInConfigurationOpts_e.swThisConfiguration, "")
                splitFullname = Split(swDimension.fullname, "@")
                ReDim Preserve returnArray(0 To listCounter) As Variant
                returnArray(listCounter) = Array(splitFullname(0), splitFullname(1), splitFullname(2), values(0))
                listCounter = listCounter + 1
                Set swDisplayDimension = swFeature.GetNextDisplayDimension(swDisplayDimension)
            Loop
        End If
    Next
    auslesen = returnArray
End Function
Sub schreiben(fullname As String, newValue As Double)
    Dim swDimension As Dimension
    Set swDimension = swModel.Parameter(fullname)
    If Not swDimension Is Nothing Then
        Dim returnValue As swSetValueReturnStatus_e
        returnValue = swDimension.SetValue3(newValue, swSetValueInConfiguration_e.swSetValue_InThisConfiguration, Nothing)
        Select Case returnValue
            Case swSetValue_Failure
                swApp.SendMsgToUser "Wert konnte aus unbekanntem Grund nicht gesetzt werden."
            Case swSetValue_InvalidValue
                swApp.SendMsgToUser "Der Wert war nicht geeignet um diesen Parameter zu ändern."
            Case swSetValue_DrivenDimension
                swApp.SendMsgToUser "Kann nicht auf eine Bemassung angewendet werden, welche durch die Geometrie bestimmt ist."
            Case swSetValue_ModelNotLoaded
                swApp.SendMsgToUser "Modell muss geladen sein um den Wert zu setzen."
            Case swSetValue_FrozenFeatureOwner
                swApp.SendMsgToUser "Besitzer der Bemassung ist eingefroren."
        End Select
        Dim bool As Boolean
        bool = swModel.ForceRebuild3(False)
    Else
        swApp.SendMsgToUser "Die Bemassung mit dem Namen(" & fullname & ") gibt es nicht in dem aktuellen Modell."
    End If
End Sub