📄 tydf.frm
字号:
Begin VB.Label Label5
BackStyle = 0 'Transparent
Caption = "板 厚 G"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 5400
TabIndex = 9
Top = 3120
Width = 1335
End
Begin VB.Label Label4
BackStyle = 0 'Transparent
Caption = "高 度 H"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 5400
TabIndex = 7
Top = 2400
Width = 1455
End
Begin VB.Label Label3
BackStyle = 0 'Transparent
Caption = "短 边 B"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 5400
TabIndex = 5
Top = 1680
Width = 1455
End
Begin VB.Label Label2
BackStyle = 0 'Transparent
Caption = "长 边 A"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 5400
TabIndex = 3
Top = 960
Width = 1575
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "圆 中 径 D"
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 5400
TabIndex = 1
Top = 240
Width = 1455
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim acadapp As AcadApplication
Private Sub Command1_Click()
' 程序用两条优化多段线来画展开图，也可改用一条优化多段线来画(注释请与书中的插图配合)
Public Sub Main()
Const PI As Double = 3.1415926535
On Error Resume Next
' 得到图3.27中的J点坐标
Dim pt0 As Variant, ptBase(2) As Double
pt0 = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入“天圆地方”展开图下边中点 <0,0>:")
If Err Then
Err.Clear
ptBase(0) = 0: ptBase(1) = 0
Else
ptBase(0) = pt0(0): ptBase(1) = pt0(1)
End If
' 获得天圆地方实体的半径、高度和底面边长
Dim radius As Double, height As Double, length As Double
RETRY:
radius = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“天圆”的半径:")
height = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“天圆地方”的高度:")
length = ThisDrawing.Utility.GetDistance(ptBase, vbCrLf & "请输入“地方”的边长:")
If radius <= 0 Or height <= 0 Or length <= 0 Then
MsgBox ("输入数据必须为正，请重新输入！")
GoTo RETRY
End If
'先画展开图中的“曲线”
' 得到图3.27中的A点
Dim pt1 As Variant, pt2 As Variant
pt1 = ThisDrawing.Utility.PolarPoint(ptBase, 0, -0.5 * length)
' 得到图3.27中的B点
pt2 = ThisDrawing.Utility.PolarPoint(ptBase, 0, 0.5 * length)
' 得到图3.27中的AE、BE的长度
Dim dist0 As Double
dist0 = Sqr(0.25 * length ^ 2 + (0.5 * length - radius) ^ 2 + height ^ 2)
' 得到图3.27中的角EAJ，为EH段各等分点坐标的计算作准备
Dim ang1, ang2 As Double
ang1 = Atn((Sqr(height ^ 2 + (0.5 * length - radius) ^ 2) / (0.5 * length)))
' 角EAJ的补角，为EF段各等分点坐标的计算作准备
ang2 = PI - ang1
Dim dist(90) As Double, i As Integer, tmp As Double
Dim angle1(90) As Double, angle2(90) As Double
For i = 0 To 90
If i = 0 Then ' 初值
dist(i) = dist0
angle1(i) = ang1
angle2(i) = ang2
Else
' 计算与A点与EH段各等分点、B点与EF段各等分点的距离
dist(i) = Sqr((height ^ 2 + (0.5 * length - radius * Sin(i * PI / 180)) ^ 2) _
+ (0.5 * length - radius * Cos(i * PI / 180)) ^ 2)
' 计算与A点与EH段各等分点连线和X轴正向的夹角
tmp = (dist(i) ^ 2 + dist(i - 1) ^ 2 - (radius * PI / 180) ^ 2) / (2 * dist(i) * dist(i - 1))
angle1(i) = angle1(i - 1) + Atn(-tmp / Sqr(-tmp * tmp + 1)) + 2 * Atn(1)
' 计算与B点与EF段各等分点连线和X轴正向的夹角
angle2(i) = angle2(i - 1) - Atn(-tmp / Sqr(-tmp * tmp + 1)) - 2 * Atn(1)
End If
Next
' 计算组成展开图的曲线部分的各点的坐标
Dim point1(721) As Double
For i = 0 To 2 * 360 + 1 Step 2
If i < 180 Then
' 计算EH段各等分点的坐标
point1(i + 180) = pt1(0) + dist(90 - i / 2) * Cos(angle1(90 - i / 2))
point1(i + 181) = pt1(1) + dist(90 - i / 2) * Sin(angle1(90 - i / 2))
ElseIf i < 360 Then
' 计算EF段各等分点的坐标
point1(i + 180) = pt2(0) + dist(i / 2 - 90) * Cos(angle2(i / 2 - 90))
point1(i + 181) = pt2(1) + dist(i / 2 - 90) * Sin(angle2(i / 2 - 90))
ElseIf i <= 540 Then
' 计算FG段各等分点的坐标
tmp = (dist(90) ^ 2 + 0.25 * length ^ 2 - height ^ 2 - (0.5 * length - radius) ^ 2) / (dist(90) * length)
Dim ang3 As Double
ang3 = angle2(90) - Atn(-tmp / Sqr(-tmp * tmp + 1)) - 2 * Atn(1)
Dim pt3(2) As Double
pt3(0) = pt2(0) + length * Cos(ang3)
pt3(1) = pt2(1) + length * Sin(ang3)
point1(i + 180) = pt3(0) + dist(i / 2 - 180) * Cos(angle2(i / 2 - 180) + ang3)
point1(i + 181) = pt3(1) + dist(i / 2 - 180) * Sin(angle2(i / 2 - 180) + ang3)
Else
' 计算HG段各等分点的坐标
Dim ang4 As Double
ang4 = angle1(90) + Atn(-tmp / Sqr(-tmp * tmp + 1)) + 2 * Atn(1)
Dim pt4(2) As Double
pt4(0) = pt1(0) + length * Cos(ang4)
pt4(1) = pt1(1) + length * Sin(ang4)
point1(0) = pt4(0) + dist(0) * Cos(angle1(90) + ang4 - PI)
point1(1) = pt4(1) + dist(0) * Sin(angle1(90) + ang4 - PI)
point1(i - 540) = pt4(0) + dist(360 - i / 2) * Cos(angle1(360 - i / 2) + ang4 - PI)
point1(i - 539) = pt4(1) + dist(360 - i / 2) * Sin(angle1(360 - i / 2) + ang4 - PI)
End If
Next
Dim objPoly1 As AcadLWPolyline
Set objPoly1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(point1)
' 再画展开图中的“折线”
Dim point2(15) As Double
point2(0) = point1(0)
point2(1) = point1(1)
Dim ang5 As Double
ang5 = 2 * ang4 - PI
point2(2) = pt4(0) + 0.5 * length * Cos(ang5)
point2(3) = pt4(1) + 0.5 * length * Sin(ang5)
point2(4) = pt4(0)
point2(5) = pt4(1)
point2(6) = pt1(0)
point2(7) = pt1(1)
point2(8) = pt2(0)
point2(9) = pt2(1)
point2(10) = pt3(0)
point2(11) = pt3(1)
Dim ang6 As Double
ang6 = 2 * ang3
point2(12) = pt3(0) + 0.5 * length * Cos(ang6)
point2(13) = pt3(1) + 0.5 * length * Sin(ang6)
point2(14) = point1(720)
point2(15) = point1(721)
Dim objPoly2 As AcadLWPolyline
Set objPoly2 = ThisDrawing.ModelSpace.AddLightWeightPolyline(point2)
ZoomExtents
End Sub
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Set acadapp = CreateObject("autocad.application")
acadapp.Visible = True
End Sub
Private Sub Command2_Click()
End
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -