五金模具设计之CAD二次开发VBA绘基础图形
上几节和大家介绍了如何在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绘基础图形
页:
[1]