Folge 36 – Welle erstellen

In diesem Video erstelle ich das Projekt aus dem vorherigen Video.

Und an dieser Stelle der Code der im Makro vorhanden ist.

{form_main}

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Option Explicit
 
Dim updateValuesCycle As Boolean
 
Private Sub btn_addValues_Click()
    If Not IsNumeric(tbx_diameter) Then
        MsgBox ("Der Durchmesser ist kein Zahl.")
        Exit Sub
    End If
    If Not IsNumeric(tbx_width) Then
        MsgBox ("Die Breite ist kein Zahl.")
        Exit Sub
    End If
    AddDataToListbox
    ClearFields
    tbx_diameter.SetFocus
End Sub
 
Private Sub btn_createShaftInSolidworks_Click()
    If lbx_features.ListCount > 0 Then
        mod_swx.CreateFirstShoulder lbx_features.List(0, 0), lbx_features.List(0, 1)
        If lbx_features.ListCount > 1 Then
            Dim counter As Integer
            For counter = 1 To lbx_features.ListCount - 1
                mod_swx.CreateNextShoulder lbx_features.List(counter, 0), lbx_features.List(counter, 1)
            Next
        End If
    End If
End Sub
 
Private Sub btn_deleteEntry_Click()
    lbx_features.RemoveItem lbx_features.ListIndex
    ClearFields
    lbx_features.selected(lbx_features.ListIndex) = False
    tbx_diameter.SetFocus
    btn_addValues.Enabled = True
End Sub
 
Private Sub btn_resetList_Click()
    lbx_features.Clear
    ClearFields
    tbx_diameter.SetFocus
End Sub
 
Private Sub btn_undoSelection_Click()
    ClearFields
    lbx_features.selected(lbx_features.ListIndex) = False
    tbx_diameter.SetFocus
End Sub
 
Private Sub btn_updateValues_Click()
    updateValuesCycle = True
    lbx_features.List(lbx_features.ListIndex, 0) = tbx_diameter
    lbx_features.List(lbx_features.ListIndex, 1) = tbx_width
    ClearFields
    lbx_features.selected(lbx_features.ListIndex) = False
    updateValuesCycle = False
    tbx_diameter.SetFocus
    btn_addValues.Enabled = True
End Sub
 
Private Sub lbx_features_Click()
    If updateValuesCycle = False Then
        tbx_diameter.Text = lbx_features.List(lbx_features.ListIndex, 0)
        tbx_width.Text = lbx_features.List(lbx_features.ListIndex, 1)
        btn_updateValues.Enabled = True
        btn_deleteEntry.Enabled = True
        btn_undoSelection.Enabled = True
        btn_addValues.Enabled = False
        tbx_diameter.SetFocus
    End If
End Sub
 
Private Sub AddDataToListbox()
    lbx_features.AddItem
    lbx_features.List(lbx_features.ListCount - 1, 0) = tbx_diameter
    lbx_features.List(lbx_features.ListCount - 1, 1) = tbx_width
End Sub
 
Private Sub ClearFields()
    tbx_diameter.Text = ""
    tbx_width.Text = ""
    btn_updateValues.Enabled = False
    btn_deleteEntry.Enabled = False
    btn_undoSelection.Enabled = False
End Sub
 
Private Sub UserForm_Initialize()
    ClearFields
    mod_swx.Init
End Sub

{mod_start}

1
2
3
4
5
Option Explicit
 
Sub main()
    form_main.Show vbModeless
End Sub

{mod_swx}

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Option Explicit
 
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swFeatureManager As FeatureManager
Dim nameCounter As Integer
 
Sub Init()
    Set swApp = Application.SldWorks
    nameCounter = 1
End Sub
 
Sub CreateFirstShoulder(ByVal diameter As Double, ByVal width As Double)
    CreatePart
    SelectSketchPlane True
    CreateShoulder diameter, width
End Sub
 
Sub CreateNextShoulder(ByVal diameter As Double, ByVal width As Double)
    SelectSketchPlane False
    CreateShoulder diameter, width
End Sub
 
Private Sub SelectSketchPlane(ByVal firstShoulder As Boolean)
    Dim selected As Boolean
    If firstShoulder Then
        selected = swModel.Extension.SelectByID2("Ebene rechts", "PLANE", 0#, 0#, 0#, False, -1, Nothing, 0)
    Else
        selected = swModel.Extension.SelectByRay(1#, 0#, 0#, -1#, 0#, 0#, 1#, swSelectType_e.swSelFACES, False, -1, swSelectOption_e.swSelectOptionDefault)
    End If
End Sub
 
Private Sub CreatePart()
    Dim partTemplate As String
    partTemplate = swApp.GetUserPreferenceStringValue(swUserPreferenceStringValue_e.swDefaultTemplatePart)
    Set swModel = swApp.NewDocument(partTemplate, 0, 0, 0)
    If swModel Is Nothing Then
        swApp.SendMsgToUser2 "Fehler beim erstellen der Part-Datei. Bitte Vorlagen Pfad prüfen.", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
        End
    End If
    Set swFeatureManager = swModel.FeatureManager
End Sub
 
Private Sub CreateShoulder(ByVal diameter As Double, ByVal width As Double)
    swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swInputDimValOnCreate, False
     
    diameter = diameter / 1000
    width = width / 1000
    Dim swSketchMgr As SketchManager
    Set swSketchMgr = swModel.SketchManager
    swSketchMgr.InsertSketch True
    Dim swSketchSeg As SketchSegment
    Set swSketchSeg = swSketchMgr.CreateCircleByRadius(0#, 0#, 0#, diameter / 2)
    swSketchSeg.Select4 False, Nothing
    Dim swDisplayDimension As DisplayDimension
    Set swDisplayDimension = swModel.AddDiameterDimension2(0, 0, 0)
    swSketchMgr.InsertSketch True
    Dim swSelMgr As SelectionMgr
    Set swSelMgr = swModel.SelectionManager
    Dim swFeature As Feature
    Set swFeature = swSelMgr.GetSelectedObject6(1, -1)
    swFeature.Name = "Skizze_Absatz_" & nameCounter
    Set swFeature = swFeatureManager.FeatureExtrusion3( _
                                    True, _
                                    False, _
                                    False, _
                                    swEndConditions_e.swEndCondBlind, _
                                    swEndConditions_e.swEndCondBlind, _
                                    width, _
                                    0#, _
                                    False, _
                                    False, _
                                    False, _
                                    False, _
                                    0#, _
                                    0#, _
                                    False, _
                                    False, _
                                    False, _
                                    False, _
                                    True, _
                                    True, _
                                    True, _
                                    swStartConditions_e.swStartSketchPlane, _
                                    0#, _
                                    False)
    swFeature.Name = "Absatz_" & nameCounter
     
    swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swInputDimValOnCreate, True
    nameCounter = nameCounter + 1
End Sub

Schreibe einen Kommentar

Deine E-Mail-Adresse wird nicht veröffentlicht. Erforderliche Felder sind mit * markiert

➤