---

Spax_01.jpg

Hallo Zusammen!

Ich bin dabei mir ein Programm zu schreiben bei dem ich aus einer Liste eine Spanplattenschraube (Spax) auswählen kann, die dann erzeugt und in der Zeichnung als Block abgelegt bzw. eingefügt wird.
Dieses funktioniert auch soweit, erfordert aber viel schreibarbeit.
Kann mir von Euch jemand helfen, wie ich dieses einfacher und komprimierter schreiben könnte?

Hier ein Auszug aus dem Programm:
Const pi = 3.14159

Function dtr(a As Double) As Double
    dtr = (a / 180) * pi
End Function

Private Sub Cbo_Change()
    'wählt einen Layer aus der ComboBox aus
    'und macht ihn zu dem aktuellen Layer
    Dim PickLayer As String
    Dim NewLayer As AcadLayer
    PickLayer = Cbo.Text
    Set NewLayer = ThisDrawing.Layers(PickLayer)
End Sub

Private Sub Cbo1_Change()
    'wählt einen Linientype aus der ComboBox aus
    'und macht ihn zu dem aktuellen Linientype
    Dim Pickltype As String
    Dim Newltype As AcadLineType
    Pickltype = Cbo1.Text
    Set Newltype = ThisDrawing.Linetypes(Pickltype)
End Sub

Private Sub Cmd_click()

Dim Prompt1 As String
Dim IPoint As Variant
Dim Angle As Double
Dim lineobj As AcadPolyline
Dim lineobj1 As acadline
Dim lineobj2 As acadline
Dim Reihe As Long              'rechtwinklige Anordnung
Dim Spalte As Long              'rechtwinklige Anordnung
Dim Ebene As Long              'rechtwinklige Anordnung
Dim AbstandReihe As Double      'rechtwinklige Anordnung
Dim AbstandSpalte As Double    'rechtwinklige Anordnung
Dim AbstandEbene As Double      'rechtwinklige Anordnung

Spax_01.Hide

Prompt1 = vbCrLf & "Einfügepunkt:"
IPoint = ThisDrawing.Utility.GetPoint(, Prompt1) 'Einfügepunkt
Angle = ThisDrawing.Utility.GetAngle(IPoint, Prompt1)
   
Select Case Lst.ListIndex

Case 0  'Auswahl der Schraube "Spax 3 x 12mm"
   
    'Definition des Reihebefels bei der rechtwinkligen Anordnung
    Reihe = 8
    Spalte = 1
    Ebene = 1
    AbstandReihe = -0.9004
    AbstandSpalte = 1
    AbstandEbene = 1
           
'Definition des Blocks "Spax312"
Dim Spax312b As AcadBlock
Dim Spax312ep(0 To 2) As Double
    Spax312ep(0) = 0
    Spax312ep(1) = 0
    Spax312ep(2) = 0
Set Spax312b = ThisDrawing.Blocks.Add(Spax312ep, "Spax312")
     
