[转贴]：参数化螺栓螺母程序

hanweisheng

从一个网站上看得这段程序，那位大侠能给我指导一下，怎么能在cad2006下运行！急用！开 始
       
参数分析

判断

螺 母

垫 片

螺 栓

结 束
  否
是
Private Sub canshu_Click()

End Sub

Private Sub CmdExit_Click()

Unload Me

End Sub

Private Sub CmdOk_Click()

'检查参数赋值情况

If TextX.Text = "" Or TextY.Text = "" Or TextZ.Text = "" Then

MsgBox "请在屏幕选起点!", vbExclamation, "警告"

Exit Sub

End If

'定义直线对象

Dim objLine01, ObjLine02, ObjLine03, ObjLine04, ObjLine05, ObjLine06, ObjLine07, ObjLine08, ObjLine09, ObjLine10, ObjLine11, ObjLine12, ObjLine13, ObjLine14, ObjLine15 As AcadLine

'定义数组变量，作为各顶点的坐标

Dim Pt01(2) As Double：Dim Pt02(2) As Double：Dim Pt03(2) As Double

Dim Pt04(2) As Double：Dim Pt05(2) As Double：Dim Pt06(2) As Double

Dim Pt07(2) As Double：Dim Pt08(2) As Double：Dim Pt09(2) As Double

Dim Pt10(2) As Double：Dim Pt11(2) As Double：Dim Pt12(2) As Double

Dim Pt13(2) As Double：Dim Pt14(2) As Double：Dim Pt15(2) As Double

Dim Pt16(2) As Double：Dim Pt17(2) As Double：Dim Pt18(2) As Double

Dim Pt19(2) As Double：Dim Pt20(2) As Double：Dim Pt21(2) As Double

Dim Pt22(2) As Double：Dim Pt23(2) As Double：Dim d, l, b As Double

Dim x, y, z As Variant

x = TextX: y = TextY: z = TextZ

'检查参数赋值情况

If TextZhiJ.Text = "" Or TextChangD.Text = "" Then

MsgBox "参数不能为空，请检查参数的输入．", vbExclamation, "警告"

Exit Sub

End If

d = TextZhiJ: l = TextChangD

If d = 5 Then

MsgBox "螺栓长度应为:GB5780 25~50; GB5781 10~40", vbExclamation, "警告"

b = 16

If l < 16 Or l > 50 Then

Exit Sub

End If

End If

If d = 6 Then

MsgBox "螺栓长度应为:GB5780 30~60; GB5781 12~50", vbExclamation, "警告"

b = 18

If l < 18 Or l > 60 Then

Exit Sub

End If

End If

If d = 8 Then

MsgBox "螺栓长度应为:GB5780 35~80; GB5781 16~65", vbExclamation, "警告"

b = 22

If l < 22 Or l > 80 Then

Exit Sub

End If

End If

If d = 10 Then

MsgBox "螺栓长度应为:GB5780 40~100; GB5781 20~80", vbExclamation, "警告"

b = 26

If l < 26 Or l > 100 Then

Exit Sub

End If

End If

If d = 12 Then

MsgBox "螺栓长度应为:GB5780 45~120; GB5781 25~100", vbExclamation, "警告"

b = 30

If l < 30 Or l > 120 Then

Exit Sub

End If

End If

If d = 16 Then

MsgBox "螺栓长度应为:GB5780 55~160; GB5781 35~100", vbExclamation, "警告"

b = 38

If l < 38 Or l > 160 Then

Exit Sub

End If

End If

If d = 20 Then

MsgBox "螺栓长度应为:GB5780 65~200; GB5781 40~100", vbExclamation, "警告"

b = 40

If l < 40 Or l > 200 Then

Exit Sub

End If

End If

If d = 24 Then

MsgBox "螺栓长度应为:GB5780 80~240; GB5781 50~100", vbExclamation, "警告"

b = 54

If l < 54 Or l > 240 Then

Exit Sub

End If

End If

If d = 30 Then

MsgBox "螺栓长度应为:GB5780 90~300; GB5781 60~100", vbExclamation, "警告"

b = 66

If l < 66 Or l > 300 Then

Exit Sub

End If

End If

If d = 36 Then

MsgBox "螺栓长度应为:GB5780 110~300; GB5781 70~100", vbExclamation, "警告"

b = 78

If l < 78 Or l > 300 Then

Exit Sub

End If

End If

If d = 42 Then

MsgBox "螺栓长度应为:GB5780 160~420; GB5781 80~420", vbExclamation, "警告"

