CAD批量替换块（批量替换外图框）——CADc#(vba)插件实现

 如下图所示：文件夹内大量dwg图，统一把外图框替换为新的模板图框，可使用如下插件一键替换。

根据上图演示效果，处理14个文件用时13秒，平均不到1秒替换一个dwg文件的块。

使用说明：c#开发的dll插件，（特点：速度快，不用逐一打开待替换的DWG文件即可完成，支持普通块、属性块、含有属性字段的块，所有模型空间和图纸空间符合要求的块全部一键替换。）
1.打开包含新块的一个DWG图，命令行输入“netload”加载此dll插件后，输入“ kthzs ”运行此程序。
2.此插件要求新块基点位于新块最小矩形包围盒的左下角点，，否则会出现图形移位情况。
3.支持替换属性块和普通块，同时支持模型空间和多个图纸空间，一键替换所有块。

目前版本已升级到V5.5

 

以下为vba插件（特点为适用各种CAD版本，需逐一打开待替换的DWG文件）

使用方法：

第一步：
复制“XK新块.dwg”和 “替换块.dvb” 两个文件，
粘贴到需处理的cad图所在文件夹。
第二步：
打开“XK新块.dwg”（不用打开其他cad图），加载“替换块.dvb” 插件，运行即可。
（管理—>加载应用程序—>始终加载 —>运行vba宏 —>运行）

说明：插件会在cad原始图目录下新建一个“替换块”的文件夹，
新生成的cad图保存在这个文件夹中。
运行结束后关闭“XK新块.dwg”，
切记不保存此文件（不要修改此文件，否则可能影响下次使用）。
此插件要求cad原始图中所有图的图框大小相同。

附部分代码：

Sub 替换块各种尺寸()
'打开模板dwg文件，运行此插件
On Error Resume Next
Dim counter As Integer
counter = 0 '计数器，记录替换的文字数量
Dim fileName As String
Dim acadDoc As AcadDocument
Dim pt_one As Variant
Dim pt_two As Variant
Dim pt_one_old As Variant
Dim pt_two_old As Variant
Dim olddisx As Double
Dim olddisy As Double
Dim disx As Double
Dim disy As Double
Dim ent As AcadEntity
Dim str As String
Dim ptbase(2) As Double: ptbase(0) = 0: ptbase(1) = 0: ptbase(2) = 0:
Dim newblock As AcadBlock
Dim newblockname As String
Dim entb As AcadBlock
pt_one_old = ThisDrawing.GetVariable("extmin")
pt_two_old = ThisDrawing.GetVariable("extmax")
olddisx = pt_two_old(0) - pt_one_old(0)
olddisy = pt_two_old(1) - pt_one_old(1)
newblockname = "xk新块"
lj = ThisDrawing.path
Dim folderPath As String '新建个文件夹
folderPath = lj & "\替换块"
If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
        'MsgBox "文件夹 '更新块' 已成功创建在当前路径下。", vbInformation
End If
ljwj = Dir(lj & "\*.dwg")
zong = ThisDrawing.Name
fileName = Dir(lj & "\*.dwg")  '获取文件夹中的DWG文件
Set blockdoc = ActiveDocument '创建选择集，复制新块
Do While blockdoc.SelectionSets.Count > 0
     blockdoc.SelectionSets.Item(0).Delete
Loop
Set sel = blockdoc.SelectionSets.Add("mysel")
sel.Select acSelectionSetAll
If sel.Count > 0 Then
    Dim arr() As Object
    ReDim arr(sel.Count - 1)
    Dim newarr() As Object
    ReDim newarr(sel.Count - 1)
    For I = 0 To sel.Count - 1
       Set arr(I) = sel.Item(I)
    Next I
End If
Do While ljwj <> ""
    If ljwj <> zong Then
        Set acadDoc = Documents.Open(lj & "\" & ljwj)
        Set acadDoc = ActiveDocument
        pt_one = acadDoc.GetVariable("extmin")
        pt_two = acadDoc.GetVariable("extmax")
        disx = pt_two(0) - pt_one(0)
        disy = pt_two(1) - pt_one(1)
        For Each ent In acadDoc.ModelSpace '删除旧图框
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''省略部分代码
'''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        acadDoc.Close False
    End If
    ljwj = Dir()
Loop
MsgBox "共替换了 " & counter & " 个块,文件另存于： " & folderPath & Space(20) & vbCr
End Sub

另有版本二：针对不同图框大小，各种尺寸.dvb插件可实现自动缩放图框模版并插入到当前图。
作者：↓↓↓