VERSION 5.00 Begin VB.Form Form1 Caption = "Form1" ClientHeight = 3195 ClientLeft = 60 ClientTop = 345 ClientWidth = 4680 LinkTopic = "Form1" ScaleHeight = 3195 ScaleWidth = 4680 StartUpPosition = 3 'Windows ‚ÌŠù’è’l Begin VB.Timer TimerForPic1Init Left = 2160 Top = 1320 End Begin VB.Timer Timer1 Left = 2280 Top = 720 End Begin VB.CheckBox XYZpolepointpermitCHK Caption = "Check1" Height = 375 Left = 960 TabIndex = 27 Top = 1080 Width = 615 End Begin VB.CheckBox LinePermitCHK Caption = "Check1" Height = 615 Left = 480 TabIndex = 26 Top = 1800 Width = 735 End Begin VB.PictureBox Pic1 Height = 480 Left = 0 ScaleHeight = 420 ScaleWidth = 1140 TabIndex = 0 Top = 0 Width = 1200 End Begin VB.CommandButton RollBTN Height = 480 Index = 0 Left = 0 TabIndex = 1 Top = 0 Width = 1200 End Begin VB.CommandButton RollBTN Height = 480 Index = 1 Left = 0 TabIndex = 2 Top = 0 Width = 1200 End Begin VB.CommandButton RollBTN Height = 480 Index = 2 Left = 0 TabIndex = 3 Top = 0 Width = 1200 End Begin VB.CommandButton RollBTN Height = 480 Index = 3 Left = 0 TabIndex = 4 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 0 Left = 0 TabIndex = 5 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 1 Left = 0 TabIndex = 6 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 2 Left = 0 TabIndex = 7 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 3 Left = 0 TabIndex = 8 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 4 Left = 0 TabIndex = 9 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 5 Left = 0 TabIndex = 10 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 6 Left = 0 TabIndex = 11 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 7 Left = 0 TabIndex = 12 Top = 0 Width = 1200 End Begin VB.TextBox EM Height = 480 Index = 8 Left = 0 TabIndex = 13 Top = 0 Width = 1200 End Begin VB.TextBox inXYZ Height = 480 Index = 0 Left = 0 TabIndex = 14 Top = 0 Width = 1200 End Begin VB.TextBox inXYZ Height = 480 Index = 1 Left = 0 TabIndex = 15 Top = 0 Width = 1200 End Begin VB.TextBox inXYZ Height = 480 Index = 2 Left = 0 TabIndex = 16 Top = 0 Width = 1200 End Begin VB.TextBox DushXYZ Height = 480 Index = 0 Left = 0 TabIndex = 20 Top = 0 Width = 1200 End Begin VB.TextBox DushXYZ Height = 480 Index = 1 Left = 0 TabIndex = 21 Top = 0 Width = 1200 End Begin VB.TextBox DushXYZ Height = 480 Index = 2 Left = 0 TabIndex = 22 Top = 0 Width = 1200 End Begin VB.VScrollBar ZoomHSB Height = 1200 Left = 0 TabIndex = 23 Top = 0 Width = 240 End Begin VB.CommandButton XYZreflexBTN Height = 480 Left = 0 TabIndex = 24 Top = 0 Width = 1200 End Begin VB.CommandButton ExitBTN Height = 480 Left = 0 TabIndex = 25 Top = 0 Width = 1200 End Begin VB.Label inXYZdushLBL Height = 480 Index = 0 Left = 0 TabIndex = 17 Top = 0 Width = 1200 End Begin VB.Label inXYZdushLBL Height = 480 Index = 1 Left = 0 TabIndex = 18 Top = 0 Width = 1200 End Begin VB.Label inXYZdushLBL Height = 480 Index = 2 Left = 0 TabIndex = 19 Top = 0 Width = 1200 End End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Rem ======================================================================================== Rem Rem OctaHedron on 3D Ver 0.01 CopyRight Miyama. 2011 December Rem Rem http://www.geocities.jp/kaz_kimijima Rem kaz_kimijima@yahoo.co.jp Rem Rem ======================================================================================== Option Explicit Rem -parameters on grobal-- Dim OnceTimerEnabled As Boolean 'for Picture1 graaphic initialize Rem Dim FSO 'to make check inner log report as test for making logic Rem Dim WTS Dim E(48 + 6 - 1, 8) 'Elements for 3 by 3 Matrix '48 is 6 pieces by 8 planes of the octahedron '6 is the points on the +-xyz ploes base point Dim P(2) 'Point as XYZ 0 is x 1 is y 2 is z Dim MoveP(48 + 6 - 1, 2) 'The Multiplied E matrix and P Point Dim GX(48 + 6 - 1) As Double 'Practical Graphic point on 2D picture-plane Dim GY(48 + 6 - 1) As Double Dim GCLR(48 + 6 - 1, 2) As Double 'Graphic point's color Dim RGBbind(9, 2) Dim HU As Integer 'Height-Unit number for controls layout Dim WU As Integer 'Width-Unit Dim CommonControl 'for control layout template structure Dim OSD As Double 'One Step Degree on 360 as one round Sub Form_Load() Rem Set FSO = CreateObject("SCRIPTING.FILESYSTEMOBJECT") Rem Set WTS = FSO.CREATETEXTFILE("OCTREP.TXT") OnceTimerEnabled = True With TimerForPic1Init .Enabled = True .Interval = 1 End With OSD = 3.1415 / 180 Call MakeRGBPalette Call ControlsDesign Call ArrayInit End Sub Sub TimerForPic1Init_timer() If OnceTimerEnabled = True Then OnceTimerEnabled = False TimerForPic1Init.Enabled = False Call MakeMoveP Call Graphics End If End Sub Sub MakeRGBPalette() Dim index As Integer Dim R As Integer Dim G As Integer Dim B As Integer Dim j As Integer Dim tmpValue As Integer For index = 0 To 9 Select Case index Case 0 'red R = 255 G = 0 B = 0 Case 1 'green R = 0 G = 255 B = 0 Case 2 'orange R = 255 G = 128 B = 0 Case 3 'waterblue R = 128 G = 128 B = 255 Case 4 'yellow R = 255 G = 255 B = 0 Case 5 'blue R = 0 G = 0 B = 255 Case 6 'pink R = 255 G = 128 B = 128 Case 7 'purple R = 255 G = 0 B = 255 Case 8 'white R = 255 G = 255 B = 255 Case 9 'dark R = 128 G = 128 B = 128 End Select For j = 0 To 2 Select Case j Case 0 tmpValue = R Case 1 tmpValue = G Case 2 tmpValue = B End Select RGBbind(index, j) = tmpValue Next Next End Sub Sub ControlsDesign() Rem Dim WU As Integer 'width unit Rem Dim HU As Integer 'height unit Dim i As Integer Dim j As Integer Dim RealIndex As Integer Dim tmpValue As Variant Rem Dim CommonControl WU = 1000 HU = 1000 With Form1 .Height = 8.5 * HU .Width = 12 * WU .Caption = "OctaHedron on 3D Ver0.01" End With For i = 0 To 2 For j = 0 To 2 RealIndex = 3 * i + j With EM(RealIndex) .Height = HU .Width = WU .Top = i * HU .Left = j * WU .Font.Size = 38 .ForeColor = RGB(40, 40, 40) .Alignment = 2 .Text = 0 End With Next Next With XYZpolepointpermitCHK .Top = 4 * HU .Top = 3 * HU .Left = 2 * WU .Height = HU .Width = WU .Value = 0 .Caption = "DispPolePoint" End With For i = 0 To 2 Set CommonControl = inXYZ(i) Call tune(i) Select Case i Case 0 tmpValue = 2 Case 1 tmpValue = 5 Case 2 tmpValue = 1 End Select With CommonControl .Left = 0 .Text = tmpValue End With Set CommonControl = inXYZdushLBL(i) Call tune(i) Select Case i Case 0 tmpValue = "X" Case 1 tmpValue = "Y" Case 2 tmpValue = "Z" End Select With CommonControl .Left = 1 * WU .BackColor = RGB(255, 128, 128) .Caption = "in out" + vbCrLf + tmpValue .Font.Size = 16 End With Set CommonControl = DushXYZ(i) Call tune(i) With CommonControl .Left = 2 * WU .Text = "0" End With Next With Pic1 .Height = 7 * HU .Width = 7 * WU .Top = 0 * HU .Left = 3 * WU .BackColor = RGB(0, 0, 0) End With For i = 0 To 1 For j = 0 To 1 RealIndex = 2 * i + j With RollBTN(RealIndex) Select Case i Case 0 .Top = 7 * HU .Height = 1 * HU .Left = 3 * WU .Left = (3 + 3.5 * j) * HU .Width = 3.5 * WU Case 1 .Top = 0 * HU .Top = 3.5 * j * HU .Height = 3.5 * HU .Left = 10 * WU .Width = 1 * WU End Select Select Case RealIndex Case 0 .Caption = "Left &L" Case 1 .Caption = "Right &R" Case 2 .Caption = "Up &U" Case 3 .Caption = "Down &D" End Select End With Next Next With LinePermitCHK .Top = 7 * HU .Left = 10 * WU .Height = HU .Width = WU .Value = 1 .Caption = "Center Lines" End With With ZoomHSB .Top = 0 .Left = 11 * WU .Height = 8 * HU .Width = 1 * WU .Min = -1000 .Max = 100 .Value = -400 End With With XYZreflexBTN .Top = 7 * HU .Left = 0 .Height = 1 * HU .Width = 1.5 * WU .Caption = "Fix &F" End With With ExitBTN .Top = 7 * HU .Left = 1.5 * WU .Height = 1 * HU .Width = 1.5 * WU .Caption = "Exit &X" End With End Sub Sub tune(i As Integer) With CommonControl .Height = HU .Width = WU .Top = i * HU + 4 * HU .Font.Size = 38 .ForeColor = RGB(40, 40, 40) .Alignment = 2 End With End Sub Sub ArrayInit() Dim i As Integer Dim j As Integer Dim k As Integer Dim index As Integer Dim OutNewIndex As Integer Dim aI As Integer Dim bI As Integer Dim cI As Integer For i = 0 To 48 + 6 - 1 For j = 0 To 8 E(i, j) = 0 Next Next For i = 0 To 7 index = 6 * i Rem 0 1 2 Rem 3 4 5 Rem 6 7 8 E(index, 0) = 1 E(index, 4) = 1 E(index, 8) = 1 Select Case i Case 0 'posi Rem no doing Case 1 'nega E(index, 0) = -1 Case 2 'posi E(index, 0) = -1 E(index, 4) = -1 Case 3 'nega E(index, 4) = -1 Case 4 'posi E(index, 4) = -1 E(index, 8) = -1 Case 5 'nega E(index, 8) = -1 Case 6 'posi E(index, 0) = -1 E(index, 8) = -1 Case 7 'nega E(index, 0) = -1 E(index, 4) = -1 E(index, 8) = -1 End Select Next For i = 1 To 5 Select Case i Rem 0 1 2 Rem 3 4 5 Rem 6 7 8 Case 1 Rem 2 3 7 aI = 2 bI = 3 cI = 7 Case 2 Rem 1 5 6 aI = 1 bI = 5 cI = 6 Case 3 Rem 0 5 7 aI = 0 bI = 5 cI = 7 Case 4 Rem 1 3 8 aI = 1 bI = 3 cI = 8 Case 5 Rem 2 4 6 aI = 2 bI = 4 cI = 6 End Select E(i, aI) = 1 E(i, bI) = 1 E(i, cI) = 1 Next For i = 48 To 48 + 6 - 1 Select Case i Case 48 aI = 0 bI = 1 Case 49 aI = 0 bI = -1 Case 50 aI = 4 bI = 1 Case 51 aI = 4 bI = -1 Case 52 aI = 8 bI = 1 Case 53 aI = 8 bI = -1 End Select E(i, aI) = bI For k = 0 To 2 GCLR(i, k) = RGBbind(8, k) Next Next Rem multiply--- For i = 0 To 7 For j = 0 To 5 OutNewIndex = i * 6 + j Call MM(OutNewIndex, i * 6, j) 'out 2nd 1st MatrixArray For k = 0 To 2 GCLR(OutNewIndex, k) = RGBbind(i, k) Next Next Next End Sub Sub MM(OutI As Integer, SndI As Integer, FstI As Integer) 'MM is MultiplyMatrix Dim tmpNewMaTrix(8) As Double Dim i As Integer Dim j As Integer For j = 0 To 2 For i = 0 To 2 tmpNewMaTrix(j * 3 + i) = _ E(SndI, j * 3 + 0) * E(FstI, 0 * 3 + i) + _ E(SndI, j * 3 + 1) * E(FstI, 1 * 3 + i) + _ E(SndI, j * 3 + 2) * E(FstI, 2 * 3 + i) Next Next For j = 0 To 2 For i = 0 To 2 E(OutI, j * 3 + i) = tmpNewMaTrix(j * 3 + i) Next Next End Sub Sub xyzreflexbtn_click() MakeMoveP Call Graphics End Sub Sub linepermitchk_click() Call Graphics End Sub Sub xyzpolepointpermitchk_click() Call Graphics End Sub Sub zoomhsb_change() Call Graphics End Sub Sub MakeMoveP() 'to fix uniqe parametors from point value windows--- Dim i As Integer Dim index As Integer For i = 0 To 2 P(i) = Val(inXYZ(i)) Next For index = 0 To 48 + 6 - 1 For i = 0 To 2 MoveP(index, i) = _ E(index, 3 * i + 0) * P(0) + _ E(index, 3 * i + 1) * P(1) + _ E(index, 3 * i + 2) * P(2) Next Next End Sub Sub ExitBTN_Click() Unload Me End Sub Sub RollBTN_Click(index As Integer) Rem index is '0 left '1 rigth '2 down '3 up Rem | / ---> Minus rolling on real physical Rem | / Rem | / Rem |---------- Rem | Rem | Rem <--- index 0 is left rolling from back view Rem | / ^ Rem | / | is up rolling in the phisical. Rem | / Rem |---------- Rem | | Rem | Vindex 2 is down rooling from back,then Rem Dim OSD As Double 'one step degree360 unit Dim i As Integer Dim j As Integer Dim asX As Double Dim asY As Double Dim RA 'real angle Dim tmpAsX As Double Dim tmpAsY As Double Rem OSD = 3.14 / 180 Pic1.Cls For i = 0 To UBound(E) If index <= 1 Then asY = MoveP(i, 1) '1 is y asX = MoveP(i, 0) '0 is x End If If 2 <= index Then asY = MoveP(i, 2) '2 is z asX = MoveP(i, 1) '1 is y End If Select Case index Case 0 RA = -5 * OSD Case 1 RA = 5 * OSD Case 2 RA = -5 * OSD Case 3 RA = 5 * OSD End Select Rem -real rolling--- tmpAsX = asX * Cos(RA) - asY * Sin(RA) tmpAsY = asX * Sin(RA) + asY * Cos(RA) If index <= 1 Then MoveP(i, 1) = tmpAsY MoveP(i, 0) = tmpAsX End If If 2 <= index Then MoveP(i, 2) = tmpAsY MoveP(i, 1) = tmpAsX End If Next Call Graphics End Sub Sub pic1_click() Call Graphics End Sub Sub Graphics() Dim tmpGX As Double Dim tmpGY As Double Dim i As Integer Dim j As Integer Dim tmpZoom As Double Dim ParRate As Double 'Parspective rate Pic1.Cls For i = 0 To UBound(E) ParRate = 50 / (MoveP(i, 1) + 50) tmpGX = _ MoveP(i, 0) * Cos(0 * OSD) + _ 0 * MoveP(i, 1) * Cos(30 * OSD) + _ MoveP(i, 2) * Cos(90 * OSD) tmpGX = ParRate * tmpGX tmpGY = _ MoveP(i, 0) * Sin(0 * OSD) + _ 0 * MoveP(i, 1) * Sin(30 * OSD) + _ MoveP(i, 2) * Sin(90 * OSD) tmpGY = ParRate * tmpGY tmpZoom = 2 ^ (ZoomHSB.Value / 100) With Pic1 tmpGX = .Width * (1 / 2 + tmpZoom * tmpGX) GX(i) = tmpGX tmpGY = .Height * (1 / 2 - tmpZoom * tmpGY) GY(i) = tmpGY If XYZpolepointpermitCHK.Value = 0 And 48 <= i Then Rem do nothing Else Pic1.Circle (tmpGX, tmpGY), 100, RGB(GCLR(i, 0), GCLR(i, 1), GCLR(i, 2)) If LinePermitCHK.Value = 1 Then Pic1.Line (tmpGX, tmpGY)-(.Width / 2, .Height / 2), RGB(64, 64, 64) End If End If End With Next End Sub Sub Pic1_MouseMove(key As Integer, shift As Integer, X As Single, Y As Single) Dim i As Integer Dim j As Integer Rem L is local Dim GXL As Double Dim GYL As Double Dim RoofUp2 As Double Dim MSRUp2 As Double 'most small Dim IndexGot As Integer MSRUp2 = Pic1.Height * 10 For i = 0 To UBound(E) 'E has two element,then this num is hitted to as big number element. GXL = GX(i) GYL = GY(i) RoofUp2 = (GXL - X) ^ 2 + (GYL - Y) ^ 2 If RoofUp2 < MSRUp2 Then MSRUp2 = RoofUp2 IndexGot = i End If Next For i = 0 To 8 EM(i).Text = E(IndexGot, i) Next For i = 0 To 2 j = 3 * i DushXYZ(i).Text = _ P(0) * E(IndexGot, j + 0) + _ P(1) * E(IndexGot, j + 1) + _ P(2) * E(IndexGot, j + 2) Next For i = 0 To 2 inXYZdushLBL(i).BackColor = RGB( _ 256 / 2 + GCLR(IndexGot, 0) / 2, _ 256 / 2 + GCLR(IndexGot, 1) / 2, _ 256 / 2 + GCLR(IndexGot, 2) / 2) Next End Sub Rem ======================================================================================== Rem Rem end of source Rem Rem ========================================================================================