zoukankan      html  css  js  c++  java
  • 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

    代码完。

    作者:codee
    文章千古事,得失寸心知。


  • 相关阅读:
    webpack4笔录
    在Salesforce中进行Report和Dashboard的配置
    在Salesforce中以PDF的格式显示对应的页面
    在Salesforce中处理Email的发送
    在Visualforce page中用自带的控件实现Ajax回调后台方法(并且可以用js去动态给parameters赋值)
    javascript settimeout and setinterval
    Convert XML to Object using LINQ
    Convert Object to XML using LINQ
    JS对Array进行自定制排序
    在Salesforce中通过 Debug Log 方式 跟踪逻辑流程
  • 原文地址:https://www.cnblogs.com/bimgoo/p/2502897.html
Copyright © 2011-2022 走看看