---

Hallo Forum
Ich möchte in einem Mtxt nach "xy" suchen und durch "ätsch" mit dem Stil wingdings ersetzen.
Bisher hatte ich leider keinen Erfolg.

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

---

Hallo It is Me,
ich begrüße dich in diesem tollen Forum.
Zuerst ließ einmal das hier Supportangaben zu PC und Software - Fragen schneller und besser beantworten.
Hier der Code den du brauchst.

Code:

---

Public Sub MTextTextChange()
    Dim ObjText As AcadMText
    Dim Pt As Variant
    Dim ObjTextOverride As String
    Const Textsearch  As String = "xy"
    Const Textoverride As String = "ätsch"
    Dim ObjTextOverrideSplit As Variant
   
   
    On Error GoTo Err_Control
    GetEntityEx ObjText, Pt, vbCr & "MText wählen: "
    ObjTextOverride = ObjText.textString
   
    If InStr(1, ObjTextOverride, Textsearch) > 0 Then
        ObjTextOverrideSplit = Split(ObjTextOverride, Textsearch)
       
        Dim i As Long
        Dim Anzahl As Long
       
        Anzahl = UBound(ObjTextOverrideSplit)
       
        ObjTextOverride = ObjTextOverrideSplit(0) & Textoverride
       
        For i = 1 To Anzahl
           
            If Anzahl = 1 Then
                ObjTextOverride = ObjTextOverride & ObjTextOverrideSplit(i)
            Else
                If i < Anzahl Then
                    ObjTextOverride = ObjTextOverride & ObjTextOverrideSplit(i) & Textoverride
                Else
                    ObjTextOverride = ObjTextOverride & ObjTextOverrideSplit(i)
                End If
            End If
           
        Next i
    End If
   
    ObjText.textString = ObjTextOverride
    ObjText.Update
    Set ObjText = Nothing
   
Exit_Here:
    Exit Sub
Err_Control:
    Err.Clear
    Resume Exit_Here
   
End Sub

Public Sub GetEntityEx(ent As Object, pickedPoint, Optional Prompt)

    On Error Resume Next
StartLoop:
    ActiveDocument.Utility.GetEntity ent, pickedPoint, Prompt
    If Err Then
        If ActiveDocument.GetVariable("errno") = 7 Then
            Err.Clear
            GoTo StartLoop
        Else
            Err.Raise vbObjectError + 5, , "User cancelled operation"
        End If
    End If

End Sub

---

------------------
Roland

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

---

Entschuldig, der Code oben ist zwar nicht falsch, aber doch ein totaler Blödsinn da es die Funktion Replace ja schon gibt.
Daher nochmals das Beispiel, nun aber richtig.

Code:

---

Public Sub MTextTextChange1()
    Dim ObjText As AcadMText
    Dim Pt As Variant
    Dim ObjTextOverride As String
    Const Textsearch  As String = "xy"
    Const Textoverride As String = "ätsch"
   
   
    On Error GoTo Err_Control
    GetEntityEx ObjText, Pt, vbCr & "MText wählen: "
    ObjTextOverride = ObjText.textString
   
    ObjTextOverride = Replace(ObjTextOverride, Textsearch, Textoverride)
   
    ObjText.textString = ObjTextOverride
    ObjText.Update
    Set ObjText = Nothing
   
Exit_Here:
    Exit Sub
Err_Control:
    Err.Clear
    Resume Exit_Here
   
End Sub

---

------------------
Roland

[Diese Nachricht wurde von RoSiNiNo am 24. September 2003 editiert.]

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

---

Danke für die Hilfe aber den schwierigsten Teil hast du leider übersehen.
Der neu eingefügte Text soll in einem anderen Schriftstil (Wingdings)eingefügt werden.
Hier bin ich bisher kläglich gescheitert.

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

---

Dann probier es einmal damit:

Code:

---

Public Sub MTextTextChange1()
    Dim ObjText As AcadMText
    Dim Pt As Variant
    Dim ObjTextOverride As String
    Const Textsearch  As String = "xy"
    Const Textoverride As String = "{\fWingdings;ätsch}"
   
   
    On Error GoTo Err_Control
    GetEntityEx ObjText, Pt, vbCr & "MText wählen: "
    ObjTextOverride = ObjText.textString
   
    ObjTextOverride = Replace(ObjTextOverride, Textsearch, Textoverride)
   
    ObjText.textString = ObjTextOverride
    ObjText.Update
    Set ObjText = Nothing
   
Exit_Here:
    Exit Sub
Err_Control:
    Err.Clear
    Resume Exit_Here
   
End Sub

---

------------------
Roland

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

---

Hallo

noch ne Frage
Warum funktioniert das unter acad aber nicht mit Autocad Mechanical
Er kennt den Befehl "Replace" nicht.

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

---

Kommt auf die Version an, geht glaube ich erst ab 2002.
Sost verwende einfach erstes Beispiel.

------------------
Roland

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

---

Hab ich versucht
Hier kennt VBA den befehl "Split" nicht

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

---

Versuch es damit:

Code:

---

Public Function Split(Str As String, Delim As String) As Variant

    Dim tokens() As String, pos As Long, i As Integer

    pos = InStr(1, Str, Delim, vbTextCompare)
    i = 0

    Do While pos > 0
      ReDim Preserve tokens(0 To i)
      tokens(i) = Mid$(Str, 1, pos - 1)
      If tokens(i) = Delim Then tokens(i) = ""
      Str = Mid$(Str, pos + Len(Delim))
      i = i + 1
      pos = InStr(1, Str, Delim, vbTextCompare)
    Loop

    If Len(Str) > 0 Then
      ReDim Preserve tokens(0 To i)
      tokens(i) = Str
    End If

    Split = tokens

End Function

---

------------------
Roland

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

---

Danke Danke Danke
Vielen Dank

Nun läuft alles ohne Probleme

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