cad一键解锁所有图层（cad解锁全部图层命令）

ExcelVBA.EDAP.通用工具之38整合多个图纸文件为一个在实际应用中暴露了一个问题，当部分图层为锁定状态时，粘贴到成品文件后无法移动，一方面无法得到预期的每行10个图纸的阵列，另一方面锁定的内容永远停留在左上角的图框范围之内，两个错误任何一个都无无法接受，因此增加批量解锁指定文件夹内CAD文件的全部图层功能，相应的安排了批量锁定图层的功能。

cad一键解锁所有图层,cad解锁全部图层命令(1)

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

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为解锁

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

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

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

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