|
|
发表于 2009-9-1 23:02:00
|
显示全部楼层
这个是我用vb 编写的程序的完整代码，套用了版主的一些代码，呵呵，初学乍练，请大家拍砖帮助修改。
Public AcadApp As AcadApplication
'Public oDocument As Object
Dim centerPoint(0 To 2) As Double
Public Function axEnt2lspEnt(entObj As AcadEntity) As String
Dim entHandle As String
entHandle = entObj.Handle
axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function
Public Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String
Dim entHandle As String
entHandle = entObj.Handle
GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & ")(list " & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & "))"
End Function
Private Sub Command1_Click()
''''''''''''''''''''''''''''''''''''''''''''''''''''Addarc
Dim arcNxObj As Object
Dim arcNsObj As Object
Dim radiusARCNx As Double
Dim startAngleInDegreeN As Double
Dim endAngleInDegreeN As Double
Dim startAngleInRadianN As Double
Dim endAngleInRadianN As Double
radiusARCNx = 15#
startAngleInDegreeN = 0#
endAngleInDegreeN = 45#
startAngleInRadianN = startAngleInDegreeN * 3.141592 / 180#
endAngleInRadianN = endAngleInDegreeN * 3.141592 / 180#
Set arcNxObj = AcadApp.ActiveDocument.ModelSpace.AddArc(centerPoint, radiusARCNx, startAngleInRadianN, endAngleInRadianN)
Dim arcNs As Object
Dim radiusARCNs As Double
radiusARCNs = 25#
Set arcNsObj = AcadApp.ActiveDocument.ModelSpace.AddArc(centerPoint, radiusARCNs, startAngleInRadianN, endAngleInRadianN)
Dim endPointNx As Variant
Dim startPointNx As Variant
Dim endPointNs As Variant
Dim startPointNs As Variant
arcNsObj.Color = acRed
startPointNx = arcNxObj.StartPoint
endPointNx = arcNxObj.EndPoint
endPointNs = arcNsObj.EndPoint
startPointNs = arcNsObj.StartPoint
Dim lineObj1 As Object
Dim lineobj2 As Object
Set lineObj1 = AcadApp.ActiveDocument.ModelSpace.AddLine(startPointNx, startPointNs)
Set lineobj2 = AcadApp.ActiveDocument.ModelSpace.AddLine(endPointNx, endPointNs)
ZoomExtents
'''''''''''''''''''''''想实现fillet 直线与圆弧的圆角功能
Dim Pnt1 As Variant
Dim det1 As String
det1 = axEnt2lspEnt(lineObj1)
Dim Pnt2 As Variant
Dim det2 As String
det2 = GetDoubleEntTable(arcNsObj, startPointNs)
AcadApp.ActiveDocument.SendCommand "_fillet" & vbCr & "r" & vbCr & "2" & vbCr & "t" & vbCr & "t" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr
'AcadApp.Quit
'Set oDocument = Nothing
'Set AcadApp = Nothing
End Sub
Private Sub Form_Load()
On Error Resume Next
Set acadpp = GetObject(, "AutoCAD.application")
If Err Then
Err.Clear
Set AcadApp = CreateObject("AutoCAD.application")
If Err Then
MsgBox ("不能运行autocad2004，请检查")
Exit Sub
End If
End If
AcadApp.Visible = True
'Set oDocument = AcadApp.ActiveDocument
'AcadApp.ActiveDocument.ActiveViewport.GridOn = True
'AcadApp.ActiveDocument.ActiveViewport = AcadApp.ActiveDocument.ActiveViewport
End Sub
|
|
置顶卡
