DOS/V Power Report 1997 March/VPR9703A.ISO/MS_DEV/VBCCE/SAMPLES/AxGrafix/AXGrafix.EXE/RCDATA/CABINET/AXGrafix.ctl

Text File | 1996-10-25 | 17KB | 657 lines

VERSION 5.00
Begin VB.UserControl AXGraphic
   Appearance      =   0  'Flat
   BackColor       =   &H80000004&
   BorderStyle     =   1  'Fixed Single
   CanGetFocus     =   0   'False
   ClientHeight    =   870
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5325
   ClipControls    =   0   'False
   PropertyPages   =   "AXGrafix.ctx":0000
   ScaleHeight     =   58
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   355
End
Attribute VB_Name = "AXGraphic"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Dim m_pPct As StdPicture        'Holds a refernce in memory to the original copy
                                'of the image

Dim m_bFlagOn As Byte           'Generally used as a state machine to determine
                                'which methods to trigger based on the client's
                                'selection of properties.

Dim m_strURL As String          'This string holds a URL reference to the displayed
                                'picture if the URLPicture property is set

Dim m_DVal As Long              'Identifies the number of milliseconds to delay
                                'between iterations

Dim m_iIterate As Integer       'Identifies the number of iterations to process
                                'the image with

Dim m_iRESWAV As Integer        'Identifies the wave to play from the res file
Dim m_iType As Integer          'Identifies the image process type
Dim m_iDir As Integer           'Used to specify the direction the control
                                'should scroll

Dim m_ROP1 As Long              'Used to specify the Raster Option used
Dim m_ROP2 As Long              'scrolling

Dim ClearURLOnly As Boolean     'Used to coordinate between setting the picture as
Dim ClearPictureOnly As Boolean 'a URL or standard picture

'These Enums are read by the client to determine which values to put in the VB
'property window list boxes
Public Enum FXType
  FX_SCROLL
  FX_SLATS
  FX_RNDSQUARE
  FX_NONE
End Enum

Public Enum Direction
  DIR_RIGHT
  DIR_LEFT
  DIR_UP
  DIR_DOWN
End Enum

Public Enum RasterType
  RO_NORMAL
  RO_INVERT
  RO_COMBINE
End Enum

Public Enum RESWAVE
  W_BLIP = 1
  W_CLICK = 2
  W_WHOOSH = 3
  W_MIX1 = 4
End Enum

'For sound index property validation
Private Const MAX_SND = 8
Private Const MIN_SND = 1

'Used to set m_bFlagOn for custom properties
Private Const GO_SND As Byte = &H2

Private Const ERR_INVALID = 100

Public Event Click()

Private Sub UserControl_Initialize()

'Hardcoded presets for selected custom properties
m_DVal = 50
m_iIterate = 1
m_bFlagOn = (m_bFlagOn Or GO_SND)
m_iRESWAV = 1

End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
'make sure these properties persist between run, design, and control copy
Dim URL As String
Dim Pic As StdPicture

On Error GoTo RP_ERROR
With PropBag

    BackColor = .ReadProperty("BackColor", UserControl.BackColor)
    BorderStyle = .ReadProperty("BorderStyle", UserControl.BorderStyle)
    EnableSound = .ReadProperty("EnableSound", False)
    DelayValue = .ReadProperty("DelayValue", 50)
    Iterations = .ReadProperty("Iterations", 5)
    ProcessType = .ReadProperty("ProcessType", 1)
    ScrollDirection = .ReadProperty("ScrollDirection", 1)
    ScrollROP1 = .ReadProperty("ScrollROP1", m_ROP1)
    ScrollROP2 = .ReadProperty("ScrollROP2", m_ROP2)
    SoundIndex = .ReadProperty("SoundIndex", m_iRESWAV)

    'This code is used from the AXButton Sample to implement the control's
    'picture as either a standard picture or a URL reference to a standard picture
    URLPicture = .ReadProperty("URLPicture", m_strURL)
    URL = .ReadProperty("URLPicture", "")       ' Read URLPicture property value
    If (URL <> "") Then                         ' If a URL has been entered...
        URLPicture = URL                        ' Attempt to download it now, URL may be unabailable at this time
    Else
        Set Pic = .ReadProperty("Picture", Nothing) ' Read Picture property value
        If Not (Pic Is Nothing) Then            ' URL is not available
            Set Picture = Pic                   ' Use existing picture (This is used only if URL is empty)
        End If
    End If

End With

RP_ERROR:
Resume Next
'Silent failure

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'Make sure these properties persist between run, design, and control copy

