ExcelVBA.EDAP.通用工具之38整合多个图纸文件为一个在实际应用中暴露了一个问题，当部分图层为锁定状态时，粘贴到成品文件后无法移动，一方面无法得到预期的每行10个图纸的阵列，另一方面锁定的内容永远停留在左上角的图框范围之内，两个错误任何一个都无无法接受，因此增加批量解锁指定文件夹内CAD文件的全部图层功能，相应的安排了批量锁定图层的功能。
PS：C04-批量合并多张图纸也做了相应更新，合并前默认执行解锁操作，无需额外操作C02按钮。
应读者要求，分享代码如下
————————————————————————————————————————
Sub Dingmurch01SU_8911ACAD_ACAD2019_02Layerlock()
‘【B对应功能】
‘【C调试时间】
‘【D简单描述】
‘0变量定义
Dim ttNo As Integer
Dim rateratE As Integer
Dim ACADDWG_obj As AcadEntity
Dim Mylayer As acadlayer
‘1变量初始化
rateratE=1
ttNo=0
”2读取cad文件清单
Dingmurch02FU_8001_RTbySelect
Dingmurch02FU_8013_FileList 0, 1, 0
”3针对每一个cad文件循环操作
‘3.1对象初始化
On Error Resume Next
Set acadApp=GetObject(, “autocad.application”)
If Err Then
Err.Clear
Set acadApp=CreateObject(“autocad.application”)
End If
acadApp.Visible=True ‘False ‘
‘3.2待处理图纸计数
For W=0 To UBound(Dingmurch10PB_04ARR_FILEARR) – 1
If Right(Dingmurch10PB_04ARR_FILEARR(W), 4)=“.DWG” Or Right(Dingmurch10PB_04ARR_FILEARR(W), 4)=“.DWG” Then ttNo=ttNo + 1
Next
MsgBox ttNo & “个文件待处理”
‘3.处理
For W=0 To UBound(Dingmurch10PB_04ARR_FILEARR) – 1
If (Right(Dingmurch10PB_04ARR_FILEARR(W), 4)=“.dwg” Or Right(Dingmurch10PB_04ARR_FILEARR(W), 4)=“.DWG”) Then
‘3.1打开对象处理
Set acaddwgnow=acadApp.Documents.Open(Dingmurch10PB_06RT_NAME & “\\\\” & Dingmurch10PB_04ARR_FILEARR(W))
For Each Mylayer In acaddwgnow.Layers
Mylayer.Lock=True ‘此处true为锁定，false为解锁
Next
acaddwgnow.Save
acaddwgnow.Close
‘3.2展示进度
Dingmurch02FU_1002_processrate rateratE, 0, ttNo, 0, 0, 100, 0, 100, 0, 100, 1, 1, “ACAD2019_02Layerlock” & Dingmurch10PB_04ARR_FILEARR(W)
DoEvents
rateratE=rateratE + 1
End If
Next
MsgBox “操作完成!”
Set ACADDWG_obj=Nothing
acadApp.Quit
Set acadApp=Nothing
Unload Wecho03FM_01
End Sub
—————————————————————————————————————————————-
Sub Dingmurch01SU_8911ACAD_ACAD2019_04DWGtoOne()
‘【B对应功能】
‘【C调试时间】
‘【D简单描述】
‘0变量定义
Dim ttNo As Integer
Dim rateratE As Integer
Dim Mylayer As acadlayer
Dim ACADDWG_obj As AcadEntity
Dim FPoint(0 To 2) As Double
Dim TPoint(0 To 2) As Double
FPoint(0)=0: FPoint(1)=0: FPoint(2)=0
‘1变量初始化
rateratE=1
ttNo=0
”2读取cad文件清单
Dingmurch02FU_8001_RTbySelect
Dingmurch02FU_8013_FileList 0, 1, 0
”3针对每一个cad文件循环操作
‘3.1对象初始化
On Error Resume Next
Set acadApp=GetObject(, “autocad.application”)
If Err Then
Err.Clear
Set acadApp=CreateObject(“autocad.application”)
End If
acadApp.Visible=False
‘3.2待处理图纸计数
For W=0 To UBound(Dingmurch10PB_04ARR_FILEARR) – 1
If Right(Dingmurch10PB_04ARR_FILEARR(W), 4)=“.dwg” Or Right(Dingmurch10PB_04ARR_FILEARR(W), 4)=“.DWG” Then ttNo=ttNo + 1
Next
ttNo=ttNo – 1
MsgBox ttNo & “个文件待合并”
SC=InputBox(“请输入图纸比例”, “1：1，1：10，1：100，输入冒号之后的数值”, “”)
‘3.3打开ALL.dwg
Set acaddwgall=acadApp.Documents.Open(Dingmurch10PB_06RT_NAME & “\\\\” & “成品.dwg”)
‘3.4处理其它文件
T1=Timer
xxx=0
yyy=0
For W=0 To UBound(Dingmurch10PB_04ARR_FILEARR) – 1
If (Right(Dingmurch10PB_04ARR_FILEARR(W), 4)=“.dwg” Or Right(Dingmurch10PB_04ARR_FILEARR(W), 4)=“.DWG”) And Dingmurch10PB_04ARR_FILEARR(W) < “成品.dwg” Then
‘3.4.1打开对象表格，统计对象数量并添加到选择集
‘MsgBox “OPEN ” & Dingmurch10PB_04ARR_FILEARR(W)
Set acaddwgnow=acadApp.Documents.Open(Dingmurch10PB_06RT_NAME & “\\\\” & Dingmurch10PB_04ARR_FILEARR(W))
For Each Mylayer In acaddwgnow.Layers
Mylayer.Lock=False
Next
Dim SSSS As AcadSelectionSet
Set SSSS=acaddwgnow.SelectionSets.Add(“T1”)
SSSS.Select (acSelectionSetAll)
k=SSSS.Count
”MsgBox k
ReDim objCollection(0 To k – 1) As Object
l=0
For Each zzzz In SSSS
Set objCollection(l)=zzzz
l=l + 1
Next
‘3.4.2打开成品
‘MsgBox “MOVE ” & “成品.dwg”
acaddwgall.Activate
On Error Resume Next
retObjects=acaddwgnow.CopyObjects(objCollection, acaddwgall.ModelSpace)
TPoint(0)=xxx: TPoint(1)=yyy: TPoint(2)=0
If xxx < 500 * 9 * SC Then
xxx=xxx + 500 * SC
ElseIf xxx=500 * 9 * SC Then
xxx=0
yyy=yyy – 300 * SC
End If
For Each MMMM In retObjects
MMMM.Move FPoint, TPoint
Next
‘3.4.3关闭对象
‘MsgBox “Close ” & Dingmurch10PB_04ARR_FILEARR(W)
acaddwgnow.Close
‘3.4.4保存成品
‘acaddwgall.Save
ZoomExtents
‘3.4.5展示进度
Dingmurch02FU_1002_processrate rateratE, 0, ttNo, 0, 0, 100, 0, 100, 0, 100, 1, 1, “ACAD2019_04DWGtoOne” & Dingmurch10PB_04ARR_FILEARR(W)
DoEvents
rateratE=rateratE + 1
End If
Next
acaddwgall.Save
ZoomExtents
T2=Timer – T1
MsgBox “操作完成!” & “耗时” & Format(T2, “0.000”) & “秒”
acadApp.Visible=True
acadApp.WindowState=acMax
Set ACADDWG_obj=Nothing
‘acadApp.Quit
‘Set acadApp=Nothing
Unload Wecho03FM_01
End Sub