ExcelVBA.EDAP.通用工具之38整合多个图纸文件为一个在实际应用中暴露了一个问题，当部分图层为锁定状态时，粘贴到成品文件后无法移动，一方面无法得到预期的每行10个图纸的阵列，另一方面锁定的内容永远停留在左上角的图框范围之内，两个错误任何一个都无无法接受，因此增加批量解锁指定文件夹内CAD文件的全部图层功能，相应的安排了批量锁定图层的功能。
PS：C04-批量合并多张图纸也做了相应更新，合并前默认执行解锁操作，无需额外操作C02按钮。
应读者要求，分享代码如下
ps图层锁定解不开，------------------------------------------------------------------------------------------------------------------------
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
&39;2读取cad文件清单
Dingmurch02FU_8001_RTbySelect
Dingmurch02FU_8013_FileList 0，1，0
&39;3针对每一个cad文件循环操作
'3.1对象初始化
On Error Resume Next
Set acadApp = GetObject(，&34;)
If Err Then
Err.Clear
Set acadApp = CreateObject(&34;)
End If
acadApp.Visible = True &39;
'3.2待处理图纸计数
For W = 0 To UBound(Dingmurch10PB_04ARR_FILEARR) - 1
If Right(Dingmurch10PB_04ARR_FILEARR(W)，4) = &34; Or Right(Dingmurch10PB_04ARR_FILEARR(W)，4) = &34; Then ttNo = ttNo + 1
Next
MsgBox ttNo & &34;
'3.处理
For W = 0 To UBound(Dingmurch10PB_04ARR_FILEARR) - 1
If (Right(Dingmurch10PB_04ARR_FILEARR(W)，4) = &34; Or Right(Dingmurch10PB_04ARR_FILEARR(W)，4) = &34;) Then
'3.1打开对象处理
Set acaddwgnow = acadApp.Documents.Open(Dingmurch10PB_06RT_NAME & &34; & 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，&34; & Dingmurch10PB_04ARR_FILEARR(W)
DoEvents
rateratE = rateratE + 1
ps中锁定和解锁图层的步骤如下：1.打开软件。2.新建文件。3.新建图层。4.选中图层。5.点击按钮，锁定选中图层。6.锁定图层以后会有小锁头标志需要解锁的话点击它就行了。这样就解决了ps中锁定和解锁图层的问题了。
End If
Next
MsgBox &34;
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
&39;2读取cad文件清单
Dingmurch02FU_8001_RTbySelect
Dingmurch02FU_8013_FileList 0，1，0
&39;3针对每一个cad文件循环操作
'3.1对象初始化
1.选中该图层，将图层上的锁头图标拖动到垃圾桶里，也可以解锁图层；2.如果图层被父图层锁定，组1这个文件夹被加了锁；那么这个组1中的文件也会被加锁，但是是透明的；3.接下来选择组1这个文件夹，然后用上面1，
On Error Resume Next
Set acadApp = GetObject(，&34;)
If Err Then
Err.Clear
Set acadApp = CreateObject(&34;)
End If
acadApp.Visible = False
'3.2待处理图纸计数
If Right(Dingmurch10PB_04ARR_FILEARR(W)，4) = &34; Or Right(Dingmurch10PB_04ARR_FILEARR(W)，4) = &34; Then ttNo = ttNo + 1
Next
ttNo = ttNo - 1
MsgBox ttNo & &34;
SC = InputBox(&34;，&34;，&34;)
'3.3打开ALL.dwg
Set acaddwgall = acadApp.Documents.Open(Dingmurch10PB_06RT_NAME & &34; & &34;)
1、首先打开ps软件，新建一个图层，新建图层之后，往往会看到图层有个锁的，双击鼠标左键。2、双击之后，就会出现下图所示，点击确认即可。3、下面来介绍下，如何给图层上锁，新建一个图层，点击图层面板上面的“锁”，给图。
'3.4处理其它文件
T1 = Timer
xxx = 0
yyy = 0
For W = 0 To UBound(Dingmurch10PB_04ARR_FILEARR) - 1
If (Right(Dingmurch10PB_04ARR_FILEARR(W)，4) = &34; Or Right(Dingmurch10PB_04ARR_FILEARR(W)，4) = &34;) And Dingmurch10PB_04ARR_FILEARR(W) <> &34; Then
'3.4.1打开对象表格，统计对象数量并添加到选择集
&34;OPEN " & Dingmurch10PB_04ARR_FILEARR(W)
For Each Mylayer In acaddwgnow.Layers
Mylayer.Lock = False
Next
Dim SSSS As AcadSelectionSet
Set SSSS = acaddwgnow.SelectionSets.Add(&34;)
SSSS.Select (acSelectionSetAll)
k = SSSS.Count
&39;MsgBox k
ReDim objCollection(0 To k - 1) As Object
l = 0
1、锁定图层 ps软件中，选择图层之后，点击上方加锁的图标，图层就会被锁定。2、点击加锁图标 被锁定的图层右侧会有锁的图标，点击这个锁的图标。3、解锁图层 选择的图层就可以解锁了。
For Each zzzz In SSSS
Set objCollection(l) = zzzz
l = l + 1
Next
'3.4.2打开成品
&34;MOVE &34;成品.dwg"
解锁时按住键盘上的快捷键Ctrl+Alt+2，可解锁全部图层。，图层前面圈出来的部位没有锁头标志，就代表已经全部解锁了，这样，图形上的所有文件就都可以选择编辑了。
acaddwgall.Activate
On Error Resume Next
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关闭对象
&34;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，&34; & Dingmurch10PB_04ARR_FILEARR(W)
DoEvents
rateratE = rateratE + 1
End If
Next
acaddwgall.Save
ZoomExtents
T2 = Timer - T1
MsgBox &34; & &34; & Format(T2，&34;) & &34;
acadApp.Visible = True
acadApp.WindowState = acMax
Set ACADDWG_obj = Nothing
'acadApp.Quit
'Set acadApp = Nothing
Unload Wecho03FM_01
End Sub