On Error GoTo WP_ERROR
With PropBag
    .WriteProperty "BackColor", UserControl.BackColor
    .WriteProperty "BorderStyle", UserControl.BorderStyle
    .WriteProperty "EnableSound", EnableSound, False
    .WriteProperty "DelayValue", 50
    .WriteProperty "Iterations", m_iIterate
    .WriteProperty "Picture", m_pPct, False
    .WriteProperty "ProcessType", m_iType, 1
    .WriteProperty "ScrollDirection", m_iDir, 1
    .WriteProperty "ScrollROP1", ScrollROP1, vbSrcCopy
    .WriteProperty "ScrollROP2", ScrollROP2, vbNotSrcCopy
    .WriteProperty "SoundIndex", m_iRESWAV, 1
    .WriteProperty "URLPicture", m_strURL, ""
End With

WP_ERROR:
Resume Next
'Silent Failure

End Sub

Private Sub RndSquares()

Dim xBuff As Single
Dim yBuff As Single
Dim ScaledW As Single
Dim ScaledH As Single
Dim iScale As Integer
Dim iNumBlock As Integer
Dim sPercent As Single
Dim pPct As StdPicture

Dim lOPCode As Long

lOPCode = vbSrcInvert

  Set pPct = UserControl.Image
  For iNumBlock = 2 To 4
    DoEvents
    For iScale = iNumBlock To 1 Step -1
      sPercent = iScale / iNumBlock
      ScaledW = UserControl.ScaleWidth * sPercent
      ScaledH = UserControl.ScaleHeight * sPercent
      xBuff = (UserControl.ScaleWidth - ScaledW - 1 + 1) * Rnd + 1
      yBuff = (UserControl.ScaleHeight - ScaledH - 1 + 1) * Rnd + 1
      PaintPicture pPct, xBuff, yBuff, ScaledW, ScaledH, 0, 0, ScaledW, _
      ScaledH, lOPCode
      DoEvents
      Delay m_DVal
      If lOPCode = vbSrcCopy Then
        lOPCode = vbNotSrcCopy
      Else
        lOPCode = vbSrcCopy
      End If
    Next
  Next

Set pPct = Nothing

End Sub

Private Sub Scroll(iDirection As Integer, OP1 As Long, OP2 As Long)

Dim iPos As Long, iStep As Long, w As Long, h As Long
Dim w2 As Long, h2 As Long

Dim pPct As StdPicture

    With UserControl
      w = .ScaleWidth
      h = .ScaleHeight
      iStep = w / 10
      Set pPct = UserControl.Image
        Select Case iDirection
          Case DIR_RIGHT
            For iPos = iStep To w - iStep Step iStep
                .PaintPicture pPct, 0, 0, iPos, h, w - iPos, 0, iPos, h, OP1
                .PaintPicture pPct, iPos, 0, w - iPos, h, 0, 0, w - iPos, h, OP2
                DoEvents
                Delay m_DVal
            Next
          Case DIR_LEFT
            For iPos = iStep To w - iStep Step iStep
                w2 = w - iPos
                .PaintPicture pPct, w2, 0, iPos, h, 0, 0, iPos, h, OP1
                .PaintPicture pPct, 0, 0, w2, h, iPos, 0, w2, h, OP2
                DoEvents
                Delay m_DVal
            Next
          Case DIR_DOWN
            For iPos = iStep To h - iStep Step iStep
                .PaintPicture pPct, 0, 0, w, iPos, 0, h - iPos, w, iPos, OP1
                .PaintPicture pPct, 0, iPos, w, h - iPos, 0, 0, w, h - iPos, OP2
                DoEvents
                Delay m_DVal
            Next
          Case DIR_UP
            For iPos = iStep To h - iStep Step iStep
                h2 = h - iPos
                .PaintPicture pPct, 0, h2, w, iPos, 0, 0, w, iPos, OP1
                .PaintPicture pPct, 0, 0, w, h2, 0, iPos, w, h2, OP2
                DoEvents
                Delay m_DVal
            Next
        End Select
    End With

  Set pPct = Nothing

End Sub

Private Sub HorizSlats()

Dim pPct As StdPicture
Dim lRet As Long
Dim SlatHeight As Single
Dim Slats As Single
Dim lStep As Single
Dim Px As Single
Dim Py As Single
Dim sSlatCnt As Single
Dim sPosCnt As Single

With UserControl
  Set pPct = .Image
  Slats = 10
  lStep = CLng(.ScaleHeight / 50)
  SlatHeight = .ScaleHeight / Slats
  Px = .ScaleWidth

  .PaintPicture pPct, 0, 0, Px, .ScaleHeight, 0, 0, Px, .ScaleHeight, vbBlackness

  For sSlatCnt = lStep To SlatHeight + lStep Step lStep
    For sPosCnt = 0 To Slats - 1
        Py = SlatHeight * sPosCnt
        .PaintPicture pPct, 0, Py, Px, sSlatCnt, 0, Py, Px, sSlatCnt, vbSrcCopy
        Delay m_DVal
    Next
  Next
