---

Hallo zusammen

Hat jemand ein Makro (oder Fragmente davon), mit dem man in einer offenen Skizze alle Texte auflösen kann (DissolveSketchText)? Und ist jemand bereit ein solches uns zur Verfügung zu stellen? Würde uns noch helfen.

Gruss, Hermann

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

---

ich mache das immer im AutoCad, vielleicht gibt es Text in Pfade umwandeln ja auch im DS. Theoretisch müsste es diese Funktion auch in kostenfreien Vektorenprogrammen geben, aber ich habe es nicht gefunden.

ich hoffe du meinst das.

herzlich Sascha

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

---

Skizze.txt

Hallo zusammen

Hab mal versucht einen Code zu schreiben. Leider funktioniert das Selektieren des Textes nur nicht immer. (Von 5 Texten wird nur einer gefunden.)

Hat jemand eine Idee, wie ich die Texte besser finden kann?

Sub Text_aufloesen()
'Makro zum Auflösen von Texten in Skizzen
'Hermann Stiefel für Zubler Handling AG, 01.10.2019
'
'Grosse Teile des Programms stammen von Stefan Berlitz und PaulchenPanter, www.cad.de

    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swSketch As SldWorks.Sketch
    Dim vSketchText As Variant
    Dim swSketchText As SldWorks.SketchText
    Dim ac As Long
    Dim boolstatus As Boolean
    Dim Coord As Variant
   
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set swSelMgr = swModel.SelectionManager
    Set swSketch = swModel.GetActiveSketch2
   
    vSketchText = swSketch.GetSketchTextSegments
   
    For ac = 0 To UBound(vSketchText)
        Set swSketchText = vSketchText(ac)
        Coord = swSketchText.GetCoordinates
        MsgBox (swSketchText.Text)
        boolstatus = swModel.Extension.SelectByID2("", "SKETCHTEXT", Coord(0), Coord(1), 0, False, 0, Nothing, 0)

        If boolstatus = 1 Then
            swModel.DissolveSketchText
        End If
       
        swModel.ClearSelection2 (True)

    Next

   
End Sub

Gruss, Hermann
PS: Beim angehängten File handelt es sich um einen sldprt-Datei mit der besagten Skizze

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

---

Hallo Hermann,

ich würde mal tippen das die Coordinaten die GetCoordinates liefert nicht genau auf dem Text (einer Linie davon) liegen und daher bei SelectByID nicht erwischt werden, ich hab es jetzt mal versucht das SketchSegemt direkt zu selectieren (Select4) und es scheint zu klappen. Das Select/ Case kann man auch anderst lösen ist vom Ausgangsbeispiel noch drin (Get All Elements of Sketch Example (VBA)).

Code:

---

Option Explicit

Sub main()
    Dim sSkSegmentsName(5) As String
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
   
    Dim SelData As SldWorks.SelectData
   
    Dim swSketch As SldWorks.Sketch
    Dim vSkSegArr As Variant
    Dim vSkSeg As Variant
    Dim swSkSeg  As SldWorks.SketchSegment

    Dim boolstatus As Boolean
   
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    Set swSketch = swModel.GetActiveSketch2

    vSkSegArr = swSketch.GetSketchSegments
   
    For Each vSkSeg In vSkSegArr
        Set swSkSeg = vSkSeg

        Select Case swSkSeg.GetType

            Case swSketchText
                boolstatus = swSkSeg.Select4(False, SelData)
       
                If boolstatus = True Then
                    swModel.DissolveSketchText
                End If
     
                swModel.ClearSelection2 (True)
       
            Case Default
           
        End Select
    Next vSkSeg
End Sub

---

Gruß
Bernd

------------------
--- Man muß nicht alles wissen, man muß nur wissen wo es steht ---

Staatlich anerkannte Deutschniete 

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

---

Hallo Bernd

Das ist sehr lieb. Du hast vieles neu formuliert. Ja, das Makro kann jetzt das, was es können sollte. Vielen Dank! 

Gruss, Hermann

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