Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/vbpg32/samples5/ch07/spin.frm

Visual Basic Form | 1997-02-16 | 15.4 KB | 481 lines

VERSION 5.00
Begin VB.Form frmSpin
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Rotation Example"
   ClientHeight    =   6030
   ClientLeft      =   465
   ClientTop       =   1590
   ClientWidth     =   9570
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   402
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   638
   ShowInTaskbar   =   0   'False
   Begin VB.CheckBox chkFun
      Caption         =   "Fun Mode"
      Height          =   195
      Left            =   7020
      TabIndex        =   20
      Top             =   4800
      Value           =   1  'Checked
      Width           =   1395
   End
   Begin VB.CheckBox Check1
      Caption         =   "Timer On/OFF"
      Height          =   255
      Left            =   7020
      TabIndex        =   19
      Top             =   4440
      Value           =   1  'Checked
      Width           =   1335
   End
   Begin VB.TextBox txtEM21
      Height          =   285
      Left            =   8580
      TabIndex        =   17
      Text            =   "0"
      Top             =   4320
      Width           =   735
   End
   Begin VB.TextBox txtEM12
      Height          =   285
      Left            =   8220
      TabIndex        =   15
      Text            =   "0"
      Top             =   2460
      Width           =   735
   End
   Begin VB.HScrollBar scrM21
      Height          =   255
      LargeChange     =   5
      Left            =   7620
      Max             =   200
      Min             =   -200
      TabIndex        =   14
      Top             =   4020
      Width           =   1695
   End
   Begin VB.VScrollBar scrM12
      Height          =   1575
      LargeChange     =   5
      Left            =   7380
      Max             =   200
      Min             =   -200
      TabIndex        =   13
      Top             =   2460
      Width           =   255
   End
   Begin VB.TextBox txtEM22
      Height          =   285
      Left            =   8220
      TabIndex        =   11
      Text            =   "0"
      Top             =   120
      Width           =   735
   End
   Begin VB.TextBox txtEM11
      Height          =   285
      Left            =   8640
      TabIndex        =   9
      Text            =   "0"
      Top             =   1980
      Width           =   735
   End
   Begin VB.VScrollBar scrM22
      Height          =   1575
      LargeChange     =   5
      Left            =   7440
      Max             =   200
      Min             =   -200
      TabIndex        =   8
      Top             =   120
      Width           =   255
   End
   Begin VB.HScrollBar scrM11
      Height          =   255
      LargeChange     =   5
      Left            =   7680
      Max             =   200
      Min             =   -200
      TabIndex        =   7
      Top             =   1680
      Width           =   1695
   End
   Begin VB.TextBox txteDx
      Height          =   285
      Left            =   7920
      TabIndex        =   5
      Text            =   "0"
      Top             =   5700
      Width           =   735
   End
   Begin VB.TextBox txteDy
      Height          =   285
      Left            =   780
      TabIndex        =   3
      Text            =   "0"
      Top             =   240
      Width           =   735
   End
   Begin VB.HScrollBar scrDx
      Height          =   255
      LargeChange     =   20
      Left            =   360
      Max             =   200
      TabIndex        =   2
      Top             =   5700
      Width           =   7095
   End
   Begin VB.VScrollBar scrDy
      Height          =   5475
      LargeChange     =   20
      Left            =   120
      Max             =   200
      TabIndex        =   1
      Top             =   240
      Width           =   255
   End
   Begin VB.CommandButton cmdSet
      Caption         =   "&Set Values"
      Default         =   -1  'True
      Height          =   435
      Left            =   7020
      TabIndex        =   0
      Top             =   5100
      Width           =   1035
   End
   Begin VB.Timer Timer1
      Interval        =   10
      Left            =   8880
      Top             =   5340
   End
   Begin VB.Label Label1
      Caption         =   "eM21"
      Height          =   255
      Index           =   2
      Left            =   8880
      TabIndex        =   18
      Top             =   3720
      Width           =   435
   End
   Begin VB.Label Label1
      Caption         =   "eM12"
      Height          =   255
      Index           =   1
      Left            =   7740
      TabIndex        =   16
      Top             =   2460
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "eM22"
      Height          =   255
      Index           =   3
      Left            =   7740
      TabIndex        =   12
      Top             =   120
      Width           =   555
   End
   Begin VB.Label Label1
      Caption         =   "eM11"
      Height          =   255
      Index           =   0
      Left            =   8940
      TabIndex        =   10
      Top             =   1380
      Width           =   435
   End
   Begin VB.Label Label2
      Caption         =   "eDx"
      Height          =   255
      Index           =   0
      Left            =   7500
      TabIndex        =   6
      Top             =   5700
      Width           =   375
   End
   Begin VB.Label Label2
      Caption         =   "eDy"
      Height          =   255
      Index           =   1
      Left            =   420
      TabIndex        =   4
      Top             =   240
      Width           =   375
   End
Attribute VB_Name = "frmSpin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Copyright
 1997 by Desaware Inc. All Rights Reserved
Dim RotAngle%, increment%
Dim dummy&
Public dviewX1!, dviewX2!, dviewY1!, dviewY2!
Public hPen&, savedDC&
Dim mySize As SIZE, myPoint As POINTAPI
Public viewOrgX&, viewOrgY&, viewExtX&, viewExtY&
Dim myXform As XFORM
Public PI As Double
Dim UpdatingScrollBars%
'**********************************
'**  Type Definitions:
#If Win32 Then
Private Type XFORM
        eM11 As Single
        eM12 As Single
        eM21 As Single
        eM22 As Single
        eDx As Single
        eDy As Single
End Type
Private Type SIZE
    cx As Long
    cy As Long
End Type
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Const PS_SOLID& = 0
'**********************************
'**  Function Declarations:
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
Private Declare Function SetWorldTransform& Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM)
Private Declare Function ModifyWorldTransform& Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM, ByVal iMode As Long)
Private Declare Function GetWorldTransform& Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM)
Private Declare Function SetGraphicsMode& Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long)
Private Declare Function GetViewportExtEx& Lib "gdi32" (ByVal hdc As Long, lpSize As SIZE)
Private Declare Function GetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI)
Private Declare Function SetViewportExtEx& Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As SIZE)
Private Declare Function ScaleViewportExtEx& Lib "gdi32" (ByVal hdc As Long, ByVal nXnum As Long, ByVal nXdenom As Long, ByVal nYnum As Long, ByVal nYdenom As Long, lpSize As SIZE)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
Private Declare Function SetWindowExtEx& Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As SIZE)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function GetWindowExtEx& Lib "gdi32" (ByVal hdc As Long, lpSize As SIZE)
Private Declare Function GetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal nSavedDC As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long)
Private Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, _
        ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)

Private Declare Function StretchBlt& Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, _
        ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
        ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long)

Const GM_ADVANCED& = 2
Const MWT_IDENTITY& = 1
Const MM_ANISOTROPIC& = 8
Const R2_COPYPEN& = 13
Const SRCCOPY& = &HCC0020
Private Sub Check1_Click()
    Timer1.Enabled = Check1.Value
End Sub
Private Sub cmdSet_Click()
    myXform.eDy = CSng(txteDy.Text)
    myXform.eDx = CSng(txteDx.Text)
    myXform.eM11 = CSng(txtEM11.Text)
    myXform.eM12 = CSng(txtEM12.Text)
    myXform.eM21 = CSng(txtEM21.Text)
    myXform.eM22 = CSng(txtEM22.Text)
    Me.Refresh
End Sub
#End If 'WIN32
Private Sub Form_Paint()
    Dim savedDC&
    'Save the DC
    savedDC& = SaveDC&(Me.hdc)
    'Make sure we can rotate
    dummy& = SetMapMode&(Me.hdc, MM_ANISOTROPIC)
    dummy& = SetGraphicsMode&(Me.hdc, GM_ADVANCED)
    PI = 3.14159265358979
    dummy& = SetWorldTransform&(Me.hdc, myXform)
    'Set the text boxes
    txtEM11 = CStr(myXform.eM11)
    txtEM12 = CStr(myXform.eM12)
    txtEM21 = CStr(myXform.eM21)
    txtEM22 = CStr(myXform.eM22)
    txteDx = CStr(myXform.eDx)
    txteDy = CStr(myXform.eDy)
    UpdateScrollBars myXform
    'Set the logical window and the viewport to reasonable values
    dummy& = SetWindowOrgEx&(Me.hdc, 0&, 0&, myPoint)
    dummy& = SetWindowExtEx&(Me.hdc, 100&, 100&, mySize)
    dummy& = SetViewportOrgEx&(Me.hdc, 200&, 150&, myPoint)
    dummy& = SetViewportExtEx&(Me.hdc, 100&, 100&, mySize)
    'Draw the color rectangles and the circle
    dummy& = Rectangle&(Me.hdc, 0, 0, 100, 100)
    Me.ForeColor = &HFF
    dummy& = Rectangle&(Me.hdc, 0, 0, 25, 25)
    Me.ForeColor = QBColor(6)
    dummy& = Rectangle&(Me.hdc, 75, 75, 100, 100)
    Me.ForeColor = QBColor(1)
    dummy& = Rectangle&(Me.hdc, 0, 75, 25, 100)
    Me.ForeColor = QBColor(2)
    dummy& = Rectangle&(Me.hdc, 75, 0, 100, 25)
    Me.ForeColor = QBColor(0)
    dummy& = Ellipse&(Me.hdc, 15, 15, 85, 85)
    'Restore the saved DC
    dummy& = RestoreDC(Me.hdc, savedDC&)
End Sub
Private Sub scrDx_Change()
    If UpdatingScrollBars Then Exit Sub
    myXform.eDx = scrDx
    txteDx = "" & scrDx
    Me.Refresh
End Sub
Private Sub scrDx_Scroll()
    myXform.eDx = scrDx
    txteDx = scrDx
    Me.Refresh
End Sub
Private Sub scrDy_Change()
    If UpdatingScrollBars Then Exit Sub
    myXform.eDy = Abs(scrDy)
    txteDy = "" & scrDy
    Me.Refresh
End Sub
Private Sub scrDy_Scroll()
    myXform.eDy = Abs(scrDy)
    txteDy = "" & scrDy
    Me.Refresh
End Sub
Private Sub scrM11_Change()
    If UpdatingScrollBars Then Exit Sub
    myXform.eM11 = CSng(scrM11) / 100!
    txtEM11 = "" & CSng(scrM11) / 100!
    Me.Refresh
End Sub
Private Sub scrM11_Scroll()
    myXform.eM11 = CSng(scrM11) / 100!
    txtEM11 = "" & CSng(scrM11) / 100!
    Me.Refresh
End Sub
Private Sub scrM12_Change()
    If UpdatingScrollBars Then Exit Sub
    myXform.eM12 = CSng(scrM12) / 100!
    txtEM12 = "" & CSng(scrM12) / 100!
    Me.Refresh
End Sub
Private Sub scrM12_Scroll()
    myXform.eM12 = CSng(scrM12) / 100!
    txtEM12 = "" & CSng(scrM12) / 100!
    Me.Refresh
End Sub
Private Sub scrM21_Change()
    If UpdatingScrollBars Then Exit Sub
    myXform.eM21 = CSng(scrM21) / 100!
    txtEM21 = "" & CSng(scrM21) / 100!
    Me.Refresh
End Sub
Private Sub scrM21_Scroll()
    myXform.eM21 = CSng(scrM21) / 100!
    txtEM21 = "" & CSng(scrM21) / 100!
    Me.Refresh
End Sub
Private Sub scrM22_Change()
    If UpdatingScrollBars Then Exit Sub
    myXform.eM22 = CSng(scrM22) / 100!
    txtEM22 = "" & CSng(scrM22) / 100!
    Me.Refresh
End Sub
Private Sub scrM22_Scroll()
    myXform.eM22 = CSng(scrM22) / 100!
    txtEM22 = "" & CSng(scrM22) / 100!
    Me.Refresh
End Sub
Private Sub Timer1_Timer()
    'This functions provides automatic rotation.
    Static increment%
    Dim radAngle!
    increment% = 5
    'Increase the angle
    RotAngle% = RotAngle% + increment%
    'If we're over 360, go back
    If RotAngle% > 360 Then
        RotAngle% = 5
    End If
    'Convert to radians
    radAngle! = RotAngle% / 180! * PI
    'Set the structure
    If chkFun.Value = 1 Then
        ' Fun rotation
        myXform.eDx = 0
        myXform.eDy = 0
        myXform.eM11 = Sin(radAngle!)
        myXform.eM12 = -1 * Cos(radAngle!)
        myXform.eM21 = Cos(radAngle!)
        myXform.eM22 = 1
    Else
        ' Boring rotation
        myXform.eDx = 0
        myXform.eDy = 25
        myXform.eM11 = Cos(radAngle!)
        myXform.eM12 = Sin(radAngle!)
        myXform.eM21 = -Sin(radAngle!)
        myXform.eM22 = Cos(radAngle!)
    End If

    'Repaint with the new values
    Me.Refresh
End Sub
Private Sub txteDx_LostFocus()
    If txteDx = "" Then
        txteDx = "0"
    End If
End Sub
Private Sub txteDy_LostFocus()
    If txteDx = "" Then
        txteDx = "0"
    End If
End Sub
Private Sub txtEM11_LostFocus()
    If txteDx = "" Then
        txteDx = "0"
    End If
End Sub
Private Sub txtEM12_LostFocus()
    If txteDx = "" Then
        txteDx = "0"
    End If
End Sub
Private Sub txtEM21_LostFocus()
    If txteDx = "" Then
        txteDx = "0"
    End If
End Sub
Private Sub txtEM22_LostFocus()
    If txteDx = "" Then
        txteDx = "0"
    End If
End Sub
Private Sub UpdateScrollBars(xf As XFORM)
    UpdatingScrollBars = True
    scrDy.Value = xf.eDy
    scrDx.Value = xf.eDx
    scrM22.Value = CInt(xf.eM22 * 100)
    scrM21.Value = CInt(xf.eM21 * 100)
    scrM11.Value = CInt(xf.eM11 * 100)
    scrM12.Value = CInt(xf.eM12 * 100)
    UpdatingScrollBars = False
End Sub