Talk:VB6 QuasiVisual3D.frm
Jump to navigation
Jump to search
Private mboLoading As Boolean Private Sub Form_Activate() Debug.Print "Beginning Form_Activate()" Dim FrameRate As Single If BeginRenderLoop = True Then '' Run render loop once '' BeginRenderLoop = False Do Until (RenderLoopCanceled) 'Or Not Me.Visible) If RefreshScene = True Then RefreshScene = False If TickCount < 10 Then TickCount = TickCount + 1 Else FinishTime = Timer If FinishTime <> BeginTime Then FrameRate = TickCount / (FinishTime - BeginTime) Me.Caption = App.Title & " - " & Format(FrameRate, "0.00") & " fps" TickCount = 0 BeginTime = Timer End If End If LastFaceOver = 0 If LockCamera = True Then VLight(MyLight).Origin = _ VectorAdd( _ VectorNull, _ VectorScale( _ OrientationToVector(OrientationInput(0, OrbitLatitude, -OrbitLongitude)), _ -OrbitRadius _ ) _ ) If CameraModel <> 0 Then VMesh(CameraModel).Origin = VLight(MyLight).Origin VMesh(CameraModel).Angles.Pitch = OrbitLatitude VMesh(CameraModel).Angles.Yaw = -OrbitLongitude VMesh(CameraModel).UpdateTransformation = True End If Else Call OrbitCamera(MyCamera, VectorNull, OrbitRadius, OrbitLongitude, OrbitLatitude) VLight(MyLight).Origin = VCamera(MyCamera).Origin End If Picture1.Cls Call RenderImage(Picture1, MyCamera) Picture1.ForeColor = vbWhite Picture1.Print "Longitude: " & Int(RadianToDegree(OrbitLongitude)) Picture1.Print "Latitude: " & Int(RadianToDegree(OrbitLatitude)) Picture1.Print "Radius: " & Int(OrbitRadius) Picture1.Print Picture1.Print "Name: " & VMesh(MyMesh).Tag Picture1.Print "Vertices: " & VMesh(MyMesh).Vertices.Length Picture1.Print "Faces: " & VMesh(MyMesh).Faces.Length End If DoEvents Loop End If Debug.Print "Ending Form_Activate()" End Sub Sub paintCanvas(C As PictureBox) C.Cls RenderImage C, MyCamera LastFaceOver = 0 If LockCamera = True Then VLight(MyLight).Origin = _ VectorAdd( _ VectorNull, _ VectorScale( _ OrientationToVector(OrientationInput(0, OrbitLatitude, -OrbitLongitude)), _ -OrbitRadius _ ) _ ) If CameraModel <> 0 Then VMesh(CameraModel).Origin = VLight(MyLight).Origin VMesh(CameraModel).Angles.Pitch = OrbitLatitude VMesh(CameraModel).Angles.Yaw = -OrbitLongitude VMesh(CameraModel).UpdateTransformation = True End If Else Call OrbitCamera(MyCamera, VectorNull, OrbitRadius, OrbitLongitude, OrbitLatitude) VLight(MyLight).Origin = VCamera(MyCamera).Origin End If Picture1.Cls RenderImage Picture1, MyCamera Picture1.ForeColor = vbWhite Picture1.Print "Longitude: " & Int(RadianToDegree(OrbitLongitude)) Picture1.Print "Latitude: " & Int(RadianToDegree(OrbitLatitude)) Picture1.Print "Radius: " & Int(OrbitRadius) Picture1.Print Picture1.Print "Name: " & VMesh(MyMesh).Tag Picture1.Print "Vertices: " & VMesh(MyMesh).Vertices.Length Picture1.Print "Faces: " & VMesh(MyMesh).Faces.Length End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyEscape Then mnuExit_Click End If End Sub Private Sub Form_Load() Debug.Print "Form_Load" Dim Extension As String On Error Resume Next mboLoading = True '' Anti-recurssion flag (tested in change events) Me.KeyPreview = True '' Added -XenoEngineer, for forever-loop cancellation '' CommonDialog1.CancelError = True InitializeScene InitializeCanvas Picture1, borderStyle:=vbTransparent, backcolor:=vbBlack InitializeCanvas Picture2, borderStyle:=vbTransparent, backcolor:=vbBlack InitializeCanvas Picture3, borderStyle:=vbTransparent, backcolor:=vbBlack mboLoading = False TickCount = 10 MyCamera = AddCamera VCamera(MyCamera).Zoom = 1 VCamera(MyCamera).DrawStyle = 2 mnuDrawStyleOption(2).Checked = True MyLight = AddLight mnuLight.Checked = True OrbitRadius = 200 OrbitSpeed = 0.01 DollySpeed = 1 '' Load dex or 3ds files if on the command line '' If Command <> "" Then Extension = LCase(Right(Command, 3)) If Extension = "dex" Then MyMesh = LoadDexMesh(Command) If Extension = "3ds" Then MyMesh = 0 Load3dsFile Command SetSceneColor ColorLongToRGB(vbWhite), 0.5 End If Call CenterMesh(MyMesh) RefreshScene = True End If BeginRenderLoop = True End Sub Private Sub Form_Resize() Debug.Print "Form_Resize()" If mboLoading Then Exit Sub Dim PaletteWidth As Integer PaletteWidth = Me.ScaleHeight / 20 Picture1.Move 0, 0, Me.ScaleWidth - PaletteWidth, Me.ScaleHeight - PaletteWidth Picture2.Move Me.ScaleWidth - PaletteWidth, 0, PaletteWidth, Me.ScaleHeight - PaletteWidth Picture3.Move 0, Me.ScaleHeight - PaletteWidth, Me.ScaleWidth, PaletteWidth RefreshScene = True End Sub Private Sub Form_Unload(Cancel As Integer) Debug.Print "Form_Unload() " RenderLoopCanceled = True DoEvents End Sub Private Sub mnuAbout_Click() Call ShowAbout End Sub Private Sub mnuBasicOption_Click(Index As Integer) Randomize Call ResetScene(0, MyCamera, MyLight) Select Case Index Case 0 MyMesh = AddMeshBox(VectorInput(40, 40, 40)) Case 1 MyMesh = AddMeshGrid(80, 80, 4, 4, False) Case 2 MyMesh = AddMeshSphere(40, 16, 8) Case 3 MyMesh = AddMeshHemisphere(40, 16, 4) Case 4 MyMesh = AddMeshCone(40, 60, 16) Case 5 MyMesh = AddMeshCylinder(40, 60, 16) Case 6 MyMesh = AddMeshPie(80, 20, 0, 60, 32) Case 7 MyMesh = AddMeshTetrahedron(40) Case 8 MyMesh = AddMeshSphere(40, 4, 2) Case 9 MyMesh = AddMeshGeoSphere(40, 2) Case 10 MyMesh = AddMeshTorus(10, 68.541, 13, 8) End Select Call CenterMesh(MyMesh) Call SetMeshColor(MyMesh, ColorRandom, 0.5) RefreshScene = True End Sub Private Sub mnuColorOption_Click(Index As Integer) Select Case Index Case 0 Call SetMeshColor(MyMesh, ColorLongToRGB(vbWhite), 0.5) Case 1 Call SetMeshColorRandom(MyMesh) Case 2 Call _ SetMeshColorGradient( _ MyMesh, _ 2, _ ColorLongToRGB(vbBlue), _ ColorLongToRGB(vbRed), _ 0.5 _ ) End Select RefreshScene = True End Sub Private Sub mnuComboOption_Click(Index As Integer) Dim A As Integer Dim B As Integer Dim C As Integer Dim D() As Single Dim E() As Long Randomize Call ResetScene(0, MyCamera, MyLight) Select Case Index Case 0 ReDim D(1 To 18) ReDim E(1 To 18) C = 1 For A = 1 To 3 For B = 1 To 6 D(C) = Rnd E(C) = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd) C = C + 1 Next B Next A MyMesh = AddMeshBarGraph(6, 3, VectorInput(80, 40, 40), 5, D(), E()) Case 1 ReDim D(1 To 25) ReDim E(1 To 25) C = 1 For A = 1 To 5 For B = 1 To 5 D(C) = Rnd E(C) = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd) C = C + 1 Next B Next A MyMesh = AddMeshGridGraph(5, 5, VectorInput(80, 40, 80), D(), vbBlue, vbRed, False) Case 2 ReDim D(1 To 4) ReDim E(1 To 4) For A = 1 To 4 D(A) = Rnd E(A) = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd) Next A MyMesh = AddMeshPieGraph(40, 10, 16, D(), E()) End Select RefreshScene = True End Sub Private Sub mnuDrawModeOption_Click(Index As Integer) mnuDrawModeOption(Index).Checked = Not mnuDrawModeOption(Index).Checked Select Case Index Case 0 VCamera(MyCamera).DoubleSided = mnuDrawModeOption(Index).Checked Case 1 VCamera(MyCamera).Metallic = mnuDrawModeOption(Index).Checked Case 2 VCamera(MyCamera).Atmosphere = mnuDrawModeOption(Index).Checked Case 3 VCamera(MyCamera).ColorCorrect = mnuDrawModeOption(Index).Checked End Select RefreshScene = True End Sub Private Sub mnuDrawStyleOption_Click(Index As Integer) mnuDrawStyleOption(VCamera(MyCamera).DrawStyle).Checked = False mnuDrawStyleOption(Index).Checked = True VCamera(MyCamera).DrawStyle = Index RefreshScene = True End Sub Private Sub mnuExit_Click() Debug.Print "mnuExit_Click" Unload Me End Sub Private Sub mnuHomepage_Click() Explore "https://groupkos.com/dev/index.php/Dex3D_Graphics" End Sub Private Sub mnuLight_Click() mnuLight.Checked = Not mnuLight.Checked VLight(MyLight).Enabled = mnuLight.Checked RefreshScene = True End Sub Private Sub mnuLoad_Click() Dim Extension As String On Error Resume Next CommonDialog1.Filter = _ "Dex3D Files (*.dex)|*.dex|3D Studio Files (*.3ds)|*.3ds|All Files (*.*)|*.*" CommonDialog1.ShowOpen If Err = 0 Then Call ResetScene(0, MyCamera, MyLight) Extension = LCase(Right(CommonDialog1.Filename, 3)) If Extension = "dex" Then MyMesh = LoadDexMesh(CommonDialog1.Filename) If Extension = "3ds" Then MyMesh = 1 Call Load3dsFile(CommonDialog1.Filename) Call SetSceneColor(ColorLongToRGB(vbWhite), 0.5) End If RefreshScene = True End If End Sub Private Sub mnuNew_Click() Call ResetScene(0, MyCamera, MyLight) RefreshScene = True End Sub Private Sub mnuOrthographic_Click() mnuOrthographic.Checked = Not mnuOrthographic.Checked VCamera(MyCamera).Orthographic = mnuOrthographic.Checked RefreshScene = True End Sub Private Sub mnuOtherOption_Click() Call ResetScene(0, MyCamera, MyLight) MyMesh = AddMeshGrid(80, 80, 10, 10, False) Call CenterMesh(MyMesh) Call RippleMesh(MyMesh, 40, 20, 0) Call SetMeshColorGradient(MyMesh, 2, ColorLongToRGB(vbBlue), ColorLongToRGB(vbRed), 0.5) RefreshScene = True End Sub Private Sub mnuRename_Click() VMesh(MyMesh).Tag = InputBox("Enter new name:", "Rename", VMesh(MyMesh).Tag) RefreshScene = True End Sub Private Sub mnuSave_Click() On Error Resume Next CommonDialog1.Filter = "Dex3D Files (*.dex)|*.dex|All Files (*.*)|*.*" CommonDialog1.ShowSave If Err = 0 Then Call SaveDexMesh(MyMesh, CommonDialog1.Filename) End Sub Private Sub mnuSpecialOption_Click(Index As Integer) Dim A As Integer Randomize Call ResetScene(0, MyCamera, MyLight) Select Case Index Case 0 For A = 1 To 40 MyMesh = AddMeshPoint(VectorScale(VectorRandom, 40)) Call SetMeshColorRandom(MyMesh) Next A Case 1 For A = 1 To 10 MyMesh = _ AddMeshLine( _ VectorScale(VectorRandom, 40), _ VectorScale(VectorRandom, 40) _ ) Call SetMeshColorRandom(MyMesh) Next A Case 2 For A = 1 To 20 MyMesh = AddMeshText("3D", VectorScale(VectorRandom, 40)) Call SetMeshColorRandom(MyMesh) Next A Case 3 For A = 1 To 10 MyMesh = _ AddMeshCurve( _ VectorScale(VectorRandom, 40), _ VectorScale(VectorRandom, 40), _ VectorScale(VectorRandom, 40), _ VectorScale(VectorRandom, 40) _ ) Call SetMeshColorRandom(MyMesh) Next A End Select RefreshScene = True End Sub Private Sub mnuTessellationOption_Click(Index As Integer) Select Case Index Case 0 Call TessellateMeshByFace(MyMesh, 1) Case 1 Call TessellateMeshByEdge(MyMesh, 1) End Select Call SetMeshColor(MyMesh, ColorLongToRGB(vbWhite), 0.5) RefreshScene = True End Sub Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = CShift Then LockCamera = True If CameraModel = 0 Then CameraModel = AddMeshCone(10, 20, 4) Call CenterMesh(CameraModel) Call TransformMesh(CameraModel, TransformationTranslate(VectorInput(0, 20, 0))) Call TransformMesh(CameraModel, TransformationRotate(1, -Pi / 2)) Call TransformMesh(CameraModel, TransformationRotate(3, Pi / 4)) Call SetMeshColor(CameraModel, ColorLongToRGB(vbRed), 0.5) Me.mnuFile.Enabled = False Me.mnuEdit.Enabled = False Me.mnuView.Enabled = False Me.mnuObject.Enabled = False Me.mnuHelp.Enabled = False End If End If End Sub Private Sub Picture1_KeyUp(KeyCode As Integer, Shift As Integer) If KeyCode = CShift Then LockCamera = False If CameraModel <> 0 Then Call RemoveMesh(CameraModel) CameraModel = 0 Me.mnuFile.Enabled = True Me.mnuEdit.Enabled = True Me.mnuView.Enabled = True Me.mnuObject.Enabled = True Me.mnuHelp.Enabled = True End If RefreshScene = True End If End Sub Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If FaceOver <> 0 Then If CameraModel = 0 Then Select Case Button Case 1 VFace(FaceOver).Color = ColorLongToRGB(BrushColor) VFace(FaceOver).Alpha = BrushAlpha RefreshScene = True Case 2 BrushColor = ColorRGBToLong(VFace(FaceOver).Color) BrushAlpha = VFace(FaceOver).Alpha Call Picture3_Resize End Select End If End If End Sub Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button <> 0 Then Select Case Button Case 1 'orbit Picture1.MousePointer = 15 OrbitLongitude = OrbitLongitude - (X - LastMousePosition.X) * OrbitSpeed OrbitLatitude = OrbitLatitude + (Y - LastMousePosition.Y) * OrbitSpeed If OrbitLongitude > Pi Then OrbitLongitude = OrbitLongitude - (2 * Pi) If OrbitLongitude < -Pi Then OrbitLongitude = OrbitLongitude + (2 * Pi) If OrbitLatitude > (Pi / 2) Then OrbitLatitude = (Pi / 2) If OrbitLatitude < -(Pi / 2) Then OrbitLatitude = -(Pi / 2) Case 2 'dolly Picture1.MousePointer = 7 OrbitRadius = OrbitRadius + (Y - LastMousePosition.Y) * DollySpeed If OrbitRadius < 0 Then OrbitRadius = 0 End Select RefreshScene = True Else If CameraModel = 0 Then FaceOver = FaceByPoint(POINTAPIInput(Int(X), Int(Y))) If FaceOver <> 0 Then Picture1.MousePointer = 2 Else Picture1.MousePointer = 0 End If If FaceOver <> LastFaceOver Then Picture1.DrawMode = 6 Picture1.DrawStyle = 0 Picture1.FillStyle = 1 If LastFaceOver <> 0 Then Call DrawFace(Picture1, LastFaceOver, ColorNull) LastFaceOver = FaceOver Call DrawFace(Picture1, FaceOver, ColorNull) Picture1.Refresh End If Else Picture1.MousePointer = 0 End If End If LastMousePosition.X = X LastMousePosition.Y = Y End Sub Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Call Picture2_MouseMove(Button, Shift, X, Y) End Sub Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Picture2.MousePointer = 2 If Button <> 0 Then PaletteColor = GetPixel(Picture2.hdc, X, Y) If PaletteColor <> -1 Then BrushColor = PaletteColor Call Picture3_Resize End If End Sub Private Sub Picture2_Resize() If mboLoading Then Exit Sub Picture2.Cls DrawColorSpectrum Picture2, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, 2 End Sub Private Sub Picture3_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Call Picture3_MouseMove(Button, Shift, X, Y) End Sub Private Sub Picture3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Picture3.MousePointer = 9 If Button <> 0 Then BrushAlpha = Abs(X - Picture3.ScaleWidth / 2) / (Picture3.ScaleWidth / 2) If BrushAlpha > 1 Then BrushAlpha = 1 Picture3_Resize End If End Sub Private Sub Picture3_Resize() If mboLoading = True Then Exit Sub Picture3.Cls DrawColorShades Picture3, 0, 0, Picture3.ScaleWidth, Picture3.ScaleHeight, 1, BrushColor DrawArrow _ Picture3, _ Picture3.ScaleWidth / 2 + BrushAlpha * Picture3.ScaleWidth / 2, _ 0, _ 1, _ Picture3.Height, _ vbWhite, _ 5 DrawArrow _ Picture3, _ Picture3.ScaleWidth / 2 - BrushAlpha * Picture3.ScaleWidth / 2, _ 0, _ 1, _ Picture3.Height, _ vbWhite, _ 5 End Sub