
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 DoubleDim Pt02(2) As DoubleDim Pt03(2) As Double

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

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

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

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

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

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

Dim Pt22(2) As DoubleDim Pt23(2) As DoubleDim 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 AcadLineTypeDim found As BooleanDim 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 AcadLWPolylineDim ptArr() As Double

Dim number As IntegerDim width As DoubleDim 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 DoubleDim mPt2(2) As DoubleDim mPt3(2) As Double

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

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

'ĸͼ߶˵

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

'ĸͼ߶˵

Dim mPt11(2) As DoubleDim mPt12(2) As DoubleDim 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 AcadLWPolylineDim 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 AcadArcDim sAngDegree As DoubleDim eAngDegree As Double

sAngDegree =90#

eAngDegree = 360#

'ǶֵתΪֵ

Dim sAngRadian As DoubleDim 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 AcadLineDim darcObj(1) As AcadCircle

'㲢ֵ

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

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

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

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

Dim dCentR(2) As DoubleDim dCentT(2) As DoubleDim 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 AcadHatchDim patternName As StringDim 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 AcadEntityDim 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

 

 