'Hinzufügen der Linien zum Block "Spax312"
Dim Point(29) As Double
Dim p01, p02, p03, p04, p05, p06, p07, p08, p09, p010, p011, p012 As Variant
       
    p01 = ThisDrawing.Utility.PolarPoint(Spax312ep, dtr(180#), 3)
    p02 = ThisDrawing.Utility.PolarPoint(p01, dtr(270#), 0.375)
    p03 = ThisDrawing.Utility.PolarPoint(p02, dtr(315#), 2.7577)
    p04 = ThisDrawing.Utility.PolarPoint(p03, dtr(270#), 7.8563)
    p05 = ThisDrawing.Utility.PolarPoint(p04, dtr(300#), 2.1)
    p06 = ThisDrawing.Utility.PolarPoint(p05, dtr(60#), 2.1)
    p07 = ThisDrawing.Utility.PolarPoint(p06, dtr(90#), 7.8563)
    p08 = ThisDrawing.Utility.PolarPoint(p07, dtr(45#), 2.7577)
    p09 = ThisDrawing.Utility.PolarPoint(p08, dtr(90#), 0.375)
    p010 = ThisDrawing.Utility.PolarPoint(Spax312ep, dtr(270#), 3.5798)
    p011 = ThisDrawing.Utility.PolarPoint(p010, dtr(13#), 1.5423)
    p012 = ThisDrawing.Utility.PolarPoint(p011, dtr(193#), 3.0846)

    'Die einzelnen Punkte der Vertex Liste (Point) zufügen
    Point(0) = Spax312ep(0): Point(1) = Spax312ep(1)
    Point(3) = p01(0): Point(4) = p01(1)
    Point(6) = p02(0): Point(7) = p02(1)
    Point(9) = p03(0): Point(10) = p03(1)
    Point(12) = p04(0): Point(13) = p04(1)
    Point(15) = p05(0): Point(16) = p05(1)
    Point(18) = p06(0): Point(19) = p06(1)
    Point(21) = p07(0): Point(22) = p07(1)
    Point(24) = p08(0): Point(25) = p08(1)
    Point(27) = p09(0): Point(28) = p09(1)
   
Set lineobj = Spax312b.AddPolyline(Point)
    lineobj.Layer = Cbo.Value
    lineobj.Linetype = Cbo1.Value
    lineobj.Closed = True
   
Set lineobj2 = Spax312b.AddLine(p02, p08)
    lineobj2.Layer = Cbo.Value
    lineobj2.Linetype = Cbo1.Value
   
Set lineobj2 = Spax312b.AddLine(p03, p07)
    lineobj2.Layer = Cbo.Value
    lineobj2.Linetype = Cbo1.Value
   
Set lineobj1 = Spax312b.AddLine(p011, p012)
    lineobj1.Layer = Cbo.Value
    lineobj1.Linetype = Cbo1.Value

    'Erstellen der Objektanordnung
Dim retObj As Variant
    retObj = lineobj1.ArrayRectangular(Reihe, Spalte, Ebene, AbstandReihe, AbstandSpalte, AbstandEbene)
   
    'Definition des Blocks Symbol "Spax312s"
Dim Spax312bs As AcadBlock
Dim Spax312eps(0 To 2) As Double
    Spax312eps(0) = 0
    Spax312eps(1) = 0
    Spax312eps(2) = 0
Set Spax312bs = ThisDrawing.Blocks.Add(Spax312eps, "Spax312s")
 
    'Hinzufügen der Linien zum Block Symbol "Spax312s"
Dim p013, p014, p015, p016 As Variant

    p013 = ThisDrawing.Utility.PolarPoint(Spax312eps, dtr(180#), 3)
    p014 = ThisDrawing.Utility.PolarPoint(p013, dtr(322#), 3.7955)
    p015 = ThisDrawing.Utility.PolarPoint(p014, dtr(38#), 3.7955)
    p016 = ThisDrawing.Utility.PolarPoint(p014, dtr(270#), 9.675)

Set lineobj2 = Spax312bs.AddLine(p013, p014)
    lineobj2.Layer = Cbo.Value
    lineobj2.Linetype = Cbo1.Value
Set lineobj2 = Spax312bs.AddLine(p014, p015)
    lineobj2.Layer = Cbo.Value
    lineobj2.Linetype = Cbo1.Value
Set lineobj2 = Spax312bs.AddLine(p014, p016)
    lineobj2.Layer = Cbo.Value
    lineobj2.Linetype = Cbo1.Value

    'Einfügen des Blocks
Dim orsy As String
Dim Spax312ref As AcadBlockReference
   
    If Opt.Value = True Then
        orsy = "Spax312"
    End If
    If Opt1.Value = True Then
        orsy = "Spax312s"
    End If
   
Set Spax312ref = ThisDrawing.ModelSpace.InsertBlock(IPoint, orsy, 1#, 1#, 1#, Angle)

    If Chk.Value = True Then
        Spax312ref.Explode
    End If
...
...
...

Private Sub Cmd3_Click()
    Cod.ShowColor
End Sub

Private Sub UserForm_Initialize()

Dim nLay As AcadLayer
Set nLay = ThisDrawing.Layers.Add("Spanplattenschraube")
nLay.Color = acCyan

Dim entry As AcadLayer
    For Each entry In ThisDrawing.Layers
        Cbo.AddItem entry.Name
    Next

Dim entry1 As AcadLineType
    For Each entry1 In ThisDrawing.Linetypes
        Cbo1.AddItem entry1.Name
    Next

Cbo.Value = "Spanplattenschraube"
Cbo1.ListIndex = 0
   
    With Lst
        .AddItem "Spax  3 x 12mm", 0
        .AddItem "Spax  3 x 16mm", 1
        .AddItem "Spax  3 x 20mm", 2
        .AddItem "Spax  3 x 25mm", 3
        .AddItem "Spax  3 x 30mm", 4
        .AddItem "Spax  3 x 35mm", 5
        .AddItem "Spax 3,5 x 16mm", 6
        .AddItem "Spax 3,5 x 20mm", 7
        .AddItem "Spax 3,5 x 25mm", 8
        .AddItem "Spax 3,5 x 30mm", 9
        .AddItem "Spax 3,5 x 35mm", 10
        .AddItem "Spax 3,5 x 40mm", 11
        .AddItem "Spax 3,5 x 12mm", 12
        .AddItem "Spax  4 x 16mm", 13
        .AddItem "Spax  4 x 20mm", 14
        .AddItem "Spax  4 x 25mm", 15
        .AddItem "Spax  4 x 30mm", 16
        .AddItem "Spax  4 x 35mm", 17
        .AddItem "Spax  4 x 40mm", 18
        .AddItem "Spax  4 x 45mm", 19
        .AddItem "Spax  4 x 50mm", 20
        .AddItem "Spax  4 x 55mm", 21
        .AddItem "Spax  4 x 60mm", 22
        .AddItem "Spax 4,5 x 20mm", 23
        .AddItem "Spax 4,5 x 25mm", 24
        .AddItem "Spax 4,5 x 30mm", 25
        .AddItem "Spax 4,5 x 35mm", 26
        .AddItem "Spax 4,5 x 40mm", 27
        .AddItem "Spax 4,5 x 45mm", 28
        .AddItem "Spax 4,5 x 50mm", 29
        .AddItem "Spax 4,5 x 60mm", 30
        .AddItem "Spax  5 x 30mm", 31
        .AddItem "Spax  5 x 35mm", 32
        .AddItem "Spax  5 x 40mm", 33
        .AddItem "Spax  5 x 45mm", 34
        .AddItem "Spax  5 x 50mm", 35
        .AddItem "Spax  5 x 60mm", 36
        .AddItem "Spax  5 x 70mm", 37
        .AddItem "Spax  5 x 80mm", 38
        .AddItem "Spax  5 x 90mm", 39
        .AddItem "Spax  6 x 50mm", 40
        .AddItem "Spax  6 x 60mm", 41
        .AddItem "Spax  6 x 70mm", 42
        .AddItem "Spax  6 x 80mm", 43
        .AddItem "Spax  6 x 90mm", 44
        .AddItem "Spax  6 x 100mm", 45
        .AddItem "Spax  6 x 120mm", 46
        .AddItem "Spax  6 x 140mm", 47
    End With
   
Lst.ListIndex = 0
   
End Sub

Private Sub Cmd1_click()
    End
End Sub

Vielen Dank im voraus.

Gruß

Dirk

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

---

Hallo Dirk,

vielleicht kannst du dir eine Funktion zur Berechnung/Erzeugung einer Schraube machen. Der Funktion übergibst du die erforderlichen Maße und diese leitet daraus die Schraubengeometrie ab.

Die Funktion ergibt sich eigentlich schon aus deiner Berechnung. Hier setzt du anstatt fester Werte Variablen ein. Ich glaube aus Durchmesser und Länge läßt sich alles andere Berechnen.

Das Formular sieht gut aus. Du hast hier die Möglichkeit eingebaut eine Farbe zu wählen.

Code:

---

Private Sub Cmd3_Click()
    Cod.ShowColor
End Sub

---

Ist das eine eigene Form?

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

Spax_Eigenschaften_01.jpg Spax_Eigenschaften_02.jpg Spax_Eigenschaften_03.jpg

Hallo Stelli!

Für die Farbzuordnung such ich noch eine Lösung, wie in den Bildchen dargestellt.
Dieses hab ich aus einem anderen Lisp-Formular mal rauskopiert.

Vielleicht kannst Du mir da ja mal wieder helfen.

Gruß

Dirk

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

---

Hi Dirk,

vielleicht hilft dir dies etwas:

Code:

---

Sub ac_farbdialog()
  Dim c1 as variant, c2 as variant
  With ThisDrawing
    c1 = .GetVariable("CECOLOR")
    .SendCommand "_color" & Chr(13)
    c2 = .GetVariable("CECOLOR")
    .SetVariable "CECOLOR", c1
  End With
  MsgBox "gewählte Farbe: " & c2, , "Return Color"
End Sub

---

Gruss Nancy

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

---

Hallo Nancy!

Vielen Dank.
Hab's mal so übernommen:

Private Sub Cmd2_Click()
    Spax_01.Hide
    Dim c1 As Variant, c2 As Variant
    With ThisDrawing
        c1 = .GetVariable("CECOLOR")
        .SendCommand "_color" & Chr(13)
        c2 = .GetVariable("CECOLOR")
        .SetVariable "CECOLOR", c1
    End With
    '''MsgBox "gewählte Farbe: " & c2, , "Return Color"
    Lbl4.Caption = ("gewählte Farbe" & "  " & c2)
    Image1.BackColor = xxxxxx??
    Spax_01.Show
End Sub

Wie bekomme ich es jetzt noch hin, daß die ausgewählte Farbe als Voransicht angezeigt wird?

Image1.BackColor = xxxxxx?? oder wie???

Vielen Dank im voraus.

Gruß

Dirk

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

---

Hi Dirk,

ich habs mal mit dem Code aus Udos zweiten Link getestet,
den ACI-Wert an ein Colorobject übergeben und dessen RGB's auf das Image übertragen.

Code:

---

Option Explicit
Private Declare Function acedSetColorDialog Lib "acad.exe" (color As Long, _
ByVal bAllowMetaColor As Boolean, ByVal nCurLayerColor As Long) As Boolean

Public Function MeGetAcadColor(DefCol As Long, MtaCol As Boolean, _
LayCol As Long) As Long
 
  MeGetAcadColor = -1
 
  On Error Resume Next
 
  If acedSetColorDialog(DefCol, MtaCol, LayCol) Then
    MeGetAcadColor = DefCol
  End If
 
End Function

Sub asdf()
    UserForm1.show 0
    Dim c As New AcadAcCmColor
    On Error Resume Next
    c.ColorIndex = MeGetAcadColor(-1, 1, -1)
    UserForm1.Image1.BackColor = RGB(c.Red, c.Green, c.Blue)
End Sub

---

Gruss Nancy

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

---

Hallo Nancy!
Hallo Udo!

Vielen Dank für Eure Hilfe. Ich komme immer ein Stück weiter.
Soweit funktioniert es auch:

Option Explicit
Private Declare Function acedSetColorDialog Lib "acad.exe" (color As Long, _
ByVal bAllowMetaColor As Boolean, ByVal nCurLayerColor As Long) As Boolean
Public Function MeGetAcadColor(DefCol As Long, MtaCol As Boolean, _
  LayCol As Long) As Long
  MeGetAcadColor = -1
  On Error Resume Next
  If acedSetColorDialog(DefCol, MtaCol, LayCol) Then
  MeGetAcadColor = DefCol
  End If
End Function

Private Sub Cmd2_Click()
    Spax_01.Hide
    Dim c As New AcadAcCmColor
    On Error Resume Next
    c.ColorIndex = MeGetAcadColor(-1, 1, -1)
    Lbl4.Caption = ("gewählte Farbe" & "  " & c.ColorIndex)
    Image1.BackColor = RGB(c.Red, c.Green, c.Blue)
    Spax_01.Show
End Sub

Nun noch die Frage, wie setze ich die ausgewählte Farbe aktive, so daß die Schraube in dem ausgewählten Farbton gezeichnet wird?

ThisDrawing. ????

Gruß

Dirk

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

---

Hallo Dirk,

die aktive Farbe kannst du wie Nancy schon schrieb mit

.SetVariable "CECOLOR", c1

setzen. Brauchst du aber nicht, denn du kannst deinen Elementen
ja die Farbe explizit setzen. Dann sind auch die Einstellungen
des Users (vielleicht arbeitet er immer mit vonLayer) nicht verstellt.

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

Hallo Stelli!

Ich hab nun verschiedenes ausprobiert mit dem .SetVariable "CECOLOR", c1 komme aber zu keinem Ergebnis.
Wie müßte die Syntac genau lauten?

Vielen Dank im voraus.

Gruß

Dirk

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

---

Hallo Dirk,

hier einige Beispiele:

   ThisDrawing.SetVariable "CECOLOR", "ByLayer"  ' VonLayer"

   ThisDrawing.SetVariable "CECOLOR", "1"        ' Rot

Schau auch mal hier: http://ww3.cad.de/foren/ubb/Forum259/HTML/000695.shtml

Was ist aus den Schrauben geworden ?

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

[Diese Nachricht wurde von Stelli1 am 16. Jan. 2006 editiert.]

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

---

Hallo Zusammen!

Ich glaub ich seh vor lauter Bäumen den Wald nicht mehr.
Weder die eine noch die andere Variante bekomme ich hin.

Die ausgewählte Farbe soll vor Erstellung einer Schraube aktiv gesetzt werden, oder die Farbe soll dem Schraubenblock zugeordnet werden.

Kann mir da nochmal einer konkret helfen?

Viele Dank im voraus.

Gruß

Dirk

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

---

Hallo Dirk,

versuchs mal so:

Code:

---

'' Userform
Option Explicit

Private Sub CommandButton1_Click()
Dim BlockRef As AcadBlockReference
Dim Schraubenname As String
Dim P(0 To 2) As Double

Select Case Me.ComboBox1.ListIndex
       Case -1
           MsgBox "Keine Schraube gewählt"
       Case 0
           Schraubenname = "Spax312"
           Schraubenblock Schraubenname, 3, 12
       Case 1
           Schraubenname = "Spax318"
           Schraubenblock Schraubenname, 3, 18
       Case 2
           Schraubenname = "Spax415"
           Schraubenblock Schraubenname, 4, 15
End Select

Set BlockRef = ThisDrawing.ModelSpace.InsertBlock(P, Schraubenname, 1, 1, 1, 0)
BlockRef.color = Me.ComboBox2.ListIndex
BlockRef.Update

End Sub

Private Sub UserForm_Initialize()
    Me.ComboBox1.AddItem "Spax 3*12", 0
    Me.ComboBox1.AddItem "Spax 3*18", 1
    Me.ComboBox1.AddItem "Spax 4*15", 2
   
    Me.ComboBox2.AddItem "vonBlock", 0
    Me.ComboBox2.AddItem "rot", 1
    Me.ComboBox2.AddItem "gelb", 2

End Sub

'' Modul
Option Explicit

Sub Block_Einfügen()

UserForm1.Show 1

End Sub

Sub Schraubenblock(Name As String, Breite As Double, Länge As Double)
    Dim Block As AcadBlock
    Dim Pline As AcadLWPolyline
    Dim P(0 To 17) As Double
    Dim NP(0 To 2) As Double
   
    On Error Resume Next
    Set Block = ThisDrawing.Blocks(Name)
    If Err.Number = 0 Then
       ' Block schon vorhanden
       Exit Sub
    End If
   
    On Error GoTo 0
   
    Set Block = ThisDrawing.Blocks.Add(NP, Name)
    P(0) = 0
    P(1) = 0
    P(2) = Breite
    P(3) = 0
   
    P(4) = 0 + Breite / 2
    P(5) = 0 - Breite / 2
   
    P(6) = 0 + Breite / 2
    P(7) = 0 - Länge + Breite / 2
    ' Spitze
    P(8) = 0
    P(9) = 0 - Länge
   
    P(10) = 0 - Breite / 2
    P(11) = 0 - Länge + Breite / 2
   
    P(12) = 0 - Breite / 2
    P(13) = 0 - Breite / 2
   
    P(14) = 0 - Breite
    P(15) = 0
   
    P(16) = 0
    P(17) = 0
   
    Set Pline = Block.AddLightWeightPolyline(P)
    Pline.color = 0  'von Block

End Sub

---

Es fehlen zwar die Fehlerabfragen, aber du must ja auch noch was zu tun haben.

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

[Diese Nachricht wurde von Stelli1 am 17. Jan. 2006 editiert.]

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

---

Hallo Dirk,

Wenn du Blöcke aus Dateien einfügen willst musst du darauf Achten, das die Eigenschaften die geändert werden können beim erstellen auf "VonBlock" stehen.
Dann kannst du auch die Farbe usw. wie in Stelli's Code (Blockref.color und blockref.update) in deinem Programm ändern.

Gruß aus dem Münsterland

[Diese Nachricht wurde von Carsten1210 am 01. Aug. 2008 editiert.]

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

---

Hallo Zusammen!

Ich will ja nicht nerven, aber ist es nicht irgendwie möglich, aus diesem QuellCode heraus die ausgewählte Farbe vor dem zeichnen der Schraube aktive zu setzen?

Option Explicit
Private Declare Function acedSetColorDialog Lib "acad.exe" _
(color As Long, ByVal bAllowMetaColor As Boolean, ByVal _ nCurLayerColor As Long) As Boolean
Public Function MeGetAcadColor(DefCol As Long, MtaCol As Boolean, _ LayCol As Long) As Long
    MeGetAcadColor = -1
    On Error Resume Next
    If acedSetColorDialog(DefCol, MtaCol, LayCol) Then
    MeGetAcadColor = DefCol
    End If
End Function
...
...
Private Sub Cmd2_Click()
    Spax_01.Hide
    Dim c As New AcadAcCmColor
    On Error Resume Next
    c.ColorIndex = MeGetAcadColor(-1, 1, -1) & vbCr
    Lbl4.Caption = ("gewählte Farbe" & "  " & c.ColorIndex)
    Image1.BackColor = RGB(c.Red, c.Green, c.Blue)
    Spax_01.Show
End Sub

In einem anderen Programm funktioniert es mit:
Private Sub cmd3_Click()
    standr1.Hide
    ThisDrawing.SendCommand "_color" & vbCr
    standr1.Show
End Sub

Nur kann ich hierbei nicht die Farbnummer auslesen und die Farbe in einem Imagefeld anzeigen lassen, was ich ja gerne erreichen wollte.

Gruß

Dirk

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

---

Hi Dirk,

hoookay, versuchs mal bitte so, die API-Function brauchste nicht

Code:

---

Sub ac_farbdialog()
    Dim c As New AcadAcCmColor
    Dim c2 As Variant, s
    With ThisDrawing
      ''''c1 = .GetVariable("CECOLOR")
      .SendCommand "_color" & Chr(13)
      c2 = .GetVariable("CECOLOR")
      ''''.SetVariable "CECOLOR", c1
    End With
    If IsNumeric(c2) Then
        'ACI
        c.ColorIndex = c2
    Else
        'Truecolor
        s = Split(Right(c2, Len(c2) - 4), ",")
        c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
    End If
    UserForm1.Image1.BackColor = RGB(c.Red, c.Green, c.Blue)
    UserForm1.show
End Sub

---

[[[ Achja und versuch mal bitte Code immer hübsch [eckig] zu klammern ]] ;-)

Gruss Nancy

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

---

Hallo Nancy!

!!!!Perfekt!!!!
Aber wo bekommt man solch ein Wissen her?
Vielen Dank an alle, die sich an der Hilfestellung beteiligt haben.

und so gehts:
Private Sub Cmd2_Click()
    Spax_01.Hide
    Dim c As New AcadAcCmColor
    Dim c2 As Variant, s
    With ThisDrawing
        .SendCommand "_color" & Chr(13)
        c2 = .GetVariable("CECOLOR")
    End With
    If IsNumeric(c2) Then
        c.ColorIndex = c2
    Else
        s = Split(Right(c2, Len(c2) - 4), ",")
        c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
    End If
    Lbl4.Caption = ("gewählte Farbe" & "  " & c.ColorIndex)
    Image1.BackColor = RGB(c.Red, c.Green, c.Blue)
    Spax_01.Show
End Sub

Nun werde ich mich um das zeichnen der einzelnen Schrauben kümmern.

Gruß

Dirk

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

---

Hallo Stelli!

Das zeichnen der Schrauben hab ich mal versucht nach Deinem Vorschlag umzusetzen.
Ich habe den QuellCode einwenig auf meine Dialogbox umgemünzt.

Code:
UserForm!!!!!!
Option Explicit
Private Sub Cmd_click()
Dim BlockRef As AcadBlockReference
Dim Schraubenname As String
Dim P(0 To 2) As Double
Select Case Me.Lst.ListIndex
    Case 0
        Schraubenname = "Spax 3,0 x 25mm"
        Schraubenblock Schraubenname, 3, 25
    Case 1
        Schraubenname = "Spax 3,0 x 30mm"
        Schraubenblock Schraubenname, 3, 30
    Case 2
        Schraubenname = "Spax 3,0 x 35mm"
        Schraubenblock Schraubenname, 3, 35
End Select
Set BlockRef = ThisDrawing.ModelSpace.InsertBlock(P, Schraubenname, 1, 1, 1, 0)
End Sub

Private Sub UserForm_Initialize()
    With Lst
        .AddItem "Spax 3,0 x 25mm", 0
        .AddItem "Spax 3,0 x 30mm", 1
        .AddItem "Spax 3,0 x 35mm", 2
    End With
End Sub

Modul!!!!
Option Explicit
Sub User_Dialog()
    Spax_01.Show
End Sub
Sub Schraubenblock(Name As String, Breite As Double, Länge As Double)
    Dim Block As AcadBlock
    Dim Pline As AcadLWPolyline
    Dim P(0 To 17) As Double
    Dim NP(0 To 2) As Double
    On Error Resume Next
    Set Block = ThisDrawing.Blocks(Name)
    If Err.Number = 0 Then
      ' Block schon vorhanden
    Exit Sub
    End If
    On Error GoTo 0
    Set Block = ThisDrawing.Blocks.Add(NP, Name)
    P(0) = 0
    P(1) = 0
    P(2) = Breite
    P(3) = 0
   
    P(4) = 0 + Breite / 2
    P(5) = 0 - Breite / 2
   
    P(6) = 0 + Breite / 2
    P(7) = 0 - Länge + Breite / 2
    ' Spitze
    P(8) = 0
    P(9) = 0 - Länge
   
    P(10) = 0 - Breite / 2
    P(11) = 0 - Länge + Breite / 2
   
    P(12) = 0 - Breite / 2
    P(13) = 0 - Breite / 2
   
    P(14) = 0 - Breite
    P(15) = 0
   
    P(16) = 0
    P(17) = 0
    Set Pline = Block.AddLightWeightPolyline(P)
    Pline.color = 0  'von Block
End Sub

Kannst Du mal ein Auge drüber werfen, da es ja bei Dir wohl funktioniert hat.

Vielen Dank im voraus.

Gruß

Dirk

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

---

Blocknamen.JPG

Hallo Dirk,

Bei den Blocknamen darfst du keine Sonderzeichen in deinen Blocknamen verwenden (Hier lieg es am Komma).
Alternativ zum Neuzeichnen der jeweiligen Schraube könnte man ja auch einen Block vom Netz einfügen.

Gruß, Carsten

[Diese Nachricht wurde von Carsten1210 am 01. Aug. 2008 editiert.]

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

---

> !!!!Perfekt!!!!

perfekt ist es sicher nicht, aber einen versuch wars wert;-)

> Aber wo bekommt man solch ein Wissen her?

Q: 'wie komm ich zur Carnegie Hall?'
A: 'üben, üben, üben ...'

lg Nancy  ;;-)))))))       

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

---

Hallo Zusammen!

Bin dabei mein Programm weiterzuschreiben.
Kann mal jemand schauen warum die ACADLine

Set Line1 = Block.AddLine(SPL1, ENP1)

nicht dem Block zugeordnet wird?

Sub Schraubenblock(Name As String, Breite As Double, Länge As Double, Reihe As Double)

    Dim Block As AcadBlock
    Dim Pline As AcadLWPolyline
    Dim Line1 As AcadLine
    Dim Line2 As AcadLine
    Dim Line3 As AcadLine
    Dim P(0 To 21) As Double
    Dim SPL1(0 To 5) As Double
    Dim ENP1(0 To 5) As Double
'    Dim SPL2(0 To 3) As Double
'    Dim ENP2(0 To 3) As Double
'    Dim SPL3(0 To 3) As Double
'    Dim ENP3(0 To 3) As Double
    Dim KK As Double
    Dim SD As Double
    Dim NP(0 To 2) As Double
   
   
        If Breite = 3 Then
        KK = 1.2
        SD = 1
    End If
    If Breite = 3.5 Then
        KK = 1.4
        SD = 1.25
    End If
    If Breite = 4 Then
        KK = 1.6
        SD = 1.5
    End If
    If Breite = 4.5 Then
        KK = 1.8
        SD = 1.75
    End If
    If Breite = 5 Then
        KK = 2.1
        SD = 2
    End If
    If Breite = 6 Then
        KK = 2.6
        SD = 2.5
    End If
   
    On Error Resume Next
    Set Block = ThisDrawing.Blocks(Name)
'    If Err.Number = 0 Then
'      ' Block schon vorhanden
'      Exit Function
'    End If

    On Error GoTo 0

    Set Block = ThisDrawing.Blocks.Add(NP, Name)
       
    P(0) = 0: P(1) = 0
    P(2) = Breite: P(3) = 0
    P(4) = Breite: P(5) = 0 - 0.3
    P(6) = 0 + SD: P(7) = 0 - (Breite - KK)
    P(8) = 0 + SD: P(9) = 0 - Länge + Breite + 1.5
    P(10) = 0: P(11) = 0 - Länge
    P(12) = 0 - SD: P(13) = 0 - Länge + Breite + 1.5
    P(14) = 0 - SD: P(15) = 0 - (Breite - KK)
    P(16) = 0 - Breite: P(17) = 0 - 0.3
    P(18) = 0 - Breite: P(19) = 0
    P(20) = 0: P(21) = 0
Set Pline = Block.AddLightWeightPolyline(P)
   
    SPL1(0) = 0: SPL1(1) = 0: SPL1(2) = 0
    SPL1(3) = -Breite: SPL1(4) = -0.3: SPL1(5) = 0
    ENP1(0) = 0: ENP1(1) = 0: ENP1(2) = 0
    ENP1(3) = Breite: ENP1(4) = -0.3: ENP1(5) = 0
Set Line1 = Block.AddLine(SPL1, ENP1)
   
End Sub

Vielen Dank im voraus.

Gruß

Dirk

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

---

Mahlzeit,

Zitat:

---

Kann mal jemand schauen warum die ACADLine

Set Line1 = Block.AddLine(SPL1, ENP1)

nicht dem Block zugeordnet wird?

---

Du musst SPL1 und ENP1 anders in der Dimension definieren, es muss

Code:

---

    Dim SPL1(0 To 2) As Double
    Dim ENP1(0 To 2) As Double

---

heissen

Gruss

H.D.

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

---

Hallo Zusammen!

Ich habe mein Programm Dank Eurer Hilfe bis auf die letzten Kleinigkeiten fertig.

2 Punkte habe ich aber noch.

1. möchte ich den Wert c.colorindex an einen Block übergeben, jedoch erhalte ich da die Meldung "Variable nich deklariert".
Dieses hat, so denk ich, mit lokal und global zutun, aber wie ändere ich dieses ab?

Private Sub Cmd2_Click()
    Spax_01.Hide
    Dim c As New AcadAcCmColor  '?????????
    Dim c2 As Variant, s
    With ThisDrawing
        .SendCommand "_color" & Chr(13)
        c2 = .GetVariable("CECOLOR")
    End With
    If IsNumeric(c2) Then
        c.ColorIndex = c2
    Else
        s = Split(Right(c2, Len(c2) - 4), ",")
        c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
    End If
    Lbl4.Caption = ("gewählte Farbe" & "  " & c.ColorIndex)
    Image1.BackColor = RGB(c.Red, c.Green, c.Blue)
    Spax_01.Show
End Sub

Private Sub Cmd_click()
...
...
If Opt.Value = True Then
Set BlockRef = ThisDrawing.ModelSpace.InsertBlock(IPoint, Schraubenname, 1#, 1#, 1#, Angle)
BlockRef.Layer = Cbo.Value
BlockRef.Linetype = Cbo1.Value
BlockRef.TrueColor = c.ColorIndex '???????????
BlockRef.Update
    If Chk.Value = True Then
    BlockRef.Explode
    End If
End If

2. wähle ich aus der Farbdialogbox den Button VonLayer oder VonBlock, kommt die Fehlermeldung "Index außerhalb des gültigen Bereichs". Kann man dieses unterdrücken?

Vielen Dank im voraus.

Gruß

Dirk

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

---

Hallo Dirk,

die Systemvariable CECOLOR ist vom Typ String. Du fragst nur ab ob sie numerisch ist. Du musst auch prüfen ob sie ein String ist (byBlock, byLayer). Bei "byLayer" musst du aus der Layersteuerung die Farbe lesen um sie darzustellen.

Bei deiner Methode setzt du die gewählte Farbe aktuell. Dann brauchst du beim Einfügen die Farbe nicht explizit setzen, da der Block schon die Eigenschaft hat.

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

f_ByLayer.jpg f_Rot.jpg f_TrueColor.jpg

Hallo Dirk,

hatte die Bilder vergessen

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

Hallo Stelli!

zu:
----
Bei deiner Methode setzt du die gewählte Farbe aktuell. Dann brauchst du beim Einfügen die Farbe nicht explizit setzen, da der Block schon die Eigenschaft hat.
----
Nur wenn ich den zuvor eingefügten Block erneut mit einer neuen ausgewählten Farbe einfüge, übernimmt ACAD die vorherige Farbe.

zu:
----
die Systemvariable CECOLOR ist vom Typ String
----
Dieses hab ich noch nicht verstanden. Wie könnte ich dieses den konkret lösen?
Laut DXF - Gruppencode:
Aktuelle Element-Farbnummer:
0 = VONBLOCK; 256 = VONLAYER

Gruß

Dirk

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

---

Hi Dirk,

byblock & bylayer hatte ich weggelassen, du brauchst nur den String prüfen,
mal mit select, ungetestet, sinngemäss:

Code:

---

select case c2
  case 1 to 255: c.colorindex=c2
  case is "VONBLOCK": c.colorindex=0
  case is "VONLAYER": c.colorindex=256 '-1?
  case else
  s = Split(Right(c2, Len(c2) - 4), ",")
  c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
end select

---

Gruss Nancy
 

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

---

Hallo Nancy!

Ich hab es mal so versucht:
Private Sub Cmd2_Click()
    Spax_01.Hide
    Dim c As New AcadAcCmColor
    Dim c2 As Variant, s
    With ThisDrawing
        .SendCommand "_color" & Chr(13)
        c2 = .GetVariable("CECOLOR")
    End With
Select Case c2
  Case 1 To 255: c.ColorIndex = c2
  Case "VONBLOCK": c.ColorIndex = 0
  Case "VONLAYER": c.ColorIndex = 256 '- 1
  Case Else
  s = Split(Right(c2, Len(c2) - 4), ",")
  c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
End Select
''    If IsNumeric(c2) Then
''        c.ColorIndex = c2
''    Else
''        s = Split(Right(c2, Len(c2) - 4), ",")
''        c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
''    End If
    Lbl4.Caption = ("gewählte Farbe" & "  " & c.ColorIndex)
    Image1.BackColor = RGB(c.Red, c.Green, c.Blue)
    Spax_01.Show
End Sub

Nur wird dabei folgendes angemeckert:
  c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))

Hast Du noch ne Idee?

Ferner such immer noch die Möglichkeit c.colorindex direkt an den Block zu übergeben.

BlockRef.TrueColor = c.Colorindex  ????

Vielen Dank im voraus.

Gruß

Dirk

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

---

Hallo Dirk,

Für die Übergabe der Farbe an den Block reicht "BlockRef.TrueColor = c".  

Die Zeile : "c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))" funktioniert ohne Probleme. Was für eine Fehlermeldung kommt denn da bei dir?  

Gruß aus dem Münsterland, Carsten

[Diese Nachricht wurde von Carsten1210 am 01. Aug. 2008 editiert.]

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

---

Hallo Carsten!

Bei mir kommt folgende Fehlermeldung:
Fehler beim Kompilieren:
Variable nicht definiert

Kann es damit zusammenhängen, daß die Variable "c" im Bereich

Code:

---

Private Sub Cmd2_Click()
    Spax_01.Hide
    Dim c As New AcadAcCmColor
    ...
    ...
    Spax_01.Show
End Sub

---

und der Block aus dem Bereich

Code:

---

Private Sub Cmd_Click()
    ...
    ...
    If Opt.Value = True Then
    Set BlockRef = ThisDrawing.ModelSpace.InsertBlock(IPoint, _
    Schraubenname, 1#, 1#, 1#, Angle)
    BlockRef.Layer = Cbo.Value
    BlockRef.Linetype = Cbo1.Value
    BlockRef.TrueColor = c
    BlockRef.Update
    If Chk.Value = True Then
    BlockRef.Explode
    End If
    ...
End Sub

---

eingefügt wird?

Gruß

Dirk

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

---

Hallo Dirk,

Du hast sehr wahrscheinlich ganz oben im Code "Option Explicit" stehen. Da wird überprüft ob die Variable wirklich angelegt wurde.
Schreib mal direkt unter Option Explicit "Dim c As New AcadAcCmColor".
Dann kannst du auch von dem 2. CommandButton aus auf diese Variable zugreifen. Wenn du diese Variable erst im Code des CommandButtons anlegst, ist sie auch nur in dieser Sub-Routine vorhanden. Sobald du das Hauptformular wieder aufrufst, ist die Variable nicht mehr vorhanden.

Gruß, Carsten

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

---

Farbe01.jpg

Hallo Carsten!

Der Tip war Ok, dieses Problem habe ich damit lösen können.
Mein Problem mit dem "VonBlock" / "VonLayer" hab ich noch nicht lösen können.
Mit diesem Code bricht zumindist das Programm nicht mehr ab.

Code:

---

Private Sub Cmd2_Click()
    Spax_01.Hide
    With ThisDrawing
        .SendCommand "_color" & Chr(13)
        c2 = .GetVariable("CECOLOR")
    End With
    Select Case IsNumeric(c2)
        Case 1 To 255: c.ColorIndex = c2
        Case acByBlock: c2 = 0
        Case acByLayer: c2 = 256
        Case Else
            s = Split(Right(c2, Len(c2) - 4), ",")
            c2.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
    End Select
    Lbl4.Caption = ("gewählte Farbe" & "  " & c.ColorIndex)
    Image1.BackColor = RGB(c.Red, c.Green, c.Blue)
    Spax_01.Show
End Sub

---

Nur bekomme ich es noch nicht hin, daß der richtige Index angezeigt wird "gewählte Farbe ...".
Wähle ich aus der Farbdialogbox "VonBlock" bzw. "VonLayer" steht dort immer "gewählte Farbe 256".

Füge ich einen Block zum ersten mal ein, wird dieser richtig angezeigt. Füge ich ihn erneut ein jedoch mit einer zuvor andern ausgewählten Farbe übernimmt AutoCAD die vorherige. Klick ich jedoch den zuletzt eingefügten Block an, wird die neue Farbe angezeigt.

Code:

---

If Opt.Value = True Then
Set BlockRef = ThisDrawing.ModelSpace.InsertBlock(IPoint, _
Schraubenname, 1#, 1#, 1#, Angle)
BlockRef.Layer = Cbo.Value
BlockRef.Linetype = Cbo1.Value
BlockRef.TrueColor = c
BlockRef.Update
    If Chk.Value = True Then
    BlockRef.Explode
    End If
End If

---

Hat da jemand eine Idee, wie ich dieses Problem lösen kann?

Vielen Dank im voraus.

Gruß

Dirk

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

---

Hallo Dirk,

du fügst zuerst einen Block ein, dann legts du Farbe und Layer für die Blockreferenz fest.
Wenn du nun den Block sprengst, erhalten die Elemente die Farbe der Blockdefinition.
Ich glaube wenn du den Block einfügst und wieder zerlegst wird das so nicht klappen. Deine Blockdefinitionen werden doch in einer Function zusammengebaut. Schalte doch hier eine Funktion zwischen.

Code:

---

sub Erzeuge_Schraube (Parentobject as objekt, Länge,Breite,InsPkt() as double)
    ' Hier Schraube anlegen
    ' Im Parentobject wird entweder die neue Blockdefintion übergeben
    ' oder der Modelspace
    ' Parentobject.addline ........
end sub

sub Erzeuge_SchraubenBlock (Name,Länge,Breite)   
    set NewBlock=thisdrawing.blocks.add (Name ........
    Erzeuge_Schraube NewBlock, Länge,Breite,InsPkt
end sub

sub Zeichne_Block (Name,Laäne,Breite)
    insPkt(0) = 123
    insPkt(1) = 234
    Erzeuge_Schraube Thsdrawing.Modelspace , Länge,Breite,InsPkt 
end sub

---

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

Hi Dirk,

Select Case IsNumeric(c2) ?!?!? ;;-)))

IsNumeric liefert wahr, wenn c2 numerisch, sonst falsch.
Würde Truecolor gewählt, ist c2 auf jedenfall ein String.
Aber davon abgesehen, mal ein andrer Vorschlag:

Code:

---

Select Case c2
        Case 1 To 255
c.ColorIndex = c2
Lbl4.Caption = ("gewählte Farbe  " & c2)
        Case acByBlock
c2 = 0
Lbl4.Caption = ("gewählte Farbe  " & "vonBlock")
        Case acByLayer
c2 = 256
Lbl4.Caption = ("gewählte Farbe  " & "vonLayer")
        Case Else
          s = Split(Right(c2, Len(c2) - 4), ",")
            c2.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
Lbl4.Caption = ("gewählte Farbe  " & c2)
End Select

---

Gruss Nancy

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

---

Hallo Dirk,

Durchlaufe doch bei der Erstellung des Blocks die Item-Collection und überschreibe die Farbwerte innerhalb des Blocks wie folgt:

For i = 0 To Block.Count - 1
Block.Item(i).color = 4 'Farbe der Elemente innerhalb des Blocks(Variable einfügen)
Next

Füge diesen Code-Block nach der Erstellung der Elemente im Block ein.
Interessant wird es, wenn du dem Blockrefobject eine andere Farbe zuweist. Das wird dann ignoriert.

Das andere Problem sollte sich mit der Lösung von Nancy auch erledigt haben.

Gruß, Carsten

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

---

Hallo Dirk,

sorry, mein Code tat doch nicht ganz, hab ich jetz erst im VBE gemerkt. Hab' doch glatt die Enum's vergessen ... :dream

also CECOLOR gibt dir ein Variant zurück, darin kann zum einem stecken ein Integer:
als ACI-Index
zum andren, wenn Wahl ByBlock/Bylayer, gibt es entweder den String:
"BYBLOCK" oder "BYLAYER"
oder, wenn Truecolor gewählt, ebenfalls nen Sring, der schaut aber vom aufbau so aus RGB: r,g,b:
RGB: 100,150,200

Code:

---

Select Case IsNumeric(c2)
        Case 1 To 255: c.ColorIndex = c2
        Case acByBlock: c2 = 0
        Case acByLayer: c2 = 256
        Case Else
s = Split(Right(c2, Len(c2) - 4), ",")
        c2.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
    End Select

---

Die Abfrage gibt zwar keinen direkten Fehler zurück, da acByBlock eine enumerierte Konstante ist, aber CECOLOR gibt nunmal den String "BYBLOCK" zurück und somit läuft select case ins case else rein,
der wiederum, kann den erwarteten Split() nicht ausführen, da es bei "BYBLOCK" nix zu splitten gibt, das setRGB(), löst dann den error aus, setRGB() kann mit strings wenig anfangen;-)

Also sorry, wenn das immernochnicht laufen sollte, ich hab das:
Case is = "BYLAYER" verschlampt;-)
probiere nochmal so:

Code:

---

Private Sub CommandButton1_Click()
    'Spax_01.Hide
    Dim c As New AcadAcCmColor, c2, s
    With ThisDrawing
        .SendCommand "_color" & Chr(13)
        c2 = .GetVariable("CECOLOR")
    End With
    Select Case c2
        Case 1 To 255
            c.ColorIndex = c2
            Me.Caption = ("gewählte Farbe  " & c2)
        Case Is = "BYBLOCK"
            c2 = 0
            Me.Caption = ("gewählte Farbe  " & "vonBlock")
        Case Is = "BYLAYER"
            c2 = 256
            Me.Caption = ("gewählte Farbe  " & "vonLayer")
        Case Else
          s = Split(Right(c2, Len(c2) - 4), ",")
          c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
          Me.Caption = ("gewählte Farbe  " & c2)
    End Select
    Me.BackColor = RGB(c.Red, c.Green, c.Blue)
    'Spax_01.Show
End Sub

---

Achja, Me ..., ich hab das mal einfach an der Userform selbst getestet gehabt, musst natürlich an deine Controls anpassen.

HTH, Nancy

[Diese Nachricht wurde von startrek am 30. Jan. 2006 editiert.]

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

---

Hallo Dirk,

hier noch ein Nachtrag mit den Farben.
Es wird die aktuelle Farbe gelesen.
Die RGB Anteile jeder Farbe stehen dann im Feld myRGB

Code:

---

Option Explicit

Sub active_Color()
    Dim acFarbe As New AcadAcCmColor
    Dim LayColor As AcadAcCmColor
    Dim strColor As String
    Dim intColor As Integer
    Dim RGB As Variant
    Dim myRGB(0 To 2) As Integer
           
    strColor = ThisDrawing.GetVariable("CECOLOR")
   
    Select Case strColor
          Case "BYLAYER"
                acFarbe.ColorMethod = acColorMethodByLayer
                acFarbe.ColorIndex = acByLayer
                Debug.Print acFarbe.Red, acFarbe.Green, acFarbe.Blue
                ' Anstatt ThisDrawing.ActiveLayer.Name kann der gewählte Layer angegeben werden
                Set LayColor = ThisDrawing.Layers(ThisDrawing.ActiveLayer.Name).TrueColor
                myRGB(0) = LayColor.Red
                myRGB(1) = LayColor.Green
                myRGB(2) = LayColor.Blue
         
          Case "BYBLOCK"
                acFarbe.ColorMethod = acColorMethodByBlock
                acFarbe.ColorIndex = acByBlock
                Debug.Print acFarbe.Red, acFarbe.Green, acFarbe.Blue
                ' Macht keinen Sinn mit ByBlock einzufügen
         
          Case Else
                intColor = Val(strColor)
                If intColor > 0 Then
                  ' IndexFarbe
                  acFarbe.ColorMethod = acColorMethodByACI
                  acFarbe.ColorIndex = intColor
                  Debug.Print acFarbe.Red, acFarbe.Green, acFarbe.Blue
                  myRGB(0) = acFarbe.Red
                  myRGB(1) = acFarbe.Green
                  myRGB(2) = acFarbe.Blue
                Else
                  ' True Color
                  If Left$(strColor, 4) = "RGB:" Then
                      acFarbe.ColorMethod = acColorMethodByRGB
                      RGB = Split(Mid$(strColor, 5), ",")
                      acFarbe.SetRGB RGB(0), RGB(1), RGB(2)
                      myRGB(0) = RGB(0)
                      myRGB(1) = RGB(1)
                      myRGB(2) = RGB(2)
                  End If
                End If
    End Select
    ' Die RGB Farben zum Füllen eines Feldes stehen
    ' jetzt im Feld myRGB
   
   
    ' Test Einfügen von Eintity mit Farbzuweisung
    Dim P(0 To 2) As Double
    Dim testtext As AcadMText
    Set testtext = ThisDrawing.ModelSpace.AddMText(P, 0, "TEXTEXT")
    testtext.TrueColor = acFarbe
End Sub

---

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

Hallo Nancy!
Hallo Stelli!

Ich habe Eure Lösungen mal separat getestet und es funktionierte.
Füge ich den Code jedoch in mein Programm ein funktioniert es mit dem ColorIndex / VonLayer / VonBlock soweit auch, nur wird der Block immer wieder in der vorherigen Farbe eingefügt und dargestellt, obwohl in der Farbsteuerung die neu ausgewählte Farbe angezeigt wird.
Kann es daran liegen, daß der Block ansich in einem Modul erzeugt wird, sieh Modul1:

Code:

---

Sub Schraubenblock(Name As String, Breite As Double, Länge As Double, Reihe As Double)

    Dim Block As AcadBlock
    Dim Pline As AcadLWPolyline
    Dim Line1 As AcadLine
    Dim Line2 As AcadLine
    Dim Line3 As AcadLine
    Dim P(0 To 21) As Double
    Dim SPL1(0 To 2) As Double
    Dim ENP1(0 To 2) As Double
    Dim SPL2(0 To 2) As Double
    Dim ENP2(0 To 2) As Double
    Dim SPL3(0 To 2) As Double
    Dim ENP3(0 To 2) As Double
    Dim KK As Double
    Dim SD As Double
    Dim Re As Long              'rechtwinklige Anordnung
    Dim Sp As Long              'rechtwinklige Anordnung
    Dim Eb As Long              'rechtwinklige Anordnung
    Dim AbsR As Double      'rechtwinklige Anordnung
    Dim AbsS As Double    'rechtwinklige Anordnung
    Dim AbsE As Double      'rechtwinklige Anordnung
    Dim NP(0 To 2) As Double
   
    'Definition des Reihebefels bei der rechtwinkligen Anordnung
    Re = Reihe
    Sp = 1
    Eb = 1
    AbsR = 1
    AbsS = 1
    AbsE = 1
   
        If Breite = 3 Then
        KK = 1.2
        SD = 1
    End If
    If Breite = 3.5 Then
        KK = 1.4
        SD = 1.25
    End If
    If Breite = 4 Then
        KK = 1.6
        SD = 1.5
    End If
    If Breite = 4.5 Then
        KK = 1.8
        SD = 1.75
    End If
    If Breite = 5 Then
        KK = 2.1
        SD = 2
    End If
    If Breite = 6 Then
        KK = 2.6
        SD = 2.5
    End If
   
    On Error Resume Next
    Set Block = ThisDrawing.Blocks(Name)
    If Err.Number = 0 Then
      ' Block schon vorhanden
      Exit Sub
    End If

    On Error GoTo 0
    Set Block = ThisDrawing.Blocks.Add(NP, Name)
       
    P(0) = 0: P(1) = 0
    P(2) = Breite: P(3) = 0
    P(4) = Breite: P(5) = 0 - 0.3
    P(6) = 0 + SD: P(7) = 0 - (Breite - KK)
    P(8) = 0 + SD: P(9) = 0 - Länge + Breite + 1.5
    P(10) = 0: P(11) = 0 - Länge
    P(12) = 0 - SD: P(13) = 0 - Länge + Breite + 1.5
    P(14) = 0 - SD: P(15) = 0 - (Breite - KK)
    P(16) = 0 - Breite: P(17) = 0 - 0.3
    P(18) = 0 - Breite: P(19) = 0
    P(20) = 0: P(21) = 0
Set Pline = Block.AddLightWeightPolyline(P)
   
    SPL1(0) = -Breite: SPL1(1) = -0.3: SPL1(2) = 0
    ENP1(0) = Breite: ENP1(1) = -0.3: ENP1(2) = 0
Set Line1 = Block.AddLine(SPL1, ENP1)
   
    SPL2(0) = 0 - ((Breite / 2) - 0.5): SPL2(1) = 0 - (Breite - KK): SPL2(2) = 0
    ENP2(0) = 0 + ((Breite / 2) - 0.5): ENP2(1) = 0 - (Breite - KK): ENP2(2) = 0
Set Line2 = Block.AddLine(SPL2, ENP2)

    SPL3(0) = 0 - Breite / 2: SPL3(1) = 0 - Länge + Breite + 1.7: SPL3(2) = 0
    ENP3(0) = 0 + Breite / 2: ENP3(1) = 0 - Länge + Breite + 2.7: ENP3(2) = 0
Set Line3 = Block.AddLine(SPL3, ENP3)

Dim retObj As Variant
    retObj = Line3.ArrayRectangular(Re, Sp, Eb, AbsR, AbsS, AbsE)
End Sub

---

und der Block in der UserForm, siehe:

Code:

---

Private Sub Cmd_click()

Dim Prompt1 As String
Dim IPoint As Variant
Dim Angle As Double

Me.Hide

Prompt1 = vbCrLf & "Einfügepunkt:"
IPoint = ThisDrawing.Utility.GetPoint(, Prompt1) 'Einfügepunkt
Angle = ThisDrawing.Utility.GetAngle(IPoint, Prompt1)

Dim Blockref As AcadBlockReference
Dim BlockRef1 As AcadBlockReference
Dim BlockRef2 As AcadBlockReference
Dim Schraubenname As String
Dim Schraubenname1 As String
Dim Schraubenname2 As String

Select Case Lst.ListIndex
    Case 0
        If Opt.Value = True Then
        Schraubenname = "Spax325"
        Schraubenblock Schraubenname, 3, 25, 18
        End If
        If Opt1.Value = True Then
        Schraubenname1 = "Spax325k"
        Schraubenblock1 Schraubenname1, 6, 0.75, 3
        End If
        If Opt2.Value = True Then
        Schraubenname2 = "Spax325s"
        Schraubenblock2 Schraubenname2, 3, 25
        End If
    Case 1
        If Opt.Value = True Then
        Schraubenname = "Spax330"
...
...
...
    End Select

    If Opt.Value = True Then
    Set Blockref = ThisDrawing.ModelSpace.InsertBlock(IPoint, _
    Schraubenname, 1#, 1#, 1#, Angle)
    Blockref.Layer = Cbo.Value
    Blockref.Linetype = Cbo1.Value
    Blockref.Update
    If Chk.Value = True Then
    Blockref.Explode
    End If
End If

---

Währe es evtl. sinnvoller die ausgewählte Farbe an die Linien im Modul zu übergeben, wenn ja, wie?

Gruß

Dirk

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

---

Hallo Dirk,

den Fehler hast du von Anfang an. Du musst allen Elementen in der Blockdefinition die Farbe vonBlock zuweisen. Sonst kannst du den Blöcken später keine explicite Farbe mehr zuweisen.

Aus einem vorherigen Post:

Code:

---

...
    Set Pline = Block.AddLightWeightPolyline(P)
    Pline.color = 0  'von Block
...

---

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

Spax_01.zip

Hallo Stelli!

Ich will ja nicht nerven, aber das funktioniert auch nicht.

Pline.color = 0 nicht
Pline.color = acByBlock nicht
Pline.TrueColor = 0 nicht
...

Ich hab mal das Programm angehangen.

Es wäre schön, wenn wir das Problem noch irgendwie lösen könnten.

Vielen Dank im voraus.

Gruß

Dirk

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

---

spax.jpg

Hallo Dirk,

wenn wie oben gesagt, bei allen Linien, vonBlock gesetzt wird geht es.

Code:

---

....
Set Line2 = Block.AddLine(SPL2, ENP2)
    Line2.color = 0
'  Line2.TrueColor = acByBlock 'VonBlock
       
    SPL3(0) = 0 - Breite / 2: SPL3(1) = 0 - Länge + Breite + 1.7: SPL3(2) = 0
    ENP3(0) = 0 + Breite / 2: ENP3(1) = 0 - Länge + Breite + 2.7: ENP3(2) = 0
Set Line3 = Block.AddLine(SPL3, ENP3)
    Line3.color = 0
'  Line3.TrueColor = acByBlock 'VonBlock

---

Zuerst lief das Progi gar nicht.
Du solltest aber aus falsch(Spax_xx.hide) richtig(me.hide) machen.
Die reservierten Schlüsselwörter (bei dir Variablen) Prompt und angle hab ich in xAngle getauscht.
Bei dem Richtuingspunkt sollte der Prompt nicht Einfügepunkt sondern Richtungspunkt lauten.

Sonst eine schöne Sache.

Viel Erfolg Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

Hallo Dirk,

mir ist noch aufgefallen das du sehr fleißig getipt hast.
Einiges könntest du einfacher machen. Dann kannst du dein Programm auch besser um eine Schraube ergänzen.

Ich würde einen Schraubentyp mit allen erforderlichen Angaben definieren.

Code:

---

Public Type Meine_Schrauben_typen
     Name As String
     Blockname As String
     Länge As Double
     Breite As Double
     'usw.
End Type
   
Public SpaxSchraube(0 To 49) As Meine_Schrauben_typen

---

Dann deine Schrauben an einer Stelle parameterisieren

Code:

---

Private Sub UserForm_Initialize()

SpaxSchraube(0).Name = "Spax 3,0 x 25mm"
SpaxSchraube(0).Blockname = "Spax325"
' .....

---

und die Liste befüllen lassen anstatt alles wieder einzugeben

Code:

---

For i = 0 To UBound(SpaxSchraube)
     Lst.AddItem SpaxSchraube(i).Name
Next i

---

Diesen Code zum Einfügen der Schrauben

Code:

---

If Opt.Value = True Then
   Schraubenblock spaxschraube(lst.ListIndex).Blockname ,spaxschraube(lst.ListIndex).Länge , ....
ElseIf Opt1.Value = True Then
      Schraubenblock spaxschraube(lst.ListIndex).Blockname & "k" ,spaxschraube(lst.ListIndex).Länge , ....
ElseIf Opt1.Value = True Then
      Schraubenblock spaxschraube(lst.ListIndex).Blockname & "s" ,spaxschraube(lst.ListIndex).Länge , ....
End If

---

anstelle von 47 mal

Code:

---

   
    Case 0
        If Opt.Value = True Then
        Schraubenname = "Spax325"
        Schraubenblock Schraubenname, 3, 25, 18
        End If
        If Opt1.Value = True Then
        Schraubenname1 = "Spax325k"
        Schraubenblock1 Schraubenname1, 6, 0.75, 3
        End If
        If Opt2.Value = True Then
        Schraubenname2 = "Spax325s"
        Schraubenblock2 Schraubenname2, 3, 25
        End If
    Case 1

---

 

Stelli
------------------
Warum lisp'eln wenn's auch anders geht.

[Diese Nachricht wurde von Stelli1 am 01. Feb. 2006 editiert.]

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

---

Hallo Stelli!

Es funktioniert!
Dir und allen anderen, die sich an der Problemlösung beteiligt haben vielen Dank.
Mit Deiner Anregung der verkürzten Schreibweise werde ich mich mal auseinandersetzen.

Nochmals vielen Dank.

Gruß

Dirk

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

---

Programmstart.jpg Fehler.jpg

Hallo und guten Morgen Zusammen!

Einen kleinen Nachschlag an Hilfe benötige ich noch.
Ich möchte in dem Programm ja zur Laufzeit einen neuen Layer "Spanplattenschraube" erzeugen und den Linientyp "Verdeckt" aus der ACAD.LIN laden, da ich nicht davon ausgehen kann, daß diese in der jeweiligen Zeichnung bereits enthalten sind.
Dieses funktioniert auch soweit, nur wenn ich den Layer wechsel bzw. den Linientyp, bricht das Programm ab, siehe Bildchen Fehler.

Auszug aus der UserForm:

Code:

---

Private Sub UserForm_Initialize()

Dim nLay As AcadLayer
Set nLay = ThisDrawing.Layers.Add("Spanplattenschraube")
ThisDrawing.ActiveLayer = nLay

Dim linetypeName As String
    linetypeName = "VERDECKT"

On Error Resume Next
    ThisDrawing.Linetypes.Load linetypeName, "acad.lin"

Dim nVerdeckt As AcadLineType
Set nVerdeckt = ThisDrawing.Linetypes.Add("Verdeckt")
ThisDrawing.ActiveLinetype = nVerdeckt

Dim entry As AcadLayer
    For Each entry In ThisDrawing.Layers
        Cbo.AddItem entry.Name
    Next

Dim entry1 As AcadLineType
    For Each entry1 In ThisDrawing.Linetypes
        Cbo1.AddItem entry1.Name
    Next

Cbo.Text = "Spanplattenschraube"
Cbo1.ListIndex = 0

---

Auszug aus dem Modul1:

Code:

---

    On Error GoTo 0
    Set Block = ThisDrawing.Blocks.Add(NP, Name)
     
    P(0) = 0: P(1) = 0
    P(2) = Breite: P(3) = 0
    P(4) = Breite: P(5) = 0 - 0.3
    P(6) = 0 + SD: P(7) = 0 - (Breite - KK)
    P(8) = 0 + SD: P(9) = 0 - Länge + Breite + 1.5
    P(10) = 0: P(11) = 0 - Länge
    P(12) = 0 - SD: P(13) = 0 - Länge + Breite + 1.5
    P(14) = 0 - SD: P(15) = 0 - (Breite - KK)
    P(16) = 0 - Breite: P(17) = 0 - 0.3
    P(18) = 0 - Breite: P(19) = 0
    P(20) = 0: P(21) = 0
Set Pline = Block.AddLightWeightPolyline(P)
    Pline.color = 0
    Pline.Linetype = 0
         
    SPL1(0) = -Breite: SPL1(1) = -0.3: SPL1(2) = 0
    ENP1(0) = Breite: ENP1(1) = -0.3: ENP1(2) = 0
Set Line1 = Block.AddLine(SPL1, ENP1)
    Line1.color = 0
    Line1.Linetype = 0

---

Ich vermute mal, daß mir eine Abfragefunktion fehlt, die prüft ob das jeweilige schon vorhanden ist ja oder nein?

Wie kann ich dieses Problem lösen?

Vielen Dank im voraus.

Gruß

Dirk

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

---

Hallo Dirk,

Du musst den Linientyp erst laden, wenn er nicht schon vorhanden ist.
Das kannst du wie folgt machen:

Dim linetypeName As String
linetypeName = "ACAD_ISO02W100"
ThisDrawing.Linetypes.Load linetypeName, "acad.lin" 'Linientyp laden

Gruß, Carsten

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

---

Hallo Dirk,

der linentyp ist keine Zahl (0)!
....
Dim linetypeName As String
    linetypeName = "VERDECKT"

On Error Resume Next
    ThisDrawing.Linetypes.Load linetypeName, "acad.lin"

......
Set Pline = Block.AddLightWeightPolyline(P)
    Pline.color = 0
    Pline.Linetype = "VERDECKT"
         

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.

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

---

Hallo Zusammen!

OK.
Wenn ich das Programm nun einmal gestartet habe funktioniert auch alles. Das Programm wird ja nach dem einfügen eines Blocks ausgeblendet aber nicht wirklich entladen / beendet. Ruf ich das Programm erneut auf, werden die letzten Einstellungen übernommen und angezeigt;- auch gut -.
Öffne ich aber in der Zwischenzeit eine neue Zeichnung bricht das Programm bei der Ausführung ab.

Wie kann ich dieses abfangen?

Gruß

Dirk

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

---

Hallo Dirk,

Der Fehler tritt dort auf, wo dem Block der Layer zugewiesen wird.
Da bei dir der Layer nur erstellt wird, wenn bei der Combobox, eine Änderung bzw. ein anklicken ausgelöst wird. Daher würde ich den Layer "Spanplatte" um den es hier geht direkt am anfang deines Code auch anlegen.

Dann sollte es funktionieren. Der Absturz tritt auch auf, wenn du das Programm das erste Mal startest und die Layereinstellung in der Combobox nicht änderst.

Du solltest auf jeden Fall das Lokalfenster in der VBA-IDE anzeigen lassen. Dort kannst du bei Debuggen nachschauen, welche Inhalte die Variablen usw. haben.

Gruß aus dem Münsterland, Carsten.

Jetzt geht's erst mal ins Wochenende... 

[Diese Nachricht wurde von Carsten1210 am 01. Aug. 2008 editiert.]

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

---

Spax_01.zip

Hallo Dirk,

Hab mal ein bißchen in deinem Code geändert. Lade die Lisp- und die DVB-Datei in AutoCAD.
Dein Programm kannst du in Autocad mit dem Befehl Spax starten. Dies ist in der Lisp-Datei hinterlegt (Erste Zeile).
Den Rest der Schraubentypen musst du noch einfügen. Ein Bißchen sollst du ja auch noch zu tun haben.
Schau dir mal die Änderungen an. Wenn noch Fragen sind, einfach melden / posten.

Gruß aus dem Münsterland, Carsten

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

---

Hallo Carsten!
Hallo an den Rest der Gemeinde!

Ist man eigentlich bei der Verwendung von Parametern an einer Zeilen-bzw. Zeichenlänge gebunden, oder kann diese unendlich lang sein.
Ich habe mir nun schon einige kleinere Programme nach diesem Stil angelegt und sie funktionieren auch recht gut.
Nun habe ich ein etwas komplexeres Programm, wo ich so keinen Fehler erkennen kann, außer das ich einiges an Parametern abfragen muß.

Könnte dieses ein Problem sein?

Code:

---

Private Sub Zuweis(Name As String, Blockname As String, d1 As Double, m As Double, sw As Double, _
SL As Double, SL1 As Double, Ra1 As Double, Ra2 As Double, SL2 As Double, S1 As Double, _
E1 As Double, S2 As Double, E2 As Double, S3 As Double, E3 As Double, S4 As Double, E4 As Double, _
d2 As Double, d3 As Double, h As Double, Ra3 As Double, Ra4 As Double, Sa1 As Double, _
Ea1 As Double, Sa2 As Double, Ea2 As Double, Sb1 As Double, Eb1 As Double, Sb2 As Double, _
Eb2 As Double)
SKD985(i).Name = Name
SKD985(i).Blockname = Blockname
SKD985(i).d1 = d1
SKD985(i).m = m
SKD985(i).sw = sw
SKD985(i).SL = SL
SKD985(i).SL1 = SL1
SKD985(i).Ra1 = Ra1
SKD985(i).Ra2 = Ra2
SKD985(i).SL2 = SL2
SKD985(i).S1 = S1
SKD985(i).E1 = E1
SKD985(i).S2 = S2
SKD985(i).E2 = E2
SKD985(i).S3 = S3
SKD985(i).E3 = E3
SKD985(i).S4 = S4
SKD985(i).E4 = E4
SKD985(i).d2 = d2
SKD985(i).d3 = d3
SKD985(i).h = h
SKD985(i).Ra3 = Ra3
SKD985(i).Ra4 = Ra4
SKD985(i).Sa1 = Sa1
SKD985(i).Ea1 = Ea1
SKD985(i).Sa2 = Sa2
SKD985(i).Ea2 = Ea2
SKD985(i).Sb1 = Sb1
SKD985(i).Eb1 = Eb1
SKD985(i).Sb2 = Sb2
SKD985(i).Eb2 = Eb2
i = i + 1
End Sub

---

Gruß

Dirk

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

---

Hallo Dirk,

Übergibst du der Sub auch wirklich alle Paramter die du festgelegt hast?
Wenn einer fehlt, sollte es schon nicht mehr funktionieren.
Du hast ausserdem eine PM von mir.

Gruß, Carsten

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