b = 96

If l < 96 Or l > 420 Then

Exit Sub

End If

End If

If d = 48 Then

MsgBox "螺栓长度应为:GB5780 180~480; GB5781 90~480", vbExclamation, "警告"

b = 108

If l < 108 Or l > 480 Then

Exit Sub

End If

End If

'判断语句

If d <> 5# And d <> 6 And d <> 8 And d <> 10 And d <> 12 And d <> 16 And d <> 20 And d <> 24 And d <> 30 And d <> 36 And d <> 42 And d <> 48 Then

MsgBox "螺栓直径可能为5,6,8,10,12,16,20,24,30,36,42,48？", vbExclamation, "警告"

Exit Sub

End If



'根据螺栓直径，长度计算各顶点的坐标

Pt01(0) = x: Pt01(1) = y: Pt01(2) = z

'计算各顶点的坐标

Pt02(0) = x: Pt02(1) = y + 0.5 * d: Pt02(2) = z

Pt03(0) = x: Pt03(1) = y + 1.5 * d: Pt03(2) = z

Pt04(0) = x: Pt04(1) = y + 2 * d: Pt04(2) = z

Pt05(0) = x + 0.7 * d: Pt05(1) = y + 2 * d: Pt05(2) = z

Pt06(0) = x + 0.7 * d: Pt06(1) = y + 1.5 * d: Pt06(2) = z

Pt07(0) = x + 0.7 * d: Pt07(1) = y + 0.5 * d: Pt07(2) = z

Pt08(0) = x + 0.7 * d: Pt08(1) = y: Pt08(2) = z

Pt09(0) = x + 0.7 * d + l - b: Pt09(1) = y + 0.5 * d: Pt09(2) = z

Pt10(0) = x + 0.7 * d + l - b: Pt10(1) = y + 1.425 * d: Pt10(2) = z

Pt11(0) = x + 0.7 * d + l - b: Pt11(1) = y + 0.575 * d: Pt11(2) = z

Pt12(0) = x + 0.7 * d + l - b: Pt12(1) = y + 1.5 * d: Pt12(2) = z

Pt13(0) = x + 0.7 * d + l: Pt13(1) = y + 1.5 * d: Pt13(2) = z

Pt14(0) = x + 0.7 * d + l: Pt14(1) = y + 1.425 * d: Pt14(2) = z

Pt15(0) = x + 0.7 * d + l: Pt15(1) = y + 0.575 * d: Pt15(2) = z

Pt16(0) = x + 0.7 * d + l: Pt16(1) = y + 0.5 * d: Pt16(2) = z

Pt17(0) = x - 5: Pt17(1) = y + 1# * d: Pt17(2) = z

Pt18(0) = x + 0.7 * d + l + 5: Pt18(1) = y + 1# * d: Pt18(2) = z

Pt19(0) = x + 3.5 * d + l + 5: Pt19(1) = y + 1# * d: Pt19(2) = z

Pt20(0) = x + 2# * d + l + 5: Pt20(1) = y + 1# * d: Pt20(2) = z

Pt21(0) = x + 5# * d + l + 5: Pt21(1) = y + 1# * d: Pt21(2) = z

Pt22(0) = x + 3.5 * d + l + 5: Pt22(1) = y - 0.5 * d: Pt22(2) = z

Pt23(0) = x + 3.5 * d + l + 5: Pt23(1) = y + 2.5 * d: Pt23(2) = z

'加载线形

'定义线形

Dim entry As AcadLineType：Dim found As Boolean：Dim ltName(0 To 2) As String

Dim i As Integer

    found = False

    '准备添加的3种线型

    ltName(0) = "BORDER"

    ltName(1) = "CENTER"

    ltName(2) = "DASHDOT"

    For i = 0 To 2

        '搜寻要添加的线型在线型集合中是否已存在

        For Each entry In ThisDrawing.Linetypes

            If StrComp(entry.Name, ltName(i), 1) = 0 Then

                found = True

                Exit For

            End If

        Next

        '如果不存在则将其从线型文件acadiso.lin中加载

        If Not (found) Then

            ThisDrawing.Linetypes.Load ltName(i), "acadiso.lin"

        End If

    Next

'创建图层

Dim objLayer As AcadLayer

'粗实线

Set objLayer = ThisDrawing.Layers.Add("粗实线")

objLayer.color = acWhite

objLayer.Linetype = "Continuous"

objLayer.Lineweight = acLnWt030

ThisDrawing.ActiveLayer = objLayer

Set objLine01 = ThisDrawing.ModelSpace.AddLine(Pt01, Pt04)

Set ObjLine02 = ThisDrawing.ModelSpace.AddLine(Pt04, Pt05)

Set ObjLine03 = ThisDrawing.ModelSpace.AddLine(Pt05, Pt08)

Set ObjLine04 = ThisDrawing.ModelSpace.AddLine(Pt08, Pt01)

Set ObjLine05 = ThisDrawing.ModelSpace.AddLine(Pt02, Pt07)

Set ObjLine06 = ThisDrawing.ModelSpace.AddLine(Pt03, Pt06)

Set ObjLine07 = ThisDrawing.ModelSpace.AddLine(Pt06, Pt13)

Set ObjLine08 = ThisDrawing.ModelSpace.AddLine(Pt13, Pt16)

Set ObjLine09 = ThisDrawing.ModelSpace.AddLine(Pt16, Pt07)

Set ObjLine10 = ThisDrawing.ModelSpace.AddLine(Pt09, Pt12)

'定义动态数组

Dim objPline As AcadLWPolyline：Dim ptArr() As Double

Dim number As Integer：Dim width As Double：Dim angle As Variant

Const PI = 3.1415926

width = 0

angle = 0

number = 6

'顶点的个数为number,需要2*number个元素来表示

ReDim ptArr(2 * number - 1)

'每条边对应的角度

Dim ang As Double

ang = 2 * PI / number

'为点的坐标数组赋值

Dim n As Integer

For n = 0 To 2 * number - 1

If n Mod 2 = 0 Then

   ptArr(n) = Pt19(0) + d * Cos(((n + 1) / 2) * ang)

   ElseIf n Mod 2 <> 0 Then

   ptArr(n) = Pt19(1) + d * Sin((n / 2) * ang)

End If

Next n

'创建多线段，并调整其特征

Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)

objPline.Closed = True

objPline.Rotate Pt19, angle

objPline.Linetype = "ByLayer"

objPline.Update

'画圆

Dim objCir As AcadCircle

Set objCir = ThisDrawing.ModelSpace.AddCircle(Pt19, d * Sin(PI / 3))

'细实线

Set objLayer = ThisDrawing.Layers.Add("细实线")

objLayer.color = acWhite

objLayer.Linetype = "Continuous"

objLayer.Lineweight = acLnWt009

ThisDrawing.ActiveLayer = objLayer

Set ObjLine11 = ThisDrawing.ModelSpace.AddLine(Pt10, Pt14)

ObjLine11.Linetype = "ByLayer"

Set ObjLine12 = ThisDrawing.ModelSpace.AddLine(Pt11, Pt15)

ObjLine12.Linetype = "ByLayer"

'点划线

Set objLayer = ThisDrawing.Layers.Add("点划线")

objLayer.color = acWhite

objLayer.Lineweight = acLnWt009

objLayer.Linetype = "DASHDOT"

ThisDrawing.ActiveLayer = objLayer

'连接对应的点

Set ObjLine13 = ThisDrawing.ModelSpace.AddLine(Pt17, Pt18)

ObjLine13.Linetype = "ByLayer"

Set ObjLine14 = ThisDrawing.ModelSpace.AddLine(Pt20, Pt21)

ObjLine14.Linetype = "ByLayer"

Set ObjLine15 = ThisDrawing.ModelSpace.AddLine(Pt22, Pt23)

ObjLine15.Linetype = "ByLayer"

'定义螺母的中心点

Dim CenPt(2) As Double

'定义螺母左视图中各点坐标

Dim mPt1(2) As Double：Dim mPt2(2) As Double：Dim mPt3(2) As Double

Dim mPt4(2) As Double：Dim mPt5(2) As Double：Dim mPt6(2) As Double

Dim mPt7(2) As Double：Dim mPt8(2) As Double

'定义螺母左视图中心线端点

Dim mPt9(2) As Double：Dim mPt10(2) As Double

'定义螺母主视图中心线端点

Dim mPt11(2) As Double：Dim mPt12(2) As Double：Dim mPt13(2) As Double

Dim mPt14(2) As Double

'定义直线对象

Dim mObjLine(8) As AcadLine

'计算螺母各点的坐标

'定义中心点

CenPt(0) = x + 2# * d + l + 5: CenPt(1) = y - 3# * d: CenPt(2) = z

'螺母线端点

