---

Hallo Zusammen!

Ich habe mir mittels VBA einen Acad3DSolid -Körper erzeugt.
...
Dim solidobj1 As Acad3DSolid
...
Dieser liegt auf einem Punkt P22 (Dim P1 ...P22 As Variant) und soll innerhalb der Routine in Z -Achse um 16mm verschoben werden.
solidobj1.Move P22, ......

Wie gebe ich den Punkt in Z an?

Gruß

Dirk

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

---

Hi Dirk,

Du definierst dir einen Basispunkt p1 und einen Punkt p2 wo halt z + 16 liegt?
Oder aber ich versteh' das Problem [noch] nicht ganz ;-)

Gruss Nancy
--

Code:

---

Sub Example_AddBox()
    ' This example creates a box in model space.
    Dim boxObj As Acad3DSolid
    Dim length As Double, width As Double, height As Double
    Dim center(0 To 2) As Double
    Dim p1#(2), p2#(2)
    p2(2) = p1(2) + 16
   
    ' Define the box
    center(0) = 5#: center(1) = 5#: center(2) = 5#
    length = 5#: width = 7: height = 10#
   
    ' Create the box (3DSolid) object in model space
    Set boxObj = ThisDrawing.ModelSpace.AddBox(center, length, width, height)
   
    boxObj.Move p1, p2
   
    ZoomAll
   
End Sub

---

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

---

Hallo Nancy!

Vielen Dank für Deine Hilfe, es funktioniert.

Nun habe ich noch ein Problem und hoffe, daß Du mir auch dabei helfen kannst.
Kurz zu meinem Programm:
Ich erzeuge mit meinem Programm ein Rechteckrohr in 3D. In der Frontfläche sollen Schlitzlöcher entstehen.
Diese (Quader / solidobj3)sollen dann über "solidobj1.Boolean acSubtraction, solidobj3" von dem Rechteckrohr (solidobj1) abgezogen werden, siehe Foto. Das unter wird auch abgezogen, so das ein Loch ensteht. Die oberen, die ich über den Befehl "rechteckige Anordnung"
in einem auf die Höhe des Rechteckrohres im 35mm Raster angeordnet habe, funktioniert dies nicht.

.....
'verschieben des Volumenkörpers solidobj3 um 16mm in Z-Achse
Dim P28#(2), P29#(2)
    P29(2) = P28(2) + 16
solidobj3.Move P28, P29

'Erstellen der rechteckigen Anordnung
Dim nor As Long    'numberOfRows
Dim noc As Long    'numberOfColuns
Dim nol As Long    'numberOfLevels
Dim dbr As Double  'distanceBwtnRows
Dim dbc As Double  'distanceBwtnColumns
Dim dbl As Double  'distanceBwtnLevels
Dim reihe As Variant
reihe = (HZ / 35)  'Höhe des Rechteckrohrs / 35 (Raster) um die Anzahl der Ebenen zu ermitteln
nor = 1
noc = 1
nol = reihe
dbr = 1
dbc = 1
dbl = 35

'Erstellen der Objekanordnung
Dim retobj As Variant
retobj = solidobj3.ArrayRectangular(nor, noc, nol, dbr, dbc, dbl)
   
solidobj1.Boolean acSubtraction, solidobj3
....

Kannst Du mir auch dafür einen Tip geben.

(Mit dem Bildchen funktioniert leider nicht)

Gruß

Dirk

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

---

> Nun habe ich noch ein Problem und hoffe, daß Du mir auch dabei helfen kannst.

Dirk, also das mit der z-Verschiebung war ja grad noch so 'ne Hausfrauenfrage ;-)
Allerdings, jetzt klink' ich mich aus ...
Tja - so is das mit den Bräuten - sobalds komplizierter wird, kneifen 'se ...

Vielleicht bessert sich das ja 2005, rutsch' erstmal gut rein!
Gruss Nancy
--
ps: vielleicht weiss ja noch wer eine 'konstruktivere' Antwort ;-)

[Diese Nachricht wurde von startrek am 29. Dez. 2004 editiert.]

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

---

3D_Objekt.jpg

Hallo Nancy!

Trotzdem vielen Dank für Deine Hilfe.
Auch ich wünsche Dir, aber auch allen anderen einen guten "Rutsch" und ein erfolgreiches und gesundes Jahr 2005.

