home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DOS/V Power Report 1997 March
/
VPR9703A.ISO
/
MS_DEV
/
VBCCE
/
SAMPLES
/
AxGrafix
/
AXGrafix.EXE
/
RCDATA
/
CABINET
/
AXGrafix.ctl
< prev
next >
Wrap
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