End With

'Clean up a bit
Set pPct = Nothing

End Sub

Private Sub StretchInit()

Dim Bmp As BITMAP
Dim lRet As Long
Dim pDc As Long

'IMPORTANT!!! This allows the loaded picture to be persistant
AutoRedraw = True

UserControl.Cls

'Create a valid hdc to load the picture into temporarily
pDc = CreateCompatibleDC(UserControl.hdc)

'SelectObject uses pPct's handle to make m_lPict the active picture for the hdc
lRet = SelectObject(pDc, m_pPct.Handle)

'We are going to need the picture's boundaries for StretchBlt
lRet = GetObject(m_pPct.Handle, Len(Bmp), Bmp)

'Transfer the picture in the temporary hdc over to the *real* hdc (UserControl.hdc)
lRet = StretchBlt(UserControl.hdc, 0, 0, UserControl.ScaleWidth, (UserControl.ScaleHeight), pDc, _
           0, 0, Bmp.bmWidth, (Bmp.bmHeight), SRCCOPY)

UserControl.Refresh

'IMPORTANT!!! This allows the image processing procedures to blt to the usercontrol's
'hDc quickly.  The processed images are not persistent after AutoRedraw is changed.
AutoRedraw = False

'IMPORTANT!!! Since we are using API calls, VB does not know to clean up the
'compatible hDc that we have created.  Clean up a bit so that we don't consume
'more memory than is necessary.
Call DeleteDC(pDc)

End Sub

Private Sub PlayWave()
'The module handle cannot be accessed in design mode for this control's source so...
'do not be suprised if you do not hear anything.  Compile and then load in host app.
Dim hModl As Long
Dim lRes As Long

If (m_bFlagOn And GO_SND) > 0 Then
    lRes = PlaySound("#" & m_iRESWAV, App.hInstance, SND_RESOURCE Or SND_ASYNC)
End If

End Sub

Private Sub Delay(lVal As Long)
Dim lStart As Long

lStart = GetTickCount

Do Until lStart + lVal < GetTickCount
Loop

End Sub

Public Property Get DelayValue() As Long

DelayValue = m_DVal

End Property

Public Property Let DelayValue(ByVal lNew As Long)

m_DVal = lNew

End Property


Private Sub MouseInRange()
Dim lRet As Long

  RunGraphic

End Sub


Private Sub UserControl_Click()

RaiseEvent Click

RunGraphic

End Sub

Private Sub UserControl_Resize()

If Not m_pPct Is Nothing Then StretchInit

End Sub

Private Sub UserControl_Show()

If m_pPct Is Nothing Then
    Set m_pPct = LoadResPicture(9, vbResBitmap)
    StretchInit
End If

End Sub

Private Sub UserControl_Terminate()

Set m_pPct = Nothing

End Sub

Private Sub RunGraphic()

Dim iCnt As Integer

If Not m_pPct Is Nothing Then

    PlayWave

    Select Case m_iType
    Case FX_SCROLL
        Dim lOPCode As Long
        Dim lNotOp As Long
        For iCnt = 1 To m_iIterate
        If lOPCode = m_ROP1 Then
          lOPCode = m_ROP2
          lNotOp = m_ROP1
        Else
          lOPCode = m_ROP1
          lNotOp = m_ROP2
        End If
        Scroll m_iDir, lOPCode, lNotOp
        Next
    Case FX_RNDSQUARE
        For iCnt = 1 To m_iIterate
            RndSquares
        Next
    Case FX_SLATS
        For iCnt = 1 To m_iIterate
            HorizSlats
        Next
    End Select

End If

Cls

End Sub

Public Property Get Iterations() As Integer

Iterations = m_iIterate

End Property

Public Property Let Iterations(ByVal iNew As Integer)

m_iIterate = iNew

PropertyChanged Iterations

End Property

Public Property Get ProcessType() As FXType

ProcessType = m_iType

End Property

Public Property Let ProcessType(ByVal iNew As FXType)

m_iType = iNew

PropertyChanged ProcessType

End Property

Public Property Get ScrollROP1() As RasterType

Select Case m_ROP1
    Case vbSrcCopy
        ScrollROP1 = RO_NORMAL
    Case vbNotSrcCopy
        ScrollROP1 = RO_INVERT
    Case vbSrcAnd
        ScrollROP1 = RO_COMBINE
End Select

End Property

Public Property Let ScrollROP1(ByVal iNew As RasterType)

