Zum Umbenennen von Blöcken habe ich mir mal vor langer Zeit soetwas ausgedacht. Block anklicken editieren fertig.
Es zeigt wie man blockdefinitionen mit VBA umbenennt.
Mag hilfreich sein wenn nach der Excel Tabelle nocheinmal etwas ausgebessert werden muss.
lg
Thomas
Sub block_definition_rename()
Dim fileName As String
Dim oBlkRef As AcadBlockReference
Dim oEnt As AcadEntity, oBlock As AcadBlock
Dim varPt
Dim insVpt, insPt(2) As Double
Dim BNAME As String
Dim i As Long, j As Long, idpairs As Long
Dim expObjs As Variant
Dim objSelSet As AcadSelectionSet
Dim objTarget As AcadDocument
Dim currentdrawing As AcadDocument
Set currentdrawing = ThisDrawing
'Dim documents As AcadDocuments
Dim document As AcadDocument
Dim objOrgEnts() As Object
Dim destEnts As Variant
Dim intCnt As Long
Dim blo As AcadBlock
Dim strFullDef As String
Dim objBlock As AcadBlock
Dim objBlock1 As AcadBlock
Dim colBlocks As AcadBlocks
Dim objArray(0) As Object
Dim oldname As String
ThisDrawing.SetVariable "DELOBJ", 1
On Error Resume Next
Err.Clear
ThisDrawing.UTILITY.GetEntity oEnt, varPt, "Select block: "
If Err.number <> 0 Then
On Error GoTo 0
Exit Sub
End If
If TypeOf oEnt Is AcadBlockReference Then
Set oBlkRef = oEnt
oldname = oBlkRef.EffectiveName
BNAME = oBlkRef.EffectiveName & "_" & i
BNAME = InputBox("New block name is: ", "BLOCKRENAM", BNAME)
insVpt = oBlkRef.insertionPoint
For j = 0 To UBound(insVpt)
insPt(j) = insVpt(j)
Next
For Each oBlock In ThisDrawing.BLOCKS
If oBlock.Name = BNAME Then
MsgBox "Block " & BNAME & " does already exist"
Exit Sub
End If
Next
Set colBlocks = ThisDrawing.BLOCKS
Set objBlock = colBlocks.ITEM(oldname)
objBlock.Name = BNAME
End If
Err_Control:
If Err.number = 0 Then
MsgBox "Done"
Else
MsgBox Err.Description
End If
End Sub
------------------
Wer es nicht versucht, hat schon verlorn
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP