天体运行程序代码

'以下是窗体代码，在 VB6.0 调试通过：

'一、必须在引用中勾选：OLE Automatuon，否则 Img As StdPicture 语句会出错

'二、需在窗体放置以下 4 个控件，所有控件不用设置任何属性，均采用默认设置：

' Picture1，Picture2，Timer1，Command1（注意：在属性窗口将 Command1 的 Index 属性设置为 0）

'三、为窗体添加一个名为 mFast 的菜单，再为 mFast 添加一个名为 mmFast 的下级子菜单，并将 mmFast 的索引设置为 0。

' 即：mmFast 是以序号 0 开头的菜单数组控件的第一个。

Dim ctD() As tyD, ctDs As Long, ctB() As Long, ctCenter As Long, ct3D As Boolean

Dim ctBi As Single, ctV As Single, ctBW As Long, ctSeeJ As Long, ctTrack As Boolean

Dim ctSeeBi As Single, ctSet As MenuSet, ctShowXX As Boolean, ctColorXX As Boolean

Dim ctP180 As Single, ctP90 As Single, ctP270 As Single, ctP360 As Single

Dim ctSmall() As tySmall, ctSmalls As Long, ctX() As tyX, ctXs As Long, ctSize

As Long

'定义表示星星的数据类型

Private Type tyX

x As Single

y As Single

r As Long

t As Long

Se As Long

End Type

'定义表示天体的数据类型

Private Type tyD

Ji As Long '天体级别

Cap As String '天体名称

r As Long '天体半径（像素，下同）

a As Single '轨道：横半径

b As Single '轨道：纵半径

C As Single '轨道：焦点

e As Single '轨道：偏心率

Dip As Single '轨道：倾角

IsHui As Boolean '是否彗星

IsSmall As Boolean '是否小行星

Father As Long '父天体序号：轨道焦点上的天体

Se As Long '颜色

V As Single '运行角速度

Jiao As Single '某时刻的与父天体连线角度

x As Single '天体当前坐标

y As Single

xUp As Single '上一时刻坐标

yUp As Single

Visible As Boolean '是否显示：球体

ShowCap As Boolean '是否显示：标题

GuiDao As Boolean '是否显示：轨道

GuiJi As Boolean '是否显示：轨迹

Img As StdPicture '天体 3D 图像

LineFu As Boolean '与父天体的中心连线

End Type

'定义小行星类型

Private Type tySmall

a As Single '轨道：横半径

b As Single '轨道：纵半径

Jiao As Single

End Type

Enum MenuSet

'以下为 选项菜单 标示

ms_Size = -11 '设置字体大小

ms_RunStop = -10 '开始/暂停

ms_3D = -9 '3D 立体图像

ms_ColorXX = -8 '是否显彩色星星

ms_ShowXX = -7 '是否显示闪烁的星星

ms_DefSet = -6 '默认设置

ms_Track = -5 '轨迹：显示/隐藏

'以下为 菜单全选、全不选

ms_Wei = -4

ms_Xing = -3

ms_All = -2

ms_NoAll = -1

'以下为 按钮 标示

ms_Step = 0 '步进，下一位置

ms_UnRun '后退

ms_Opt '显示选项菜单

ms_Center '参照系

ms_Visible '天体：显示/隐藏

ms_ShowCap '天体名称

ms_GuiDao '轨道

ms_GuiJi '轨迹

ms_LineFu '与父天体的中心连线

ms_Bi '缩放比

ms_V '速度

ms_SeeJ '视角

End Enum

Private Declare Function GdiTransparentBlt Lib \"gdi32\" (ByVal hdc1 As Long, ByVal X1 As Long, ByVal y1 As Long, ByVal W1 As Long, ByVal H1 As Long, ByVal Hdc2 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal W2 As Long, ByVal H2 As Long, ByVal Color As Long) As Long

Private Sub Form_Load()

Me.ScaleMode = 3: Me.Caption = \"太阳系行星运行演示\"

mFast.Visible = False: ctP180 = 3.1415926

ctP90 = ctP180 * 0.5: ctP360 = ctP180 * 2: ctP270 = ctP90 * 3

Timer1.Interval = 25: Timer1.Enabled = True

Call Init

'窗体大小为屏幕的 3/4，居中

Me.Move Screen.Width * 0.1, Screen.Height * 0.1, Screen.Width * 0.8, Screen.Height * 0.8

End Sub

Private Sub Form_Resize()

Dim I As Long, L As Single, t As Single, H As Single, H1 As Single, W As Single

'设置控件位置

H1 = Me.TextHeight(\"A\"): L = H1 * 0.3: t = L

L = 3

For I = 0 To Command1.Count - 1

W = Me.TextWidth(Command1(I).Caption & \"ab\")

Command1(I).Move L, t, W, H1 * 2

L = L + W + 3

Next

t = t * 2 + Command1(0).Height: H = Me.ScaleHeight - t

If H > 0 Then Picture1.Move 0, t, Me.ScaleWidth, H

'将 Picture1 的中心设置为坐标原点

Picture1.ScaleMode = 3

Picture1.ScaleLeft = -Picture1.ScaleWidth * 0.5

Picture1.ScaleTop = -Picture1.ScaleHeight * 0.5

Picture1.Cls

Call Run1

End Sub

Private Sub Init()

'初始化天体参数

Dim I As Long, K As Long, S As Long

ctBW = 0 ' 40 '四周边界空白区，仅用于调试。调试完毕应设为 0 。调试代码****

Picture1.AutoRedraw = True: Picture1.BackColor = &H180000

Picture1.ScaleMode = 3

Picture2.BorderStyle = 0: Picture2.ScaleMode = 3

Picture2.AutoRedraw = True: Picture2.Visible = False

Picture2.BackColor = Picture1.BackColor

ctSize = 9

ctCenter = 0: ctBi = 1: ctV = 1 '参照系（位于中心的天体），缩放比列，速度

ctSeeJ = 30: ctSeeBi = ctSeeJ / 90 '视点角度，视角比

ctTrack = False '默认：不显示运动轨迹（不是轨道）

ct3D = True '默认：3D 立体图像

ctShowXX = True '默认：显示闪烁的星星

Call RndXX '初始闪烁的星星

'添加按钮

KjCls Command1: Command1(0).BackColor = Me.BackColor

KjAdd Command1, \"选项(&O)\设置选项\"

KjAdd Command1, \"进(&W)\步进，运行到下一位置\"

KjAdd Command1, \"退(&T)\步进，后退到上一位置\"

KjAdd Command1, \"参照系(&C)\设置参照系（位于中心的天体）\"

KjAdd Command1, \"天体(&X)\天体：显示/隐藏\"

KjAdd Command1, \"名称(&M)\天体名称：显示/隐藏\"

KjAdd Command1, \"轨道(&D)\天体运行轨道：显示/隐藏\"

KjAdd Command1, \"轨迹(&J)\运动轨迹，选中“选项-显示运动轨迹”时有效\"

KjAdd Command1, \"连线(&L)\与父天体的中心连线，同时显示对应天体时有效\"

KjAdd Command1, \"速度(&V)\设置速度\"

KjAdd Command1, \"视角(&S)\设置视点角度\"

KjAdd Command1, \"缩放(&F)\设置缩放比列\"

'添加天体（演示比列状态下），半径以 100 像素为标准

'参数依次是：名称，父天体名称，天体半径，轨道长半轴，轨道偏心率，运动角速度，轨道倾角，天体颜色，初始角度，彗星否

ctDs = -1: ReDim ctD(0 To 0)

AddCircle \"太阳\

AddCircle \"水星\

AddCircle \"金星\

AddCircle \"地球\

AddCircle \"月亮\地球\

' ctD(CapToNum(\"月亮\")).IsSmall = True '调试代码****

AddCircle \"嫦娥1号\月亮\

AddCircle \"火星\

AddCircle \"火卫1\火星\

AddCircle \"火卫2\火星\

AddCircle \"小行星\'小行星轨道倾角多少？

ctD(CapToNum(\"小行星\")).IsSmall = True

AddCircle \"木星\

AddCircle \"木卫1\木星\

AddCircle \"木卫2\木星\

AddCircle \"木卫3\木星\

AddCircle \"木卫4\木星\

AddCircle \"土星\

AddCircle \"土卫6\土星\

AddCircle \"天王星\

AddCircle \"天卫3\天王星\

AddCircle \"天卫4\天王星\

AddCircle \"海王星\

AddCircle \"海卫1\海王星\

AddCircle \"哈雷彗星\

ctD(CapToNum(\"哈雷彗星\")).IsHui = True

'初始化小行星

For K = 0 To ctDs

If ctD(K).IsSmall Then

ctD(K).GuiDao = False: ctSmalls = 90 '小行星 总个数

S = ctD(K).b * 0.07 ' 12 '小行星带宽度

ReDim ctSmall(0 To ctSmalls)

ctSmall(0).a = ctD(K).a: ctSmall(0).b = ctD(K).b

For I = 1 To ctSmalls

Randomize I

ctSmall(I).a = Rnd * S - S * 0.5 + ctD(K).a

ctSmall(I).b = Rnd * S - S * 0.5 + ctD(K).b

ctSmall(I).Jiao = Rnd * ctP360

Next

Exit For

End If

Next

Call SortB '将天体按轨道短半径从小到大排序，用数组 ctB() 记忆排序结果（天体序号）

Call DrawAllBall '绘制所有天体的 3D 立体图像，存入天体变量 ctD(I).Img

Call Form_Resize

End Sub

Private Sub RndXX()

Dim I As Long, J As Long

ctXs = 90 '闪烁的星星个数

ReDim ctX(0 To ctXs)

For I = 0 To ctXs

Randomize I

ctX(I).x = Rnd * Screen.Width / Screen.TwipsPerPixelX - Screen.Width / Screen.TwipsPerPixelX * 0.5

ctX(I).y = Rnd * Screen.Height / Screen.TwipsPerPixelY - Screen.Height / Screen.TwipsPerPixelY * 0.5

Randomize

ctX(I).r = 2 * Rnd: ctX(I).t = 6 * Rnd

If ctColorXX Then

ctX(I).Se = &HFFFFFF * Rnd

Else

J = 255 * Rnd: ctX(I).Se = RGB(J, J, J)

End If

Next

End Sub

Private Sub DrawAllBall(Optional I As Long = -1, Optional ShowInf As Boolean)

'绘制所有天体的 3D 球形图像

Dim r As Long, nStr As String, x As Single, y As Single

If I > -1 Then GoSub SubDraw1: Exit Sub

Me.MousePointer = 11

Picture1.Font.Size = 32

For I = 0 To ctDs

If ShowInf Then

If I = 0 Then nStr = \"1%\" Else nStr = Int(I / ctDs * 100) & \"%\"

nStr = \"正在更新图像 \" & vbCrLf & nStr

x = -Picture1.TextWidth(nStr) * 0.5: y = -Picture1.TextHeight(nStr) * 0.5

Picture1.Line (x, y)-Step(-x * 2, -y * 2), &H776633, BF

Picture1.CurrentX = x: Picture1.CurrentY = y

Picture1.Print nStr

Picture1.Refresh

End If

GoSub SubDraw1

Next

Picture2.Cls

Picture2.Move 0, 0, 2, 2

Me.MousePointer = 0

' doe

Exit Sub

SubDraw1:

r = ctBi * ctD(I).r

If r < 2 Then r = 2

DrawBall r, r, r, &HFFFFFF, ctD(I).Se

Set ctD(I).Img = Picture2.Image

Return

End Sub

Private Sub DrawBall(r As Long, ByVal x0 As Long, ByVal y0 As Long, Se1 As Long, Se2 As Long)

'画一个立体球图案

Dim GDs As Long, r0 As Single, rG As Single

Dim StepR As Single, StepG As Single, StepB As Single

Dim x As Long, y As Long, X1 As Long, y1 As Long, Bi As Single

Dim R1 As Long, G1 As Long, B1 As Long, R2 As Long, G2 As Long, B2 As Long

GetRGB Se1, R1, G1, B1: GetRGB Se2, R2, G2, B2

Picture2.Cls

Picture2.Width = r * 2 + 1: Picture2.Height = r * 2 + 1

GDs = 6 '与背景的过渡带

X1 = r * 0.6: y1 = r * 0.6 '高光中心点

rG = Sqr((X1 - x0) ^ 2 + (y1 - y0) ^ 2) '高光 与 中心 的距离

StepR = R2 - R1: StepG = G2 - G1: StepB = B2 - B1

For y = 0 To Picture2.ScaleHeight

For x = 0 To Picture2.ScaleWidth

r0 = Sqr((x - x0) ^ 2 + (y - y0) ^ 2)

If r0 > r Then GoTo Next1 '在球外

r0 = Sqr((x - X1) ^ 2 + (y - y1) ^ 2)

Bi = r0 / (r + rG)

If Bi > 1 Then GoTo Next1

Picture2.PSet (x, y), RGB(R1 + StepR * Bi, G1 + StepG * Bi, B1 + StepB * Bi)

Next1:

Next

Next

' Picture2.Visible = True

End Sub

Private Sub Command1_Click(Index As Integer)

Dim I As Long, J As Long, nStr As String, Zu As Variant

Dim nSel As Long, nAll As Long, nNo As Long

ctSet = Val(Command1(Index).Tag) '得到按钮标示

KjCls mmFast '清除菜单

'装载快捷菜单，并勾选选定项目

Select Case ctSet

Case ms_Step '步进，前进到下一位置

If Not Timer1.Enabled Then Run1 True

Timer1.Enabled = False

Case ms_UnRun '步进，后退到下一位置

If Not Timer1.Enabled Then Run1 True, True

Timer1.Enabled = False

Case ms_Bi '缩放比列

Zu = Array(0.1, 0.2, 0.3, 0.4, \"-\8, 10)

KjAddZu mmFast, Zu, ctBi, \" 倍\": GoTo Show1 '添加数组菜单，并勾选 ctBi

Case ms_SeeJ '视点角度

Zu = Array(\"90 度（天球北极）\度\度\度\度\度\

\"40 度\度\度\度\度\度\度\度\度（天球赤道）\")

KjAddZu mmFast, Zu, ctSeeJ: GoTo Show1 '添加数组菜单，并勾选 ctSeeJ

Case ms_V '速度

Zu = Array(0.1, 0.2, 0.3, 0.4, \"-\7.5, 10)

KjAddZu mmFast, Zu, ctV, \" 倍\": GoTo Show1

Case ms_Opt '选项

I = KjAdd(mmFast, \"状态\

mmFast(I).Checked = Timer1.Enabled

If Timer1.Enabled Then mmFast(I).Caption = \"(&Z) 状态：运行中\" Else mmFast(I).Caption = \"(&Z) 状态：已暂停\"

mmFast(I).Caption = mmFast(I).Caption & \"（双击图像区可改变状态）\"

I = KjAdd(mmFast, \"(&D) 用 3D 立体图像显示天体\ms_3D):

mmFast(I).Checked = ct3D

I = KjAdd(mmFast, \"(&X) 闪烁的星星\ms_ShowXX): mmFast(I).Checked = ctShowXX

I = KjAdd(mmFast, \"(&S) 彩色小星星（同时选中“闪烁的星星”时有效）\ms_ColorXX): mmFast(I).Checked = ctColorXX

I = KjAdd(mmFast, \"(&G) 显示运动轨迹\ms_Track): mmFast(I).Checked = ctTrack

KjAdd mmFast, \"(&F) 字体大小：\" & ctSize & \" ...\

KjAdd mmFast, \"-\"

KjAdd mmFast, \"(&M) 恢复默认设置\

GoTo Show1

Case Else '装载天体名称

For I = 0 To ctDs

J = Ji(I) '天体 I 的级别

KjAdd mmFast, \"&\" & I & \" \" & String(J * 2, \" \") & ctD(I).Cap

Next

End Select

'勾选选定天体

Select Case ctSet

Case ms_Center: mmFast(ctCenter).Checked = True: GoTo Show1 '参照系（中心天体）

Case ms_ShowCap '显示天体名称

For I = 0 To ctDs: mmFast(I).Checked = ctD(I).ShowCap: Next

Case ms_Visible '天体 是否可见

For I = 0 To ctDs: mmFast(I).Checked = ctD(I).Visible: Next

Case ms_GuiDao '轨道

For I = 0 To ctDs: mmFast(I).Checked = ctD(I).GuiDao: Next

Case ms_LineFu '连线

For I = 0 To ctDs: mmFast(I).Checked = ctD(I).LineFu: Next

Case ms_GuiJi '轨迹

For I = 0 To ctDs: mmFast(I).Checked = ctD(I).GuiJi: Next

Case ms_Opt '选项

Case Else: Exit Sub

End Select

KjAdd mmFast, \"-\"

nAll = KjAdd(mmFast, \"全选\

KjAdd mmFast, \"行星\

KjAdd mmFast, \"卫星\

nNo = KjAdd(mmFast, \"全不选\

For I = 0 To ctDs

If mmFast(I).Checked Then nSel = nSel + 1

Next

If nSel = 0 Then mmFast(nNo).Checked = True: mmFast(nNo).Enabled = False

If nSel = ctDs + 1 Then mmFast(nAll).Checked = True: mmFast(nAll).Enabled = False

Show1:

Command1(Index).BackColor = &HFFCCCC '将选中按钮设置为淡蓝色

Me.PopupMenu mFast, , Command1(Index).Left, Command1(Index).Top Command1(Index).Height - 3

Command1(Index).BackColor = Me.BackColor

End Sub

Private Sub mmFast_Click(Index As Integer)

'通过快捷菜单设置天体有关参数

Dim nTag As MenuSet, I As Long, nStr As String

nTag = Val(mmFast(Index).Tag) '菜单标示：ms_All 全选，ms_NoAll 全不选

+

Select Case ctSet 'ctSet：按钮标示，在 Command1_Click 中设置

Case ms_Opt '选项 菜单

Select Case nTag

Case ms_RunStop: Timer1.Enabled = Not Timer1.Enabled '运动/暂停

Case ms_ShowXX: ctShowXX = Not ctShowXX '显示闪烁的星星

Case ms_ColorXX: ctColorXX = Not ctColorXX: Call RndXX '重新初始闪烁的星星

Case ms_3D: ct3D = Not ct3D '3D 立体图像

Case ms_Track: ctTrack = Not ctTrack '运动轨迹

Case ms_DefSet: Call Init '默认设置

Case ms_Size '设置字体

nStr = InputBox(\"设置天体名称字体大小，范围 3-300：\字体大小\

If nStr = \"\" Then Exit Sub

I = Val(nStr)

If I < 3 Or I > 300 Then Exit Sub

ctSize = I

End Select

Case ms_V '速度

ctV = Val(mmFast(Index).Caption)

Case ms_SeeJ '视点角度

ctSeeJ = Val(mmFast(Index).Caption) '视点角度

ctSeeBi = ctSeeJ / 90 '视角比

For I = 0 To ctDs: ctD(I).xUp = 0: ctD(I).yUp = 0: Next

Case ms_Bi '缩放比列

ctBi = Val(mmFast(Index).Caption)

For I = 0 To ctDs: ctD(I).xUp = 0: ctD(I).yUp = 0: Next

Call DrawAllBall(, True) '绘制所有天体的球形图像

Case ms_Center '参照系（中心天体）

ctCenter = Index

For I = 0 To ctDs: ctD(I).xUp = 0: ctD(I).yUp = 0: Next

Case ms_ShowCap '显示名称

If Index <= ctDs Then

ctD(Index).ShowCap = Not ctD(Index).ShowCap

Else

For I = 0 To ctDs: ctD(I).ShowCap = OptSet(I, nTag): Next

End If

Case ms_Visible '天体 是否可见

If Index <= ctDs Then

ctD(Index).Visible = Not ctD(Index).Visible

Else

For I = 0 To ctDs: ctD(I).Visible = OptSet(I, nTag): Next

End If

Case ms_GuiDao '轨道

If Index <= ctDs Then

ctD(Index).GuiDao = Not ctD(Index).GuiDao

Else

For I = 0 To ctDs: ctD(I).GuiDao = OptSet(I, nTag): Next

End If

Case ms_LineFu '连线

If Index <= ctDs Then

ctD(Index).LineFu = Not ctD(Index).LineFu

Else

For I = 0 To ctDs: ctD(I).LineFu = OptSet(I, nTag): Next

End If

Case ms_GuiJi '轨迹

If Index <= ctDs Then

ctD(Index).GuiJi = Not ctD(Index).GuiJi

Else

For I = 0 To ctDs: ctD(I).GuiJi = OptSet(I, nTag): Next

End If

End Select

Picture1.Cls

Call Run1

End Sub

Private Function OptSet(I As Long, nMenu As MenuSet) As Boolean

If nMenu = ms_NoAll Then OptSet = False '全不选

If nMenu = ms_All Then OptSet = True '全选

If nMenu = ms_Xing Then OptSet = ctD(I).Ji = 0 '所有行星

If nMenu = ms_Wei Then OptSet = ctD(I).Ji > 0 '所有卫星

End Function

Private Sub AddCircle(nName As String, nFather As String, r As Long, a As Single, e As Single, V As Single, _

Optional Dip As Single, Optional Se As Long = 255, Optional Jiao As Single)

'添加一个天体，参数依次是：

' 名称，父天体名称，天体半径，轨道长半轴，轨道偏心率，运动角速度，轨道倾角，天体颜色，初始角度

Dim I As Long, J As Long

a = a * 100 '半径以 100 像素为标准

ctDs = ctDs + 1: ReDim Preserve ctD(0 To ctDs)

'设置父天体编号

For I = 0 To ctDs - 1

If LCase(ctD(I).Cap) = LCase(nFather) Then ctD(ctDs).Father = I: Exit For

Next

ctD(ctDs).Cap = nName: ctD(ctDs).r = r: ctD(ctDs).a = a

ctD(ctDs).C = a * e: ctD(ctDs).b = Sqr(a ^ 2 - ctD(ctDs).C ^ 2)

ctD(ctDs).Se = Se: ctD(ctDs).V = JiaoOrFu(V)

ctD(ctDs).xUp = 0: ctD(ctDs).yUp = 0: ctD(ctDs).Dip = JiaoOrFu(Dip)

ctD(ctDs).GuiDao = True: ctD(ctDs).Visible = True: ctD(ctDs).Ji = Ji(ctDs)

Randomize

' If Jiao = 0 Then ctD(ctDs).Jiao = Rnd * ctP360 Else ctD(ctDs).Jiao = JiaoOrFu(Jiao)

End Sub

Private Function JiaoOrFu(S As Single, Optional ToJiao As Boolean) As Single

'角度与弧度的转换 弧度转角度 角度转弧度

If ToJiao Then JiaoOrFu = S / ctP180 * 180 Else JiaoOrFu = S / 180 * ctP180

End Function

Private Function KjAddZu(Kj, Zu As Variant, ByVal CheckStr As String, Optional SameStr As String)

'添加一个数组菜单，并勾选标题为 CheckStr 的条目

Dim I As Long, J As Long, nCap As String

If Left(CheckStr, 1) = \".\" Then CheckStr = \"0\" & CheckStr

For I = LBound(Zu) To UBound(Zu)

nCap = Zu(I)

If Left(nCap, 1) = \".\" Then nCap = \"0\" & nCap

If nCap = \"-\" Then J = KjAdd(Kj, nCap) Else J = KjAdd(Kj, nCap & SameStr)

' If LCase(CheckStr) = LCase(nCap) Then Kj(J).Checked = True

If Val(CheckStr) = Val(nCap) Then Kj(J).Checked = True

Next

End Function

Private Function KjAdd(Kj, nCap As String, Optional nTag As String, Optional nNote As String) As Long

'为数组控件添加一个成员，返回新添加的成员序号

Dim I As Long

I = Kj.Count - 1

If Kj(I).Caption <> \"\" Then I = I + 1: Load Kj(I)

On Error Resume Next

Kj(I).Checked = False

Kj(I).Caption = nCap

Kj(I).Tag = nTag

Kj(I).ToolTipText = nNote

Kj(I).Visible = True

KjAdd = I

End Function

Private Function KjCls(Kj) As Long

'卸载数组控件的所有成员(0号除外)

Dim I As Long

For I = Kj.Count - 1 To 1 Step -1

Unload Kj(I)

Next

On Error Resume Next

Kj(0).Caption = \"\"

Kj(0).Checked = False

End Function

Private Function CapToNum(nCap As String) As Long

'返回名称为 nCap 的天体编号

Dim I As Long

For I = 0 To ctDs

If LCase(ctD(I).Cap) = LCase(nCap) Then CapToNum = I: Exit Function

Next

CapToNum = -1

End Function

Private Function Ji(ByVal D As Long) As Long

'返回天体级别（编号为 D ）

Do

If ctD(D).Father = 0 Then Exit Do

D = ctD(D).Father: Ji = Ji + 1

Loop

End Function

Private Sub Picture1_DblClick()

Timer1.Enabled = Not Timer1.Enabled '运动/暂停

Run1

End Sub

Private Sub Timer1_Timer()

Run1 True

End Sub

Private Sub Run1(Optional nRun As Boolean, Optional UnRun As Boolean)

'显示一次运行的瞬时状态

Dim wB As Single, hB As Single, x As Single, y As Single

Dim I As Long, CenX As Single, CenY As Single

'计算天体瞬时位置：相对与父天体的角度：上面（后面）

For I = 0 To ctDs

If nRun Then

If UnRun Then x = ctD(I).Jiao - ctD(I).V * ctV Else x = ctD(I).Jiao + ctD(I).V * ctV

ctD(I).Jiao = In360(x) '保证数值在 0 到 ctP360 的范围内

End If

' If I = CapToNum(\"地球\") Then Me.Caption = ctD(I).Jiao / ctP180 * 180 '调试代码****

x = ctBi * (ctD(I).a * Sin(ctD(I).Jiao) + ctD(I).C)

y = ctBi * ctSeeBi * (ctD(I).b * Cos(ctD(I).Jiao))

Zhuan ctD(I).Dip, x, y '叠加轨道倾角

'加上父天体的位置

ctD(I).x = x + ctD(ctD(I).Father).x: ctD(I).y = y + ctD(ctD(I).Father).y

Next

'移位参照系

CenX = ctD(ctCenter).x: CenY = ctD(ctCenter).y '中心天体位置

For I = 0 To ctDs

ctD(I).x = CenX - ctD(I).x: ctD(I).y = CenY - ctD(I).y

Next

ctBW = 0 '四周边界空白区。调试代码****

wB = Picture1.ScaleWidth * 0.5 - ctBW: hB = Picture1.ScaleHeight * 0.5 - ctBW '可视区大小

'Picture1.Visible = False '调试代码****

If Not ctTrack Then Picture1.Cls '保留轨迹，不擦除上次图像

If ctBW > 0 Then '可见区方框，调试代码****

x = 9 * ctBi: If x <> 9 Then x = 9

Picture1.Font.Size = x: Picture1.ForeColor = &HFFFFFF

Picture1.DrawWidth = 1

Picture1.Line (-wB, -hB)-(wB, hB), , B

End If

'显示闪烁的星星

If ctShowXX Then DrawXX '画闪烁的行星

Picture1.ForeColor = &HFFFFFF: Picture1.Font.Size = ctSize

Draw1 0, wB, hB '用递归调用法，画出所有天体

' Picture1.Refresh: Picture1.Visible = True '调试代码****

If Timer1.Enabled Then Exit Sub

Picture1.CurrentX = Picture1.ScaleLeft + 6: Picture1.CurrentY Picture1.ScaleTop + 6

Picture1.ForeColor = &HFFFFFF: Picture1.Font.Size = 21

Picture1.Print \"已暂停\"

End Sub

Private Sub Draw1(I As Long, wB As Single, hB As Single)

=

'画一个天体

Dim K As Long, x As Single, y As Single, r As Single

Dim J As Single, S As Long, InD As Boolean, InD1 As Boolean

' nStr = ctD(I).Cap '调试代码****

'递归调用：在画 I 之前，先画 I 上面（后面）的卫星 和 小行星

For S = ctDs To 0 Step -1

K = ctB(S) '排序后的天体编号，先画短半径 b 大的天体

If I <> K And ctD(K).Father = I Then

If ctD(K).GuiDao Then GuiDao K '画轨道：上半部分

If ctD(K).IsSmall And ctD(K).Visible Then DrawSmall K '画小行星 上半部

J = ctD(K).Jiao

If J <= ctP90 Or J >= ctP270 Then Draw1 K, wB, hB

End If

Next

x = ctD(I).x: y = ctD(I).y: r = ctBi * ctD(I).r

If r < 2 Then r = 2

InD = Not (x + r < -wB Or x - r > wB Or y + r < -hB Or y - r > hB) '是否在可见区内

'画运动轨迹：上一个点和当前点的连线：有一个在可见区内

If ctTrack Then

InD1 = Not (ctD(I).xUp + r < -wB Or ctD(I).xUp - r > wB Or ctD(I).yUp + r < -hB Or ctD(I).yUp - r > hB)

If (InD Or InD1) And ctD(I).xUp <> 0 And ctD(I).yUp <> 0 Then

If ctBi < 1 Then Picture1.DrawWidth = 1 Else Picture1.DrawWidth = ctBi * 2

If ctD(I).GuiJi Then Picture1.Line (x, y)-(ctD(I).xUp, ctD(I).yUp), ctD(I).Se

Picture1.DrawWidth = 1

End If

End If

ctD(I).xUp = x: ctD(I).yUp = y '记忆上次位置

'画天体 I 的图像

If InD And ctD(I).Visible Then

If Not ctD(I).IsSmall Then

If ctD(I).IsHui Then Tail I, x, y '画彗尾

DrawImg I, x, y, r '画天体图像

'Picture1.Refresh '调试代码****

If ctD(I).LineFu Then

On Error Resume Next

Picture1.Line (x, y)-(ctD(ctD(I).Father).x, ctD(ctD(I).Father).y), ctD(I).Se '中心连线

On Error GoTo 0

End If

End If

End If

'递归调用：在画 I 之后，再画 I 下面（前面）的卫星

For S = 0 To ctDs

K = ctB(S) '排序后的天体编号，先画短半径 b 小的天体

If I <> K And ctD(K).Father = I Then

If ctD(K).GuiDao Then GuiDao K, True '画轨道：下半部分

If ctD(K).IsSmall And ctD(K).Visible Then DrawSmall K, True '画小行星 下半部

J = ctD(K).Jiao

If J > ctP90 And J < ctP270 Then Draw1 K, wB, hB

End If

Next

'显示天体名称

If ctD(I).ShowCap Then

If I = 0 Then

ShowStr wB, hB, ctD(I).Cap, x, y - Picture1.TextHeight(\"A\") * 0.5, True, 0

Else

ShowStr wB, hB, ctD(I).Cap, x, y + r + 3, True

End If

End If

End Sub

Private Sub DrawSmall(I As Long, Optional InDown As Boolean)

'画小行星

Dim K As Long, x As Single, y As Single, W1 As Single, H1 As Single

Dim Jiao As Single, J As Single, Se As Long, C As Single

Dim CenX As Single, CenY As Single, InD As Boolean

Jiao = ctD(I).Jiao: Se = ctD(I).Se: C = ctD(I).C

CenX = ctD(ctD(I).Father).x: CenY = ctD(ctD(I).Father).y '父天体的位置

W1 = Picture1.ScaleWidth * 0.5 - ctBW: H1 = Picture1.ScaleHeight * 0.5 - ctBW

K = 2 * ctBi

If K < 1 Then K = 1

Picture1.DrawWidth = K

For K = ctSmalls To 0 Step -1

J = In360(Jiao + ctSmall(K).Jiao) '保证数值在 0 到 ctP360 的范围内

If J < ctP90 Or J > ctP270 Then

If InDown Then GoTo Next1

Else

If Not InDown Then GoTo Next1

End If

GetXY I, ctSmall(K).a, ctSmall(K).b, J, CenX, CenY, x, y

InD = Not (x < -W1 Or x > W1 Or y < -H1 Or y > H1) '点1是否在可见区内

If InD Then

If K = 0 Then Picture1.PSet (x, y), &HEEEEEE Else Picture1.PSet (x, y), Se

End If

Next1:

Next

Picture1.DrawWidth = 1

End Sub

Private Function In360(ByVal J As Single) As Single

'保证数值在 0 到 ctP360 的范围内

If J > ctP360 Then J = J - ctP360

If J < 0 Then J = J + ctP360

In360 = J

End Function

Private Sub DrawXX()

'画闪烁的行星

Dim I As Long, r As Long

For I = 0 To ctXs

r = ctX(I).r

'If r > -1 Then Picture1.Line (ctX(I).X - r * 0.5, ctX(I).Y - r * 0.5)-Step(r, r), ctX(I).Se, BF

If r > -1 Then

Picture1.DrawWidth = r + 1: Picture1.FillColor = ctX(I).Se

Picture1.PSet (ctX(I).x, ctX(I).y), ctX(I).Se

End If

ctX(I).t = ctX(I).t + 1

If ctX(I).t > 5 Then

ctX(I).t = 0

ctX(I).r = ctX(I).r + 1

If ctX(I).r > 2 Then ctX(I).r = -1

End If

Next

Picture1.DrawWidth = 1

End Sub

Private Sub DrawImg(I As Long, ByVal x As Single, ByVal y As Single, ByVal r As Single)

'将 I 的图像绘制到 Picture1

If ct3D Then '画立体球形

Dim W As Long, H As Long

x = x - Picture1.ScaleLeft: y = y - Picture1.ScaleTop

W = r * 2 + 1: H = r * 2 + 1

Picture2.Move 0, 0, W, H: Picture2.Cls

Picture2.PaintPicture ctD(I).Img, 0, 0

GdiTransparentBlt Picture1.hDC, x - r, y - r, W, H, Picture2.hDC, 0, 0, W, H, Picture2.BackColor

Else '画一个填充的圆

Picture1.FillColor = ctD(I).Se: Picture1.FillStyle = 0 '打开填充

Picture1.Circle (x, y), r, 0 '画天体

Picture1.FillStyle = 1 '关闭填充

End If

End Sub

Private Sub Tail(I As Long, x As Single, y As Single)

'画天体 I 的 彗尾

Dim x0 As Single, y0 As Single, S As Single

Dim X1 As Single, y1 As Single, J As Single

'无压缩时的位置

x0 = ctD(I).a * Sin(ctD(I).Jiao): y0 = ctD(I).b * Cos(ctD(I).Jiao)

J = ctBi * Sqr((x0 + ctD(I).C) ^ 2 + y0 ^ 2) '与焦点（即：父天体）距离

S = ctBi * (ctD(I).a - ctD(I).C) ^ 2 / J - (ctD(I).a - ctD(I).C) / 5 '彗发长度：近日距离4/5

If S < 0 Then Exit Sub

S = S * ctBi

If S > Picture1.ScaleWidth Then S = Picture1.ScaleWidth

X1 = ctD(ctD(I).Father).x: y1 = ctD(ctD(I).Father).y '父天体位置

X1 = S / J * (x - X1): y1 = S / J * (y - y1)

Picture1.DrawMode = 14: Picture1.DrawWidth = ctD(I).r * 3 * ctBi + 1

Picture1.Line (x, y)-Step(X1, y1), &H999999

Picture1.Line (x, y)-Step(X1, y1), &H999999

Picture1.DrawWidth = 1: Picture1.DrawMode = 13

End Sub

Private Sub ShowStr(wB As Single, hB As Single, nStr As String, ByVal x As Single, ByVal y As Single, Optional CenLR As Boolean, Optional Se As Long = -1)

'显示字符 wB,hB：可见区边界 CenLR = T：左右居中

Dim W As Single, H As Single, nSe As Long

W = Picture1.TextWidth(nStr): H = Picture1.TextHeight(nStr)

If CenLR Then x = x - W * 0.5

If x < -wB - W Or x > wB Or y < -hB - H Or y > hB Then Exit Sub

Picture1.CurrentX = x: Picture1.CurrentY = y: Picture1.Print nStr

If Se = -1 Then Exit Sub

nSe = Picture1.ForeColor: Picture1.ForeColor = Se

Picture1.CurrentX = x + 1: Picture1.CurrentY = y + 1

Picture1.Print nStr

Picture1.ForeColor = nSe

End Sub

Private Sub SortB()

'将天体按轨道短半径从小到大排序，用数组 ctB() 记忆排序结果（天体序号）

'排序结果决定绘图时天体的前后顺序

Dim I As Long, J As Long, K As Long, b As Single

ReDim ctB(0 To ctDs) '数组个数与 ctD() 一样

ctB(0) = 0

For I = 1 To ctDs '依次比较天体的短半径 b

b = ctD(I).b '待比较的 b

For J = 0 To I - 1 '用 b 与已排序数组比较

If b < ctD(ctB(J)).b Then

For K = I - 1 To J Step -1 '下移已排序数组中 J 之后的

ctB(K + 1) = ctB(K)

Next

ctB(J) = I: GoTo Next1

End If

Next

ctB(I) = I

Next1:

Next

End Sub

Private Sub GetXY(ByVal I As Long, a As Single, b As Single, Jiao As Single, CenX As Single, CenY As Single, x As Single, y As Single)

'获取某天体 I 在 Jiao 位置的绝对位置

'CenX，CenY：父天体的位置

x = ctBi * (a * Sin(Jiao) + ctD(I).C)

y = ctBi * ctSeeBi * b * Cos(Jiao)

Zhuan ctD(I).Dip, x, y '叠加轨道倾角

x = CenX - x: y = CenY - y

End Sub

Private Sub GuiDao(I As Long, Optional IsDown As Boolean)

'画轨道

Dim J As Single, x As Single, y As Single, CenX As Single, CenY As Single, r As Long

Dim W1 As Single, H1 As Single, xUp As Single, a As Single, b As Single, yUp As Single

Dim InD As Boolean, InUpD As Boolean, J1 As Single, J2 As Single, Is2 As Boolean

Picture1.DrawWidth = 1

W1 = Picture1.ScaleWidth * 0.5 - ctBW: H1 = Picture1.ScaleHeight * 0.5 - ctBW

CenX = ctD(ctD(I).Father).x: CenY = ctD(ctD(I).Father).y '父天体的位置

If IsDown Then

J1 = ctP180 * 0.6: J2 = ctP180 * 1.4 '下半部分少些 0.5-1.5

Else

J1 = ctP180 * 1.4: J2 = ctP180 * 2.6 '上半部分多些 1.5-2.5

End If

a = ctD(I).a: b = ctD(I).b

For J = J1 To J2 Step 0.1

Call GetXY(I, a, b, J, CenX, CenY, x, y)

InD = Not (x < -W1 Or x > W1 Or y < -H1 Or y > H1) '点1是否在可见区内

If Is2 And (InD Or InUpD) Then

Picture1.Line (x, y)-(xUp, yUp), ctD(I).Se

End If

xUp = x: yUp = y: InUpD = InD: Is2 = True

Next

'末点：将轨道封闭

Call GetXY(I, a, b, J2, CenX, CenY, x, y)

InD = Not (x < -W1 Or x > W1 Or y < -H1 Or y > H1)

If InD Or InUpD Then Picture1.Line (x, y)-(xUp, yUp), ctD(I).Se

End Sub

'-----------------------------------------------------

Private Sub GetRGB(ByVal Se As Long, r As Long, G As Long, b As Long)

b = Se \\ 65536: Se = Se Mod 65536

G = Se \\ 256: r = Se Mod 256

End Sub

Private Sub Zhuan(ToJ As Single, x As Single, y As Single)

'将点 x,y 顺时针旋转 ToJ 角度，返回旋转后的位置

'注意：要预先设置圆周率 ctP180 = 3.1415926

Dim S As Single, J As Single

S = Sqr(x ^ 2 + y ^ 2) '目标：X,Y 与中心点的距离

If S = 0 Then J = 0 Else J = y / S '与水平线的夹角的正弦值

If Abs(J) >= 1 Then

If J > 0 Then J = ctP90 Else J = -ctP90 '90 度时的特殊情况

Else

J = Atn(J / Sqr(-J * J + 1)) '与水平线的夹角

End If

If x < 0 Then J = -ctP180 - J

x = S * Cos(J + ToJ): y = S * Sin(J + ToJ) '返回旋转后的位置

End Sub