Hot News:

Mit Unterstützung durch:

  Foren auf CAD.de (alle Foren)
  Rund um AutoCAD
  vba / text ausrichten

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  vba / text ausrichten (1123 mal gelesen)
jobau
Mitglied
Bauingenieur


Sehen Sie sich das Profil von jobau an!   Senden Sie eine Private Message an jobau  Schreiben Sie einen Gästebucheintrag für jobau

Beiträge: 209
Registriert: 21.01.2003

erstellt am: 22. Mai. 2003 15:33    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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

Karsten HST
Mitglied
Bauingenieur


Sehen Sie sich das Profil von Karsten HST an!   Senden Sie eine Private Message an Karsten HST  Schreiben Sie einen Gästebucheintrag für Karsten HST

Beiträge: 54
Registriert: 22.04.2003

erstellt am: 22. Mai. 2003 17:29    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für jobau 10 Unities + Antwort hilfreich

Damit keine zweite Kopie des Textes erstellt wird, müsstest Du folgende Zeilen tauschen
     

        Set Elem = Elem3.Copy
        If Err Then Exit Sub
       
in
        If Err Then Exit Sub
        Set Elem = Elem3.Copy

Beim der zweiten Abfrage wird der vorher gewählte Text nochmals kopiert.       
Ausserdem kannst Du, wenn Du willst, die Zeilen

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

durch

If MsgBox("Um 200 gon Drehen?" & Chr(13),vbYesNo) = vbYes Then
  Elem.Rotate drehpunkt, 3.141592654
End If

ersetzen.

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

jobau
Mitglied
Bauingenieur


Sehen Sie sich das Profil von jobau an!   Senden Sie eine Private Message an jobau  Schreiben Sie einen Gästebucheintrag für jobau

Beiträge: 209
Registriert: 21.01.2003

erstellt am: 23. Mai. 2003 06:59    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

ja super, vielen dank. klappt jetzt genauso, wie ich
es haben wollte... und das mit der abfrage gefällt mir
auch viel besser. die 10pkt hast du dir verdient :-)))
gruß jörg

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

DraftsmanCAD
Mitglied


Sehen Sie sich das Profil von DraftsmanCAD an!   Senden Sie eine Private Message an DraftsmanCAD  Schreiben Sie einen Gästebucheintrag für DraftsmanCAD

Beiträge: 2
Registriert: 08.12.2022

erstellt am: 08. Dez. 2022 10:08    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für jobau 10 Unities + Antwort hilfreich

Ein herzliches Hallo in die Runde! 

Sorry, dass ich diesen alten Thead nochmal „wiederbelebe“.
Ich finde die Lösung schon super, aber gibt es auch die Möglichkeit den Text an alle Segmente einer Polylinie zu kopieren?
Wie müsste ich den Code anpassen?
Schonmal vielen Dank im Voraus!

[Diese Nachricht wurde von DraftsmanCAD am 08. Dez. 2022 editiert.]

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

KlaK
Ehrenmitglied V.I.P. h.c.
Dipl. Ing. Vermessung, CAD- und Netz-Admin



Sehen Sie sich das Profil von KlaK an!   Senden Sie eine Private Message an KlaK  Schreiben Sie einen Gästebucheintrag für KlaK

Beiträge: 2607
Registriert: 02.05.2006

AutoCAD LandDesktop R2 bis 2004
Civil 3D 2005 - 2022
Bricscad V11-V21 pro
Plateia, Canalis
Visual Basic

erstellt am: 08. Dez. 2022 13:39    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für jobau 10 Unities + Antwort hilfreich

Hallo DraftsmanCAD, Willkommen im Forum 

Kann man im Prinzip schon erweitern, allerdings ist das nicht ganz trivial denn man muß hier noch unterscheiden ob es sich um ein LW-Polyline, Polyline oder 3D-Polylinie handelt. Zudem muß natürlich bei einfachen Polylinien geschaut werden ob zusätzlich Bögen (Bulge) vorhanden sind.
Um die einzelnen Mittelpunkte zu erhalten muß man durch die Polylinie "wandern" und dabei unterscheiden ob das Coordinates-Feld zwei oder drei Werte pro Punkt speichert (alles machbar).

Bis wann bräuchtest Du denn eine Lösung? Derzeit habe ich wenig Zeit aber in den Weihnachtsferien ...

Grüße
Klaus   

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

cadwomen
Ehrenmitglied V.I.P. h.c.
Mädchen für fast alles


Sehen Sie sich das Profil von cadwomen an!   Senden Sie eine Private Message an cadwomen  Schreiben Sie einen Gästebucheintrag für cadwomen

Beiträge: 2951
Registriert: 26.08.2002

ACAD R11 - 2022
(Plant3D)
AVIS
ACAD LT 2013- 2021
ZWCAD 2015 Versuch "nun ja"
[s]History P3D 2012/(13) SP und Hotfix([/s]<P>
Windows 10 / 64 Bit
Xeon CPU 3.5GHz
16GB Ram
NVIDIA Quadro P2000
3x Dell TV100 88P Monitore

erstellt am: 08. Dez. 2022 13:43    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für jobau 10 Unities + Antwort hilfreich

Hy

vielleicht findest du darin den passenden Teil

http://www.lee-mac.com/curvealignedtext.html

Dornate nicht vergessen ;-)

cu cw

------------------
Also ich finde Unities gut ... und andere sicher auch
------------------------------------------------
cadwomen™
Plant ist nur die Spitze des Berges der da treibt ?

[Diese Nachricht wurde von cadwomen am 08. Dez. 2022 editiert.]

[Diese Nachricht wurde von cadwomen am 13. Dez. 2022 editiert.]

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

DraftsmanCAD
Mitglied


Sehen Sie sich das Profil von DraftsmanCAD an!   Senden Sie eine Private Message an DraftsmanCAD  Schreiben Sie einen Gästebucheintrag für DraftsmanCAD

Beiträge: 2
Registriert: 08.12.2022

erstellt am: 08. Dez. 2022 15:57    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für jobau 10 Unities + Antwort hilfreich

Zitat:
Original erstellt von cadwomen:
Hy

filleicht findest du darin den passenden Teil

http://www.lee-mac.com/curvealignedtext.html

Dornate nicht vergessen ;-)

cu cw


Oh, wow danke Dir! Das ist schon ziemlich perfekt und ich kann damit arbeiten.

Zitat:
Bis wann bräuchtest Du denn eine Lösung? Derzeit habe ich wenig Zeit aber in den Weihnachtsferien ...

Grüße
Klaus


Da ich mit der LISP von lee-mac erstmal arbeiten kann, ist es nicht so dringend. Eine VBA-Lösung würde ich zwar favorisieren, möchte dich aber auch nicht um Deine Weihnachtsferien bringen ;-)

Vielen Dank euch beiden!

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

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz