hallo zusammen,
ich hab mir folgenden vba-code hier aus dem forum (nochmal danke)
kopiert und ihn meinen 'wünschen' entsprechend angepasst. soweit
klappt auch alles prima, der text wird ausgerichtet und bei bedarf
um 200 gon gedreht. ausserdem wird der quelltext vor dem ausrichten
kopiert. allerdings 2 mal. auf jedenfall steht der quelltext nachher
doppelt da...wenn ich anstatt 'elem3' nur 'elem' schreibe, steht der
ausgerichtete text doppelt da. was mach ich falsch?
danke jörg
Private Sub CommandButton27_Click()
Dim Elem As AcadEntity
Dim PtT As Variant
Dim Elem2 As AcadEntity
Dim Elem3 As AcadEntity
Dim PtL As Variant
Dim objText As AcadText
Dim objMText As AcadMText
Dim EPText(2) As Double
Dim drehpunkt(2) As Double
Dim objLinie As AcadLine
Dim objLinie2 As AcadLine
Dim objArc As AcadArc
Dim objArc2 As AcadArc
Dim Obj As Variant
Dim objLinArc As AcadLine
Dim intLinArc As Variant
Dim Abstand As Double
Unload Me
Do
MTextText:
On Error Resume Next
ThisDrawing.Utility.GetEntity Elem3, PtT, "Text/MText wählen: "
Set Elem = Elem3.Copy
If Err Then Exit Sub
If Elem.EntityType = acMtext Or Elem.EntityType = acText Then
Elem.Highlight True
Abstand = Elem.height / 2
Else
GoTo MTextText
End If
LinieBogen:
On Error Resume Next
ThisDrawing.Utility.GetEntity Elem2, PtL, "Linie/Bogen wählen: "
If Err Then
Elem.Highlight False
Exit Sub
End If
Select Case Elem2.EntityType
Case acLine
Set objLinie = Elem2
Elem.Rotation = ThisDrawing.Utility.AngleFromXAxis(objLinie.startPoint, objLinie.endPoint)
Obj = objLinie.Offset(Abstand)
Set objLinie2 = Obj(0)
EPText(0) = (objLinie2.startPoint(0) + objLinie2.endPoint(0)) / 2
EPText(1) = (objLinie2.startPoint(1) + objLinie2.endPoint(1)) / 2
EPText(2) = (objLinie2.startPoint(2) + objLinie2.endPoint(2)) / 2
drehpunkt(0) = EPText(0)
drehpunkt(1) = EPText(1)
drehpunkt(2) = EPText(2)
objLinie2.Delete
Case acArc
Set objArc = Elem2
EPText(0) = (objArc.startPoint(0) + objArc.endPoint(0)) / 2
EPText(1) = (objArc.startPoint(1) + objArc.endPoint(1)) / 2
EPText(2) = (objArc.startPoint(2) + objArc.endPoint(2)) / 2
Elem.Rotation = ThisDrawing.Utility.AngleFromXAxis(objArc.endPoint, objArc.startPoint)
Obj = objArc.Offset(Abstand)
Set objArc2 = Obj(0)
Select Case ThisDrawing.ActiveSpace
Case Is = 0
Select Case ThisDrawing.MSpace
Case True
Set objLinArc = ThisDrawing.ModelSpace.AddLine(objArc.center, EPText)
Case False
' Arbeiten wir im PaperSpace wird der Block in mm Eingesetzt
Set objLinArc = ThisDrawing.PaperSpace.AddLine(objArc.center, EPText)
End Select
Case Is = 1
Set objLinArc = ThisDrawing.ModelSpace.AddLine(objArc.center, EPText)
End Select
intLinArc = objArc2.IntersectWith(objLinArc, acExtendOtherEntity)
EPText(0) = intLinArc(0)
EPText(1) = intLinArc(1)
EPText(2) = intLinArc(2)
objLinArc.Delete
objArc2.Delete
Case Else
GoTo LinieBogen
End Select
Select Case Elem.EntityType
Case acText
Set objText = Elem
objText.Alignment = acAlignmentCenter
objText.TextAlignmentPoint = EPText
Case acMtext
Set objMText = Elem
objMText.AttachmentPoint = acAttachmentPointBottomCenter
objMText.insertionPoint = EPText
End Select
Elem.Update
x = InputBox("Um 200 gon Drehen?" & Chr(13) & "(für NEIN beliebige Taste drücken)", Default:="JA")
If x = "JA" Then
'MsgBox ("")
Elem.Rotate drehpunkt, 3.141592654
End If
Loop
End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP