天体运行程序代码.doc

以下是窗体代码，在 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 BooleanDim ctBi As Single, ctV As Single, ctBW As Long, ctSeeJ As Long, ctTrack As BooleanDim ctSeeBi As Single, ctSet As MenuSet, ctShowXX As Boolean, ctColorXX As BooleanDim ctP180 As Single, ctP90 As Single, ctP270 As Single, ctP360 As SingleDim 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 LongEnd 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 SingleEnd TypeEnum MenuSet以下为 选项菜单 标示 ms_Size = -11设置字体大小 ms_RunStop = -10 开始/暂停 ms_3D = -93D 立体图像 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 EnumPrivate 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 LongPrivate 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.8End SubPrivate 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 Run1End SubPrivate 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), ms_Opt, 设置选项 KjAdd Command1, 进(&W), ms_Step, 步进，运行到下一位置 KjAdd Command1, 退(&T), ms_UnRun, 步进，后退到上一位置 KjAdd Command1, 参照系(&C), ms_Center, 设置参照系（位于中心的天体） KjAdd Command1, 天体(&X), ms_Visible, 天体：显示/隐藏 KjAdd Command1, 名称(&M), ms_ShowCap, 天体名称：显示/隐藏 KjAdd Command1, 轨道(&D), ms_GuiDao, 天体运行轨道：显示/隐藏 KjAdd Command1, 轨迹(&J), ms_GuiJi, 运动轨迹，选中“选项-显示运动轨迹”时有效 KjAdd Command1, 连线(&L), ms_LineFu, 与父天体的中心连线，同时显示对应天体时有效 KjAdd Command1, 速度(&V), ms_V, 设置速度 KjAdd Command1, 视角(&S), ms_SeeJ, 设置视点角度 KjAdd Command1, 缩放(&F), ms_Bi, 设置缩放比列添加天体（演示比列状态下），半径以 100 像素为标准参数依次是：名称，父天体名称，天体半径，轨道长半轴，轨道偏心率，运动角速度，轨道倾角，天体颜色，初始角度，彗星否 ctDs = -1: ReDim ctD(0 To 0) AddCircle 太阳, , 22, 2, 0, 1.44, , RGB(230, 180, 0) AddCircle 水星, , 5, 0.5, 0.206, 5.45, 7.001, &H999999 AddCircle 金星, , 9, 0.8, 0.007, 3.24, 3.394, &H55AAAA AddCircle 地球, , 10, 1.2, 0.017, 1.81, , RGB(0, 0, 255) AddCircle 月亮, 地球, 4, 0.2, 0, 10.8, , &H333333 ctD(CapToNum(月亮).IsSmall = True 调试代码* AddCircle 嫦娥1号, 月亮, 2, 0.06, 0, 21.6, , &HCCCCCC AddCircle 火星, , 6, 1.8, 0.093, 0.91, 1.851, &H1155FF AddCircle 火卫1, 火星, 3, 0.1, 0, 15, , &H555500, 10 AddCircle 火卫2, 火星, 3, 0.15, 0, 17, , &H5555DD, 200 AddCircle 小行星, , 6, 2.4, 0.093, 0.7, 0, &H666666 小行星轨道倾角多少？ ctD(CapToNum(小行星).IsSmall = True AddCircle 木星, , 16, 3, 0.0483, 0.54, 1.308, &H776655 AddCircle 木卫1, 木星, 2, 0.25, 0, 9, , &H883487, 10 AddCircle 木卫2, 木星, 2, 0.3, 0, 6.3, , &H348888, 100 AddCircle 木卫3, 木星, 3, 0.35, 0, 5.4, , &HAA34CC, 190 AddCircle 木卫4, 木星, 4, 0.45, 0, 3.6, , &H888888, 280 AddCircle 土星, , 14, 5, 0.056, 0.36, 2.488, &H2266CC AddCircle 土卫6, 土星, 4, 0.25, 0, 9.5, 30, &H99EEEE AddCircle 天王星, , 12, 6.5, 0.046, 0.27, 0.774, &HCC7777 AddCircle 天卫3, 天王星, 3, 0.2, 0, 9.6, , &H33FF88, 10 AddCircle 天卫4, 天王星, 3, 0.3, 0, 6.2, , &HFF3311, 200 AddCircle 海王星, , 12, 9.2, 0.009, 0.18, 1.774, &HFF7766 AddCircle 海卫1, 海王星, 3, 0.25, 0, -5.4, , &H882388 AddCircle 哈雷彗星, , 2, 5.5, 0.83, -0.21, 18, &H777777, -10 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_ResizeEnd SubPrivate 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 NextEnd SubPrivate 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 SubSubDraw1: r = ctBi * ctD(I).r If r 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 = TrueEnd SubPrivate 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, -, 0.5, 0.6, 0.7, 0.8, 0.9, -, 1, 1.2, 1.5, 1.8, 2, 3, 5, 8, 10) KjAddZu mmFast, Zu, ctBi, 倍: GoTo Show1 添加数组菜单，并勾选 ctBi Case ms_SeeJ 视点角度 Zu = Array(90 度（天球北极）, 80 度, 70 度, 60 度, 50 度, 45 度, 40 度, 30 度, 20 度, 15 度, 10 度, 6 度, 3 度, 1 度, 0 度（天球赤道）) KjAddZu mmFast, Zu, ctSeeJ: GoTo Show1 添加数组菜单，并勾选 ctSeeJ Case ms_V 速度 Zu = Array(0.1, 0.2, 0.3, 0.4, -, 0.5, 0.6, 0.7, 0.8, 0.9, -, 1, 1.5, 2, 2.5, 3, 4, 5, 7.5, 10) KjAddZu mmFast, Zu, ctV, 倍: GoTo Show1 Case ms_Opt选项 I = KjAdd(mmFast, 状态, ms_RunStop) 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 & ., ms_Size KjAdd mmFast, - KjAdd mmFast, (&M) 恢复默认设置, ms_DefSet 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, 全选, ms_All) KjAdd mmFast, 行星, ms_Xing KjAdd mmFast, 卫星, ms_Wei nNo = KjAdd(mmFast, 全不选, ms_NoAll) 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 = FalseShow1: Command1(Index).BackColor = &HFFCCCC 将选中按钮设置为淡蓝色 Me.PopupMenu mFast, , Command1(Index).Left, Command1(Index).Top + Command1(Index).Height - 3 Command1(Index).BackColor = Me.BackColorEnd SubPrivate 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 ct3D3D 立体图像 Case ms_Track: ctTrack = Not ctTrack运动轨迹 Case ms_DefSet: Call Init默认设置 Case ms_Size设置字体 nStr = InputBox(设置天体名称字体大小，范围 3-300：, 字体大小, ctSize) If nStr = Then Exit Sub I = Val(nStr) If 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 0所有卫星End FunctionPrivate 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 SubPrivate Function JiaoOrFu(S As Single, Optional ToJiao As Boolean) As Single角度与弧度的转换 弧度转角度 角度转弧度 If ToJiao Then JiaoOrFu = S / ctP180 * 180 Else JiaoOrFu = S / 180 * ctP180End FunctionPrivate 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 = KjAd