Personal Computer World 2002 March/PCWMAR02.iso/software/turbocad/v8trial/TurboCADv8ProfessionalNoReg.exe/Data.Cab/F40749_frmCamera.frm

Visual Basic Form | 2001-10-16 | 11.1 KB | 354 lines

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmCamera
   Caption         =   "SDK Camera Test"
   ClientHeight    =   5760
   ClientLeft      =   36
   ClientTop       =   336
   ClientWidth     =   8832
   OleObjectBlob   =   "frmCamera.frx":0000
   StartUpPosition =   1  'CenterOwner
Attribute VB_Name = "frmCamera"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'******************************************************************'
'*                                                                *'
'*                      TurboCAD for Windows                      *'
'*                   Copyright (c) 1993 - 2001                    *'
'*             International Microcomputer Software, Inc.         *'
'*                            (IMSI)                              *'
'*                      All rights reserved.                      *'
'*                                                                *'
'******************************************************************'
Const zoom_factor = 1.5
Const slide_factor = 0.1
Const tilt_pan_factor = 3.14159265358979 / 18 ' 10 degrees
Const rotate_factor = 3.14159265358979 / 18 ' 10 degrees
Private hwndForm As Long
Private vwForm As View
'FindWindow Win32 API
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub ClearCameraParams()
    tbxPosX = "Not available"
    tbxPosY = "Not available"
    tbxPosZ = "Not available"
    tbxLookAtX = "Not available"
    tbxLookAtY = "Not available"
    tbxLookAtZ = "Not available"
    tbxDirX = "Not available"
    tbxDirY = "Not available"
    tbxDirZ = "Not available"
    tbxUpX = "Not available"
    tbxUpY = "Not available"
    tbxUpZ = "Not available"
    tbxRightX = "Not available"
    tbxRightY = "Not available"
    tbxRightZ = "Not available"
    btnPerspective.Caption = "Not available"
End Sub
Private Sub RefreshCameraParams(gxCam As Camera)
    Dim gxVrt As Vertex
    Set gxVrt = gxCam.Location
    tbxPosX = Round(gxVrt.X, 6)
    tbxPosY = Round(gxVrt.Y, 6)
    tbxPosZ = Round(gxVrt.Z, 6)
    Set gxVrt = gxCam.LookAt
    tbxLookAtX = Round(gxVrt.X, 6)
    tbxLookAtY = Round(gxVrt.Y, 6)
    tbxLookAtZ = Round(gxVrt.Z, 6)
    Set gxVrt = gxCam.Direction
    tbxDirX = Round(gxVrt.X, 6)
    tbxDirY = Round(gxVrt.Y, 6)
    tbxDirZ = Round(gxVrt.Z, 6)
    Set gxVrt = gxCam.Up
    tbxUpX = Round(gxVrt.X, 6)
    tbxUpY = Round(gxVrt.Y, 6)
    tbxUpZ = Round(gxVrt.Z, 6)
    Set gxVrt = gxCam.Right
    tbxRightX = Round(gxVrt.X, 6)
    tbxRightY = Round(gxVrt.Y, 6)
    tbxRightZ = Round(gxVrt.Z, 6)
    If (gxCam.Perspective) Then
        btnPerspective.Caption = "Perspective"
    Else
        btnPerspective.Caption = "Not Perspective"
    End If
End Sub
Private Sub RefreshViewParams(gxVw As View)
    tbxVwLeft = Round(gxVw.ViewLeft, 6)
    tbxVwTop = Round(gxVw.ViewTop, 6)
    tbxVwWidth = Round(gxVw.ViewWidth, 6)
    tbxVwHeight = Round(gxVw.ViewHeight, 6)
End Sub
Private Sub btnOrbit_Click()
    Dim gxVw As View
    Dim gxCam As Camera
    Dim rf As Double
    rf = rotate_factor
    Set gxVw = ActiveDrawing.ActiveView
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        gxCam.Perspective = True
        gxCam.Orbit rf, True, 10, 0, 0
        gxVw.Refresh
        gxCam.Perspective = False
        RefreshCameraParams gxCam
    Else
        MsgBox "Not available for Paper Space view"
    End If
    RefreshViewParams gxVw