Ich habe es nochmal mit dem Bildchen probiert, vielleicht wird es dadurch ja noch verständlicher.

Könnte man dies evtl. über einen Auswahlsatz regeln?

Gruß

Dirk

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

---

Hallo Zusammen!

Ich wünsche allen ein frohes und gesundes neue Jahr und hoffe Ihr seit gut reingerutscht.

Leider bin ich mit meinem Problem noch nicht weiter gekommen.
Daher stelle ich mal den gesamten Sub - Bereich zur Verfühgung und hoffe, daß mir nun jemand helfen kann.
Mein Problem liegt darin, daß ich die mit dem

'Erstellen der Objektanordnung
Dim retobj As Variant
retobj = solidobj3.ArrayRectangular(nor, noc, nol, dbr, dbc, dbl)
   
erzeugten Quader (Acad3DSolid) nicht von dem zuvor erzeugten Rechteckrohr mit der

solidobj1.Boolean acSubtraction, solidobj3

abgezogen bekomme. Es wird nur das Ursprungobjekt solidobj3 (das untere) abgezogen, so daß da ein Loch in dem Rechteckrohr entsteht.

Code:
...
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, P16, P17, P18, P19, _
P20, P21, P22, P23, P24, P25, P26, P27 As Variant

Dim BX, TY, HZ, RA, WA As Integer
Dim peditobj1(0 To 7) As AcadEntity
Dim peditobj2(0 To 3) As AcadEntity
Dim peditobj3(0 To 3) As AcadEntity

'Festlegung des ErrorHandles
If (tbo1.Value = "" Or tbo2.Value = "" Or tbo3.Value = "" Or tbo4.Value = "" Or tbo5.Value = "") _
Then GoTo MyErrorHandler
If (tbo4.Value = "0") Then GoTo MyErrorHandler1

UserForm1.Hide      'Blendet die Dialogbox aus, löscht sie aber nicht aus dem Speicher
Prompt1 = vbCrLf & "Einfügepunkt:"
P0 = ThisDrawing.Utility.GetPoint(, Prompt1) 'Einfügepunkt

'Werte einzelnen Variablen zu ordnen
BX = tbo1.Value
TY = tbo2.Value
HZ = tbo3.Value
RA = tbo4.Value
WA = tbo5.Value

