正六形形顶点坐标
本帖最后由 作者 于 2008-9-8 23:08:44 编辑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
本帖最后由 作者 于 2008-9-8 23:09:12 编辑
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
页:
[1]