VERSION 5.00 Begin VB.Form StarBowl_FRM Caption = "Form1" ClientHeight = 3195 ClientLeft = 60 ClientTop = 345 ClientWidth = 4680 Icon = "MainCalc.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 3195 ScaleWidth = 4680 StartUpPosition = 3 'Windows の既定値 Begin VB.HScrollBar TimerInterVal_HSB Height = 255 Left = 1440 TabIndex = 49 Top = 1200 Width = 375 End Begin VB.TextBox starname_txt Height = 2775 Left = 3000 MultiLine = -1 'True TabIndex = 48 Text = "MainCalc.frx":030A Top = 480 Width = 3495 End Begin VB.HScrollBar HScroll7 Height = 255 Left = 1680 TabIndex = 47 Top = 720 Visible = 0 'False Width = 255 End Begin VB.TextBox TimerInterval_TXT Height = 495 Left = 3360 TabIndex = 46 Text = "Text2" Top = 120 Width = 375 End Begin VB.Timer Timer Left = 720 Top = 600 End Begin VB.ComboBox DataFileList_CMB Height = 300 Left = 0 TabIndex = 28 Text = "Combo1" Top = 0 Width = 1215 End Begin VB.CheckBox CSVRead_CHK Height = 480 Left = 0 TabIndex = 0 Top = 0 Width = 1200 End Begin VB.TextBox RollAngleStep_TXT Height = 480 Left = 0 TabIndex = 1 Top = 0 Width = 1200 End Begin VB.TextBox SlideStep_TXT Height = 480 Left = 0 TabIndex = 2 Top = 0 Width = 1200 End Begin VB.HScrollBar RollAngleStep_HSB Height = 240 Left = 0 TabIndex = 3 Top = 0 Width = 1200 End Begin VB.HScrollBar SlideStep_HSB Height = 240 Left = 0 TabIndex = 4 Top = 0 Width = 1200 End Begin VB.PictureBox Picture1 Height = 480 Left = 0 ScaleHeight = 420 ScaleWidth = 1140 TabIndex = 5 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 0 Left = 0 TabIndex = 6 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 1 Left = 0 TabIndex = 7 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 2 Left = 0 TabIndex = 8 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 3 Left = 0 TabIndex = 9 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 4 Left = 0 TabIndex = 10 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 5 Left = 0 TabIndex = 11 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 6 Left = 0 TabIndex = 12 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 7 Left = 0 TabIndex = 13 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 8 Left = 0 TabIndex = 14 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 9 Left = 0 TabIndex = 15 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 10 Left = 0 TabIndex = 16 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 11 Left = 0 TabIndex = 17 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 12 Left = 0 TabIndex = 18 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 13 Left = 0 TabIndex = 19 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 14 Left = 0 TabIndex = 20 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 15 Left = 0 TabIndex = 21 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 16 Left = 0 TabIndex = 22 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 17 Left = 0 TabIndex = 23 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 18 Left = 0 TabIndex = 24 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 19 Left = 0 TabIndex = 25 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 20 Left = 0 TabIndex = 26 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 21 Left = 0 TabIndex = 27 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 22 Left = 0 TabIndex = 38 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 23 Left = 0 TabIndex = 39 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 24 Left = 0 TabIndex = 29 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 25 Left = 0 TabIndex = 30 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 26 Left = 0 TabIndex = 31 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 27 Left = 0 TabIndex = 32 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 28 Left = 0 TabIndex = 33 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 29 Left = 0 TabIndex = 34 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 30 Left = 0 TabIndex = 35 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 31 Left = 0 TabIndex = 36 Top = 0 Width = 1200 End Begin VB.CommandButton tune_btn Height = 480 Index = 32 Left = 0 TabIndex = 37 Top = 0 Width = 1200 End Begin VB.CommandButton Galaxies_BTN Height = 480 Left = 0 TabIndex = 40 Top = 0 Width = 1200 End Begin VB.CommandButton reset_btn Height = 480 Left = 0 TabIndex = 41 Top = 0 Width = 1200 End Begin VB.CommandButton exit_btn Height = 480 Left = 0 TabIndex = 42 Top = 0 Width = 1200 End Begin VB.VScrollBar Scale_VSB Height = 1200 Left = 0 TabIndex = 43 Top = 0 Width = 240 End Begin VB.VScrollBar Role_VSB Height = 1200 Left = 0 TabIndex = 44 Top = 0 Width = 240 End Begin VB.HScrollBar Role_HSB Height = 240 Left = 0 TabIndex = 45 Top = 0 Width = 1200 End End Attribute VB_Name = "StarBowl_FRM" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Rem ============================================================================================ Rem Rem 星屑どんぶり ver0.04 メインソースファイル Rem STARBOWL.EXE on VisualBasic6.0 Rem CopyRight MIYAMA. 2009 March:ver0.02 // 2010 September:ver0.04 Rem http://kimijima.at.infoseek.co.jp Rem kaz_kimijima@yahoo.co.jp Rem Rem ============================================================================================ Rem 論理の概要OutLines Rem このプログラムはテキスト形式の天体データファイルから各天体の Rem 座標や光度データを読み込み仮想三次元空間に投影表示するプログラムである Rem 表示空間は適宜回転平行移動拡大縮小が出来る Rem また子フォームにその天体のプロフィールを表示することがマウス操作により可能 Rem 各データは表示操作中全てメモリ領域に配列として管理される Rem 配列の管理番号インデックスはファイルデータ行の読み込み順に割り振られこれが内部の Rem 天体管理番号になるただし明示的にその番号は操作者に対して表示はされない Rem The program is that it makes 3D star composition of fix stars data-text. Rem The textdata has brightgrade,spectol color,distance,longitude and latitude. Rem Rem The 3D space has anctions of rolling and sliding-parallel wide and shrink. Rem The program shows 3D composition and other text comment data Rem Rem The program reads the star-datas into PC memory all without using disc-data temporaly after once-all reading. Rem This data style on the memory as the arrey. Rem This program has dynamic-arrey controll methods. Rem Its declearnation as one arrey name as about C-pointer, Rem and next, count datatext's significant datalines number, it makes Rem the past arrey name to be extended by those significant dataline's number. Rem --For this reason, the global parameters for original star datas, it Rem was not decleared on the detail-datatype for example of the integer. Rem The no initialized variant type is only able to be extended to the arrey. Rem ******************************************************************************************** Rem Rem Change points from 0.02 to 0.04 2010 August - September Rem *The operationa buttons logic and location on the form chaninging Rem *Equator and Galaxy guide cross bar point function Rem Rem *Stella guide function Rem *two forms re-tune up for those expressional style Rem *English data and document Rem *3D display control booleans and mouse move condition boolean Rem :Under tune butons function Rem *Slide Roll functions blush up Rem Rem Ver0.01から0.02への変更事項 Change Points from 0.01 to 0.02 2009 March Rem Rem ・初期読み込みデータファイルSTARDATA.TXTが存在しないときのエラー処理がないのを改善 Rem *To take a error-action when base booking name stardata file stardata.txt Rem UpDate Item 2 3ab Rem Rem ・春分点などの補助ガイド線の描画のエラー（描画のピクチュアオブジェクトの座標値が大きすぎる場合） Rem が堅牢でないことに 対する 補正 Rem *The earth directional guide lines error was removed Rem UpDate item 4 Rem Rem ・初期描画画面を鳥瞰図形式から単純直交表示形式に変更 Rem *The Draw view changed from a bird view to simple 3D mathmatical one without perthpactive function Rem UpDateItem 5ab Rem Rem ・マウスドラッグによる描画画面の回転転がし操作論理の新設 Rem *The new Rolling function by mouse drag was made Rem UpDate item 1 5ab 6ab 7 Rem Rem まずマウスクリックイベントでピクチュアオブジェクト上から回転したい角度方向とその回転角度値 Rem を取得 Rem 具体的にはキーダウンイベントからキーアップイベントのあいだのX成分とY成分をもとに Rem 方向角度と回転の大きさを取得 Rem Mouse-rolling: by mouse drag with mouse-keydown/up event, the demand from rolling Rem angle quontity and angle direction is degestined to the X pole rolling and Z pole. Rem In other saying, the length of mouse-drag moving leaded by x,y from mouse down Rem and x,y to mouse up of those 4 values, it goes as a dy/dx value into the triangle Rem world of the cos-sin. This triangle's roof direction is rolling direction, the roof Rem bigth is rolling angle quontity Rem Rem 数学的には方向角度はdy/dxその大きさの２乗ははdy^2+dx^2で与えられるが Rem 一次変換論理に対するプログラム管理の都合上 Rem 実際には3d_X軸に対する演算と3d_Z軸に対する演算を分けて行っている Rem Rem The angle methods is separated to two stages. Rem angle's direction and quontity is separated X pole and Z pole elements. Rem the elaments liner transformations: Rem Z pole rolling: dx Rem X pole rolling: dz Rem this concern dx^2+dz^2=rooflength from mause-triangle Rem in other words, Rem dx=mouseup x-mousedown x Rem dz=mouseup z-mousedown z Rem ******************************************************************************************** Rem ============================================================================================ Rem Rem 演算用グローバル変数の宣言Global Fix Parameters Declaration Rem Rem ============================================================================================ Option Explicit Rem あやまった入力のあるデータでも動作上のエラーのでない堅牢な論理を作成すること Rem Having to make hard logics without actional errors from unsignificant data of any file-line Rem 横セルの少ないデータでもメンバを数を固定した配列にコピーしてから処理 Rem The Execute arrey and tmporary arrey for line reading are another beings each Rem 充足しなかった余りメンバは初期化値で処理される Rem The Execute arrey is initialized on the reset-time with null-chr or 0 value, Rem then the readed tmp arrey's value is copied to exe arrey Rem For this reason, if the datafile's line has only short members, right side arrey Rem member of execute arrey are have 0 value or null-chr as the result not enough Rem copied compleatly, Rem In the opposite,when over many members are on the line, over cell-data throws Rem off. Rem 逆にデータセル個数が多い場合は余ったセルは切り捨てられる Rem ------------------------------------------------------------------- Rem 読み込み受け用使い捨て変数を作る Public FSO 'ファイルシステムオブジェクト FileSystemObj Rem The reset function requires read filename booked it is there on the global area// Public FileName As String ' Main Data files name Public FileNameTrunk As String 'データファイルの名前 Public WorkFileName As String ' File for being recieved all data file Public EquFileName As String ' Guide crossbar filename using the system Public GlxFileName As String ' same Public StellaFileName As String ' Stella guide filename made by the authour.. Public ActivateLines_SumNumber As Integer Public MemberNum14 As Integer Rem テキストファイルから天体データ有効行が何行あるかを取得する変数 Rem It is the parametor to get the datafiles' significant lines data Rem この変数から動的に天体用配列データを宣言しこの要素数だけ固定メモリ領域に確保する Rem This makes stardata pieces' number and it makes extend stardata-arreys as the pointer-using Rem この変数の値をnとするとSplit関数を使用して配列を策定するため天体用の Rem インデックス配列は０からn-1になる Rem The A_sumnumber makes index 0 to n-1 for fixed star Rem また第n番目の要素として地球基準座標をシステム内部で割り当てている Rem The method of Spilt function of the VB, using spilt with A_sumnumber + 1 value, Rem and then,the index 'n' made from +1 operation, Rem it is the last elements of the arrey using for the Earth's center base point that Rem it is used by the center guided directional lines. Rem Rem MemberNum14 is a fixed number data items of lines. Rem 一時使用されるだけの受け渡し変数-------------------------------------------------------------- Rem 変数名は１４個 インデックスは０から１３まで すべてテンポラリ変数 Rem 必ずしもグローバルにおく必要はない Rem 引数引き渡しが面倒なので一時変数だがグローバルに置く Rem 一時変数なので、配列化して格納用変数としては扱わない Rem Nexts are tmporary for reading lines Rem All are not for arrey only a tmp Variant Rem Rem global parametors for data copying Public ReadLineIndex '0 元データファイル上の天体データの通番用領域システムからは無視されるCommentArea1 Public Name_GreekCHR '1 恒星のギリシア文字番号 任意の文字が可能 StarName as Greek Chr Public Name_Stella '2 所属星座の名前 任意の文字可能 Stella Name Public Name_starJPN '3 恒星の固有名ニックネーム 日本語 任意文字 StarNicName for Japanese Public Name_starAlabee '4 恒星の固有名ニックネーム アラビア語英語綴り 任意文字 StarNicName for english Public Longi_Hour '5 赤経時 数値 longitude hour Public Longi_Minite '6 赤経分 数値 longitude minite Public lAti_Degree '7 赤維度 数値 latitude degree Public lAti_Second '8 赤維秒 数値 latitude second Public tmpBrightGrade '9 見かけの等級 数値 Bright Grade on the earth's night sky with the wine Public tmpColor_CHR '10 スペクトル型文字部分 半角で大文字小文字可能 無効記述ならグレー表示 Spectol Chr Public tmpColor_NUM '11 スペクトル型数字部分 システムは処理に使用せず Spectol Num small :as comment no-using by this system Public tmpDistance '12 地球からのおよその距離 単位光年 数値 distance by the unit LightYear... Public tmpComment '13 任意のコメント領域 guideと記述するとシステムはこの天体データを補助線として描画する CommentArea2 :also guide line function for the guide mode keys. Rem 各天体用データ格納用変数 演算後配列にインデックス番号をキーとして格納---------------------------- Rem 後でSPLIT命令で配列化するので無垢なvariantとしてポインタ風に扱う Rem The Next are Execute Arreyes parameters for data storing with dynamic using-- Rem This parametors will be extended to arrey by A_sumnumber as a C-Pointer/ Public TotalName '文字情報の集積文字列 Staked strings name's charactors Public LongiTude '赤経度変数 単位３６０度 the unit is 360 degrees Public lAtiTude '赤緯度変数 単位３６０度 sure Public Distance '地球からの距離 単位光年 the unit is Light Year Public BrightGrade '見かけの光度等級 on the earth's night sky Public ABS_Bright '絶対光度太陽の明るさの何倍か the Absolute-brightness on the doom of 10 persec// Public ColorCHR 'スペクトル型のアルファベット部分 Spectol type as a alphabet Public RGB_COLOR '表示用色彩変数１６７７万色単位 スペクトル型により一意に決まる Display color Public Comment '備考欄 補助座標線の場合は文字列Guideを記述すること Comment Area 2 on the lead line/ Rem 補助座標線の色彩は便宜上スペクトル型の欄に文字として記述すること Public Grade '値格納のみの変数 Steel parameter Public Color '値格納のみの変数 Steel p Rem 操作用座標変数 これもデータ用格納変数扱い 3D calcurational Point-locatinal Arrey------------------------------------------------------ Rem このプログラムは平行 回転変換をこの中間座標変数に対して行う演算後同じインデックス番号の各変数に再格納される Rem リセットボタン リセット関数によって初期化されてデータテキストから再構成される Rem Fix stars 3D locational numbers are arrey too Rem They are controlled from the liner transformation for rolling action and sliding Rem process Rem X Y Z to Operate Rem Point(XtoOperate,YtoOperate,ZtoOperate) Public XtoOperate Public YtoOperate Public ZtoOperate Rem 座標補助線用補助座標 これらも平行回転変換の操作の対象になる 格納配列 Rem 読み込み演算開始時天体座標の点の赤道面に対する射影点 Rem The 3D point data for virtical guide line:arrey Rem For the guide pillow virtical line from the base plane 's Rem data are also Arrey that 3D parametors was also controlled Rem FistTime BasePoint(XopeBase,YopeBase,0) :Z element has 0 firstly because Rem they are included into the horizontal base plane// Public XopeBase Public YopeBase Public ZopeBase Rem 演算補助変数Help parameter--------------------------------------------------------------------------------- Rem 空間変換処理用変数と定数 Rem ３６０度角度をシステム三角関数入力用にラジアン単位に変換する係数 Rem The rate for user 360 to Radian for system cos-sin:constant Public ThetaToRadian As Double Rem 平行と回転の変換単位角度は３６０度単位 平行は光年単位 Rem The rolling and sliding step unit that are those value controlled Rem by manual operation Rem rolling unit is the degree of 360 Rem sliding unit is light year Public Stepper_Angle As Double Public Stepper_Slide As Double Rem zoom 率も格納 Rem Zoom rate for display zooming Rem This rate is only to act to the 2D expression-world. Rem It is no touch to 3D arrey for location-- Public ZoomRate As Double Rem 画像表示用パラメータ 格納配列変数------------------------------------------------------------- Rem これは逐一変換描画後にマウスによるテキスト情報表示時にこの座標データが呼び出しあつかいで Rem いるので配列格納扱いで保存する必要あり Rem ---2D picture-display arrey for Display Picture object-- Rem This arrey is used only by the star detail text data expressional function. Rem The mouse-pointing 3D star composition,2D display picture mouse pointing location Rem searchs the expressioned fix star index through this 2D visual arreys. Rem The index searched guides the detail text star data for the expressional text window. Public PsetX Public PsetY Rem UpDate 0.02 Item1/7************************************************************************* Rem マウスによる画面回転のためのパラメータを取得する変数for mouse rolling Public FMP_X As Integer 'First Mouse Point Public FMP_Y As Integer Public LMP_X As Integer 'Last Mouse Point Public LMP_Y As Integer Rem ******************************************************************************************** Rem 3D star composition expression boolean controlled from Indi_FRM Rem Those parameters was controlled from Indi_FRM's side buttons function- Public OnGalaxyBool As Boolean Public StarGuideBool As Boolean Public CenterDirectionGuideBool As Boolean Public StellaExpressBool As Boolean Public EqGuideExpressBool As Boolean Public GxGuideExpressBool As Boolean Public StarExpressBigthBool As Boolean Rem The button index as about buttons looking the TV remote controller// Rem Those buttons are also componet-arrey. The index of arrey makes decide Rem the each deffer functions. Public BTNIndexGlobal As Integer Rem This charactor strings contorolls the guide lines nature// Rem file sending side and recieve side use it each togather//// Public CommentGuideSTR As String Public CommentStellaSTR As String Public CommentEquSTR As String Public CommentGlxSTR As String Rem ============================================================================================ Rem Rem フォームのロードと初期化 Rem Work Forms Load and Initialize Rem Rem ============================================================================================ Public Sub Form_Load() Load INDI_FRM INDI_FRM.Visible = True Call INDI_FRM.Form_Load Rem it is ok free double form load error Rem for Indi_FRM's parameter initialzing. Rem next init is executed from Indi_FRM -- 'OnGalaxyBool = False 'StarGuideBool = True ' False 'CenterDirectionGuideBool = False 'StellaExpressBool = True 'EqGuideExpressBool = False 'GxGuideExpressBool = False 'StarExpressBigthBool = True With StarBowl_FRM .Width = 4000 '10000 .Height = 6000 Rem .MaxButton = False'not tuned from inner code.. End With Rem **renewal on the 0.04*** Call ParaINIT FileNameTrunk = "StarData." WorkFileName = "tmpData.tmp" EquFileName = "EquCross.tmp" GlxFileName = "GlxCross.tmp" StellaFileName = "Stella.txt" CommentGuideSTR = "guide" CommentEquSTR = "equ" CommentGlxSTR = "glx" CommentStellaSTR = "stella" Rem //***** With INDI_FRM Rem .Width = 8000 Rem .height=12000 With .picture1 .ForeColor = RGB(255, 255, 255) .BackColor = RGB(0, 0, 0) .AutoRedraw = True .Cls End With End With CSVRead_CHK.Value = 0 Rem ver0.04****** Timer.Enabled = False Timer.Interval = 500 '0.5 second aboutly With CSVRead_CHK FileName = FileNameTrunk + "txt" .Value = 0 If FSO.fileexists(FileName) = False Then FileName = FileNameTrunk + "csv" .Value = 1 If FSO.fileexists(FileName) = False Then Rem call error MsgBox "StarData.TXT/CSV file is nothere." Unload INDI_FRM Unload StarBowl_FRM Else Call ReSet End If Else Call ReSet End If End With End Sub Public Sub CSVRead_CHK_click() With CSVRead_CHK Select Case .Value Case 0: FileName = FileNameTrunk + "txt" Case 1: FileName = FileNameTrunk + "csv" End Select End With Call DataFileListAddItem End Sub Public Sub ReSet() Dim ExTStr Call TuneFrame Rem TUNEFRAME関数は現状のフォームの大きさを変更しないでボタンの配置をフォームの大きさに合わせる Rem TuneFrame makes to tune the button and window relocation from now form's width Rem 厳密にはフォームは幅を基準とした黄金比に保たれる0.04 にとって無効 Call ParaINIT 'コントロールのパラメータはフォーム上の配置を決定した後に調整 Rem form's global parameter will be tuned after the tunig location buttons. ZoomRate = 1 Rem Call InitIndexARR(10) '平行回転関数評価用キューブ座標評価ルーチンの名残 Rem the remaining 3D functional testing------- Rem UpDate 0.02 Item2/7************************************************************************* Rem 0.04*** If CSVRead_CHK.Value = 0 Then ExTStr = "txt" Else ExTStr = "csv" End If Rem FileName = FileNameTrunk + ExTStr Rem Call DataFileListAddItem Rem FileName = FileNameTrunk + ExtStr If FSO.fileexists(FileName) = True Then Rem Call DataFileListAddItem Rem MsgBox FileName Call MakeGuideDataFileandJoin Call Read_DataTXT Rem 0.04*** If OnGalaxyBool = True Then Call OnGalaxiesIze Rem Indi_FRM.picture1.Cls Call plotsDraw Else MsgBox FileName + "data file is no exists." Rem 0.04****** Unload INDI_FRM Unload StarBowl_FRM End If Rem ******************************************************************************************** End Sub Public Sub Form_Click() Rem フォームの余白をクリックするとボタンの配置を調整 Rem Tuning buttuns location on the clicking the form Call TuneFrame End Sub Public Sub remIndi_FRM_picture1_Click() Rem 描画ピクチャをクリックするとボタンの配置を調整 Rem Tuning buttons location on the clicking 3D picture--This function Rem is aleady used with no-visible picture on this form--- Rem Call TuneFrame End Sub Public Sub Exit_BTN_Click() Rem EXITで全てのフォームを閉じるExit makes unload-- Unload INDI_FRM Unload StarBowl_FRM End Sub Public Sub ReSet_BTN_CLICK() Rem リセットボタンを押すと表示がリセットされる 笑 Rem フォームの大きさは変更されずに配置のみがリセットされる Rem Rem 0.04 reset function was renewaled//please look the reset ruitine Call ReSet End Sub Public Sub DataFileListAddItem() 'データファイルリストをフォーム上のコンポーネントに作成Making the datafile list on the combo Dim ObjFolder Dim ObjFile Dim ExTStr As String With DataFileList_CMB .Clear .Text = "FileList" End With Set ObjFolder = FSO.getfolder(".\") For Each ObjFile In ObjFolder.Files ExTStr = FSO.getextensionname(ObjFile.Name) Rem 0.04***** ExTStr = LargeAlphabetToSmall(ExTStr) Select Case CSVRead_CHK.Value Case 1 If ExTStr = "csv" Then DataFileList_CMB.AddItem ObjFile.Name End If Case 0 If ExTStr = "txt" Then DataFileList_CMB.AddItem ObjFile.Name End If End Select Next End Sub Public Sub DataFileList_CMB_click() '他のデータファイルを読み込む Rem Reading for anothername data file to the datafile.txt/csv-- With DataFileList_CMB Rem MsgBox .ListIndex FileName = .List(.ListIndex) End With Call ReSet End Sub Public Sub ParaINIT() '変数初期化論理Environmetal parametors init---- Rem 操作用定数および構造体を調整する MemberNum14 = 14 Set FSO = CreateObject("Scripting.FileSystemObject") ThetaToRadian = 3.141592 / 180 Rem Stepper_Angle = 1 '0.1 Rem Stepper_Slide = 0.1 Rem ここにslideとrollのHSBを調整すべし With INDI_FRM.Zoom_VSB .Min = -100 .Max = 100 .Value = 0 End With With SlideStep_HSB .SmallChange = 1 .Min = 1 .Max = 2000 Rem 20000 .Value = 1 End With With RollAngleStep_HSB '1 step is 1 degree/360 .SmallChange = 1 .Min = 1 .Max = 20 .Value = 5 End With With TimerInterVal_HSB .SmallChange = 1 .Min = 100 .Max = 2000 .Value = 500 End With ZoomRate = 1 Call DataFileListAddItem Call SlideStep_HSB_Change Call RollAngleStep_HSB_Change Call TimerInterval_HSB_Change End Sub Rem ============================================================================================ Rem Rem データファイルを読み込みデータ数に応じて配列の組数を確保し天体のデータを格納 Rem Read Data File and Declariont of Dynamic ARRAY Paramaeter Rem Rem ============================================================================================ Public Sub InitARRWidth(ActivateIndex As Integer) '読み込み有効行数で格納変数配列の範囲を操作 Rem Making arrey to the pointer in the global parameters by --ActivateLines_SumNumber Dim i As Integer Dim tmpStake As String 'a Tool data for making arrey-strings----- tmpStake = "" For i = 0 To ActivateIndex '8 この８はキューブテスト時のindex数0.01 tmpStake = tmpStake + "0," Next i Call InitWide(XtoOperate, tmpStake) '空間変換時につねに演算格納される空間変数 Call InitWide(YtoOperate, tmpStake) Call InitWide(ZtoOperate, tmpStake) Call InitWide(XopeBase, tmpStake) Call InitWide(YopeBase, tmpStake) Call InitWide(ZopeBase, tmpStake) Call InitWide(PsetX, tmpStake) 'PsetXはデータ表示のために配列格納する必要がある Call InitWide(PsetY, tmpStake) Rem -- 以下は読み込み時一度演算して格納すると後は値の変更はなし Call InitWide(ABS_Bright, tmpStake) Call InitWide(RGB_COLOR, tmpStake) Call InitWide(TotalName, tmpStake) Call InitWide(lAtiTude, tmpStake) Call InitWide(LongiTude, tmpStake) Call InitWide(Grade, tmpStake) '設計時に最初に使った変数 Call InitWide(Color, tmpStake) '上におなじ Call InitWide(Distance, tmpStake) Call InitWide(Comment, tmpStake) Rem Call CubeTune'キューブテスト時の残り End Sub Public Sub InitWide(OBJ1, dammyINITSTR) 'InitWideはInit Array to wideの意味InitWide is init wide for arrey OBJ1 = Split(dammyINITSTR, ",") End Sub Rem ============================================================================================ Rem Rem 回転論理評価に使用したキューブ頂点座標の値を算出する演算 Rem Logic for Moving calcuration test Rem Rem ============================================================================================ Public Sub CubeTune() '回転とスライド機能のテスト関数 キューブが動く Rem the test roll and sliding primitive logic test-------------------------- Dim i Dim j Dim tmpPer Dim Unit Dim k tmpPer = 0 Unit = 1 / 2 For i = 1 To 8 j = i - 1 TotalName(i) = str(i) If i < 5 Then tmpPer = Unit Else tmpPer = -Unit End If XtoOperate(i) = tmpPer If i < 7 Then If i < 5 Then If i < 3 Then tmpPer = Unit Else tmpPer = -Unit End If Else tmpPer = Unit End If Else tmpPer = -Unit End If YtoOperate(i) = tmpPer If i = 1 Then tmpPer = Unit If i = 2 Then tmpPer = -Unit If i = 3 Then tmpPer = Unit If i = 4 Then tmpPer = -Unit If i = 5 Then tmpPer = Unit If i = 6 Then tmpPer = -Unit If i = 7 Then tmpPer = Unit If i = 8 Then tmpPer = -Unit ZtoOperate(i) = tmpPer Next i Rem 以下評価時の残り論理 Rem this old test function deleated on the logics----- Rem Call Read_Array(XtoOperate) Rem Call Read_Array(YtoOperate) Rem Call Read_Array(ZtoOperate) Rem Call Read_DataTXT Rem Call plotsDraw End Sub Rem ============================================================================================ Rem Rem データファイルの読み込み論理本体 Rem Read Data TXT Rem Rem ============================================================================================ Rem 0.04Public Function Rem //On the 0.04 renewal, this ruitine was changed from Function to Sub Rem because result code is not needed, Rem because of making more upper comtrol-layer and it checks the booking name Rem stardata datafile to exist// Rem This ruitine makes all data of one data file be taked to PC memory. Rem but this ruitine not uses readall methods for comment out lines-skipping.-- Rem Rem 1st, as the prepair-process, logic counts the file's data line-number, Rem without the comment-outed line, Rem 2nd, the process prepaires a arrey for data-line recieving and it copies Rem data to those arrey's member. One member of the arrey's contents is One line.-- Rem This arrey is local not is global--. Public Sub Read_DataTXT() Rem As Boolean 'from Sub to Function 0.02 UpDate Item 3/7*********** Rem Dim FileName '読み込みファイル名別データファイル名でも読み込みできるようにしたためグローバル化 Rem renewal to read on the other dataname,the globalized one is controlled by the another processes-- Dim RTS '読み込み用テキストストリーム ReadtextStream Dim ReadLineSTR 'ReadLineステートメントで読み込まれる文字列 ReadStr from Rts.Readline methods Dim IgnoreSymbolSTR 'データ行用のコメントアウト文字列 comment str out on the reading-- Dim StakeSTR '一度データファイルをcr区切りメモリデータにするための堆積用意文字列 Rem The parametor is a kind of readall methods,with recognize comment out lines-- Dim LineARR 'SatekSTRからcrコード区切りによって切り出される配列用ヘッダ Rem Line Data Chr strings arrey for data file-- 'この時点ではポインタ扱いヴァリアント Rem Now pointer, it will be expanded as arrey..--- Dim LineCounter 'データファイルの一時有効ラインカウンタData file lines counter Dim tmpDATAARR '各LineARR(index)からtabコード区切りによって切り出される天体のパラメータ配列 'メンバ数はデータ行に依存し不定 Rem the datas from one each data line/This index is a flexible for irrigal data lines---- Rem Dim tmpSEGMENT '''no use with renewal Rem Dim STRforInit '''sure Dim i Dim j Dim tmpS Dim L Rem FileName = "StarData.txt"'tuned on the reset initializing-- IgnoreSymbolSTR = "$" StakeSTR = "" Rem 0.04 sub-inzing from functional style, this ruitine for result code value --- Rem was not needs/This functional role is moved to the upper logical controll layer----- Rem データファイルの有無をチェックして存在していなければ以下の処理を全て止める Rem If FSO.fileexists(FileName) = False Then Rem Read_DataTXT = False 'UpDate 0.02 Item3-A/7************************************************* Rem MsgBox FileName + vbCrLf + "データファイルが同じフォルダーにありません 実行の処理を終了します" Rem 'フラグをたてて後の処理を制御する方向に仕様変更？？しない Rem Else Rem Read_DataTXT = True 'UpDate 0.02 Item3-B/7************************************************** Rem ******interrupt point************** Set RTS = FSO.openTextFile(WorkFileName) '(FileName) LineCounter = 0 Do While RTS.AtEndOfStream = False ReadLineSTR = RTS.readline If 0 < InStr(ReadLineSTR, IgnoreSymbolSTR) Then Rem do nothing Else LineCounter = LineCounter + 1 StakeSTR = StakeSTR + ReadLineSTR + vbCr 'Split関数用の区切りなので複合コードcrlfは使わない Rem no need for crlf enough cr /but tab and cumma is not permitted-- End If Loop RTS.Close ActivateLines_SumNumber = LineCounter Call InitARRWidth(LineCounter + 1) 'ファイルの行数にあわせて配列を準動的に確保//ポインタ風にメンバ数を拡張宣言 'Making Lines Arrey LineARR = Split(StakeSTR, vbCr) For i = 0 To ActivateLines_SumNumber - 1 + 1 'UBound(LineARR) UBOUNDで表現してもよい/Another expression using Ubound// '+1 は第n要素 地球座標のために使用+ 1 for earth data area------ If ActivateLines_SumNumber = i Then Rem MsgBox vbCr Rem 論理到達チェック This ruitine i is a final item number for earth point//// tmpS = "" '地球座標は赤経赤維また距離ともにゼロ値パラメータ初期化処理値のまま使用 Rem Earth point has 0 longitude and latitude For L = 1 To MemberNum14 - 1 tmpS = tmpS + "," Next L tmpDATAARR = Split(tmpS, ",") Call ARRtoTmpPARA(tmpDATAARR) Name_starJPN = "EarthPoint" Else tmpDATAARR = Split(LineARR(i), vbTab) Call ARRtoTmpPARA(tmpDATAARR) End If Call ARRCopy(i) Next i Rem End If End Sub 'Function Rem ============================================================================================ Rem Rem 読みとった不定数の配列データを整頓して格納用配列に格納 Rem Calcuration data and to copy to new Array for star location moving Rem from leadlines arrey from data file----------- Rem Rem ============================================================================================ Public Sub ARRtoTmpPARA(InputARR) Rem This ruitine's purpose is Inputs data arrey's irrigality tuning Rem The receptArr is tuned the membership in the inner this ruitine.-- Rem The Tuning is doned through the copying process the between of the both-- Dim ReceptARR '配列インデックス数を整頓するための一時被copy用配列変数 Dim Ubound_ReceptARR 'ReceptARRの最終メンバindex n個の場合n-1 Dim Ubound_InputARR '同じくInputARRの最終メンバindex n個の場合n-1 Dim i '以下Lまでloop用integer変数 from i to L for looping// Dim j Dim k Dim s Dim L Dim initSTR 'ReceptARRを配列化するための繰り返し文字列for making receptarr string// Dim Mem 'VAL評価関数のための中間要素 ヴァリアントfor variant functions sub parametor Dim VacantDataSpace ' 1 byte space-- VacantDataSpace = Chr(32) '1byte space chr k = MemberNum14 '0 to 13 ; 14 member メンバがn個の時最終インデックスはn-1になる For j = 0 To k - 1 - 1 initSTR = initSTR + vbTab Next ReceptARR = Split(initSTR, vbTab) Ubound_ReceptARR = UBound(ReceptARR) Ubound_InputARR = UBound(InputARR) For L = 0 To Ubound_ReceptARR ReceptARR(L) = VacantDataSpace Next For s = 0 To Ubound_InputARR If s <= k - 1 Then ReceptARR(s) = InputARR(s) Next For i = 0 To Ubound_ReceptARR Mem = ReceptARR(i) If Mem = "" Then Mem = VacantDataSpace Select Case i Case 0: ReadLineIndex = Val(Mem) Case 1: Name_GreekCHR = Mem Case 2: Name_Stella = Mem Case 3: Name_starJPN = Mem Case 4: Name_starAlabee = Mem Case 5: Longi_Hour = Val(Mem) Case 6: Longi_Minite = Val(Mem) Case 7: lAti_Degree = Val(Mem) Case 8: lAti_Second = Val(Mem) Case 9: tmpBrightGrade = Val(Mem) Case 10: tmpColor_CHR = Mem Case 11: tmpColor_NUM = Mem Case 12: tmpDistance = Val(Mem) Case 13: tmpComment = Mem End Select Next End Sub Public Sub ARRCopy(LI) 'LIはLine index Numberの意味Li is Line Index Rem From recept arr to real operational arr,with tranlational-calcuration/ On Error Resume Next Dim tmpSTR As String Dim i As Integer Dim Lati As Double Dim Longi As Double Dim Dist As Double Dim LC Dim RGBtmp Dim Ccode Dim ABSCalc As Double Dim LogBase Dim SunABSGrade Dim Ten_Persec Dim ValBrightGrade Dim ValDis Dim Guidestrchk(5) Dim G tmpSTR = "" tmpSTR = tmpSTR + "Stella: " + vbTab + Name_Stella + vbCrLf tmpSTR = tmpSTR + "Greek: " + vbTab + Name_GreekCHR + vbCrLf tmpSTR = tmpSTR + "Name1: " + vbTab + Name_starJPN + vbCrLf tmpSTR = tmpSTR + "Name2: " + vbTab + Name_starAlabee + vbCrLf LongiTude(LI) = 360 * (Longi_Hour + Longi_Minite / 60) / 24 lAtiTude(LI) = lAti_Degree + lAti_Second / 60 ' Grade(LI) = tmpBrightGrade Color(LI) = tmpColor_CHR & tmpColor_NUM Distance(LI) = tmpDistance Comment(LI) = tmpComment LogBase = 100 ^ (1 / 5) SunABSGrade = 4.83 Ten_Persec = 32.616 '10persec=32.616rightyear ValBrightGrade = Val(tmpBrightGrade) ValDis = Val(tmpDistance) If ValBrightGrade = 0 Then ValBrightGrade = 0 If ValDis = 0 Then ValDis = Ten_Persec ABSCalc = (LogBase ^ (SunABSGrade - ValBrightGrade)) * ((ValDis / Ten_Persec) ^ 2) ABS_Bright(LI) = RoundNum(ABSCalc, 3) ' Rem **0.04*** If LI = ActivateLines_SumNumber Or _ GuideStrExistsCHK(Comment(LI)) = True Then Rem 0 < InStr(Comment(LI), CommentGuideSTR) Then TotalName(LI) = tmpSTR 'Name_starJPN Else tmpSTR = tmpSTR + vbCrLf tmpSTR = tmpSTR + "AbsoluteBright:" + vbCrLf + vbTab + ABS_Bright(LI) + " SolBright" + vbCrLf tmpSTR = tmpSTR + "Color: " + vbTab + Color(LI) + vbCrLf tmpSTR = tmpSTR + "Distance:" + vbTab + Distance(LI) + " LightYear" + vbCrLf tmpSTR = tmpSTR + "Etc: " + vbTab + Comment(LI) TotalName(LI) = tmpSTR End If Rem //**0.04*** Rem 赤経赤維光年から三次元初期座標を計算して格納 Rem Initialize 3D location on the mathmatical is calcurated and stored Rem to memory as the arrey to operate Rem この数値は平行回転演算でつねに変更される Rem Those math-parameters are always changing on the calcuration of the roll and slide Rem ズーム演算はこれらの数値を操作しない Rem zoom function takes not to change those 3D inner paras without sliding logic Rem ズーム演算はピクチャ描画関数でしか関与しない Rem zoom function on only drawing picture display without sliding logic-- Longi = LongiTude(LI) * ThetaToRadian Lati = lAtiTude(LI) * ThetaToRadian Dist = Distance(LI) / 100 '100 便宜上倍率100 is for size-tuning unit light year-- XtoOperate(LI) = Dist * Cos(Lati) * Cos(Longi) YtoOperate(LI) = Dist * Cos(Lati) * Sin(Longi) ZtoOperate(LI) = Dist * Sin(Lati) Rem OpeBase変数配列は描画補助線用これらも平行回転によって値が評価される Rem The virtical root of star guide line on the plane of equ and glx-- Rem THey are also operated by roll-slide calc---- XopeBase(LI) = XtoOperate(LI) YopeBase(LI) = YtoOperate(LI) ZopeBase(LI) = 0# Ccode = Asc(Color(LI)) Rem Ccode = Asc(Trim(Color(Li))) '全くキャラクタのない文字列をASC関数に渡すとエラーになるのでTRIMは使用しない Rem Trim for vacant strings-chr is makes to error Rem if lines color data is nomeaning, it alwasy becomr to 1 byte space, Rem it not makes error-- '初期化時に全てのデータ文字列は半角スペースに初期化される事で対応 If 0 < Err.Number Then 'このエラーとラップは残す MsgBox TotalName(LI) + vbCrLf + Err.Description Stop End If Rem スペクトル型の描画色への反映全角ではなく半角しかし大文字小文字でもかまわない Rem display color made from spectol chr :large and small letters are ok//-- Rem LC = 0 'Small CHR of 1byte alphabet Rem LC = 32 'Large CHR RGBtmp = RGB(80, 80, 80) 'init to Grey Color For LC = 0 To 32 Step 32 'この書式は大文字小文字ともにヒットする on asc, a-A is 32 deffer chr code Select Case Ccode Rem Case 1 :rgb(,,)'template Rem o111 b98 a97 f102 g103 k107 m109 'chr code Case 111 - LC: RGBtmp = RGB(255, 128, 255) 'Oo purple Case 98 - LC: RGBtmp = RGB(128, 128, 255) 'Bb blue Case 97 - LC: RGBtmp = RGB(255, 255, 255) 'Aa white Case 102 - LC: RGBtmp = RGB(255, 255, 192) 'Ff cream Case 103 - LC: RGBtmp = RGB(255, 255, 0) 'Gg yellow Case 107 - LC: RGBtmp = RGB(255, 128, 0) 'Kk orange Case 109 - LC: RGBtmp = RGB(255, 0, 0) 'Mm red Case 110 - LC: RGBtmp = RGB(180, 180, 255) 'Nn Nebure water blue End Select Next RGB_COLOR(LI) = RGBtmp End Sub Public Function GuideStrExistsCHK(CommentSTR) 'made new on the renewal 0.04 Dim StakeInt As String StakeInt = 0 Rem stakeint=stakeint+instr(commentstr,commentstr) StakeInt = StakeInt + InStr(CommentSTR, CommentGuideSTR) StakeInt = StakeInt + InStr(CommentSTR, CommentEquSTR) StakeInt = StakeInt + InStr(CommentSTR, CommentGlxSTR) StakeInt = StakeInt + InStr(CommentSTR, CommentStellaSTR) If StakeInt = 0 Then GuideStrExistsCHK = False Else GuideStrExistsCHK = True End If End Function Public Function RoundNum(InputDouble, N) 'N は 有効桁数N is significant places Dim Step10DegitS '入力数値の小数部分を含まない桁数 Dim SmallRateForRound_Log '四捨五入用桁数倍率調整用指数 Step10DegitS = Int(Log(InputDouble) / Log(10)) + 1 SmallRateForRound_Log = N - Step10DegitS RoundNum = Int(InputDouble * 10 ^ SmallRateForRound_Log + 0.5) / (10 ^ SmallRateForRound_Log) End Function Rem ============================================================================================ Rem Rem 格納された天体配列変数からピクチャオブジェクトに座標を描画する Rem Call all star data from array Rem Rem ============================================================================================ Public Sub plotsDraw() Dim k As Integer INDI_FRM.picture1.Cls For k = ActivateLines_SumNumber To 0 Step -1 '第n要素が地球座標を意味しているのでloopを降順に操作する Rem No n member is for the point of the earth, Rem this way is needed for center-direction guide line, Rem The center-guide lines are drawed when star-plot, Rem if the earth point is not initalized, all star-virtical Rem star guide lines gather for the edge point picture-upper left. Rem Rem Therefor, this index-calling loop starts from last No n elaement--. 'こうしないと全ての天体座標の補助線が三次元演算されていない座標点に集まってしまうため '補助線がピクチャの左上の00点にあつまってしまう'8はキューブテストの名残り Call DrawPoinT(k) '以下は旧書式の引数Call DrawPoinT(XtoOperate, YtoOperate, ZtoOperate, k) Rem it is old functional style------- Next k End Sub Rem ============================================================================================ Rem Rem 各配列要素においてピクチャオブジェクトに座標と補助線を描画するPset each one star data on Indi_FRM.picture1 Rem Rem ============================================================================================ Public Sub DrawPoinT(index) '以下は旧書式の引数(objX, objY, objZ, index)old style Dim tmpX As Double Dim tmpY As Double Dim tmpZ As Double Dim x As Double Dim y As Double Dim PX Dim PY Dim BaseX Dim BaseY Dim ZeroX Dim ZeroY Dim Crossbar_bool Dim SqLengH 'SQR Rootof picuteboxピクチャの高さの平方根 Dim RGBc '煩雑になるので色彩変数を格納for the temporary stored Dim PICWID Dim PICHEI Dim CmtSTR Dim DirectionPermission Dim ABSPermittedGuideLine Dim StarRingBigth Rem **renewal 0.04*** this func was developed to new guide lines Rem Crossbar_bool = False Rem If 0 < InStr(Comment(index), commentguidestr) Then ' CmtSTR = Comment(index) Rem init------ Crossbar_bool = False DirectionPermission = False ABSPermittedGuideLine = False If 0 < InStr(CmtSTR, CommentGuideSTR) Then Crossbar_bool = True DirectionPermission = True If CenterDirectionGuideBool = True Then ABSPermittedGuideLine = True End If If 0 < InStr(CmtSTR, CommentStellaSTR) Then Crossbar_bool = True DirectionPermission = False If StellaExpressBool = True Then ABSPermittedGuideLine = True End If If 0 < InStr(CmtSTR, CommentEquSTR) Then Crossbar_bool = True DirectionPermission = False If EqGuideExpressBool = True Then ABSPermittedGuideLine = True End If If 0 < InStr(CmtSTR, CommentGlxSTR) Then Crossbar_bool = True DirectionPermission = False If GxGuideExpressBool = True Then ABSPermittedGuideLine = True End If tmpX = XtoOperate(index) tmpY = YtoOperate(index) tmpZ = ZtoOperate(index) PX = Make2DX(tmpX, tmpY, tmpZ) PY = Make2DY(tmpX, tmpY, tmpZ) SqLengH = INDI_FRM.picture1.ScaleWidth / 2 Rem PX = SqLengH * (1 + X)'ピクチャオブジェクト に対する相対論理 Rem PY = SqLengH * (1 - Y) Rem 星データ表示窓の論理用にピクチャオブジェクト上の表示２Ｄ座標をも格納する Rem 2D display location are also stored for detail text data express PsetX(index) = PX PsetY(index) = PY Rem 描画準備 prepairing to draw------------------------------------------------------- Rem 画面がうるさくなるので枠外の星の脚までは描画しない Rem It do not draw the guide line of over far star from 3d window// Rem 描画 of 三次元座標のＸＹ平面への脚star leg drawing to guide tmpX = XopeBase(index) tmpY = YopeBase(index) Rem tmpZ = ZopeBase(Index) tmpZ = ZopeBase(index) BaseX = Make2DX(tmpX, tmpY, tmpZ) BaseY = Make2DY(tmpX, tmpY, tmpZ) ZeroX = PsetX(ActivateLines_SumNumber) ZeroY = PsetY(ActivateLines_SumNumber) RGBc = RGB_COLOR(index) '煩雑になるから値を 一時格納 If Crossbar_bool = True Then Rem 座標ガイド線の宣言があれば画面外からも地球点までガイド線を引く Rem If PY + PX < 30000 Then 'あまり値が大きくなるとピクチャオブジェクトの動作が乱れる Rem たぶんintegerのため32000以上のピクセルは一度ゼロになる？？ Rem UpDate 0.02 Item4/7******************************************************************** With INDI_FRM.picture1 PICWID = .Width PICHEI = .Height End With Rem 5 to 1.5 If -1.5 * PICWID < PX And PX < 1.5 * PICWID And _ -1.5 * PICHEI < PY And PY < 1.5 * PICHEI Then Rem *************************************************************************************** Rem If CenterDirectionGuideBool = True Then Rem EqGuideExpressBool = True O Rem GxGuideExpressBool = True Then Rem crossar draw--- If ABSPermittedGuideLine = True Then INDI_FRM.picture1.Line (PX - 100, PY)-(PX + 100, PY), RGBc INDI_FRM.picture1.Line (PX, PY - 100)-(PX, PY + 100), RGBc Rem earth direction drawing-- If DirectionPermission = True Then INDI_FRM.picture1.Line (PX, PY)-(ZeroX, ZeroY), RGBc End If End If End If Else Rem ガイド線宣言ブーリアン真でなければ天体データと見なすRegarding the fix star Rem 画面外の天体およびその補助線脚までは描画しないfar out guide leg line not draw If 0 < PX And PX < 2 * SqLengH And _ 0 < PY And PY < 2 * SqLengH Then If StarExpressBigthBool = True Then StarRingBigth = 50 Else StarRingBigth = 20 End If INDI_FRM.picture1.Circle (PX, PY), StarRingBigth, RGBc If StarGuideBool = True Then 'GuideLineOnOff_CHK.Value = 1 Then INDI_FRM.picture1.Line (ZeroX, ZeroY)-(BaseX, BaseY), RGB(128, 128, 128) INDI_FRM.picture1.Line (PX, PY)-(BaseX, BaseY), RGB(128, 128, 128) End If End If End If End Sub Rem 天体三次元座標から描画オブジェクトに対する座標を演算する 画面 X 成分 Public Function Make2DX(tmpX, tmpY, tmpZ) Dim tmpHold Rem UpDate 0.02 Item5-A/7*********************************************************************** Rem _ tmpHold = tmpX * Cos(20 * ThetaToRadian) + _ tmpY * Cos(-20 * ThetaToRadian) + _ tmpZ * Cos(90 * ThetaToRadian) Rem tmpHold = tmpX * Cos(0 * ThetaToRadian) + _ tmpZ * Cos(90 * ThetaToRadian) Rem ******************************************************************************************** Rem 0.04 arctangent perspective renewal tmpHold = ThetaView(tmpX, tmpY, tmpZ, True) Make2DX = INDI_FRM.picture1.ScaleWidth * (1 + ZoomRate * tmpHold) / 2 End Function Rem おなじく 画面 Y 成分 Public Function Make2DY(tmpX, tmpY, tmpZ) Dim tmpHold Rem UpDate 0.02 Item5-B/7*********************************************************************** Rem _ tmpHold = tmpX * Sin(20 * ThetaToRadian) + _ tmpY * Sin(-20 * ThetaToRadian) + _ tmpZ * Sin(90 * ThetaToRadian) Rem tmpHold = tmpX * Sin(0 * ThetaToRadian) + _ tmpZ * Sin(90 * ThetaToRadian) Rem ******************************************************************************************** Rem 0.04 arctan sure tmpHold = ThetaView(tmpX, tmpY, tmpZ, False) Make2DY = INDI_FRM.picture1.ScaleWidth * (1 - ZoomRate * tmpHold) / 2 End Function Public Function ThetaView(x, y, z, PXBool) 'arc tangent perspective Dim Rpara Dim Lpara Dim d 'distance from the earth as view Dim Base Dim Rate Dim tmpR 'tmpRoof Rem | Rem tmpRoof /| dz Rem / | Rem -- Rem dx Rem this triangle is base unit, Rem far percpective the the roof is so small-shirink inthe view Rem rate is arctan_funcresult/tmproof Rem the result Rem Rem new |dx| = rate * |dx| Rem |dz| |dz|, Rem angle | tmpRoof's length Rem view ----------------------------- Rem so far= base Rem the angle (on the radian base) Rem = arctangent(base/tmproof) Rem PostScript Rem the 'Xbase' boolean is dz and dx chanigng for easiness to calcuration Rem and this sight has a fish eyed sight as curve view on so near distances Rem because the num is not correct length being but angle's width. d = 1000 'from view 1000 light years far If PXBool = False Then Rpara = z Lpara = x Else Rpara = x Lpara = z End If If Rpara = 0 And Lpara = 0 Then ThetaView = 0 Else Base = d + y If Base <= 0 Then Rate = 100000 Rem it is sumilar to the infinite Else tmpR = Rpara ^ 2 + Lpara ^ 2 tmpR = tmpR ^ 0.5 Rate = d * (1 / 3.1415) * Atn(tmpR / Base) / tmpR End If ThetaView = Rate * Rpara End If End Function Public Function ValTrim(MatherSTR) As Double 'この論理は余り使っていないThis function is not used now ValTrim = Val(Trim(MatherSTR)) End Function Rem ============================================================================================ Rem Rem 平行移動および回転変換の幾何演算 Rem move action section rolling sliding Rem Rem ============================================================================================ Rem 操作ボタンは全て配列コントロールなのでこのような論理になる 以下 Rem Operation buttons for moving is arrey-componet Rem ==0.04 timer makes continue-calling those button click event Rem on the autobutton pushing phasse===== Public Sub Timer_Timer() SubTune_BTN_CLick (BTNIndexGlobal) End Sub Public Sub Tune_BTN_Click(CI As Integer) 'CI is Control Index If Int(CI / 2) = CI / 2 Then 'no functional action on the index 32 then timer_event stops too Timer.Enabled = False Call SubTune_BTN_CLick(CI) Else BTNIndexGlobal = CI 'global Rem Timer.Interval = 1000'hsb tuner is no-active?? Timer.Enabled = True End If End Sub Public Sub SubTune_BTN_CLick(CI As Integer) Rem ci は二進数　二進数の桁が指示属性を格納// Rem CI is 2 digit for functional constructure Dim YorNotBool As Boolean Dim XOrZBool As Boolean Dim SlideOrRollBool As Boolean Dim PlusOrMinusBool As Boolean Dim ContinueBool As Boolean Dim XYZindex As Integer Dim PM As Integer If 32 <= CI Then Rem it is error on the logic but, Rem and no-function-the32 index button makes stoping of the auto-processes- Else If 16 <= CI Then YorNotBool = True CI = CI - 16 Else YorNotBool = False End If If 8 <= CI Then XOrZBool = True 'code X CI = CI - 8 Else XOrZBool = False 'code Z End If If 4 <= CI Then SlideOrRollBool = True 'roll CI = CI - 4 Else SlideOrRollBool = False 'slide End If If 2 <= CI Then PlusOrMinusBool = True 'plus CI = CI - 2 Else PlusOrMinusBool = False 'minus End If If 1 = CI Then ContinueBool = True 'Auto timer on CI = CI - 1 'This continue boolean now is used logical branch Else 'the timer-auto is choosed by detect index is odd or even on the upper layer-- ContinueBool = False 'off End If 'CI=0 then logical cascerd is end If YorNotBool = True Then XYZindex = 4 Else If XOrZBool = True Then XYZindex = 1 Else XYZindex = 2 End If End If Rem value=3 is no use If PlusOrMinusBool = True Then PM = 1 Else PM = -1 End If If SlideOrRollBool = False Then Call Pre_Slide(PM, XYZindex) Else If XYZindex = 4 Then PM = -PM ' view from -|Y| direction,then anti-ize . Call Pre_Roll(PM, XYZindex) End If End If End Sub Public Sub PastLogic(CI As Integer) 'ボタンコントロール配列に対する命令操作と その解釈old function nouse on the 0.04-- Dim i As Integer Dim j As Integer Dim PM As Integer '回転および平行移動値のplus or minus方向の区別変数 Rem MsgBox ci Rem Stop i = 1 Do Until CI <= (i - 1) * 4 i = i + 1 Loop i = i - 1 j = CI - (i - 1) * 4 Select Case j Case 1 PM = 1 Call Pre_Slide(PM, i) Case 2 PM = -1 Call Pre_Slide(PM, i) Case 3 PM = 1 Call Pre_Roll(PM, i) Case 4 PM = -1 Call Pre_Roll(PM, i) End Select End Sub Rem スライド平行移動論理前処理//pre operation for slide Public Sub Pre_Slide(PM As Integer, XYZindex As Integer) Select Case XYZindex Rem x pole parallel sliding Case 1 Call Slide(XtoOperate, PM) Call Slide(XopeBase, PM) Rem y pole parallel sliding Case 2 Call Slide(ZtoOperate, PM) Call Slide(ZopeBase, PM) Rem no use Case 3: Rem ---do nothing Rem z pole parallel sliding Case 4 Call Slide(YtoOperate, PM) Call Slide(YopeBase, PM) End Select End Sub Rem 回転論理前処理pre operation for rolling Public Sub Pre_Roll(PM As Integer, XYZindex As Integer) Select Case XYZindex Rem This paramater formation on the wuation,==0.04 write=== Rem Rem from viewing from rolling poles's Plus delection,// Rem Upper is plus pole is first element Rem Right is plus pole is seconds element. Rem for example Rem Rem |Y is Plus Rem | Rem | /Z is Minus Rem |/ Rem ------------X is Plus Rem / Rem Z is Plus-- Rem Rem in this case, rolling around Z pole,and expression is next: Rem roll(Yarrey, Xarrey, PlusMinusParametorForRollingAngle ) Rem UpperPole RightPole Rem X pole rolling Case 1 Call Roll(ZtoOperate, YtoOperate, PM) Call Roll(ZopeBase, YopeBase, PM) Rem Z pole rolling Case 2 Call Roll(YtoOperate, XtoOperate, PM) Call Roll(YopeBase, XopeBase, PM) Rem no use Case 3: Rem ---do nothing Rem Y pole rolling Case 4 Call Roll(ZtoOperate, XtoOperate, PM) Call Roll(ZopeBase, XopeBase, PM) End Select End Sub Public Sub Slide(ArrayObj, PM As Integer) '配列をポインタ風に丸ごと渡すthrow the arrey-whole as near pointer of the C Rem with XYZ arrey each, plus slide step-unit Dim i As Integer For i = 0 To ActivateLines_SumNumber - 1 + 1 '8キューブテスト ArrayObj(i) = ArrayObj(i) + PM * Stepper_Slide / ZoomRate Next i INDI_FRM.picture1.Cls Call plotsDraw End Sub Public Sub Roll(OBJ1, OBJ2, PM As Integer) '配列をポインタ風に丸ごと渡すthrow arrey-whole as near pointer of the C-- Rem XY YZ ZY each liner transformation,one of each arrey Dim i As Integer For i = 0 To ActivateLines_SumNumber - 1 + 1 '8キューブテスト Call RollCalc(OBJ1, OBJ2, i, PM) Next i INDI_FRM.picture1.Cls Call plotsDraw End Sub Rem SlideCalc Cubruitine is nothing & no need- Public Sub RollCalc(OBJ1, OBJ2, index As Integer, PM As Integer) '回転移動は数学的には一次変換 Rem Rolling around one pole it is a liner transformation-- Dim TMP1 As Double Dim TMP2 As Double Dim inner_Theta As Double '回転ステップ単位込みの変換角度用変数tmp angle parametors- inner_Theta = PM * ThetaToRadian * Stepper_Angle TMP1 = OBJ1(index) TMP2 = OBJ2(index) OBJ1(index) = TMP1 * Cos(inner_Theta) - TMP2 * Sin(inner_Theta) OBJ2(index) = TMP1 * Sin(inner_Theta) + TMP2 * Cos(inner_Theta) End Sub Rem ============================================================================================ Rem Rem 表示倍率変更時の論理 描画オブジェクトに対するのみの論理 天体座標配列は操作しない Rem Zoom Logic Rem Rem ============================================================================================ Public Sub ZoomChange() With INDI_FRM.Zoom_VSB ZoomRate = (2# ^ (.Value / 10)) '変化率をスムースにするために指数関数で倍率を与える Rem change nature a^x style--- End With INDI_FRM.picture1.Cls plotsDraw End Sub Public Sub SlideStep_HSB_Change() Dim tmpValue As Double Dim tmpZoom As Double tmpValue = SlideStep_HSB.Value * 0.1 Stepper_Slide = tmpValue If ZoomRate = 0 Then tmpZoom = 1 Else tmpZoom = ZoomRate End If SlideStep_TXT.Text = "Slide Step/LY = " & RoundNum(tmpValue / tmpZoom, 3) End Sub Public Sub RollAngleStep_HSB_Change() Dim tmpValue tmpValue = RollAngleStep_HSB.Value Stepper_Angle = tmpValue RollAngleStep_TXT.Text = "Roll Step/degree = " & tmpValue End Sub Rem ==0.04=== Public Sub TimerInterval_HSB_Change() Dim tmpValue tmpValue = TimerInterVal_HSB.Value Timer.Interval = tmpValue TimerInterval_TXT.Text = "TimerInterval/sec=" & tmpValue / 1000 End Sub Rem ******************************************************************************************** Rem ********************************************************************************* Rem renewal on 0.04 Rem Rem Main picture1 obj went to Indicate frm,-- this mouse-function are subruitined Rem and controlled from Indicate form's picture object-- Rem ********************************************************************************* Rem UpDate 0.02 Item6-A/7***** Rem Public Sub picture1_MouseDown0.04 Public Sub PictureMouseDown(key As Integer, shift As Integer, x As Single, y As Single) Rem クリック時にピクチュアオブジェクト上の始点位置を取得 グローバル格納 Rem getting the starting points of xy on the picture obj and into global para-- FMP_X = x FMP_Y = y End Sub Rem UpDate 0.02 Item6-B/7***** Rem Public Sub picture1_MouseUp Public Sub PictureMouseUp(key As Integer, shift As Integer, x As Single, y As Single) Rem ドラッグ終了時に終点位置を取得 グローバル格納 Rem finish point LMP_X = x LMP_Y = y Rem 子プロセスを呼び出しcalling subprocess, Rem it calcurates grobal mouse 2 point locational value Rem to roll-moving angle quontities---- Call MouseRoll_CalcAndDisplay End Sub Rem updated 0.04 Public Sub PictureMouseSlideDown(key As Integer, shift As Integer, x As Single, y As Single) FMP_X = x FMP_Y = y End Sub Rem 0.04 Public Sub PictureMouseSlideUp(key As Integer, shift As Integer, x As Single, y As Single) LMP_X = x LMP_Y = y Call MouseSlide_CalcAndDisplay End Sub Rem 0.04 Public Sub PictureMouseCenter(key As Integer, shift As Integer, x As Single, y As Single) With INDI_FRM.picture1 FMP_X = x FMP_Y = y LMP_X = .Width / 2 LMP_Y = .Height / 2 End With Call MouseSlide_CalcAndDisplay End Sub Rem //******************************************************************************* Rem UpDate 0.02 Item7/7************ Public Sub MouseRoll_CalcAndDisplay() Dim DeltaX Dim DeltaY Dim BAK_Stepper_Angle Dim SlowRate SlowRate = 0.1 DeltaX = LMP_X - FMP_X DeltaY = -LMP_Y + FMP_Y 'This anti direction from XY picture object's location system// Rem all element has need to be minus-ize Rem -------------------->X plus ^ Y plus Rem | | Rem | | Rem | | Rem | | Rem v on picture Obj -----------------------> X plus Rem Y plus on the Mathmatical space DeltaX = DeltaX DeltaY = -DeltaY 'Around X pole rolling angle direction is Rem anti from pictureobjects directional value// Rem deltaY on the segment logic, it is rolling direction----- Rem <=On the Screen Rem * Rem ^rolling angle,this value is plus Rem --------*------------------* Rem | X pole Rem |:The roll- Directing from Mouse drag Rem v This value minus quantety With INDI_FRM.picture1 Rem 回転論理はラジアンではなく３６０度単位で入出力をしている Rem ピクチュア半画面で１８０度の回転として認識するように設計 Rem Rem ただし調整変数SlowRateで回転具合の微調整を行う Rem Mouse rooling logic uses the unit 360 not 1 Radian Rem picture objecct half width=180 moving design-- Rem Rem but the SlowRate for tuning. DeltaX = SlowRate * DeltaX * 360 / .Width DeltaY = SlowRate * DeltaY * 360 / .Height End With Rem ボタン操作用回転単位パラメータをページング Rem この値を操作することによって回転角度の量を操作している Rem 回転呼び出し論理は回転論理を呼び出しているだけ 呼び出し時に引数として直接値を渡してはいない Rem 値はグローバル渡し Rem The mouse rolling do es not use the way to call on the many steps Rem for rolling subruitin, Rem it calls only once roll-sub,but it tunes rolling angle quontity Rem as a global parametor will be changed big or small Rem Now value is backed up ,this value is basically for another one and rent it with thanks, Rem sometimes we have to send any christmas-gift with the thanks of this co-operation---------- BAK_Stepper_Angle = Stepper_Angle Rem 3d_Z軸周りに回転rolling around Zpole Stepper_Angle = DeltaX Call Pre_Roll(1, 2) Rem 3d_X軸周りに回転rolling around Xpole Stepper_Angle = DeltaY Call Pre_Roll(1, 1) Rem 回転単位パラメータの値をボタン回転論理用に書き戻す Rem back up functional angle value to restore- Stepper_Angle = BAK_Stepper_Angle End Sub Rem 0.04 Public Sub MouseSlide_CalcAndDisplay() Dim DeltaX Dim DeltaY Dim bakstepper__slide Dim BAK_Stepper_Slide Dim SlowRate Rem MsgBox vbCr//test SlowRate = 6.37 '1# this value manual tuning// DeltaX = LMP_X - FMP_X DeltaY = -LMP_Y + FMP_Y Rem This concerning is same on the past pre_roll With INDI_FRM.picture1 DeltaX = SlowRate * DeltaX / .Width DeltaY = SlowRate * DeltaY / .Height End With BAK_Stepper_Slide = Stepper_Slide Stepper_Slide = DeltaX Call Pre_Slide(1, 1) Rem ^1 is around Xpole Stepper_Slide = DeltaY Call Pre_Slide(1, 2) '画面上向きはＺ軸の正の方向 Rem ^2 is around Zpole Stepper_Slide = BAK_Stepper_Slide End Sub Rem ******************************************************************************************** Rem ============================================================================================ Rem Rem 天体文字情報を表示フォームに表示 表示上画面が近づいた天体データを表示 Rem DisPlay StarName on Indi_FRM.Picture Rem Rem ============================================================================================ Rem Public Sub picture1_MouseMove Public Sub PictureMouseMove(key As Integer, shift As Integer, x As Single, y As Single) Rem ピクチャオブジェクト上でマウス座標に最も近い天体をモンテカルロ法でピックアップする Rem The loop searching Most Near Star for the mouse point Rem with Index Number of 2D data ---- Dim index As Integer Dim tmpLong As Double Dim tmpLongPast As Double Dim hold_Index As Integer Call Change_DisplayOperate(False) tmpLong = 0 tmpLongPast = 10 ^ 10 For index = ActivateLines_SumNumber To 0 Step -1 '8キューブテスト tmpLong = (PsetX(index) - x) ^ 2 + (PsetY(index) - y) ^ 2 If tmpLong < tmpLongPast Then tmpLongPast = tmpLong hold_Index = index End If Next index StarName_TXT.Text = (TotalName(hold_Index)) '==ver0.04 color tuning renewal StarName_TXT.BackColor = ColorSoftize(RGB_COLOR(hold_Index)) StarName_TXT.ForeColor = RGB(200, 200, 200) '0.04 0 to 200 End Sub Rem ver0.04 Public Function ColorSoftize(FullColor) 'the idea from Unlimitted white blue===== Dim b As Double Dim G As Double Dim R As Double Dim DarkRate As Double Dim RemainFC As Double Dim StakeFC As Double RemainFC = Int(FullColor) 'without int unknown errorData Cast type?? StakeFC = 0 DarkRate = 0.5 'b = 0 'do do While b* 256 ^ 2 <= RemainFC 'do do b = b + 1 'Loop 'b = b - 1 'remainfc = remainfc-256 ^ 2 * b ''StakeFC = StakeFC + 256^2*Int(b / 2 + 0.5) b = 0 Do While b * 256 ^ 2 <= RemainFC b = b + 1 Loop b = b - 1 RemainFC = RemainFC - 256 ^ 2 * b StakeFC = StakeFC + 256 ^ 2 * Int(DarkRate * b + 0.5) G = 0 Do While 256 * G <= RemainFC G = G + 1 Loop G = G - 1 RemainFC = RemainFC - 256 * G StakeFC = StakeFC + 256 ^ 1 * Int(DarkRate * G + 0.5) R = 0 Do While R <= RemainFC R = R + 1 Loop R = R - 1 RemainFC = RemainFC - R StakeFC = StakeFC + 256 ^ 0 * Int(DarkRate * R + 0.5) ColorSoftize = StakeFC End Function Rem ============================================================================================ Rem Rem 操作フォーム上でボタンなどの再配置論理 フォームの幅が以前と異なる場合は現行フォームの幅で再配置 Rem Form Component RayOut Dynamic Rem Rem ============================================================================================ Rem renewal 0.04-- Public Sub TuneFrame() Call SubTuneFrame(True) End Sub Public Sub SubTuneFrame(BTNTrue As Boolean) Dim fW As Single 'form Width Dim fH As Single 'form Hieght Dim i As Integer Dim j As Integer Dim k As Integer Dim xyzKind As Integer 'for a middle step calcuration// Dim YOrNotKind As Integer Dim XorZKind As Integer Dim SlideOrRollKind As Integer Dim PlusOrMinusKind As Integer Dim ContinueKind As Integer Dim AASTR As String Dim BBSTR As String Dim ccstr As String Dim DDStr As String Dim tOBJ As Object Dim StarNameTrue As Boolean Dim Wunit As Double Dim Hunit As Double If BTNTrue = True Then StarNameTrue = False Else StarNameTrue = True End If '/ Sqr(2) '黄金比 no use on the 0.04 picture1.Visible = False With StarBowl_FRM Rem .Height = .Width * 1.2 Wunit = .Width / 8 Hunit = .Height / 26 .Caption = "BtnToMove & DetailData " End With With StarName_TXT .Top = 0 .Left = 0 .Width = Wunit * 8 .Height = Hunit * 19 Rem .MultiLine = True .Font.Size = 12 .MousePointer = 1 .Visible = StarNameTrue End With Rem With Indi_FRM until 0.02 '.Height = .Width * 1.2 'With .Picture1 '.Top = 0 '.Left = 0 '.Width = Indi_FRM.Width '.Height = .Width 'End With 'With .exit_btn '.Top = Indi_FRM.Height / 1.2 '.Left = 0 '.Width = Indi_FRM.Width '.Height = Indi_FRM.Height / 12 'End With Rem ------End With Rem 操作ボタンの配置演算 操作ボタンはすべてコントロール配列----------------------------------------- Rem Tune button are all control arrey-componet Rem タブインデックスやショートカットも配列引数から生成 Rem ショートカットの暫定文字は配列因数からアスキーコードを経て添付 Rem Index of arrey-componet is have a imformation of the kindness of those functions-- Rem 4 * 4*2= 32 keys Rem 2th digit 2^5-1 Rem 2^4 place Y or not kind Rem 2^3 place X or Z kind Rem 2^2 place roll ro slid kind Rem 2^1 place plus minus Rem 2^0 continue kind For YOrNotKind = 0 To 1 For XorZKind = 0 To 1 xyzKind = 16 * YOrNotKind + 8 * XorZKind Select Case xyzKind Case 24: AASTR = "Y " Case 16: AASTR = "Y " 'no use Case 8: AASTR = "X " Case 0: AASTR = "Z " End Select For SlideOrRollKind = 0 To 1 Select Case SlideOrRollKind Case 0: BBSTR = "Slide " Case 1: BBSTR = "Roll" End Select For PlusOrMinusKind = 0 To 1 Select Case PlusOrMinusKind Case 0: DDStr = "Minus" Case 1: DDStr = "Plus" End Select For ContinueKind = 0 To 1 i = 16 * YOrNotKind + _ 8 * XorZKind + _ 4 * SlideOrRollKind + _ 2 * PlusOrMinusKind + _ 1 * ContinueKind With tune_btn(i) If ContinueKind = 1 Then .Caption = "Auto" Else .Caption = AASTR + BBSTR + vbCrLf + DDStr '+ " &" + Trim(Chr(97 + I - 1)) End If 'ASC Code でショートカットを生成 Rem 0.04 no use the short cut functions .Width = 2 * Wunit .Height = Hunit * 2 .Top = (8 - 2 * (xyzKind / 8) - (PlusOrMinusKind) - 1) * Hunit * 2 Rem Btnkind = SlideOrRollKind '+ PlusOrMinusKind .Left = 2 * Wunit * (2 * SlideOrRollKind + ContinueKind) If xyzKind = 16 Then .Visible = False Else .Visible = BTNTrue End If .TabIndex = i - 1 + 1 End With Next Next Next Next Next tune_btn(32).Visible = True Rem --common component-------------------------------------------------------------------------- With tune_btn(32) 'design for stop button for the timer-auto continue function .Width = Wunit * 8 .Height = Hunit * 2 .Top = Hunit * 16 .Left = 0 .Caption = "Auto Stop&S" .TabIndex = i + 1 End With With Scale_VSB Rem this virtical SCrollBar is now sleeping ,ZZZZZZZZZZZZ Rem this function has a same in the Indi_FRM-- .Width = Wunit .Height = Me.Height .Top = 0 .Left = Wunit * 8 .Visible = False 'BTNTrue Rem .TabIndex = i + 1 - 1 End With With CSVRead_CHK .Top = Hunit * 21 .Left = Wunit * 4 .Width = Wunit * 3 .Height = Hunit .Caption = "ReadCSV" Rem .Value = 1 this mode operasioned over the reset deed-function-- .Visible = BTNTrue .TabIndex = i + 11 End With With SlideStep_HSB .Top = Hunit * 4 .Left = Wunit * 4 .Width = Wunit * 4 .Height = Hunit .Visible = BTNTrue .TabIndex = i + 2 End With With SlideStep_TXT Set tOBJ = SlideStep_HSB .Font.Size = 8 .Alignment = 2 .Top = Hunit * 4 .Left = 0 .Width = Wunit * 4 .Height = Hunit Rem .Text = "Slide" if the declear in this place, reset function always txt init .Visible = BTNTrue .TabIndex = i + 3 End With With RollAngleStep_HSB .Top = Hunit * 6 .Left = Wunit * 4 .Width = Wunit * 4 .Height = Hunit .Visible = BTNTrue .TabIndex = i + 4 End With With RollAngleStep_TXT .Font.Size = 8 .Alignment = 2 .Top = Hunit * 6 .Left = 0 .Font.Size = 8 .Width = Wunit * 4 .Height = tOBJ.Height Rem .Text = "Roll " sure of the upper same lines// .Visible = BTNTrue .TabIndex = i + 5 End With With TimerInterVal_HSB .Top = Hunit * 7 .Left = Wunit * 4 .Width = Wunit * 4 .Height = Hunit .Visible = BTNTrue .TabIndex = i + 6 End With With TimerInterval_TXT .Font.Size = 8 .Alignment = 2 .Top = Hunit * 7 .Left = 0 .Width = Wunit * 4 .Height = Hunit Rem .Text = "AutoInterval"also sure .Visible = BTNTrue .TabIndex = i + 7 End With With DataFileList_CMB .Top = Hunit * 21 .Left = 0 .Width = Wunit * 4 Rem .Height = Hunit'combo box unable to be small than the font's charactor .Visible = BTNTrue .TabIndex = i + 10 End With Set tOBJ = reset_btn With tOBJ .Top = Hunit * 19 .Left = Wunit * 4 .Width = Wunit * 4 .Height = Hunit * 2 .Caption = "ReSet Equ/Glx &R" .Visible = BTNTrue .TabIndex = i + 8 End With With exit_btn .Top = Hunit * 19 .Left = 0 .Width = Wunit * 4 .Height = Hunit * 2 .Caption = "Exit &X" .Visible = True 'AlwaysTrueDirectExit .TabIndex = i + 9 End With End Sub Public Sub StarName_TXT_Click() Call Change_DisplayOperate(True) End Sub Public Sub Change_DisplayOperate(SwitchBool) 'called picture mousemove event too. SubTuneFrame (SwitchBool) End Sub Rem ====================================================================== Rem Rem All Fix stars' 3D location are calcurated by Galaxies-Location system Rem Rem ====================================================================== Public Function ElOngiGNorthPole01() 'value for 0 to 1-- ElOngiGNorthPole01 = 12 / 24 + 51.4 / 1440 End Function Public Function ElAtiGNorthPole01() 'value from 0 to 1---- ElAtiGNorthPole01 = (27 + 8 / 60) / 360 End Function Public Sub OnGalaxiesIze() Rem 1 minus rolling on z pole galaxies central longitude Rem 2 minus rolling on x pole latitude Dim BAK_Stepper_Angle Dim tmpAngle Dim i BAK_Stepper_Angle = Stepper_Angle tmpAngle = ElOngiGNorthPole01 Stepper_Angle = tmpAngle * 360 Call Roll(XtoOperate, YtoOperate, -1) ' zpole rolling tmpAngle = 1 / 4 - ElAtiGNorthPole01 '1/4 on the 0-1 system ------------is 90 degrees of the 360 system Rem |Z Rem | / Rem | / Rem | / Rem | / Rem |B/ Rem |/ A Rem ----------------X Rem A =Galaxie 's North point latitude Rem B = 90-A Rem Around Y pole, X and Z elements +|B| rolling are All Stars ' Rem Galaxies -system -location pointize on the latitude side// Stepper_Angle = tmpAngle * 360 Call Roll(XtoOperate, ZtoOperate, 1) '--y pole rolling Stepper_Angle = BAK_Stepper_Angle 'restore for button command---- For i = 0 To ActivateLines_SumNumber XopeBase(i) = XtoOperate(i) YopeBase(i) = YtoOperate(i) ZopeBase(i) = 0 'Star guide virtical line as the root are galaxy-planized// Next i End Sub Rem --0.04---------------------------------------------------------------- Rem Rem guide file insert logic Rem Rem ---------------------------------------------------------------------- Public Sub MakeGuideDataFileandJoin() Rem it is called from the place of readtxt then, it is Rem after position that stardata.txt already exist as before layer checking-- Rem Concept Rem equcross.tmp + glxcross.tmp + stella.txt + stardata.txt Rem ---system making file------ prepaired file ---------- Rem => new read tmp file-- Rem need stella.txt chk but no exist is not error Dim RTS 'ReadTextStream Dim WTS 'Write Call MakeEquAndGLXCrossGuide Rem ---------- Set WTS = FSO.createTextFile(WorkFileName) Set RTS = FSO.openTextFile(EquFileName) Do While RTS.AtEndOfStream = False WTS.writeline RTS.readline Loop RTS.Close Set RTS = FSO.openTextFile(GlxFileName) Do While RTS.AtEndOfStream = False WTS.writeline RTS.readline Loop RTS.Close If FSO.fileexists(StellaFileName) = False Then MsgBox "stella file is no exists" Else Set RTS = FSO.openTextFile(StellaFileName) Do While RTS.AtEndOfStream = False WTS.writeline RTS.readline Loop End If Set RTS = FSO.openTextFile(FileName) Do While RTS.AtEndOfStream = False WTS.writeline CummaToTab(RTS.readline) 'csv and tabtxt go through this same process Loop WTS.Close End Sub Public Sub MakeEquAndGLXCrossGuide() Dim EquTS Rem Dim EquFileName global Dim GlxTS Rem Dim GlxFileName global Dim i As Integer Dim j As Integer Dim ZeroSTR As String Dim Times1 As Integer Dim Times2 As Integer Dim tmpSTR As String Rem ------- Dim glO As Double Dim glA As Double Dim GlOngi As Double Dim GlAti As Double Dim x As Double Dim y As Double Dim z As Double Dim tmpX As Double Dim tmpY As Double Dim tmpZ As Double Dim TmP As Double Dim YperX As Double Rem EquFileName = "EquCross.tmp" global Rem GlxFileName = "GlxCross.tmp" global ZeroSTR = "0" Set EquTS = FSO.createTextFile(EquFileName) Set GlxTS = FSO.createTextFile(GlxFileName) For i = 0 To 24 - 1 Rem Select Case i Rem Select Case i Rem Case 0: ReadLineIndex = Val(Mem) Rem Case 1: Name_GreekCHR = Mem Rem Case 2: Name_Stella = Mem Rem Case 3: Name_starJPN = Mem Rem Case 4: Name_starAlabee = Mem Rem Case 5: Longi_Hour = Val(Mem) Rem Case 6: Longi_Minite = Val(Mem) Rem Case 7: lAti_Degree = Val(Mem) Rem Case 8: lAti_Second = Val(Mem) Rem Case 9: tmpBrightGrade = Val(Mem) Rem Case 10: tmpColor_CHR = Mem Rem Case 11: tmpColor_NUM = Mem Rem Case 12: tmpDistance = Val(Mem) Rem Case 13: tmpComment = Mem For Times1 = 1 To 4 tmpSTR = "" tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab + "Equator Guide" tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab + str(i) tmpSTR = tmpSTR + vbTab + ZeroSTR tmpSTR = tmpSTR + vbTab + ZeroSTR tmpSTR = tmpSTR + vbTab + ZeroSTR tmpSTR = tmpSTR + vbTab + "1" tmpSTR = tmpSTR + vbTab + "K" tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab + str(10 ^ Times1) tmpSTR = tmpSTR + vbTab + CommentEquSTR EquTS.writeline tmpSTR Next Times1 Rem --------- j = i * 2 * 3.14 / 24 Rem x = Cos(j) y = Sin(j) z = 0 glO = ElOngiGNorthPole01 * 2 * 3.14 glA = (1 / 4 - ElAtiGNorthPole01) * 2 * 3.14 tmpZ = Cos(glA) * z - Sin(glA) * x tmpX = Sin(glA) * z + Cos(glA) * x tmpY = y x = tmpX y = tmpY z = tmpZ tmpX = Cos(glO) * x - Sin(glO) * y tmpY = Sin(glO) * x + Cos(glO) * y tmpZ = z x = tmpX y = tmpY z = tmpZ TmP = x ^ 2 + y ^ 2 TmP = TmP ^ 0.5 GlAti = 180 * Atn(z / TmP) / 3.1415 YperX = y / x TmP = 12 * Atn(YperX) / 3.1415 If 0 < YperX Then If 0 < x Then TmP = TmP If x < 0 Then TmP = TmP + 12 End If If YperX < 0 Then If 0 < x Then TmP = TmP If x < 0 Then TmP = TmP + 12 End If GlOngi = TmP For Times2 = 1 To 4 tmpSTR = "" tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab + "Milky Way Guide" tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab + str(GlOngi) tmpSTR = tmpSTR + vbTab + ZeroSTR tmpSTR = tmpSTR + vbTab + str(GlAti) tmpSTR = tmpSTR + vbTab + ZeroSTR tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab + "N" tmpSTR = tmpSTR + vbTab tmpSTR = tmpSTR + vbTab + str(10 ^ Times2) tmpSTR = tmpSTR + vbTab + CommentGlxSTR GlxTS.writeline tmpSTR Next Times2 Next i EquTS.Close GlxTS.Close End Sub Public Function LargeAlphabetToSmall(str As String) 'Extention str to small letters-- Dim i As Integer Dim tmpCHR As String Dim StakeSTR As String Dim LenSTR As Integer Dim AscCHR As Integer LenSTR = Len(str) StakeSTR = "" For i = 1 To LenSTR tmpCHR = Mid(str, i, 1) AscCHR = Asc(tmpCHR) If 65 <= AscCHR And AscCHR <= 65 + 26 Then tmpCHR = Chr(AscCHR - 65 + 97) End If StakeSTR = StakeSTR + tmpCHR Next LargeAlphabetToSmall = StakeSTR End Function Public Function CummaToTab(StrWithCM As String) 'for CSV Reading-- Dim LenSTR Dim tmpCHR Dim i Dim StakeSTR StakeSTR = "" LenSTR = Len(StrWithCM) For i = 1 To LenSTR tmpCHR = Mid(StrWithCM, i, 1) If tmpCHR = "," Then tmpCHR = vbTab StakeSTR = StakeSTR + tmpCHR Next CummaToTab = StakeSTR End Function Rem End Sub Rem -------------------------------------------------------------------------------------------- Rem ============================================================================================ Rem ============================================================================================ Rem Rem Logic End 論理の終わり CopyRight 2009--2010 MIYAMA. Rem Rem ============================================================================================ Rem ============================================================================================