AutoCAD VBA 按图层进行缩放

AutoCAD二次开发，按图层进行缩放操作，代码如下。

Private Function GetLeftBottomPt(ByRef ptArr() As Variant) As Variant
Dim ptleftbottom(0 To 2) As Double
Dim i As Long
For i = 0 To UBound(ptArr)
If i = 0 Then
ptleftbottom(0) = ptArr(i)(0)
ptleftbottom(1) = ptArr(i)(1)
End If
If ptArr(i)(0) < ptleftbottom(0) Then ptleftbottom(0) = ptArr(i)(0)
If ptArr(i)(1) < ptleftbottom(1) Then ptleftbottom(1) = ptArr(i)(1)
Next i
ptleftbottom(2) = 0
GetLeftBottomPt = ptleftbottom
End Function
Private Function GetRightTopPt(ByRef ptArr() As Variant) As Variant
Dim ptRightTop(0 To 2) As Double
Dim i As Long
For i = 0 To UBound(ptArr)
If i = 0 Then
ptRightTop(0) = ptArr(i)(0)
ptRightTop(1) = ptArr(i)(1)
End If
If ptArr(i)(0) > ptRightTop(0) Then ptRightTop(0) = ptArr(i)(0)
If ptArr(i)(1) > ptRightTop(1) Then ptRightTop(1) = ptArr(i)(1)
Next i
ptRightTop(2) = 0
GetRightTopPt = ptRightTop
End Function
Private Sub LayerZoom(ByVal strLayer As String)
Dim ptarr1() As Variant
Dim ptarr2() As Variant
Dim ent As AcadEntity
Dim i As Long
Dim count As Long
count = -1
For i = 0 To ThisDrawing.ModelSpace.count - 1
Set ent = ThisDrawing.ModelSpace.Item(i)
If StrComp(ent.Layer, strLayer, vbTextCompare) = 0 Then
count = count + 1
ReDim Preserve ptarr1(count)
ReDim Preserve ptarr2(count)
ent.GetBoundingBox ptarr1(count), ptarr2(count)
End If
Next i
Dim ptleftbottom As Variant, ptRightTop As Variant
ptleftbottom = GetLeftBottomPt(ptarr1)
ptRightTop = GetRightTopPt(ptarr2)
ZoomWindow ptleftbottom, ptRightTop
End Sub
Public Sub ZoomToLayer()
Dim strLayer As String
strLayer = ThisDrawing.Utility.GetString(True, "输入图层名称：")
If HasLayer(strLayer) Then
Call LayerZoom(strLayer)
Else
ThisDrawing.Utility.Prompt "不存在指定图层！" & vbCrLf
End If
End
End Sub
Private Function HasLayer(ByVal strLayer As String) As Boolean
HasLayer = False
Dim objLayer As AcadLayer
For Each objLayer In ThisDrawing.Layers
If StrComp(objLayer.Name, strLayer, vbBinaryCompare) = 0 Then
HasLayer = True
Exit Function
End If
Next objLayer
End Function

代码完。