'Koordinatenfestlegung über Variablen für "peditobj1"
P1 = ThisDrawing.Utility.PolarPoint(P0, dtr(0#), BX)
P2 = ThisDrawing.Utility.PolarPoint(P1, dtr(90#), TY)
P3 = ThisDrawing.Utility.PolarPoint(P2, dtr(180#), BX)
P4 = ThisDrawing.Utility.PolarPoint(P0, dtr(90#), RA)
P5 = ThisDrawing.Utility.PolarPoint(P0, dtr(0#), RA)
P6 = ThisDrawing.Utility.PolarPoint(P1, dtr(180#), RA)
P7 = ThisDrawing.Utility.PolarPoint(P1, dtr(90#), RA)
P8 = ThisDrawing.Utility.PolarPoint(P2, dtr(270#), RA)
P9 = ThisDrawing.Utility.PolarPoint(P2, dtr(180#), RA)
P10 = ThisDrawing.Utility.PolarPoint(P3, dtr(0#), RA)
P11 = ThisDrawing.Utility.PolarPoint(P3, dtr(270#), RA)
P12 = ThisDrawing.Utility.PolarPoint(P4, dtr(0#), RA)
P13 = ThisDrawing.Utility.PolarPoint(P7, dtr(180#), RA)
P14 = ThisDrawing.Utility.PolarPoint(P8, dtr(180#), RA)
P15 = ThisDrawing.Utility.PolarPoint(P11, dtr(0#), RA)

'Koordinatenfestlegung über Variablen für "peditobj2"
P16 = ThisDrawing.Utility.PolarPoint(P0, dtr(0#), (BX / 2))
P17 = ThisDrawing.Utility.PolarPoint(P16, dtr(90#), WA)
P18 = ThisDrawing.Utility.PolarPoint(P17, dtr(180#), (BX / 2) - WA)
P19 = ThisDrawing.Utility.PolarPoint(P18, dtr(0#), BX - (2 * WA))
P20 = ThisDrawing.Utility.PolarPoint(P18, dtr(90#), TY - (2 * WA))
P21 = ThisDrawing.Utility.PolarPoint(P19, dtr(90#), TY - (2 * WA))

'Koordinatenfestlegung über Variablen für "peditobj3"
P22 = ThisDrawing.Utility.PolarPoint(P0, dtr(0#), (BX / 2))
P23 = ThisDrawing.Utility.PolarPoint(P22, dtr(270#), 1)
P24 = ThisDrawing.Utility.PolarPoint(P23, dtr(180#), 5)
P25 = ThisDrawing.Utility.PolarPoint(P24, dtr(90#), WA + 2)
P26 = ThisDrawing.Utility.PolarPoint(P25, dtr(0#), 10)
P27 = ThisDrawing.Utility.PolarPoint(P26, dtr(270#), WA + 2)

'Definition des "peditobj1"
Set peditobj1(0) = ThisDrawing.ModelSpace.AddArc(P12, RA, dtr(180#), dtr(270#))
Set peditobj1(1) = ThisDrawing.ModelSpace.AddArc(P13, RA, dtr(270), dtr(0))
Set peditobj1(2) = ThisDrawing.ModelSpace.AddArc(P14, RA, dtr(0), dtr(90))
Set peditobj1(3) = ThisDrawing.ModelSpace.AddArc(P15, RA, dtr(90), dtr(180))
Set peditobj1(4) = ThisDrawing.ModelSpace.AddLine(peditobj1(0).EndPoint, peditobj1(1).StartPoint)
Set peditobj1(5) = ThisDrawing.ModelSpace.AddLine(peditobj1(1).EndPoint, peditobj1(2).StartPoint)
Set peditobj1(6) = ThisDrawing.ModelSpace.AddLine(peditobj1(2).EndPoint, peditobj1(3).StartPoint)
Set peditobj1(7) = ThisDrawing.ModelSpace.AddLine(peditobj1(3).EndPoint, peditobj1(0).StartPoint)

'Definition des "peditobj2"
Set peditobj2(0) = ThisDrawing.ModelSpace.AddLine(P18, P20)
Set peditobj2(1) = ThisDrawing.ModelSpace.AddLine(P19, P21)
Set peditobj2(2) = ThisDrawing.ModelSpace.AddLine(peditobj2(0).StartPoint, peditobj2(1).StartPoint)
Set peditobj2(3) = ThisDrawing.ModelSpace.AddLine(peditobj2(0).EndPoint, peditobj2(1).EndPoint)
       
'Definition des "peditobj3"
Set peditobj3(0) = ThisDrawing.ModelSpace.AddLine(P24, P25)
Set peditobj3(1) = ThisDrawing.ModelSpace.AddLine(P27, P26)
Set peditobj3(2) = ThisDrawing.ModelSpace.AddLine(peditobj3(0).StartPoint, peditobj3(1).StartPoint)
Set peditobj3(3) = ThisDrawing.ModelSpace.AddLine(peditobj3(0).EndPoint, peditobj3(1).EndPoint)
       
'Festlegung der Regionen
Dim regionobj1 As Variant
regionobj1 = ThisDrawing.ModelSpace.AddRegion(peditobj1)
Dim regionobj2 As Variant
regionobj2 = ThisDrawing.ModelSpace.AddRegion(peditobj2)
Dim regionobj3 As Variant
regionobj3 = ThisDrawing.ModelSpace.AddRegion(peditobj3)

' Definition der Extrusion
Dim taperAngle As Double
taperAngle = 0
   
' 3D Körper erstellen
Dim solidobj1 As Acad3DSolid
Dim solidobj2 As Acad3DSolid
Dim solidobj3 As Acad3DSolid
Set solidobj1 = ThisDrawing.ModelSpace.AddExtrudedSolid(regionobj1(0), HZ, taperAngle)
solidobj1.Layer = cbo1.Value
Set solidobj2 = ThisDrawing.ModelSpace.AddExtrudedSolid(regionobj2(0), HZ, taperAngle)
solidobj2.Layer = cbo1.Value
Set solidobj3 = ThisDrawing.ModelSpace.AddExtrudedSolid(regionobj3(0), 16, taperAngle)
solidobj3.Layer = cbo1.Value

'Farbauswahl für die Darstellung des Volumenkörpers
Select Case cbo3.ListIndex
Case 0  'Rot
    solidobj1.color = 1
    solidobj2.color = 1
    solidobj3.color = 1
Case 1  'Gelb
    solidobj1.color = 2
    solidobj2.color = 2
    solidobj3.color = 2
Case 2  'Grün
    solidobj1.color = 3
    solidobj2.color = 3
    solidobj3.color = 3
Case 3  'Cyan
    solidobj1.color = 4
    solidobj2.color = 4
    solidobj3.color = 4
Case 4  'Blau
    solidobj1.color = 5
    solidobj2.color = 5
    solidobj3.color = 5
Case 5  'Magenta
    solidobj1.color = 6
    solidobj2.color = 6
    solidobj3.color = 6
Case 6  'Weiß
    solidobj1.color = 7
    solidobj2.color = 7
    solidobj3.color = 7
Case 7  'Grau
    solidobj1.color = 8
    solidobj2.color = 8
    solidobj3.color = 8
Case 8  'Grau
    solidobj1.color = 9
    solidobj2.color = 9
    solidobj3.color = 9
Case 9  'Grau
    solidobj1.color = 252
    solidobj2.color = 252
    solidobj3.color = 252
Case 10  'Grau
    solidobj1.color = 253
    solidobj2.color = 253
    solidobj3.color = 253
Case 11  'Grau
    solidobj1.color = 254
    solidobj2.color = 254
    solidobj3.color = 254
Case 12  'Grau
    solidobj1.color = 255
    solidobj2.color = 255
    solidobj3.color = 255
Case 13  'Blaugrün
    solidobj1.color = 123
    solidobj2.color = 123
    solidobj3.color = 123
Case 14  'Blaugrün
    solidobj1.color = 132
    solidobj2.color = 132
    solidobj3.color = 132
Case 15  'Hellblau
    solidobj1.color = 151
    solidobj2.color = 151
    solidobj3.color = 151
End Select

'Differenz der Volumenkörper
solidobj1.Boolean acSubtraction, solidobj2

'verschieben des Volumenkörpers solidobj3 um 16mm in Z-Achse
Dim P28#(2), P29#(2)
    P29(2) = P28(2) + 16
solidobj3.Move P28, P29

'Erstellen der rechteckigen Anordnung
Dim nor As Long    'numberOfRows
Dim noc As Long    'numberOfColuns
Dim nol As Long    'numberOfLevels
Dim dbr As Double  'distanceBwtnRows
Dim dbc As Double  'distanceBwtnColumns
Dim dbl As Double  'distanceBwtnLevels
Dim reihe As Variant
reihe = (HZ / 35)  'Höhe des Rechteckrohrs / 35 (Raster) um die Anzahl der Ebenen zu ermitteln
nor = 1
noc = 1
nol = reihe
dbr = 1
dbc = 1
dbl = 35

'Erstellen der Objektanordnung
Dim retobj As Variant
retobj = solidobj3.ArrayRectangular(nor, noc, nol, dbr, dbc, dbl)
   
solidobj1.Boolean acSubtraction, solidobj3

'löschen der nicht mehr benötigten peditobj1 Elemente
peditobj1(0).Delete
peditobj1(1).Delete
peditobj1(2).Delete
peditobj1(3).Delete
peditobj1(4).Delete
peditobj1(5).Delete
peditobj1(6).Delete
peditobj1(7).Delete

'löschen der nicht mehr benötigten peditobj2 Elemente
peditobj2(0).Delete
peditobj2(1).Delete
peditobj2(2).Delete
peditobj2(3).Delete

'löschen der nicht mehr benötigten peditobj3 Elemente
peditobj3(0).Delete
peditobj3(1).Delete
peditobj3(2).Delete
peditobj3(3).Delete

'löschen der nicht mehr benötigten Regionen
regionobj1(0).Erase
regionobj2(0).Erase
regionobj3(0).Erase

'Festlegung der Ansichtsformen
Dim NewDirection(0 To 2) As Double
If obp1 = True Then 'Ansicht = Draufsicht
    NewDirection(0) = 0: NewDirection(1) = 0: NewDirection(2) = 1
End If
If obp2 = True Then 'Ansicht = SW
    NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
End If
If obp3 = True Then 'Ansicht = SO
    NewDirection(0) = 1: NewDirection(1) = -1: NewDirection(2) = 1
End If
If obp4 = True Then 'Ansicht = NO
    NewDirection(0) = 1: NewDirection(1) = 1: NewDirection(2) = 1
End If
If obp5 = True Then 'Ansicht = NW
    NewDirection(0) = -1: NewDirection(1) = 1: NewDirection(2) = 1
End If
   
'NewDirection(0) = 1: NewDirection(1) = -1: NewDirection(2) = 1
ThisDrawing.ActiveViewport.Direction = NewDirection
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
ZoomAll

'Festlegung der _shademode Methode
If obp6.Value = True Then
    ThisDrawing.SendCommand "_shademode" & vbCr & "_2" & vbCr
End If
If obp7.Value = True Then
    ThisDrawing.SendCommand "_shademode" & vbCr & "_h" & vbCr
End If
If obp8.Value = True Then
    ThisDrawing.SendCommand "_shademode" & vbCr & "_g" & vbCr
End If
 
'Informationen zu dem ErrorHandles
    Exit Sub
MyErrorHandler:
    MsgBox "Bitte geben Sie entsprechende Werte ein", 64, "Hinweis"
MyErrorHandler1:
    MsgBox "Der Radius muß mindestens 0,1mm betragen", 64, "Hinweis"

End Sub
...

Vielen Dank im voraus.

Gruß

Dirk

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

---

Hallo Dirk,

immernoch keine Lösung für dein Problem,
dafür aber paar nebensächliche Anmerkungen zum Code [nur überflogen]:

Code:

---

Dim P0, P1, P2, P3, P4, P5, P6, P7, P8, P9, P10, P11, P12, P13, P14, P15, P16, P17, P18, P19, _
P20, P21, P22, P23, P24, P25, P26, P27 As Variant
'P27 ist explicit als Variant deklariert, P0-P26 sind's sowieso, da ohne Angabe;-)

---

Fast ähnlich hier:

Code:

---

Dim BX, TY, HZ, RA, WA As Integer ' sei Dir bewusst dass hier ebenso nur WA ein Integer darstellt,
'da es das letzte in der Zeile deklarierte ist! Der Rest ist schlichtergreifend weder Fisch noch Fleisch;-)
' BX, TY, HZ und RA sind Variant ...

---

'wöllteste die komplette Zeile mit Int's belegen, dann immer zuschreiben,
'ob nun in Kurzform % oder as Integer, also entweder sowas:

Code:

---

Dim BX as integer, TY as integer, HZ as integer, RA as integer, WA As Integer
'oder so, in der Kurznotation:
Dim BX%, TY%, HZ%, RA%, WA%

---

Desweiteren, manche Codepassagen schreien geradezu nach einem With!
also irgendwie so:

Code:

---

'Koordinatenfestlegung über Variablen für "peditobj1"
with thisdrawing.utility
  P1 = .PolarPoint(P0, dtr(0#), BX)
  P2 = .PolarPoint(P1, dtr(90#), TY)
  P3 = .PolarPoint(P2, dtr(180#), BX)
  P4 = .PolarPoint(P0, dtr(90#), RA)
  P5 = [...]
end with

---

Es ist mir bewusst, dass ich nix zu deinem eigentlichen Problem/Frage hiermit beigetragen habe,
aber ich konnte nicht anders;-)

Mal im Ernst, versuch mal dich an derlei Konventionen zu halten, macht die Sache einfach mal lesbarer,
versuch strukturiert deine Befehle zusammenzufassen und benütze Einrückungen.

Vielleicht klingts ja etwas pedantisch, oberlehrerhaft, solls aber nicht, Dirk.
Fakt ist, das man sich genau mit Einhaltung dieser pedantischen und stinklangweiligen [igitt] Konventionen,
ne Menge Ärger ersparen kann und obendrein [wenns gut läuft] den Fehler auch noch selber [besser] finden kann.

Nancy 

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

---

Hallo Nancy!

Da ich mir bislang fast alles selber angeeignet habe, was mit VBA zutun hat, bis auf die Hilfestellungen aus dem Forum, bin ich für jede Info und Änderungsanregung, was die Programmerstellung vereinfacht, oder vom schreibaufwand verkürzt, dankbar.

Gruß

Dirk

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