Code:
Const pi = 3.14159 'Festlegung der Konstanten PI = 3,14159Function dtr(a As Double) As Double
dtr = (a / 180) * pi
'Festlegung der Winkelfunktion
End Function
Private Sub cmd1_Click()
'Festlegung der Variablen
Dim Prompt1 As String
Dim P0, P1, P2, P3, P4, P5, P6, P7, P8, P9, P10, P11, P12, P13, P14, P15 As Variant
Dim Point(23) As Double
Dim Point1(20) As Double
Dim XL, YL As Integer
Dim pline As AcadPolyline
Dim pline1 As AcadPolyline
Dim nHatch As AcadHatch
Dim nHatch1 As AcadHatch
Dim HObjs(0) As AcadEntity
Dim HObjs1(0) As AcadEntity
Dim scal1 As Double
Dim wink1 As Double
Dim schr1 As Variant
If (tbo1.Value = "" Or tbo2.Value = "") Then GoTo MyErrorHandler
Falzleiste.Hide 'Blendet die Dialogbox aus, löscht sie aber nicht aus dem Speicher
Prompt1 = vbCrLf & "Einfügepunkt:"
P0 = ThisDrawing.Utility.GetPoint(, Prompt1) 'Einfügepunkt
On Local Error Resume Next 'Fehlerübersprung
'Werte einzelnen Variablen zu ordnen
XL = tbo1.Value 'Materialstärke
YL = tbo2.Value 'Höhe der Falzleisten
scal1 = tbo3.Value
wink1 = tbo4.Value
schr1 = cbo3.Value
'Koordinatenfestlegung über Variablen
P1 = ThisDrawing.Utility.PolarPoint(P0, dtr(90#), YL - 5)
P2 = ThisDrawing.Utility.PolarPoint(P1, dtr(180#), XL)
P3 = ThisDrawing.Utility.PolarPoint(P2, dtr(270#), YL - 10)
P4 = ThisDrawing.Utility.PolarPoint(P3, dtr(0#), XL / 2)
P5 = ThisDrawing.Utility.PolarPoint(P4, dtr(270#), 7)
P6 = ThisDrawing.Utility.PolarPoint(P5, dtr(270#), 3)
P7 = ThisDrawing.Utility.PolarPoint(P6, dtr(0#), 3)
P8 = ThisDrawing.Utility.PolarPoint(P7, dtr(0#), (XL / 2) - 3)
P9 = ThisDrawing.Utility.PolarPoint(P8, dtr(270#), YL - 10)
P10 = ThisDrawing.Utility.PolarPoint(P9, dtr(180#), XL)
P11 = ThisDrawing.Utility.PolarPoint(P10, dtr(90#), YL)
P12 = ThisDrawing.Utility.PolarPoint(P11, dtr(0#), (XL / 2) - 3)
P13 = ThisDrawing.Utility.PolarPoint(P12, dtr(0#), 3)
P14 = ThisDrawing.Utility.PolarPoint(P13, dtr(270#), 3)
P15 = ThisDrawing.Utility.PolarPoint(P14, dtr(270#), 7)
'Die einzelnen Punkte der Vertex Liste (Point) zufügen
Point(0) = P0(0): Point(1) = P0(1)
Point(3) = P1(0): Point(4) = P1(1)
Point(6) = P2(0): Point(7) = P2(1)
Point(9) = P3(0): Point(10) = P3(1)
Point(12) = P4(0): Point(13) = P4(1)
Point(15) = P5(0): Point(16) = P5(1)
Point(18) = P7(0): Point(19) = P7(1)
Point(21) = P8(0): Point(22) = P8(1)
'Polylinie zeichnen
Set pline = ThisDrawing.ModelSpace.AddPolyline(Point)
pline.Layer = cbo1.Value
pline.Closed = True
'Die einzelnen Punkte der Vertex Liste (Point1) zufügen
Point1(0) = P8(0): Point1(1) = P8(1)
Point1(3) = P9(0): Point1(4) = P9(1)
Point1(6) = P10(0): Point1(7) = P10(1)
Point1(9) = P11(0): Point1(10) = P11(1)
Point1(12) = P12(0): Point1(13) = P12(1)
Point1(15) = P14(0): Point1(16) = P14(1)
Point1(18) = P15(0): Point1(19) = P15(1)
'Polylinie zeichnen
Set pline1 = ThisDrawing.ModelSpace.AddPolyline(Point1)
pline1.Layer = cbo1.Value
pline1.Closed = True
'Schraffurdefinition
Set nHatch = ThisDrawing.ModelSpace.AddHatch(0, schr1, True)
Set HObjs(0) = pline
nHatch.AppendOuterLoop (HObjs)
nHatch.Layer = cbo2.Text
nHatch.PatternAngle = ThisDrawing.Utility.AngleToReal(wink1, acDegrees)
nHatch.PatternScale = scal1
nHatch.Evaluate
nHatch.color = acCyan
ThisDrawing.Regen True
'Schraffurdefinition
Set nHatch1 = ThisDrawing.ModelSpace.AddHatch(0, schr1, True)
Set HObjs1(0) = pline1
nHatch1.AppendOuterLoop (HObjs1)
nHatch1.Layer = cbo2.Text
nHatch1.PatternAngle = ThisDrawing.Utility.AngleToReal(wink1, acDegrees)
nHatch1.PatternScale = scal1
nHatch1.Evaluate
nHatch1.color = acCyan
ThisDrawing.Regen True
Exit Sub
MyErrorHandler:
MsgBox "Bitte geben Sie entsprechende Werte ein", 64, "Hinweis"
End Sub
Private Sub tbo1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Erlaubt = "0123456789.," & Chr$(8)
zeichen = Chr$(KeyAscii)
If InStr(1, Erlaubt, zeichen) = 0 Then
KeyAscii = 0
End If
End Sub
Private Sub tbo1_Change()
tbo1.Text = Replace(tbo1.Text, ".", ",")
End Sub
Private Sub tbo2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Erlaubt = "0123456789.," & Chr$(8)
zeichen = Chr$(KeyAscii)
If InStr(1, Erlaubt, zeichen) = 0 Then
KeyAscii = 0
End If
End Sub
Private Sub tbo2_Change()
tbo2.Text = Replace(tbo2.Text, ".", ",")
End Sub
Private Sub tbo3_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Erlaubt = "0123456789.," & Chr$(8)
zeichen = Chr$(KeyAscii)
If InStr(1, Erlaubt, zeichen) = 0 Then
KeyAscii = 0
End If
End Sub
Private Sub tbo3_Change()
tbo3.Text = Replace(tbo3.Text, ".", ",")
End Sub
Private Sub tbo4_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Erlaubt = "0123456789.," & Chr$(8)
zeichen = Chr$(KeyAscii)
If InStr(1, Erlaubt, zeichen) = 0 Then
KeyAscii = 0
End If
End Sub
Private Sub tbo4_Change()
tbo4.Text = Replace(tbo4.Text, ".", ",")
End Sub
Private Sub cbo1_Change()
Dim PickLayer As String
Dim NewLayer As AcadLayer
PickLayer = cbo1.Text
Set NewLayer = ThisDrawing.Layers(PickLayer)
End Sub
Private Sub UserForm_Initialize()
Dim nLay(0 To 1) As AcadLayer
Set nLay(0) = ThisDrawing.Layers.Add("Falzleiste")
Set nLay(1) = ThisDrawing.Layers.Add("Falzleistenschraffur")
Dim entry As AcadLayer
For Each entry In ThisDrawing.Layers
cbo1.AddItem entry.Name
cbo2.AddItem entry.Name
Next
cbo1.Value = "Falzleiste"
cbo2.Value = "Falzleistenschraffur"
cbo3.Value = "Ansi31"
With cbo3
.AddItem ("Angle")
.AddItem ("Ansi31")
.AddItem ("Ansi32")
.AddItem ("Ansi33")
.AddItem ("Ansi34")
.AddItem ("Ansi35")
.AddItem ("Ansi36")
.AddItem ("Ansi37")
.AddItem ("Ansi38")
End With
End Sub
Private Sub cmd2_click()
End
End Sub
Foren auf CAD.de (alle Foren)
| 