End Sub
Private Sub btnPan_Click()
    Dim gxVw As View
    Dim gxCam As Camera
    Dim pf As Double
    pf = tilt_pan_factor
    Set gxVw = ActiveDrawing.ActiveView
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        gxCam.Pan pf
        gxVw.Refresh
       RefreshCameraParams gxCam
    Else
        MsgBox "Not available for Paper Space view"
    End If
    RefreshViewParams gxVw
End Sub
Private Sub btnRotate_Click()
    Dim gxVw As View
    Dim gxCam As Camera
    Dim rf As Double
    rf = rotate_factor
    Set gxVw = ActiveDrawing.ActiveView
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        gxCam.Perspective = True
        gxCam.Rotate rf, True, 10, 0, 0
        gxVw.Refresh
        gxCam.Perspective = False
       RefreshCameraParams gxCam
    Else
        MsgBox "Not available for Paper Space view"
    End If
    RefreshViewParams gxVw
End Sub
Private Sub ScrollViewLeftOrRight(ByVal gxVw As View, ByVal sf As Double)
    Dim gxCam As Camera
    Dim dSlide As Double
    dSlide = sf * gxVw.ViewWidth
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        gxCam.Slide 0, dSlide
        gxVw.Refresh
       RefreshCameraParams gxCam
    Else
        gxVw.Update = False
        gxVw.Left = gxVw.Left + dSlide
        gxVw.Update = False
    End If
    RefreshViewParams gxVw
End Sub
Private Sub ScrollViewUpOrDown(ByVal gxVw As View, ByVal sf As Double)
    Dim gxCam As Camera
    Dim dSlide As Double
    dSlide = sf * gxVw.ViewHeight
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        gxCam.Slide dSlide, 0
        gxVw.Refresh
       RefreshCameraParams gxCam
    Else
        gxVw.Update = False
        gxVw.Top = gxVw.Top + dSlide
        gxVw.Update = False
    End If
    RefreshViewParams gxVw
End Sub
Private Sub btnScrollLeft_Click()
    ScrollViewLeftOrRight ActiveDrawing.ActiveView, -slide_factor
End Sub
Private Sub btnScrollRight_Click()
    ScrollViewLeftOrRight ActiveDrawing.ActiveView, slide_factor
End Sub
Private Sub btnScrollUp_Click()
    ScrollViewUpOrDown ActiveDrawing.ActiveView, -slide_factor
End Sub
Private Sub btnScrollDown_Click()
    ScrollViewUpOrDown ActiveDrawing.ActiveView, slide_factor
End Sub
Private Sub btnTilt_Click()
    Dim gxVw As View
    Dim gxCam As Camera
    Dim tf As Double
    tf = tilt_pan_factor
    Set gxVw = ActiveDrawing.ActiveView
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        gxCam.Tilt tf
        gxVw.Refresh
        RefreshCameraParams gxCam
    Else
        MsgBox "Not available for Paper Space view"
    End If
    RefreshViewParams gxVw
End Sub
Private Sub ZoomView(ByVal gxVw As View, ByVal zf As Double)
    Dim gxCam As Camera
    Dim x0 As Double
    Dim y0 As Double
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        gxCam.zoom zf
        gxVw.Refresh
        RefreshCameraParams gxCam
    Else
        x0 = gxVw.Left + gxVw.ViewWidth / 2
        y0 = gxVw.Top - gxVw.ViewHeight / 2
        gxVw.Update = False

        gxVw.ViewWidth = gxVw.ViewWidth / zf
        gxVw.ViewHeight = gxVw.ViewHeight / zf

        gxVw.Left = x0 - gxVw.ViewWidth / 2
        gxVw.Top = y0 + gxVw.ViewHeight / 2
        gxVw.Update = False
    End If
    RefreshViewParams gxVw
