正六形形顶点坐标

兰州人

3. Sub ls()
4.   Dim pp(0 To 2) As Double, ppp(0 To 2) As Double
5.   Dim objLine As AcadLine
6.   Dim Hexagon(6) As Variant
7.   s = 10
8.   Hexagon(0) = Array(s / 2 * Tan(30 * 3.1415926 / 180), s / 2)
9.   Hexagon(1) = Array(-s / 2 * Tan(30 * 3.1415926 / 180), s / 2)
10.   Hexagon(2) = Array(-s * Tan(30 * 3.1415926 / 180), pp(1) = 0)
11.   Hexagon(3) = Array(-s / 2 * Tan(30 * 3.1415926 / 180), -s / 2)
12.   Hexagon(4) = Array(s / 2 * Tan(30 * 3.1415926 / 180), -s / 2)
13.   Hexagon(5) = Array(s * Tan(30 * 3.1415926 / 180), pp(1) = 0)
14.   Hexagon(6) = Array(s / 2 * Tan(30 * 3.1415926 / 180), s / 2)
15.   
16.   For ii = 0 To UBound(Hexagon) - 1
17.     pp(0) = Hexagon(ii)(0): pp(1) = Hexagon(ii)(1)
18.     ppp(0) = Hexagon(ii + 1)(0): ppp(1) = Hexagon(ii + 1)(1)
19.     Set objLine = ThisDrawing.ModelSpace.AddLine(pp, ppp)
20.   Next ii
21. End Sub

Sub ls()   Dim pp(0 To 2) As Double, ppp(0 To 2) As Double   Dim objLine As AcadLine   Dim Hexagon(6) As Variant   s = 10   Hexagon(0) = Array(s / 2 * Tan(30 * 3.1415926 / 180), s / 2)   Hexagon(1) = Array(-s / 2 * Tan(30 * 3.1415926 / 180), s / 2)   Hexagon(2) = Array(-s * Tan(30 * 3.1415926 / 180), pp(1) = 0)   Hexagon(3) = Array(-s / 2 * Tan(30 * 3.1415926 / 180), -s / 2)   Hexagon(4) = Array(s / 2 * Tan(30 * 3.1415926 / 180), -s / 2)   Hexagon(5) = Array(s * Tan(30 * 3.1415926 / 180), pp(1) = 0)   Hexagon(6) = Array(s / 2 * Tan(30 * 3.1415926 / 180), s / 2)      For ii = 0 To UBound(Hexagon) - 1     pp(0) = Hexagon(ii)(0): pp(1) = Hexagon(ii)(1)     ppp(0) = Hexagon(ii + 1)(0): ppp(1) = Hexagon(ii + 1)(1)     Set objLine = ThisDrawing.ModelSpace.AddLine(pp, ppp)   Next ii End Sub

兰州人

2. Sub ls()
3.   nn = ThisDrawing.ModelSpace.Count - 1
4.   Dim objText As AcadText, objLine As AcadLine
5.   Dim Xls As New XlsMdbTxtData
6.   Dim xx As Worksheet
7.   
8.   Set xx = Xls.ReturnxlSheet("Sheet1")
9.   xx.Range("A:z").ClearContents
10.   For ii = 0 To nn
11.    Select Case ThisDrawing.ModelSpace.Item(ii).ObjectName
12.      Case "AcDbText"
13.        Set objText = ThisDrawing.ModelSpace.Item(ii)
14.        aa = Split(objText.TextString, ",")
15. '     For jj = 0 To UBound(aa)
16.        'Set objLine = ThisDrawing.HandleToObject(aa(1))
17.        With objLine
18.     '     Debug.Print .Delta(0), .Delta(1)
19.        End With
20. '     Next jj
21.     Case "AcDbLine"
22.        Set objLine = ThisDrawing.ModelSpace.Item(ii)
23.        With objLine
24.          'Debug.Print Format(.Delta(0), "0.00"), Format(.Delta(1), "0.00"), .Angle
25.          
26.            xx.Cells(ii + 1, 1) = Format(.Delta(0), "0.0000")
27.            xx.Cells(ii + 1, 2) = Format(.Delta(1), "0.0000")
28.            xx.Cells(ii + 1, 3) = Format(.Angle, "0.0000")
29.            gg = "Hexagon(" & ii
30.            gg = gg & ")=array("
31.            If Abs(Round(.Delta(0), 4)) = 5.7735 Then
32.              gg = gg & " S/tan(" & Format(.Angle, "0.0000") & ")"
33.            End If
34.            gg = gg & ","
35.            If Abs(Round(.Delta(1), 2)) = 10 Then
36.              gg = gg & .Delta(1) / Abs(.Delta(1)) & "* S"
37.            End If
38.            gg = gg & ")"
39.            Debug.Print gg
40.          Set objText = ThisDrawing.ModelSpace.AddText(tt, .StartPoint, 0.5)
41.        End With
42.       
43.   End Select
44.   Next ii
45.   
46. End Sub
47. Sub ms()
48.   S = 20
49.   Dim Hexagon(6) As Variant
50.   Dim pp(0 To 2) As Double, ppp(0 To 2) As Double
51.   Dim objLine As AcadLine
52.   
53.   Hexagon(0) = Array(-S / Tan(4.1888), -1 * S)
54.   Hexagon(1) = Array(-S / Tan(5.236), -1 * S)
55.   Hexagon(2) = Array(-2 * S / Tan(5.236), 0)
56.   Hexagon(3) = Array(1 * S / Tan(1.0472), 1 * S)
57.   Hexagon(4) = Array(1 * S / Tan(2.0944), 1 * S)
58.   Hexagon(5) = Array(2 * S / Tan(2.0944), 0)
59.   Hexagon(6) = Array(-S / Tan(4.1888), -1 * S)
60.   For ii = 0 To 5  'Step 2
61.     pp(0) = Hexagon(ii)(0): pp(1) = Hexagon(ii)(1)
62.     ppp(0) = Hexagon(ii + 1)(0): ppp(1) = Hexagon(ii + 1)(1)
63.     Set objLine = ThisDrawing.ModelSpace.AddLine(pp, ppp)
64.   Next ii
65. End Sub

Sub ls()   nn = ThisDrawing.ModelSpace.Count - 1   Dim objText As AcadText, objLine As AcadLine   Dim Xls As New XlsMdbTxtData   Dim xx As Worksheet      Set xx = Xls.ReturnxlSheet("Sheet1")   xx.Range("A:z").ClearContents   For ii = 0 To nn    Select Case ThisDrawing.ModelSpace.Item(ii).ObjectName      Case "AcDbText"        Set objText = ThisDrawing.ModelSpace.Item(ii)        aa = Split(objText.TextString, ",") '     For jj = 0 To UBound(aa)        'Set objLine = ThisDrawing.HandleToObject(aa(1))        With objLine     '     Debug.Print .Delta(0), .Delta(1)        End With '     Next jj     Case "AcDbLine"        Set objLine = ThisDrawing.ModelSpace.Item(ii)        With objLine          'Debug.Print Format(.Delta(0), "0.00"), Format(.Delta(1), "0.00"), .Angle                      xx.Cells(ii + 1, 1) = Format(.Delta(0), "0.0000")            xx.Cells(ii + 1, 2) = Format(.Delta(1), "0.0000")            xx.Cells(ii + 1, 3) = Format(.Angle, "0.0000")            gg = "Hexagon(" & ii            gg = gg & ")=array("            If Abs(Round(.Delta(0), 4)) = 5.7735 Then              gg = gg & " S/tan(" & Format(.Angle, "0.0000") & ")"            End If            gg = gg & ","            If Abs(Round(.Delta(1), 2)) = 10 Then              gg = gg & .Delta(1) / Abs(.Delta(1)) & "* S"            End If            gg = gg & ")"            Debug.Print gg          Set objText = ThisDrawing.ModelSpace.AddText(tt, .StartPoint, 0.5)        End With          End Select   Next ii    End Sub Sub ms()   S = 20   Dim Hexagon(6) As Variant   Dim pp(0 To 2) As Double, ppp(0 To 2) As Double   Dim objLine As AcadLine      Hexagon(0) = Array(-S / Tan(4.1888), -1 * S)   Hexagon(1) = Array(-S / Tan(5.236), -1 * S)   Hexagon(2) = Array(-2 * S / Tan(5.236), 0)   Hexagon(3) = Array(1 * S / Tan(1.0472), 1 * S)   Hexagon(4) = Array(1 * S / Tan(2.0944), 1 * S)   Hexagon(5) = Array(2 * S / Tan(2.0944), 0)   Hexagon(6) = Array(-S / Tan(4.1888), -1 * S)   For ii = 0 To 5  'Step 2     pp(0) = Hexagon(ii)(0): pp(1) = Hexagon(ii)(1)     ppp(0) = Hexagon(ii + 1)(0): ppp(1) = Hexagon(ii + 1)(1)     Set objLine = ThisDrawing.ModelSpace.AddLine(pp, ppp)   Next ii End Sub