mPt11(0) = x + 3.5 * d + l + 5: mPt11(1) = y - 3# * d: mPt11(2) = z

mPt12(0) = x + 0.5 * d + l + 5: mPt12(1) = y - 3# * d: mPt12(2) = z

mPt13(0) = x + 2# * d + l + 5: mPt13(1) = y - 1.5 * d: mPt13(2) = z

mPt14(0) = x + 2# * d + l + 5: mPt14(1) = y - 4.5 * d: mPt14(2) = z

mPt9(0) = x + 4.5 * d + l + 5: mPt9(1) = y - 3# * d: mPt9(2) = z

mPt10(0) = x + 6.5 * d + l + 5: mPt10(1) = y - 3# * d: mPt10(2) = z

mPt1(0) = x + 5# * d + l + 5: mPt1(1) = y - 2# * d: mPt1(2) = z

mPt2(0) = x + 5# * d + l + 5: mPt2(1) = y - 2.5 * d: mPt2(2) = z

mPt3(0) = x + 5# * d + l + 5: mPt3(1) = y - 3.5 * d: mPt3(2) = z

mPt4(0) = x + 5# * d + l + 5: mPt4(1) = y - 4# * d: mPt1(2) = z

mPt5(0) = x + 5.8 * d + l + 5: mPt5(1) = y - 4# * d: mPt5(2) = z

mPt6(0) = x + 5.8 * d + l + 5: mPt6(1) = y - 3.5 * d: mPt6(2) = z

mPt7(0) = x + 5.8 * d + l + 5: mPt7(1) = y - 2.5 * d: mPt7(2) = z

mPt8(0) = x + 5.8 * d + l + 5: mPt8(1) = y - 2# * d: mPt8(2) = z

'顶点的个数为number,需要2*number个元素来表示

Dim objPline1 As AcadLWPolyline：Dim ptArr1() As Double

ReDim ptArr1(2 * number - 1)

angle = 0

'为点的坐标数组赋值

ang = 2 * PI / number

For n = 0 To 2 * number - 1

If n Mod 2 = 0 Then

   ptArr1(n) = CenPt(0) + d * Cos(((n + 1) / 2) * ang)

   ElseIf n Mod 2 <> 0 Then

   ptArr1(n) = CenPt(1) + d * Sin((n / 2) * ang)

End If

Next n

Set objLayer = ThisDrawing.Layers.Add("粗实线")

ThisDrawing.ActiveLayer = objLayer

Set objPline1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr1)

objPline1.Closed = True

objPline1.Rotate CenPt, angle

objPline1.Linetype = "ByLayer"

objPline1.Update

Dim objCir1, objCir2 As AcadCircle

'画圆

Set objCir1 = ThisDrawing.ModelSpace.AddCircle(CenPt, d * Sin(PI / 3))

