---

Hallo zusammen!

Ich habe ein Problem mit Parameterübergaben.
Aus meinem Programm sollen gelochte Rundrohre gezeichnet werden.
Aus einer Liste (ListView1) sollen nach der selection einer Zeile (Index) bestimmte Parameter an die Variablen für den eigentlichen Programmcode übergeben werden.

Code:

---

Public Sub Zuweis1(PName As String, rad1 As Double, rad2 As Double, EPm As Double, EP1m As Double, P1m As Double, QdL As Double, QdB As Double, QdH As Double, Raster As Double, AnH As Double)
End Sub
...
...
Public Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
Select Case ListView1.SelectedItem.Index
Case 1
Zuweis1 "Rundrohr Ø28x2mm", 30, 28, 5, 10, 30, 5, 8, 19, 35, 25.5
Case 2
Zuweis1 "Rundrohr Ø30x2mm", 30, 28, 5, 10, 30, 5, 8, 25, 50, 37.5
End Select
End Sub
...
...
Private Sub MP2cmd2_click()
Dim Rohr1 As Acad3DSolid
Dim Rohr2 As Acad3DSolid
Dim ZRohr As Variant
Dim RL1 As Double
Dim RP1#(2), RP2#(2)
Dim Quad1 As Acad3DSolid
Dim Quad2 As Acad3DSolid
Dim EP, Ep1, P1 As Variant
Dim QP1#(2), QP2#(2)
Me.Hide
Dim Prompt1 As String
Prompt1 = vbCrLf & "Einfügepunkt:"
ZRohr = ThisDrawing.Utility.GetPoint(, Prompt1)
RL1 = TextBox.Value
RP1(2) = RP2(2) - (RL1 / 2)
Set Rohr1 = ThisDrawing.ModelSpace.AddCylinder(ZRohr, rad1, RL1)
Rohr1.Move RP1, RP2
Set Rohr2 = ThisDrawing.ModelSpace.AddCylinder(ZRohr, rad2, RL1)
Rohr2.Move RP1, RP2
Rohr1.Boolean acSubtraction, Rohr2
QP1(2) = QP2(2) - AnH
P1 = ThisDrawing.Utility.PolarPoint(ZRohr, dtr(270#), P1m)
EP = ThisDrawing.Utility.PolarPoint(P1, dtr(0#), EPm)
Ep1 = ThisDrawing.Utility.PolarPoint(EP, dtr(180#), EP1m)
Set Quad1 = ThisDrawing.ModelSpace.AddBox(EP, QdL, QdB, QdH)
Quad1.Move QP1, QP2
Set Quad2 = ThisDrawing.ModelSpace.AddBox(Ep1, QdL, QdB, QdH)
Quad2.Move QP1, QP2
Dim LB1, LB2, LB3 As Long
Dim LB4, LB5, LB6 As Double
Dim LRH1 As Variant
LRH1 = (RL1 / Raster)
LB1 = 1
LB2 = 1
LB3 = LRH1
LB4 = 1
LB5 = 1
LB6 = Raster
Dim LRHObj1 As Variant
Dim LRHObj2 As Variant
LRHObj1 = Quad1.ArrayRectangular(LB1, LB2, LB3, LB4, LB5, LB6)
Dim i As Integer
    For i = LBound(LRHObj1) To UBound(LRHObj1)
      Rohr1.Boolean acSubtraction, LRHObj1(i)
    Next
Rohr1.Boolean acSubtraction, Quad1

LRHObj2 = Quad2.ArrayRectangular(LB1, LB2, LB3, LB4, LB5, LB6)
Dim j As Integer
    For j = LBound(LRHObj2) To UBound(LRHObj2)
      Rohr1.Boolean acSubtraction, LRHObj2(j)
    Next
Rohr1.Boolean acSubtraction, Quad2
Me.Show
End Sub

---

Gruß

Dirk

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

---

Hallo Dirk,

Wo genau hast du denn ein Problem?! Am besten lädst du dein Formular mal komplett hoch, dann ist es einfacher dein Problem nachzuvollziehen.

Gruß, Carsten

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

---

ListView_Parameterauswahl.JPG ListView_Parameterauswahl1.JPG

Hallo Carsten!
Hallo Rest der Gemeinde!

Hier noch mal der Programmcode ohne Parameter.
Das Programm ist zum laden zu groß.
Diesen Programmteil möchte ich gern optimieren und hoffe, daß mir dabei jemand helfen kann.

Code:

---

Option Explicit
'---Winkelfunktion definieren--------------------------------------
Const pi = 3.14159
'---Variablen für die Rohrkonstruktion-----------------------------
Dim PName As String
Dim rad1 As Double
Dim rad2 As Double
Dim LO1 As Double
Dim LO2 As Double
Dim LO3 As Double
Dim LO4 As Double
Dim QdL As Double
Dim QdB As Double
Dim QdH As Double
Dim Qd1L As Double
Dim Qd1B As Double
Dim Qd1H As Double
Dim Raster As Double
Dim AnH As Double
Dim LName As String
Dim ZRohr As Variant
Dim seitig As Variant
'---Winkelfunktion definieren--------------------------------------
Function dtr(a As Double) As Double
    dtr = (a / 180) * pi
End Function
'------------------------------------------------------------------
Public Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
    Select Case ListView1.SelectedItem.Index
        Case 1
        PName = "Rundrohr Ø28x2 mm, 1-reihig, 2-seitig"
        rad1 = 14
        rad2 = 12
        LO1 = 0
        LO2 = 0
        LO3 = 0
        LO4 = 0
        QdL = 4
        QdB = 30
        QdH = 28
        Qd1L = 0
        Qd1B = 0
        Qd1H = 0
        Raster = 50
        AnH = 30
        LName = "RR28x2_1r_2s"
        seitig = 1
        StatusBar1.Panels(1).Text = "gewähltes Profil =  " & PName
       
        Case 2
        PName = "Rundrohr Ø28x2 mm, 1-reihig, 4-seitig"
        rad1 = 14
        rad2 = 12
        LO1 = 0
        LO2 = 0
        LO3 = 0
        LO4 = 0
        QdL = 4
        QdB = 30
        QdH = 28
        Qd1L = 30
        Qd1B = 4
        Qd1H = 28
        Raster = 50
        AnH = 30
        LName = "RR28x2_1r_4s"
        seitig = 2
        StatusBar1.Panels(1).Text = "gewähltes Profil =  " & PName
    End Select
   
End Sub
'------------------------------------------------------------------
Private Sub MP2cmd2_click()
'---Variablen zum zeichnen des Rohrs-------------------------------
Dim Rohr1 As Acad3DSolid
Dim Rohr2 As Acad3DSolid
Dim RL1 As Double
Dim RP1#(2), RP2#(2)
'---Variablen zum zeichnen der Quader für die Lochung--------------
Dim Quad1 As Acad3DSolid
Dim QuadD1 As Acad3DSolid
Dim Quad2 As Acad3DSolid
Dim QuadD2 As Acad3DSolid
Dim P1, P2, P3, P4 As Variant
Dim QP1#(2), QP2#(2)
'------------------------------------------------------------------
Me.Hide
'---Neuer Layer----------------------------------------------------
Dim nLay As AcadLayer
Set nLay = ThisDrawing.Layers.Add(LName)
ThisDrawing.ActiveLayer = nLay
'---Eingabe--------------------------------------------------------
Dim Prompt1 As String
Prompt1 = vbCrLf & "Einfügepunkt:"
ZRohr = ThisDrawing.Utility.GetPoint(, Prompt1)
RL1 = MP2tbo2.Value
RP1(2) = RP2(2) - (RL1 / 2)
'---Zeichnen der Rohre---------------------------------------------
Set Rohr1 = ThisDrawing.ModelSpace.AddCylinder(ZRohr, rad1, RL1)
Rohr1.Move RP1, RP2
Set Rohr2 = ThisDrawing.ModelSpace.AddCylinder(ZRohr, rad2, RL1)
Rohr2.Move RP1, RP2
Rohr1.Boolean acSubtraction, Rohr2
'---Zeichnen des Quaders-------------------------------------------
QP1(2) = QP2(2) - AnH
P1 = ThisDrawing.Utility.PolarPoint(ZRohr, dtr(0#), LO1)
P2 = ThisDrawing.Utility.PolarPoint(P1, dtr(180#), LO2)
P3 = ThisDrawing.Utility.PolarPoint(ZRohr, dtr(90#), LO3)
P4 = ThisDrawing.Utility.PolarPoint(P3, dtr(270#), LO4)
'------------------------------------------------------------------
If seitig = 1 Then
Set Quad1 = ThisDrawing.ModelSpace.AddBox(P1, QdL, QdB, QdH)
    Quad1.Move QP1, QP2
Set QuadD1 = ThisDrawing.ModelSpace.AddBox(P2, QdL, QdB, QdH)
    QuadD1.Move QP1, QP2
End If

If seitig = 2 Then
Set Quad1 = ThisDrawing.ModelSpace.AddBox(P1, QdL, QdB, QdH)
    Quad1.Move QP1, QP2
Set QuadD1 = ThisDrawing.ModelSpace.AddBox(P2, QdL, QdB, QdH)
    QuadD1.Move QP1, QP2
Set Quad2 = ThisDrawing.ModelSpace.AddBox(P3, Qd1L, Qd1B, Qd1H)
    Quad2.Move QP1, QP2
Set QuadD2 = ThisDrawing.ModelSpace.AddBox(P4, Qd1L, Qd1B, Qd1H)
    QuadD2.Move QP1, QP2
End If
'---Lochreihe / Reihenbefehl---------------------------------------
Dim LB1, LB2, LB3 As Long
Dim LB4, LB5, LB6 As Double
Dim LRH1 As Variant
LRH1 = (RL1 / Raster)  'Höhe des Rundrohrs / Raster (35er / 50er) um die Anzahl der Ebenen zu ermitteln
LB1 = 1
LB2 = 1
LB3 = LRH1
LB4 = 1
LB5 = 1
LB6 = Raster
Dim LRHObj1 As Variant
Dim LRHObj2 As Variant
Dim LRHObj3 As Variant
Dim LRHObj4 As Variant

If seitig = 1 Then
LRHObj1 = Quad1.ArrayRectangular(LB1, LB2, LB3, LB4, LB5, LB6)
Dim i As Integer
    For i = LBound(LRHObj1) To UBound(LRHObj1)
      Rohr1.Boolean acSubtraction, LRHObj1(i)
    Next
Rohr1.Boolean acSubtraction, Quad1

LRHObj2 = QuadD1.ArrayRectangular(LB1, LB2, LB3, LB4, LB5, LB6)
Dim j As Integer
    For j = LBound(LRHObj2) To UBound(LRHObj2)
      Rohr1.Boolean acSubtraction, LRHObj2(j)
    Next
Rohr1.Boolean acSubtraction, QuadD1
End If

If seitig = 2 Then
LRHObj1 = Quad1.ArrayRectangular(LB1, LB2, LB3, LB4, LB5, LB6)
Dim z As Integer
    For z = LBound(LRHObj1) To UBound(LRHObj1)
      Rohr1.Boolean acSubtraction, LRHObj1(z)
    Next
Rohr1.Boolean acSubtraction, Quad1

LRHObj2 = QuadD1.ArrayRectangular(LB1, LB2, LB3, LB4, LB5, LB6)
Dim y As Integer
    For y = LBound(LRHObj2) To UBound(LRHObj2)
      Rohr1.Boolean acSubtraction, LRHObj2(y)
    Next
Rohr1.Boolean acSubtraction, QuadD1

LRHObj3 = Quad2.ArrayRectangular(LB1, LB2, LB3, LB4, LB5, LB6)
Dim k As Integer
    For k = LBound(LRHObj3) To UBound(LRHObj3)
      Rohr1.Boolean acSubtraction, LRHObj3(k)
    Next
Rohr1.Boolean acSubtraction, Quad2

LRHObj4 = QuadD2.ArrayRectangular(LB1, LB2, LB3, LB4, LB5, LB6)
Dim l As Integer
    For l = LBound(LRHObj4) To UBound(LRHObj4)
      Rohr1.Boolean acSubtraction, LRHObj4(l)
    Next
Rohr1.Boolean acSubtraction, QuadD2
End If
'---Neuer Layer für Rundrohr---------------------------------------
Rohr1.Layer = LName
Me.Show
End Sub

---

Gruß

Dirk

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

---

Hallo Dirk,

und wo liegt genau das Problem 

Stelli

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

Hi Dirk,

Wie befüllst du dein Listview denn?!
Schildere uns doch bitte genau wo du noch ein Problem mit deinem Programm hast.

Hab dir noch ne PM geschrieben.

Gruß, Carsten

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

---

TreeView_ListView.JPG

Hallo zusammen!

Das ListView wird nach Auswahl eines TreeView.Nodes befüllt.
Hier die Frage, könnte mann nicht verschiedene Bereiche in Modulen oder Klassenmodule (Klassenmodul ?) packen?
Ausschnitt aus dem Bereich TreeView:

Code:

---

Private Sub UserForm_Initialize()
TreeView1.Height = 312
TreeView1.Width = 294
Dim RootNode As MSComctlLib.Node
Dim DrawNode As MSComctlLib.Node
Dim xNode As MSComctlLib.Node
Dim xNode1 As MSComctlLib.Node
Dim xNode2 As MSComctlLib.Node
TreeView1.Nodes.Clear
TreeView1.ImageList = ImageList1
'---TreeView1 Auflistungen------------------------------------------
Set RootNode = TreeView1.Nodes.Add(Text:="1.0 LB-System", Image:=7, SelectedImage:=8)
RootNode.Tag = "1.0"
Set xNode = TreeView1.Nodes.Add(RootNode.Index, tvwChild, Text:="1.1 Lochungen, Lochbilder", Image:=7, SelectedImage:=8)
xNode.Tag = "1.1"
Set xNode1 = TreeView1.Nodes.Add(xNode.Index, tvwChild, Text:="35 Teilung", Image:=7, SelectedImage:=8)
xNode1.Tag = "35 Teilung"
Set xNode2 = TreeView1.Nodes.Add(xNode1.Index, tvwChild, Text:="Lochbilder für Rechteckrohr 60/30/2mm", Image:=3)
xNode2.Tag = "35Rechteckrohr60"
...
...
Set xNode2 = TreeView1.Nodes.Add(xNode1.Index, tvwChild, Text:="Standelement ohne Ausleger", Image:=5, SelectedImage:=6)
xNode2.Tag = "STRR60OA"
...

---

Nun zum Befüllen des ListView:

Code:

---

Private Sub TreeView1_nodeClick(ByVal Node As MSComctlLib.Node)
Dim LV As ListItem
Dim SI As ListSubItem
Dim color1 As Variant
Dim color2 As Variant
color1 = RGB(50, 10, 250)  'blau
color2 = RGB(250, 50, 50)  'rot
ListView1.View = lvwReport
ListView1.LabelEdit = lvwManual
ListView1.FullRowSelect = True
ListView1.GridLines = True
On Local Error Resume Next
Select Case Node.Tag
    Case "35Rechteckrohr60"
    MsgBox "Programmteil ist noch in Bearbeitung", 64, "Hinweis"
...
  Case "STRR60OA"
        ListView1.ListItems.Clear
        ListView1.ColumnHeaders.Clear
        '---Spaltendefinition
        With ListView1.ColumnHeaders
        .Add Text:="Rundrohr", Width:="65"
        .Add Text:="Lochung", Width:="130"
        .Add Text:="Teilung", Width:="95"
        End With
        '--------------------------------------------------------
        '---1. / Zeile-------------------------------------------
        Set LV = ListView1.ListItems.Add(, , "Ø 28x2 mm:")
        LV.ForeColor = color1
        With LV.ListSubItems
            Set SI = .Add(, , "28/22/4, 1-reihig, 2-seitig")
            SI.ForeColor = color1
            Set SI = .Add(, , "50")
            SI.ForeColor = color1
        End With
        '---2. / Zeile-------------------------------------------
        Set LV = ListView1.ListItems.Add(, , "Ø 28x2 mm:")
        LV.ForeColor = color2
        With LV.ListSubItems
            Set SI = .Add(, , "28/22/4, 1-reihig, 4-seitig")
            SI.ForeColor = color2
            Set SI = .Add(, , "50")
            SI.ForeColor = color2
        End With
...

---

Ich komme noch mal auf das Thema Modul oder Klassenmodul zurück.
Zu dem Klassenmodul habe ich Null Ahnung, was ich damit genau machen könnte.
In meinen Programmen nutze ich aber oft folgende Codes, die Dank Eurer Hilfe auch funktionieren.
Könnte man diese nicht aus dem Code der UserForm ausgliedern?

Farbauswahl:

Code:

---

Option Explicit
Dim c2 As Variant, s
Dim c As New AcadAcCmColor
Dim i
Me.Hide
    With ThisDrawing
        .SendCommand "_color" & Chr(13)
        c2 = .GetVariable("CECOLOR")
    End With
    If IsNumeric(c2) Then
        c.ColorIndex = c2
    ElseIf c2 = "BYBLOCK" Then c.ColorIndex = 0
    ElseIf c2 = "BYLAYER" Then c.ColorIndex = 256
    Else
        s = Split(Right(c2, Len(c2) - 4), ",")
        c.SetRGB CLng(s(0)), CLng(s(1)), CLng(s(2))
    End If
If c.ColorIndex = 256 Then
LBSlbl1.Caption = ("gewählte Farbe" & "  " & "VonLayer")
ElseIf c.ColorIndex = 0 Then
LBSlbl1.Caption = ("gewählte Farbe" & "  " & "VonBlock")
Else
LBSlbl1.Caption = ("gewählte Farbe" & "  " & c.ColorIndex)
End If
LBSimg1.BackColor = RGB(c.Red, c.Green, c.Blue)
Me.Show

---

Eigenschaften von TextBoxen / nur Zahlen / Komma zu Punkt:
Dieses funktioniert leider nur bei einer normalen Tastatur und nicht auf einem Laptop?

Code:

---

Private Sub MP2tbo1_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 MP2tbo1_Change()
    MP2tbo1.Text = Replace(MP2tbo1.Text, ".", ",")
End Sub

---

Ich hoffe es ist nicht zuviel auf einmal.

Vielen Dank für Eure Bereitschaft mir mal wieder zu helfen.

Gruß

Dirk

PS.: Carsten ich melde mich noch mal bei Dir, ist nicht vergessen.

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

---

Hallo Dirk,

Du kannst natürlich wiederkehrende Funktionen in ein separates Modul auslagern. Dadurch kannst du dir eine Funktionsbibliothek in einem Separaten Modul (oder auch Projekt) erstellen.

Warum soll der Code auf einem Notebook nicht funktionieren. Privat arbeite ich nur mit einem Notebook (Mal mit Tastatur an einer Dockingstation, mal mit der Notebook Tastatur). Ich hab noch nie Probleme damit gehabt.

Gruß, Carsten

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