End Sub
Private Sub ZoomViewToExtents(ByVal gxVw As View)
    Dim gxCam As Camera
    gxVw.ZoomToExtents
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        RefreshCameraParams gxCam
    Else
        ClearCameraParams
    End If
    RefreshViewParams gxVw
End Sub
Private Sub btnZoomIn_Click()
    ZoomView ActiveDrawing.ActiveView, 1 / zoom_factor
End Sub
Private Sub btnZoomOut_Click()
    ZoomView ActiveDrawing.ActiveView, zoom_factor
End Sub
Private Sub btnZoomAll_Click()
    Dim vwActive As View
    Set vwActive = ActiveDrawing.ActiveView
    If Not vwForm Is Nothing Then
        ZoomViewToExtents vwForm
    End If
    ZoomViewToExtents vwActive
End Sub
Private Sub btnPerspective_Click()
    Dim gxVw As View
    Dim gxCam As Camera
    Set gxVw = ActiveDrawing.ActiveView
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera

        If (gxCam.Perspective) Then
            gxCam.Perspective = False
        Else
            gxCam.Perspective = True
        End If

        gxVw.Refresh

        RefreshCameraParams gxCam
        RefreshViewParams gxCam
    Else
        MsgBox "Not available for Paper Space view"
    End If
End Sub
Private Sub btnHiddenLine_Click()
    Dim gxVw As View
    Dim gxRVw As RenderView
    Dim gxRnds As Renders
    Dim gxRnd As Render
    Set gxVw = ActiveDrawing.ActiveView
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxRVw = gxVw.RenderView

        If (gxRVw.IsRenderRunned) Then
            gxRVw.EndRender
        Else
            Set gxRnds = Application.Renders
            Set gxRnd = gxRnds("Hidden Line")

            gxRnd.Run gxVw
        End If
    Else
        MsgBox "Not available for Paper Space view"
    End If
End Sub
Private Sub AddFormView()
    Dim vwActive As View
    Dim dScale As Double
    On Error GoTo NoView
    If vwForm Is Nothing Then
        hwndForm = FindWindow(vbNullString, frmCamera.Caption)
        If hwndForm = 0 Then GoTo NoView

        Set vwActive = ActiveDrawing.ActiveView
        Set vwForm = ActiveDrawing.Views.Add(hwndForm)

        'Set up basic View behavior
        vwForm.FixedAspectRatio = True
        vwForm.Margins = True
        vwForm.CenterOnExtents = True
        vwForm.SpaceMode = vwActive.SpaceMode

        'Scale from dialog units to pixels
        dScale = 4# / 3#
        vwForm.ScreenWidth = fraView.width * dScale
        vwForm.ScreenHeight = fraView.height * dScale
        vwForm.ScreenLeft = fraView.Left * dScale
        vwForm.ScreenTop = fraView.Top * dScale

        'Copy the rest from primary view
        vwForm.ViewWidth = vwActive.ViewWidth
        vwForm.ViewHeight = vwActive.ViewHeight
        vwForm.ViewLeft = vwActive.ViewLeft
        vwForm.ViewTop = vwActive.ViewTop

        'And camera
        vwForm.Camera.Location = vwActive.Camera.Location
        vwForm.Camera.Up = vwActive.Camera.Up
        vwForm.Camera.LookAt = vwActive.Camera.LookAt

        ZoomViewToExtents vwForm
    End If
    Exit Sub
NoView:
    Set vwForm = Nothing
    MsgBox "Error setting up view"
End Sub
Private Sub UserForm_Activate()
    Dim gxVw As View
    Dim gxCam As Camera
    Set gxVw = ActiveDrawing.ActiveView
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        RefreshCameraParams gxCam
    Else
        ClearCameraParams
    End If
    AddFormView
    RefreshViewParams gxVw
End Sub
Private Sub UserForm_Click()
    Dim gxVw As View
    Dim gxCam As Camera
    Set gxVw = ActiveDrawing.ActiveView
    RefreshViewParams gxVw
    If (gxVw.SpaceMode = imsiModelSpace) Then
        Set gxCam = gxVw.Camera
        RefreshCameraParams gxVw
    Else
        ClearCameraParams
    End If
End Sub