Set objCir2 = ThisDrawing.ModelSpace.AddCircle(CenPt, 0.85 * d / 2#)

Set mObjLine(0) = ThisDrawing.ModelSpace.AddLine(mPt1, mPt4)

mObjLine(0).Linetype = "ByLayer"

Set mObjLine(1) = ThisDrawing.ModelSpace.AddLine(mPt4, mPt5)

mObjLine(1).Linetype = "ByLayer"

Set mObjLine(2) = ThisDrawing.ModelSpace.AddLine(mPt5, mPt8)

mObjLine(2).Linetype = "ByLayer"

Set mObjLine(3) = ThisDrawing.ModelSpace.AddLine(mPt8, mPt1)

mObjLine(3).Linetype = "ByLayer"

Set mObjLine(4) = ThisDrawing.ModelSpace.AddLine(mPt2, mPt7)

mObjLine(4).Linetype = "ByLayer"

Set mObjLine(5) = ThisDrawing.ModelSpace.AddLine(mPt3, mPt6)

mObjLine(5).Linetype = "ByLayer"



Set objLayer = ThisDrawing.Layers.Add("细实线")

ThisDrawing.ActiveLayer = objLayer

'创建圆弧弧度值

Dim arcObj As AcadArc：Dim sAngDegree As Double：Dim eAngDegree As Double

sAngDegree =90#

eAngDegree = 360#

'将角度值转为弧度值

Dim sAngRadian As Double：Dim eAngRadian As Double

sAngRadian = sAngDegree * 3.141592 / 180#

eAngRadian = eAngDegree * 3.141592 / 180#

'在模型空间创建圆弧对象

Set arcObj = ThisDrawing.ModelSpace.AddArc(CenPt, d / 2, sAngRadian, eAngRadian)

arcObj.Linetype = "ByLayer"



Set objLayer = ThisDrawing.Layers.Add("点划线")

ThisDrawing.ActiveLayer = objLayer

Set mObjLine(6) = ThisDrawing.ModelSpace.AddLine(mPt11, mPt12)

mObjLine(6).Linetype = "ByLayer"

Set mObjLine(7) = ThisDrawing.ModelSpace.AddLine(mPt13, mPt14)

mObjLine(7).Linetype = "ByLayer"

Set mObjLine(8) = ThisDrawing.ModelSpace.AddLine(mPt9, mPt10)

mObjLine(8).Linetype = "ByLayer"

'创建垫片

'定义线段

Dim dobjLine(12) As AcadLine：Dim darcObj(1) As AcadCircle

'定义各点并赋值

Dim dPt1(2) As Double：Dim dPt2(2) As Double：Dim dPt3(2) As Double

Dim dPt4(2) As Double：Dim dPt5(2) As Double：Dim dPt6(2) As Double

Dim dPt7(2) As Double：Dim dPt8(2) As Double：Dim dPt9(2) As Double

Dim dPt10(2) As Double：Dim dCent(2) As Double：Dim dCentL(2) As Double

Dim dCentR(2) As Double：Dim dCentT(2) As Double：Dim dCentB(2) As Double

dCent(0) = x: dCent(1) = y - 3# * d: dCent(2) = z

dCentL(0) = x - 1# * d - 13: dCentL(1) = y - 3# * d: dCentL(2) = z

dCentR(0) = x + 1# * d + 13: dCentR(1) = y - 3# * d: dCentR(2) = z

dCentT(0) = x: dCentT(1) = y - 2# * d + 13: dCentT(2) = z

dCentB(0) = x: dCentB(1) = y - 4# * d - 13: dCentB(2) = z

dPt1(0) = x - 1# * d + 1# * l: dPt1(1) = y - 2# * d + 3: dPt1(2) = z

dPt2(0) = x - 1# * d + 1# * l: dPt2(1) = y - 2.5 * d + 2: dPt2(2) = z

dPt3(0) = x - 1# * d + 1# * l: dPt3(1) = y - 3.5 * d - 2: dPt3(2) = z

dPt4(0) = x - 1# * d + 1# * l: dPt4(1) = y - 4 * d - 3: dPt4(2) = z

dPt5(0) = x - 1# * d + 0.15 * d + l: dPt5(1) = y - 4 * d - 3: dPt5(2) = z

dPt6(0) = x - 1# * d + 0.15 * d + l: dPt6(1) = y - 3.5 * d - 2: dPt6(2) = z

dPt7(0) = x - 1# * d + 0.15 * d + l: dPt7(1) = y - 2.5 * d + 2: dPt7(2) = z

dPt8(0) = x - 1# * d + 0.15 * d + l: dPt8(1) = y - 2# * d + 3: dPt8(2) = z

dPt9(0) = x - 1# * d + 1# * l - 5: dPt9(1) = y - 3# * d: dPt9(2) = z

dPt10(0) = x - 1# * d + 0.15 * d + l + 5: dPt10(1) = y - 3# * d: dPt10(2) = z

'连结各点

Set objLayer = ThisDrawing.Layers.Add("粗实线")

ThisDrawing.ActiveLayer = objLayer

Set dobjLine(0) = ThisDrawing.ModelSpace.AddLine(dPt1, dPt2)

dobjLine(0).Linetype = "ByLayer"

Set dobjLine(1) = ThisDrawing.ModelSpace.AddLine(dPt2, dPt3)

dobjLine(1).Linetype = "ByLayer"

Set dobjLine(2) = ThisDrawing.ModelSpace.AddLine(dPt3, dPt4)

dobjLine(2).Linetype = "ByLayer"

Set dobjLine(3) = ThisDrawing.ModelSpace.AddLine(dPt4, dPt5)

dobjLine(3).Linetype = "ByLayer"

Set dobjLine(4) = ThisDrawing.ModelSpace.AddLine(dPt5, dPt6)

dobjLine(4).Linetype = "ByLayer"

Set dobjLine(5) = ThisDrawing.ModelSpace.AddLine(dPt6, dPt7)

dobjLine(5).Linetype = "ByLayer"

Set dobjLine(9) = ThisDrawing.ModelSpace.AddLine(dPt7, dPt8)

dobjLine(9).Linetype = "ByLayer"

Set dobjLine(10) = ThisDrawing.ModelSpace.AddLine(dPt8, dPt1)

dobjLine(10).Linetype = "ByLayer"

Set dobjLine(11) = ThisDrawing.ModelSpace.AddLine(dPt2, dPt7)

dobjLine(11).Linetype = "ByLayer"

Set dobjLine(12) = ThisDrawing.ModelSpace.AddLine(dPt3, dPt6)

dobjLine(12).Linetype = "ByLayer"

Set darcObj(0) = ThisDrawing.ModelSpace.AddCircle(dCent, 0.5 * d + 2)

Set darcObj(1) = ThisDrawing.ModelSpace.AddCircle(dCent, d + 3)

Set objLayer = ThisDrawing.Layers.Add("点划线")

ThisDrawing.ActiveLayer = objLayer

Set dobjLine(6) = ThisDrawing.ModelSpace.AddLine(dPt9, dPt10)

dobjLine(6).Linetype = "ByLayer"

Set dobjLine(7) = ThisDrawing.ModelSpace.AddLine(dCentL, dCentR)

dobjLine(7).Linetype = "ByLayer"

Set dobjLine(8) = ThisDrawing.ModelSpace.AddLine(dCentT, dCentB)

dobjLine(8).Linetype = "ByLayer"



Set objLayer = ThisDrawing.Layers.Add("细实线")

ThisDrawing.ActiveLayer = objLayer

Dim hatchObj As AcadHatch：Dim patternName As String：Dim PatternType As Long

Dim assocVar As Boolean

'定义剖面线的模式

patternName = "ANSI31"

PatternType = 0

'设定剖面线与外轮廓线相关联

assocVar = True

'在模型空间创建剖面线对象

Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, assocVar)

