cad怎么解组快捷键(cad解锁所有图层)

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