天体运行程序代码.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 = -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 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 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 ReturnEnd SubPrivate 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 = 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 = False Show1: 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 ct3D '3D 立体图像 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 < 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 DrawAl