Dim outerLoop1(0 To 3) As AcadEntity：Dim outerLoop2(0 To 3) As AcadEntity

'创建外部轮廓线

Set outerLoop1(0) = dobjLine(0) ：Set outerLoop1(1) = dobjLine(11)

Set outerLoop1(2) = dobjLine(9) ：Set outerLoop1(3) = dobjLine(10)

Set outerLoop2(0) = dobjLine(2) ：Set outerLoop2(1) = dobjLine(3)

Set outerLoop2(2) = dobjLine(4) ：Set outerLoop2(3) = dobjLine(12)

hatchObj.AppendOuterLoop outerLoop1

hatchObj.AppendOuterLoop outerLoop2

hatchObj.Evaluate

ThisDrawing.Regen True

ZoomAll

Unload Me

End Sub

Private Sub CmdPickstart_Click()

Dim PtPick As Variant

FormMain.Hide

PtPick = ThisDrawing.Utility.GetPoint(, "请在屏幕选起点：")

TextX = PtPick(0): TextY = PtPick(1): TextZ = PtPick(2)

FormMain.Show

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()

'螺栓参数默认值

TextZhiJ.Text = "": TextChangD.Text = ""

End Sub

Private Sub weizhi_Click()

End Sub

zbsj

定义剖面线的模式

patternName = "ANSI31"

PatternType = 0

'设定剖面线与外轮廓线相关联

assocVar = True

'在模型空间创建剖面线对象

Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, assocVar)

Dim outerLoop1(0 To 3) As AcadEntity：Dim outerLoop2(0 To 3) As AcadEntity

'创建外部轮廓线

Set outerLoop1(0) = dobjLine(0) ：Set outerLoop1(1) = dobjLine(11)

Set outerLoop1(2) = dobjLine(9) ：Set outerLoop1(3) = dobjLine(10)

Set outerLoop2(0) = dobjLine(2) ：Set outerLoop2(1) = dobjLine(3)

Set outerLoop2(2) = dobjLine(4) ：Set outerLoop2(3) = dobjLine(12)

hatchObj.AppendOuterLoop outerLoop1

hatchObj.AppendOuterLoop outerLoop2

hatchObj.Evaluate

ThisDrawing.Regen True

ZoomAll

Unload Me

End Sub

Private Sub CmdPickstart_Click()

Dim PtPick As Variant

FormMain.Hide

PtPick = ThisDrawing.Utility.GetPoint(, "请在屏幕选起点：")

TextX = PtPick(0): TextY = PtPick(1): TextZ = PtPick(2)

FormMain.Show

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()

'螺栓参数默认值

TextZhiJ.Text = "": TextChangD.Text = ""

End Sub

Private Sub weizhi_Click()

End Sub

比较实用啊