五金模具设计之CAD二次开发VBA绘基础图形

bsirhell

上几节和大家介绍了如何在CAD中用VBA来添加图层,后面又和大家说了一下将图层绑定到指定的模板上,我想朋友们通过前面三篇文章应该知道怎样来操作一个完整的模具图层了,今天我们来尝试写一些绘基础图形的函数,比如我们常用的直线,圆,圆弧等.这些都是基础函数,如果后面要用到,直接调用该函数名就可以了!首先我们来写一个绘制直线的函数:
‘绘直线
Public Function DrawLine(Startpoint, Endpoint, Optional LayerName$ = “0″, Optional LinetypeName$ = “ByLayer”, Optional Color% = acByLayer) As AcadLine
    On Error GoTo ER
    Dim LINE1 As AcadLine
    If LinetypeExist(LinetypeName) = False Then ThisDrawing.Linetypes.Load LinetypeName, “acadiso.lin”
    Set LINE1 = ThisDrawing.ModelSpace.AddLine(Startpoint, Endpoint)
    With LINE1
         .LAYER = LayerName
         .Linetype = LinetypeName
         .Color = Color
    End With
    Set DrawLine = LINE1
    Set LINE1 = Nothing
    Exit Function
ER:
   MsgBox Err.Number & Chr(10) & Err.Description
   Err.Clear
End Function
上面的函数提供了五个参数,分别是起点,终点,图层,线型,颜色,其中起点,终点参数为必填,图层,线型,颜色参数为选填,我们知道,两点确定一条直线,如果没有填写图层,线型,颜色参数,则按默认的图层等处理,在这里默认的图层为0层,当然,你也可以设成其它的.
‘绘圆
Public Function Drawcircle(Center, Radius#, Optional LayerName$ = “0″, Optional LinetypeName$ = “ByLayer”, Optional Color% = acByLayer) As AcadCircle
    On Error GoTo ER
    Dim Cir1 As AcadCircle
    If LinetypeExist(LinetypeName) = False Then ThisDrawing.Linetypes.Load LinetypeName, “acadiso.lin”
    Set Cir1 = ThisDrawing.ModelSpace.AddCircle(Center, Radius)
    With Cir1
          .LAYER = LayerName
          .Linetype = LinetypeName
          .Color = Color
    End With
    Set Drawcircle = Cir1
    Set Cir1 = Nothing
    Exit Function
ER:
   MsgBox Err.Number & Chr(10) & Err.Description
   Err.Clear
End Function
上面的代码为绘制圆的函数.
‘绘圆弧
Public Function DrawArc(Center, Radius#, StartAngle#, EndAngle#, Optional LayerName$ = “0″, Optional LinetypeName$ = “ByLayer”, Optional Color% = acByLayer) As AcadArc
    On Error GoTo ER
    If LinetypeExist(LinetypeName) = False Then ThisDrawing.Linetypes.Load LinetypeName, “acadiso.lin”
    Dim ObjArc As AcadArc
    Set ObjArc = ThisDrawing.ModelSpace.AddArc(Center, Radius, StartAngle, EndAngle)
    With ObjArc
         .LAYER = LayerName
         .Linetype = LinetypeName
         .Color = Color
    End With
    Set DrawArc = ObjArc
    Set ObjArc = Nothing
    Exit Function
ER:
   MsgBox Err.Number & Chr(10) & Err.Description
   Err.Clear
End Function
上面的代码为绘制圆弧的函数,这里我们用的是参数为中心点,半径,起点角度,终点角度来绘制,注意上面的角度不是0-360度,具体可以看看VBA的帮助.再来看看绘制单行文字.
‘绘文字
Public Function Drawtext(Ptinsert, Objstring$, Optional Height# = 4.5, Optional LayerName$ = “0″, Optional Color% = acByLayer) As AcadText
    On Error GoTo ER
    If Len(Objstring) = 0 Then Exit Function
    Dim TEXT1 As AcadText
    Set TEXT1 = ThisDrawing.ModelSpace.AddText(Objstring, Ptinsert, Height)
    With TEXT1
         .LAYER = LayerName
         .Color = Color
    End With
    Set Drawtext = ObjText
    Set TEXT1 = Nothing
    Exit Function
ER:
    MsgBox Err.Number & Chr(10) & Err.Description & vbCr
    Err.Clear
End Function
上面的代码我们设定文字高度为4.5,你也可以改为其它的高度.
’创建矩形
Public Function AddRect(ByVal Pt1, ByVal Pt2, Optional LayerName$, Optional LinetypeName$ = “ByLayer”, Optional Color% = 256) As AcadLWPolyline
  On Error GoTo ER
    If LayerName = “” Then LayerName = ThisDrawing.ActiveLayer.Name
    If LinetypeExist(LinetypeName) = False Then ThisDrawing.Linetypes.Load LinetypeName, “acadiso.lin”
    Dim ptarr(7) As Double
     ‘错误处理
    If Pt1(0) = Pt2(0) Or Pt1(1) = Pt2(1) Then
          MsgBox “您所输入的对角点在同一直线上，无法创建矩形！”
          Exit Function
    End If
    ptarr(0) = MinDouble(Pt1(0), Pt2(0)): ptarr(1) = MaxDouble(Pt1(1), Pt2(1))
    ptarr(2) = MinDouble(Pt1(0), Pt2(0)): ptarr(3) = MinDouble(Pt1(1), Pt2(1))
    ptarr(4) = MaxDouble(Pt1(0), Pt2(0)): ptarr(5) = MinDouble(Pt1(1), Pt2(1))
    ptarr(6) = MaxDouble(Pt1(0), Pt2(0)): ptarr(7) = MaxDouble(Pt1(1), Pt2(1))
    Set ObjPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptarr)
    With ObjPline
          .Closed = True
          .LAYER = LayerName
          .Linetype = LinetypeName
          .Color = Color
    End With
    Set AddRect = ObjPline
    Set ObjPline = Nothing
    Exit Function
ER:
   MsgBox Err.Number & Chr(10) & Err.Description
   Err.Clear
End Function
上面是绘矩形的代码.好了,今天就说到这里,我们可以在当前的object下面添加一个命名为函数,以后要用时直接输入函数名来调用就好了,例如绘直线就这样call DrawLine pt1,pt2,当然pt1,pt2在这里我们给它加入具体的数值.
转载请注明文章转载自：网络资源 [http://www.makehao.com]
本文链接地址：五金模具设计之CAD二次开发VBA绘基础图形