UserForm / Modul - Prozedur (Autodesk/AutoCAD VBA)

Hallo zusammen!

Um einen Code innerhalb einer UserForm nicht zu überladen, möchte ich bestimmte Prozeduren in Module auslagern, wie z.B. diese 3D Stellschraube.
Diese soll nach dem Clickereignis in der UserForm der Zeichnung als Block hinzugefügt werden und über einen definierten Punkt "ZRohr" eingefügt werden.
Wie ruf ich denn jetzt dieses aus meiner UserForm auf?

Modul: Stellfuss01

Code:

Option Explicit
'---Winkelfunktion definieren-----------------------------------------------------
Const pi = 3.14159
'---Winkelfunktion definieren------------------------------------------------------
Function dtr(a As Double) As Double
dtr = (a / 180) * pi
End Function
'-----------------------------------------------------
Public Sub Stellfuss01()
Dim cP(0 To 2) As Double
cP(0) = 0#: cP(1) = 0#: cP(2) = 0#
Dim StBlock As AcadBlock
Dim col1 As New AcadAcCmColor
Call col1.SetRGB(59, 59, 59)
Dim col2 As New AcadAcCmColor
Call col2.SetRGB(245, 245, 248)
On Error Resume Next
Set StBlock = ThisDrawing.Blocks("test02")
If Err.Number = 0 Then
'Block schon vorhanden
Exit Sub
End If
On Error GoTo 0
Set StBlock = ThisDrawing.Blocks.Add(cP, "test02")
Dim StLay As AcadLayer
Set StLay = ThisDrawing.Layers.Add("Stellfuss1")
Dim S1, S2, S3, S4, S5, S6 As Variant
Dim stellobj1(0 To 4) As AcadEntity
With ThisDrawing.Utility
S1 = .PolarPoint(cP, dtr(180#), 21)
S2 = .PolarPoint(S1, dtr(180#), 1.5)
S3 = .PolarPoint(S2, dtr(90#), 1.5)
S4 = .PolarPoint(S3, dtr(90#), 12.5)
S5 = .PolarPoint(S4, dtr(0#), 14)
S6 = .PolarPoint(S5, dtr(0#), 8.5)
End With
With ThisDrawing.ModelSpace
Set stellobj1(0) = .AddLine(cP, S1)
Set stellobj1(1) = .AddLine(S1, S3)
Set stellobj1(2) = .AddLine(S3, S5)
Set stellobj1(3) = .AddLine(S5, S6)
Set stellobj1(4) = .AddLine(S6, cP)
End With
Dim regobj1 As Variant
regobj1 = ThisDrawing.ModelSpace.AddRegion(stellobj1)
Dim axisDir(0 To 2) As Double
Dim angle As Double
axisDir(0) = 0.001: axisDir(1) = 360: axisDir(2) = 0
angle = (2 * pi)
Dim solidObj0 As Acad3DSolid
'Set solidObj0 = ThisDrawing.ModelSpace.AddRevolvedSolid(regobj1(0), cP, axisDir, angle)
Set solidObj0 = StBlock.AddRevolvedSolid(regobj1(0), cP, axisDir, angle)
solidObj0.TrueColor = col1
solidObj0.Layer = "Stellfuss1"
Dim rota As Double
rota = (pi * 7.5)
solidObj0.Rotate3D cP, S1, rota
stellobj1(0).Delete
stellobj1(1).Delete
stellobj1(2).Delete
stellobj1(3).Delete
stellobj1(4).Delete
regobj1(0).Erase
'---------------------------------------------------------------------
Dim G0, G1, G2, G3, G4, G5 As Variant
Dim gewiobj1(0 To 4) As AcadEntity
With ThisDrawing.Utility
G0 = .PolarPoint(S6, dtr(90#), 6)
G1 = .PolarPoint(G0, dtr(180#), 5)
G2 = .PolarPoint(G1, dtr(90#), 43)
G3 = .PolarPoint(G2, dtr(90#), 2)
G4 = .PolarPoint(G3, dtr(0#), 2)
G5 = .PolarPoint(G4, dtr(0#), 3)
End With
With ThisDrawing.ModelSpace
Set gewiobj1(0) = .AddLine(G0, G1)
Set gewiobj1(1) = .AddLine(G1, G2)
Set gewiobj1(2) = .AddLine(G2, G4)
Set gewiobj1(3) = .AddLine(G4, G5)
Set gewiobj1(4) = .AddLine(G5, G0)
End With
Dim gewreg As Variant
gewreg = ThisDrawing.ModelSpace.AddRegion(gewiobj1)
Dim axisDir1(0 To 2) As Double
Dim angle1 As Double
axisDir1(0) = 0.01: axisDir1(1) = 360: axisDir1(2) = 0
angle1 = (2 * pi)
Dim gewObj As Acad3DSolid
'Set gewObj = ThisDrawing.ModelSpace.AddRevolvedSolid(gewreg(0), cP, axisDir1, angle1)
Set gewObj = StBlock.AddRevolvedSolid(gewreg(0), cP, axisDir1, angle1)
gewObj.TrueColor = col2
gewObj.Layer = "Stellfuss1"
gewObj.Rotate3D cP, S1, rota
gewiobj1(0).Delete
gewiobj1(1).Delete
gewiobj1(2).Delete
gewiobj1(3).Delete
gewiobj1(4).Delete
gewreg(0).Erase
'---------------------------------------------------------------
Dim usObj As Acad3DSolid
Dim radius As Double
Dim height As Double
radius = 8#
height = 1#
'Set usObj = ThisDrawing.ModelSpace.AddCylinder(cP, radius, height)
Set usObj = StBlock.AddCylinder(cP, radius, height)
Dim U0#(2), U1#(2)
U1(2) = U0(2) + 14.5
usObj.Move U0, U1
usObj.TrueColor = col2
usObj.Layer = "Stellfuss1"
'---------------------------------------------------------------
Dim M0, M1, M2, M3, M4, M5, M6, M7, M8, M9, M10 As Variant
Dim muobj1(0 To 5) As AcadEntity
With ThisDrawing.Utility
M0 = .PolarPoint(cP, dtr(270#), 7.0002)
M1 = .PolarPoint(M0, dtr(180#), 4.0416)
M2 = .PolarPoint(M1, dtr(180#), 4.0416)
M3 = .PolarPoint(M2, dtr(90#), 7.002)
M4 = .PolarPoint(M3, dtr(90#), 7.002)
M5 = .PolarPoint(M4, dtr(0#), 4.0416)
M6 = .PolarPoint(M5, dtr(0#), 8.0831)
M7 = .PolarPoint(M6, dtr(0#), 4.0416)
M8 = .PolarPoint(M7, dtr(270#), 7.002)
M9 = .PolarPoint(M8, dtr(270#), 7.002)
M10 = .PolarPoint(M9, dtr(180#), 4.0416)
End With
With ThisDrawing.ModelSpace
Set muobj1(0) = .AddLine(M1, M3)
Set muobj1(1) = .AddLine(M3, M5)
Set muobj1(2) = .AddLine(M5, M6)
Set muobj1(3) = .AddLine(M6, M8)
Set muobj1(4) = .AddLine(M8, M10)
Set muobj1(5) = .AddLine(M10, M1)
End With
Dim mureg As Variant
mureg = ThisDrawing.ModelSpace.AddRegion(muobj1)
Dim taperAngle As Double
taperAngle = 0
Dim mutter As Acad3DSolid
'Set mutter = ThisDrawing.ModelSpace.AddExtrudedSolid(mureg(0), 6, taperAngle)
Set mutter = StBlock.AddExtrudedSolid(mureg(0), 6, taperAngle)
Dim MU0#(2), MU1#(2)
MU1(2) = MU0(2) + 15
mutter.Move MU0, MU1
mutter.TrueColor = col2
mutter.Layer = "Stellfuss1"
muobj1(0).Delete
muobj1(1).Delete
muobj1(2).Delete
muobj1(3).Delete
muobj1(4).Delete
muobj1(5).Delete
mureg(0).Erase
End Sub

UserForm: LBS01

Code:

Private Sub MP2cmd2_click()
Dim Prompt1 As String
Prompt1 = vbCrLf & "Einfügepunkt:"
ZRohr = ThisDrawing.Utility.GetPoint(, Prompt1)
End Sub

Vielen Dank im voraus.

Gruß

Dirk

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP