Hi
mir so nicht bekannt, In VBA "einfach" nachzuruesten, aus dem thisfrawing.Pickfirstselectionset
alle Elemente auslesen und dann gemeass elementyp darauf die funktion anwenden.
Wir haben hier ACADMTEXT, ACADTEXT, und ACADBLOCKREF. - letztere sind ein bischen tricky da gilt es die attributliste auszulesen. In Verbindung mit einem VBA Projektverweis auf die Microsoft VBscript Regular Expressions.
bleibt da auch kaum noch ein Auge trocken 
Regular Expressions sind zwar ein wenig "gewoehnungsbeduerftig"
https://de.wikipedia.org/wiki/Regul%C3%A4rer_Ausdruck
aber "ziemlich" maechtig
in VBA einmalig 2 Stunden Aufriss wenn man es fließend spricht, und um die 100 zeilen Code.
Als Startpunkt ein paar Zeilen code, kann man na klar mit ner Dialogbox noch aufwerten.
Elemente auswaehlen,
Funktion aufrufen
Function get_string(MSG As String, s As String, Optional force As Boolean = False, Optional native As Boolean = True) As Boolean
Dim T As String
Dim msg2 As String
get_string = False
RETRYs:
On Error Resume Next
Err.Clear
If native Then
s = ThisDrawing.UTILITY.getString(0, MSG)
Else
s = InputBox(MSG, "INPUT:", s)
End If
On Error GoTo 0
If Err.number = 0 Then get_string = True: Exit Function
If force Then GoTo RETRYs
End Function
Public Function RxReplace( _
ByVal SourceString As String, _
ByVal Pattern As String, _
ByVal ReplacePattern As String, _
Optional ByVal replacetype As String = "", _
Optional ByVal ignorecase As Boolean = True, _
Optional ByVal MultiLine As Boolean = True, _
Optional ByVal MatchGlobal As Boolean = True) As String
If replacetype = "R" Then
With New RegExp
.MultiLine = MultiLine
.ignorecase = ignorecase
.Global = MatchGlobal
.Pattern = Pattern
RxReplace = .Replace(SourceString, ReplacePattern)
End With
Else
RxReplace = Replace(SourceString, Pattern, ReplacePattern)
End If
End Function
Sub replacer()
Dim SelectionSetObject As AcadSelectionSet
If ThisDrawing.PickfirstSelectionSet.count = 0 Then
MsgBox "Select Items first"
Exit Sub
End If
Set SelectionSetObject = ThisDrawing.PickfirstSelectionSet
Dim TSEARCH As String
Dim TREPLACE As String
Dim replacetype As String
Dim ignorecase As Boolean
Dim MultiLine As Boolean
Dim MatchGlobal As Boolean
Dim entity As AcadEntity
Dim TMTEXT As AcadMText
Dim TTEXT As AcadText
Dim ATTRIB As AcadAttribute
Dim BLOCKREF As AcadBlockReference
Dim BLOCKDEF As AcadBlock
Dim LAYER As AcadLayer
Dim GROUP As AcadGroup
Dim SEARCHTYPE As String
Dim LEADER As AcadLeader
Dim TEXT As String
Dim DIMENSION As AcadDimension
Dim DIMENSION_RADIAL As AcadDimRadial
Dim DIMENSION_ALIGNED As AcadDimAligned
Dim DIMENSION_ROTATED As AcadDimRotated
Dim DIMENSION_ANGULAR As AcadDimAngular
Dim DIMENSION_ARC_LENGTH As AcadDimArcLength
Dim DIMENSION_DIAMETRIC As AcadDimDiametric
Dim DIMENSION_RADIAL_LARGE As AcadDimRadialLarge
Dim DIMENSION_3POINT_ANGULAR As AcadDim3PointAngular
Dim DIMENSION_ORDINATE As AcadDimOrdinate
Dim lobjext As AcadEntity
Dim REGEX As String
If Not get_string("SEARCH", TSEARCH) Then Exit Sub
If Not get_string("REPLACE WITH", TREPLACE) Then Exit Sub
If Not get_string("USE REGEX 0/1", REGEX) Then Exit Sub
If LCASE(REGEX) = "1" Then REGEX = "R"
For Each entity In SelectionSetObject
Select Case LCASE(entity.ObjectName)
Case "acdbtext"
Set TTEXT = entity
TEXT = TTEXT.textstring
Case "acdbmtext"
Set TMTEXT = entity
TEXT = TMTEXT.textstring
Case "acdbradialdimension"
Set DIMENSION_RADIAL = entity
TEXT = DIMENSION_RADIAL.TextOverride
Case "acdbrotateddimension"
Set DIMENSION_ROTATED = entity
TEXT = DIMENSION_ROTATED.TextOverride
Case "acdbaligneddimension"
Set DIMENSION_ALIGNED = entity
TEXT = DIMENSION_ALIGNED.TextOverride
Case "acdbordinatedimension"
Set DIMENSION_ORDINATE = entity
TEXT = DIMENSION_ORDINATE.TextOverride
Case "acdb3pointangulardimension"
Set DIMENSION_3POINT_ANGULAR = entity
TEXT = DIMENSION_3POINT_ANGULAR.TextOverride
Case "acdbarcdimension"
Set DIMENSION_ARC_LENGTH = entity
TEXT = DIMENSION_ARC_LENGTH.TextOverride
Case "acdbradialdimensionlarge"
Set DIMENSION_RADIAL_LARGE = entity
TEXT = DIMENSION_RADIAL_LARGE.TextOverride
Case "acdbdiametricdimension"
Set DIMENSION_DIAMETRIC = entity
TEXT = DIMENSION_DIAMETRIC.TextOverride
Case "acdbleader"
Set LEADER = entity
Set lobject = LEADER.Annotation
Select Case LCASE(entity.ObjectName)
Case "acdbmtext"
Set TMTEXT = entity
TEXT = TMEXT.textstring
End Select
Case "acdbattributedefinition"
Case "acdbblockreference"
Case Else
End Select
TEXT = RxReplace(TEXT, TSEARCH, TREPLACE, REGEX, ignorecase, MultiLine, MatchGlobal)
Select Case LCASE(entity.ObjectName)
Case "acdbtext"
Set TTEXT = entity
TTEXT.textstring = TEXT
Case "acdbmtext"
Set TMTEXT = entity
TMTEXT.textstring = TEXT
Case "acdbradialdimension"
Set DIMENSION_RADIAL = entity
DIMENSION_RADIAL.TextOverride = TEXT
Case "acdbrotateddimension"
Set DIMENSION_ROTATED = entity
DIMENSION_ROTATED.TextOverride = TEXT
Case "acdbaligneddimension"
Set DIMENSION_ALIGNED = entity
DIMENSION_ALIGNED.TextOverride = TEXT
Case "acdbordinatedimension"
Set DIMENSION_ORDINATE = entity
DIMENSION_ORDINATE.TextOverride = TEXT
Case "acdb3pointangulardimension"
Set DIMENSION_3POINT_ANGULAR = entity
DIMENSION_3POINT_ANGULAR.TextOverride = TEXT
Case "acdbarcdimension"
Set DIMENSION_ARC_LENGTH = entity
DIMENSION_ARC_LENGTH.TextOverride = TEXT
Case "acdbradialdimensionlarge"
Set DIMENSION_RADIAL_LARGE = entity
DIMENSION_RADIAL_LARGE.TextOverride = TEXT
Case "acdbdiametricdimension"
Set DIMENSION_DIAMETRIC = entity
DIMENSION_DIAMETRIC.TextOverride = TEXT
Case "acdbleader"
Set LEADER = entity
Set lobject = LEADER.Annotation
Select Case LCASE(entity.ObjectName)
Case "acdbmtext"
Set TMTEXT = entity
TMEXT.textstring = TEXT
End Select
Case "acdbattributedefinition"
Case "acdbblockreference"
Case Else
End Select
Next
End Sub
Sub show_objectname()
For Each entity In ThisDrawing.PickfirstSelectionSet
Debug.Print entity.ObjectName
Next
End Sub
LG aus Finnland
------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
[Diese Nachricht wurde von rexxitall am 30. Jun. 2013 editiert.]
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
