[原创]功能函数返回数组变量数组--执行pline
本帖最后由 作者 于 2008-3-17 11:49:48 编辑此图形是HG20595的一个剖面图形。解决方法是用ADO+数组+poyline方法安成。
程序如下：Option Explicit
Const Pi = 3.14159265358979
Dim adoCon As New ADODB.Connection
' 功能：打开指定的数据库（在frmConnectDB中指定）
' 输入：无
' 调用：无
' 返回：如果完成连接，返回True；否则返回False
' 示例：
' OpenDB
Public Function OpenDB(InputDataBaseName) As Boolean
OpenDB = True
' 如果数据库已打开，不执行任何操作
If adoCon.State <> 0 Then Exit Function
adoCon.CursorLocation = adUseClient
' 获得数据库文件的位置
Dim strDbName As String
Dim strProject As String
strProject = Left(ThisDrawing.Application.VBE.activevbProject.FileName, _
Len(ThisDrawing.Application.VBE.activevbProject.FileName) - 19)
strDbName = strProject & "\mdb\" & InputDataBaseName & ".mdb"
adoCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
strDbName & ";"
End Function
' 功能：关闭指定的数据库（在frmConnectDB中指定）
' 输入：无
' 调用：无
' 返回：如果数据库处于打开状态，就关闭它
' 示例：
' CloseDB
Public Function CloseDB()
If adoCon.State <> 0 Then
adoCon.Close
End If
End Function
Function HG20595T_Data_Preparation() As Double()
Dim d1, f2, x, w, c, n1, n, h, k, h1, d, l, PipeOutDiameter, PipeDelta, a1, rr, i, ScheduleWall, SeriesNo
Dim HG20595(12, 3) As Double
'
Dim startpoint(0 To 2) As Double
Dim endpoint(0 To 2) As Double
'
'面域
Dim curves(0 To 12) As AcadEntity
Dim regionObj As Variant
'旋转实体
Dim axisPt(0 To 2) As Double
Dim axisDir(0 To 2) As Double
Dim angle As Double
'开孔
Dim cylinderObj As Acad3DSolid
Dim radius As Double
Dim center(0 To 2) As Double
Dim height As Double
height = 500
axisPt(0) = 0: axisPt(1) = 0: axisPt(2) = 0
axisDir(0) = 0: axisDir(1) = 0: axisDir(2) = 1
angle = Pi * 2 + 0.2
Dim solidObj As Acad3DSolid
Dim Sep_N, Pn As String, Dn As String, SearchCondition
Pn = 6.3: Dn = 350
Select Case Pn
Case 1#, 10#, 16#, 25#
SearchCondition = Dn & "-" & Trim(Str(Pn) + ".0")
Case Else
SearchCondition = Dn & "-" & Trim(Str(Pn))
End Select
'
''
OpenDB ("HG20592")
'
Dim rst As New ADODB.Recordset
Dim Sql As String, ii As Integer
Sql = "select c.*,a.*,b.* from 带颈对焊法兰as A,凹凸榫槽密封面 as b ,法兰规格 as c Where " & _
" c.法兰规格 = '" & SearchCondition & "' and c.法兰规格 = a.法兰规格 and c.法兰规格 = b.法兰规格"
rst.Open Sql, adoCon, adOpenDynamic, adLockOptimistic
''
ScheduleWall = 12: SeriesNo = "B"
' d1 = rst.Fields("突台外径d"):
f2 = rst.Fields("台高f2"):
x = rst.Fields("凸面外径X"):
w = rst.Fields("榫面内径W")
'''
c = rst.Fields("WN法兰厚度C")'
Select Case SeriesNo
Case "A"
n1 = rst.Fields("WN法兰颈径NA")
PipeOutDiameter = rst.Fields("钢管外径A")
Case "B"
n1 = rst.Fields("WN法兰颈径NB")
PipeOutDiameter = rst.Fields("钢管外径B")
End Select
n = rst.Fields("螺栓数量") 'xxlSheet.cells(ii, 16).Value
h = rst.Fields("WN法兰高度H")'xxlSheet.cells(ii, 10).Value
k = rst.Fields("螺栓孔中心圆直径")'xxlSheet.cells(ii, 13).Value
h1 = rst.Fields("WN焊端长度h")
d = rst.Fields("法兰外径D")'xxlSheet.cells(ii, 12).Value
l = rst.Fields("螺栓孔直径")'xxlSheet.cells(ii, 14).Value
PipeDelta = ScheduleWall
a1 = PipeOutDiameter
rr = rst.Fields("WN圆角半径R")
CloseDB
' HG20595法兰实体赋值
ThisDrawing.SendCommand "_fillet" + Chr(10) + "r" & Chr(10) & rr & Chr(10) & Chr(10)
HG20595(1, 1) = (PipeOutDiameter - 2 * PipeDelta) / 2: HG20595(1, 2) = -f2: HG20595(1, 3) = 0
HG20595(2, 1) = w / 2: HG20595(2, 2) = -f2: HG20595(2, 3) = 0
HG20595(3, 1) = w / 2: HG20595(3, 2) = 0: HG20595(3, 3) = 0
HG20595(4, 1) = x / 2: HG20595(4, 2) = 0: HG20595(4, 3) = 0
HG20595(5, 1) = x / 2: HG20595(5, 2) = -f2: HG20595(5, 3) = 0
HG20595(6, 1) = d / 2: HG20595(6, 2) = -f2: HG20595(6, 3) = 0
HG20595(7, 1) = d / 2: HG20595(7, 2) = -c: HG20595(7, 3) = 0
HG20595(8, 1) = n1 / 2: HG20595(8, 2) = -c: HG20595(8, 3) = 0
HG20595(9, 1) = a1 / 2: HG20595(9, 2) = h1 - h: HG20595(9, 3) = 0
HG20595(10, 1) = a1 / 2: HG20595(10, 2) = -h: HG20595(10, 3) = 0
HG20595(11, 1) = (PipeOutDiameter - 2 * PipeDelta) / 2: HG20595(11, 2) = -h: HG20595(11, 3) = 0
HG20595(12, 1) = (PipeOutDiameter - 2 * PipeDelta) / 2: HG20595(12, 2) = -f2: HG20595(12, 3) = 0
HG20595T_Data_Preparation = HG20595
End Function
Sub lss()
Dim AA() As Double, bb() As Double, ii, jj, nn
Debug.Print TypeName(HG20595T_Data_Preparation)
AA = HG20595T_Data_Preparation
ReDim bb(UBound(AA) * 3 - 1) As Double
Debug.Print UBound(bb)
For ii = 1 To UBound(AA)
For jj = 1 To 3
bb(nn) = AA(ii, jj)
nn = nn + 1
Next jj
Next ii
Dim ppl As AcadPolyline
Set ppl = ThisDrawing.ModelSpace.AddPolyline(bb)
End Sub
type ---- type end方法Option Explicit
Const Pi = 3.14159265358979
Dim adoCon As New ADODB.Connection
Private Type HG20595InitialData
HG20595 As Variant '(12, 3) As Double
n As Double
k As Double
l As Double
End Type
' 功能：打开指定的数据库（在frmConnectDB中指定）
' 输入：无
' 调用：无
' 返回：如果完成连接，返回True；否则返回False
' 示例：
' OpenDB
Public Function OpenDB(InputDataBaseName) As Boolean
OpenDB = True
' 如果数据库已打开，不执行任何操作
If adoCon.State <> 0 Then Exit Function
adoCon.CursorLocation = adUseClient
' 获得数据库文件的位置
Dim strDbName As String
Dim strProject As String
strProject = Left(ThisDrawing.Application.VBE.activevbProject.FileName, _
Len(ThisDrawing.Application.VBE.activevbProject.FileName) - 19)
strDbName = strProject & "\mdb\" & InputDataBaseName & ".mdb"
adoCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
strDbName & ";"
End Function
' 功能：关闭指定的数据库（在frmConnectDB中指定）
' 输入：无
' 调用：无
' 返回：如果数据库处于打开状态，就关闭它
' 示例：
' CloseDB
Public Function CloseDB()
If adoCon.State <> 0 Then
adoCon.Close
End If
End Function
Function HG20595T_Data_Preparation() As HG20595InitialData
Dim d1, f2, x, w, c, n1, n, h, k, h1, d, l, PipeOutDiameter, PipeDelta, a1, rr, i, ScheduleWall, SeriesNo
'
''
OpenDB ("HG20592")
'
Dim rst As New ADODB.Recordset
Dim Sql As String, ii As Integer
''
Dim Sep_N, Pn As String, Dn As String, SearchCondition
Pn = 6.3: Dn = 350
Select Case Pn
Case 1#, 10#, 16#, 25#
SearchCondition = Dn & "-" & Trim(Str(Pn) + ".0")
Case Else
SearchCondition = Dn & "-" & Trim(Str(Pn))
End Select
''
Sql = "select c.*,a.*,b.* from 带颈对焊法兰as A,凹凸榫槽密封面 as b ,法兰规格 as c Where " & _
" c.法兰规格 = '" & SearchCondition & "' and c.法兰规格 = a.法兰规格 and c.法兰规格 = b.法兰规格"
rst.Open Sql, adoCon, adOpenDynamic, adLockOptimistic
''
ScheduleWall = 12: SeriesNo = "B"
' d1 = rst.Fields("突台外径d"):
f2 = rst.Fields("台高f2"):
x = rst.Fields("凸面外径X"):
w = rst.Fields("榫面内径W")
'''
c = rst.Fields("WN法兰厚度C")'
Select Case SeriesNo
Case "A"
n1 = rst.Fields("WN法兰颈径NA")
PipeOutDiameter = rst.Fields("钢管外径A")
Case "B"
n1 = rst.Fields("WN法兰颈径NB")
PipeOutDiameter = rst.Fields("钢管外径B")
End Select
HG20595T_Data_Preparation.n = rst.Fields("螺栓数量") 'xxlSheet.cells(ii, 16).Value
h = rst.Fields("WN法兰高度H")'xxlSheet.cells(ii, 10).Value
HG20595T_Data_Preparation.k = rst.Fields("螺栓孔中心圆直径")'xxlSheet.cells(ii, 13).Value
h1 = rst.Fields("WN焊端长度h")
d = rst.Fields("法兰外径D")'xxlSheet.cells(ii, 12).Value
HG20595T_Data_Preparation.l = rst.Fields("螺栓孔直径")'xxlSheet.cells(ii, 14).Value
PipeDelta = ScheduleWall
a1 = PipeOutDiameter
rr = rst.Fields("WN圆角半径R")
CloseDB
' HG20595法兰实体赋值
Dim HG20595(12, 3) As Double
ThisDrawing.SendCommand "_fillet" + Chr(10) + "r" & Chr(10) & rr & Chr(10) & Chr(10)
HG20595(1, 1) = (PipeOutDiameter - 2 * PipeDelta) / 2: HG20595(1, 2) = -f2: HG20595(1, 3) = 0
HG20595(2, 1) = w / 2: HG20595(2, 2) = -f2: HG20595(2, 3) = 0
HG20595(3, 1) = w / 2: HG20595(3, 2) = 0: HG20595(3, 3) = 0
HG20595(4, 1) = x / 2: HG20595(4, 2) = 0: HG20595(4, 3) = 0
HG20595(5, 1) = x / 2: HG20595(5, 2) = -f2: HG20595(5, 3) = 0
HG20595(6, 1) = d / 2: HG20595(6, 2) = -f2: HG20595(6, 3) = 0
HG20595(7, 1) = d / 2: HG20595(7, 2) = -c: HG20595(7, 3) = 0
HG20595(8, 1) = n1 / 2: HG20595(8, 2) = -c: HG20595(8, 3) = 0
HG20595(9, 1) = a1 / 2: HG20595(9, 2) = h1 - h: HG20595(9, 3) = 0
HG20595(10, 1) = a1 / 2: HG20595(10, 2) = -h: HG20595(10, 3) = 0
HG20595(11, 1) = (PipeOutDiameter - 2 * PipeDelta) / 2: HG20595(11, 2) = -h: HG20595(11, 3) = 0
HG20595(12, 1) = (PipeOutDiameter - 2 * PipeDelta) / 2: HG20595(12, 2) = -f2: HG20595(12, 3) = 0
HG20595T_Data_Preparation.HG20595 = HG20595
End Function
Sub lss()
Dim aa() As Double, bb() As Double, ii, jj, nn
Dim ee As AcadEntity
Set ee = DrawingEntityForHG20595T(HG20595T_Data_Preparation.HG20595 _
, HG20595T_Data_Preparation.l, HG20595T_Data_Preparation.n, HG20595T_Data_Preparation.k)
End Sub
Function DrawingEntityForHG20595T(HG20595 As Variant, l, n, k) As AcadEntity
'Dim HG20595(12, 3) As Double
'Dim HG20595
'HG20595 = HG20595InputData
'
Dim startpoint(0 To 2) As Double
Dim endpoint(0 To 2) As Double
'
'面域
Dim curves(0 To 12) As AcadEntity
Dim regionObj As Variant
'旋转实体
Dim axisPt(0 To 2) As Double
Dim axisDir(0 To 2) As Double
Dim angle As Double
'开孔
Dim cylinderObj As Acad3DSolid
Dim radius As Double
Dim center(0 To 2) As Double
Dim height As Double
height = 500
axisPt(0) = 0: axisPt(1) = 0: axisPt(2) = 0
axisDir(0) = 0: axisDir(1) = 0: axisDir(2) = 1
angle = Pi * 2 + 0.2
Dim solidObj As Acad3DSolid
Dim i
For i = 1 To 11
startpoint(0) = HG20595(i, 0): startpoint(1) = HG20595(i, 1): startpoint(2) = HG20595(i, 2)
If i <= 12 Then
endpoint(0) = HG20595(i + 1, 0): endpoint(1) = HG20595(i + 1, 1): endpoint(2) = HG20595(i + 1, 2)
End If
Set curves(i - 1) = ThisDrawing.ModelSpace.AddLine(startpoint, endpoint)
Next i
Dim str_handle1, str_handle2
str_handle1 = curves(6).Handle
str_handle2 = curves(7).Handle
ThisDrawing.SendCommand "_fillet" + Chr(10) + "(Handent" & Chr(34) & str_handle1 & Chr(34) & ")" & Chr(10) & "(Handent" & Chr(34) & str_handle2 & Chr(34) & ")" & Chr(10)
Set curves(11) = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
str_handle1 = curves(7).Handle
str_handle2 = curves(8).Handle
ThisDrawing.SendCommand "_fillet" + Chr(10) + "(Handent" & Chr(34) & str_handle1 & Chr(34) & ")" & Chr(10) & "(Handent" & Chr(34) & str_handle2 & Chr(34) & ")" & Chr(10)
Set curves(12) = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
'面域绘制
regionObj = ThisDrawing.ModelSpace.AddRegion(curves)
For i = 0 To 12
curves(i).Delete
Next i
'实体旋转
Set solidObj = ThisDrawing.ModelSpace.AddRevolvedSolid(regionObj(0), axisPt, axisDir, angle)
regionObj(0).Delete
'开孔
Dim Alfa
radius = l / 2
Alfa = Pi / n
For i = 1 To n
center(0) = k / 2 * Cos(Alfa): center(1) = k / 2 * Sin(Alfa): center(2) = 0
Set cylinderObj = ThisDrawing.ModelSpace.AddCylinder(center, radius, height)
'剪切
solidObj.Boolean 2, cylinderObj
Alfa = Alfa + 2 * Pi / n
Next i
''''
End Function
运行结果如图所示，三维HG20595-T型法兰
<p>谢谢！努力学习中</p> 谢谢，非常好，学习一下！让我们共同努力，共创论坛美好未来！
页:
[1]