五金模具设计之AUTOCAD二次开发VBA篇

bsirhell

做冲压模具设计的,大部分或多或少会用到一些外挂,比如有名的pressCAD,我想可能还有不少人依然在用,的确,presscad还是一个很不错的设计外挂,其实如果你懂一点LISP或者是VBA,你就可以打造一个属于你自已的外挂,LISP的话,我不是很通,这里我来说说VBA吧.
模具设计时,我们一般会要分层,上夹板一个层,上脱板一个层,我们先来看一下一些图层函数:
Option Explicit
Dim objPreLayer As AcadLayer
‘建新图层并为当前层（OK）
Public Function CreatLayer(ByVal LayerName As String, Optional Color% = acByLayer) As AcadLayer
     On Error GoTo errput
     Dim ObjLayer As AcadLayer
     If LayerExist(LayerName) = False Then
         Set ObjLayer = ThisDrawing.Layers.Add(LayerName)
         ObjLayer.Color = Color
     Else
         Set ObjLayer = ThisDrawing.Layers.Item(LayerName)
         ObjLayer.Color = Color
     End If
     ThisDrawing.ActiveLayer = ObjLayer
     Set CreatLayer = ObjLayer
     Exit Function
errput:
     MsgBox “Layer.CreatLayer发生错误!” & vbCr & Err.Number & Err.Description
     Err.Clear
End Function
‘图层
Public Function LayerExist(ByVal LayerName As String) As Boolean
LayerExist = False
    Dim ObjLayer As AcadLayer
    For Each ObjLayer In ThisDrawing.Layers
        If StrComp(ObjLayer.Name, LayerName, vbBinaryCompare) = 0 Then
            LayerExist = True
            Exit Function
        End If
    Next ObjLayer
End Function
Sub Cmdcloseother()
    Dim STR As String
    STR = ThisDrawing.Utility.GetString(1, “请输入图层名：”)
    If LayerExist(STR) = False Then Exit Sub
    onelayer (UCase(STR))
End Sub
Sub cmdSetCur()
   On Error GoTo ErrHandle
    Dim objDest As AcadEntity
    Dim ptBase As Variant
    ThisDrawing.Utility.GetEntity objDest, ptBase, “选择目标图层中的实体:”
    Set objPreLayer = ThisDrawing.Layers.Item(objDest.LAYER)
    ThisDrawing.ActiveLayer = objPreLayer
    Exit Sub
ErrHandle:
    Err.Clear
End Sub
Sub cmdonly()
   On Error GoTo ErrHandle
    Dim objDest As AcadEntity
    Dim ptBase As Variant
    Dim ObjLayer As AcadLayer
    ThisDrawing.Utility.GetEntity objDest, ptBase, “选择单开图层中的实体:”
    Set objPreLayer = ThisDrawing.Layers.Item(objDest.LAYER)
    For Each ObjLayer In ThisDrawing.Layers
        If ObjLayer.Name <> objPreLayer.Name Then
           ObjLayer.layeron = False
        End If
    Next
    Exit Sub
ErrHandle:
    Err.Clear
End Sub
‘关闭图层
Sub cmdClose()
   On Error GoTo ErrHandle
    Dim objDest As AcadEntity
    Dim ptBase As Variant
    ThisDrawing.Utility.GetEntity objDest, ptBase, “选择所要关闭图层中的实体:”
    Set objPreLayer = ThisDrawing.Layers.Item(objDest.LAYER)
    objPreLayer.layeron = False
    Exit Sub
ErrHandle:
    Err.Clear
End Sub
Sub cmdMerge()
    On Error GoTo ErrHandle
    ‘获得被合并的图层名称
    Dim sourceLayer As String
    Dim objSource As AcadEntity
    Dim ptBase As Variant
    ThisDrawing.Utility.GetEntity objSource, ptBase, “选择被合并的图层中的对象:”
    sourceLayer = objSource.LAYER
    ‘获得合并到的图层名称
    Dim destLayer As String
    Dim objDest As AcadEntity
    ThisDrawing.Utility.GetEntity objDest, ptBase, “选择合并到的图层中的对象:”
    destLayer = objDest.LAYER
    ‘转换所要合并的图层中的实体到目标图层
    Dim objent As AcadEntity
    For Each objent In ThisDrawing.ModelSpace
        If objent.LAYER = sourceLayer Then
            objent.LAYER = destLayer
        End If
    Next objent
   
    ‘删除被合并的图层
    Dim ObjLayer As AcadLayer
    Set ObjLayer = ThisDrawing.Layers.Item(sourceLayer)
    ObjLayer.Delete
   
    Exit Sub
   
ErrHandle:
    Err.Clear
    MsgBox “该图层不能被删除！”, vbCritical
End Sub
Sub cmdOpenPre()
    If objPreLayer Is Nothing Then
        MsgBox “无关闭图层的历史记录！”, vbCritical
    Else
        objPreLayer.layeron = True
        ThisDrawing.Regen acActiveViewport
    End If
End Sub
‘删除图层
Sub deletelayer()
On Error GoTo errput
   Dim PT As Variant
   Dim ent As AcadEntity
   ThisDrawing.Utility.GetEntity ent, PT, “选择要删除图层中的对象:”
   Call DelLayer(ent.LAYER)
Exit Sub

errput:
If Err.Number = -2147352567 Then
      Err.Clear: Exit Sub
   Else
      ThisDrawing.Utility.Prompt “运行过程发生如下错误” & vbCr & Err.Number & Err.Description & vbCrLf
      Err.Clear
      Exit Sub
   End If
End Sub
‘建新图层并为当前层（OK）
Public Function greatlayer(ByVal LayerName As String) As AcadLayer
On Error GoTo errput
Dim ObjLayer As AcadLayer
If LayerExist(LayerName) = False Then
Set ObjLayer = ThisDrawing.Layers.Add(LayerName)
Else
Set ObjLayer = ThisDrawing.Layers.Item(LayerName)
End If
ThisDrawing.ActiveLayer = ObjLayer
Set greatlayer = ObjLayer
Exit Function
errput:
MsgBox “运行过程发生如下错误” & vbCr & Err.Number & Err.Description
Err.Clear
End Function
由以上这些函数我们就可以轻易地创建我们的模板了!
文章字数有限制,请去原网站查看.转载请注明文章转载自：网络资源 [http://www.makehao.com]
本文链接地址：五金模具设计之AUTOCAD二次开发VBA篇

bsirhell

自已顶一个!