Select Case iNew
    Case RO_NORMAL
        m_ROP1 = vbSrcCopy
    Case RO_INVERT
        m_ROP1 = vbNotSrcCopy
    Case RO_COMBINE
        m_ROP1 = vbSrcAnd
End Select

PropertyChanged ScrollROP1

End Property

Public Property Get ScrollROP2() As RasterType

Select Case m_ROP2
    Case vbSrcCopy
        ScrollROP2 = RO_NORMAL
    Case vbNotSrcCopy
        ScrollROP2 = RO_INVERT
    Case vbSrcAnd
        ScrollROP2 = RO_COMBINE
End Select

End Property

Public Property Let ScrollROP2(ByVal iNew As RasterType)

Select Case iNew
    Case RO_NORMAL
        m_ROP2 = vbSrcCopy
    Case RO_INVERT
        m_ROP2 = vbNotSrcCopy
    Case RO_COMBINE
        m_ROP2 = vbSrcAnd
End Select

PropertyChanged ScrollROP2

End Property

Public Property Get ScrollDirection() As Direction

ScrollDirection = m_iDir

End Property

Public Property Let ScrollDirection(ByVal iNew As Direction)

m_iDir = iNew

PropertyChanged ScrollDirection

End Property

Public Property Get Picture() As Picture
Attribute Picture.VB_ProcData.VB_Invoke_Property = "StandardPicture;Appearance"
Attribute Picture.VB_UserMemId = 0

Set Picture = m_pPct

End Property

Public Property Set Picture(ByVal pPicture As Picture)

If (Not pPicture Is Nothing) Then

  If Not ClearPictureOnly Then
      ClearURLOnly = True                         ' If Picture property is not being set by the URLPicture
      URLPicture = ""                             ' property then clear the URLPicture value...
      ClearURLOnly = False                        ' If Picture property is not being set by the URLPicture
  End If

  If (pPicture.Handle = 0) Then Set pPicture = Nothing

  Set m_pPct = pPicture                           ' Store image to global variable

  With UserControl
      If Not pPicture Is Nothing Then             ' Check for Null picture value
      On Error Resume Next
        If Err = 0 Then StretchInit
      End If
  End With

  PropertyChanged Picture                         ' Notify property bag of property change

End If

End Property

Public Property Get EnableSound() As Boolean

If (m_bFlagOn And GO_SND) > 0 Then
    EnableSound = True
Else
    EnableSound = False
End If

End Property

Public Property Let EnableSound(ByVal bNewValue As Boolean)

If bNewValue Then
    m_bFlagOn = (m_bFlagOn Or GO_SND)
Else
    m_bFlagOn = Not ((Not m_bFlagOn) Or GO_SND)
End If

PropertyChanged EnableSound

End Property

Public Property Get SoundIndex() As RESWAVE

SoundIndex = m_iRESWAV

End Property

Public Property Let SoundIndex(ByVal iNewValue As RESWAVE)

If iNewValue > MIN_SND - 1 And iNewValue < MAX_SND + 1 Then

    m_iRESWAV = iNewValue
    PropertyChanged SoundIndex

Else

    If UserControl.Ambient.UserMode = True Then
        MsgBox "Invalid index value provided for property", vbExclamation, App.EXEName
    Else
        Err.Raise vbObjectError + ERR_INVALID, App.EXEName, "Invalid index value provided for property"
    End If

End If

End Property

Public Property Let URLPicture(URL As String)

    If (m_strURL <> URL) Then                     ' Do only if value has changed...
        ClearPictureOnly = Not ClearURLOnly       ' If Picture property is not being set by the URLPicture _
                                                  ' property then clear the URLPicture value...
        m_strURL = URL                            ' Save url string value to global variable
        PropertyChanged "URLPicture"              ' Notify property bag of property change

        If Not ClearURLOnly Then
            On Error GoTo ErrorHandler            ' Handle Error if URL is unavailable or Invalid...
            UserControl.AsyncRead URL, vbAsyncTypePicture, "Picture" ' Begin async download of bitmap
        End If
    End If

    Exit Property

ErrorHandler:
'This handles error cases and, if the URL is empty it puts the default bmp from the res file
'into the control.
Set m_pPct = LoadResPicture(9, vbResBitmap)
StretchInit
ClearPictureOnly = False

End Property

Public Property Get URLPicture() As String
    URLPicture = m_strURL                        ' Return URL string value
End Property

Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)

    If (AsyncProp.PropertyName = "Picture") Then  ' Picture download is complete
        ClearPictureOnly = True
        Set Picture = AsyncProp.Value             ' Store picture data to property...
        ClearPictureOnly = False
    End If

End Sub