GFInfoTrailer/GFInfoTrailermod.bas
Attribute VB_Name = "GFInfoTrailermod"
Option Explicit
'(c)2001, 2002 by Louis. Note that this is a beta version (does not work so good yet).
'
#Const TickTargetFormIsMfrmFlag = False 'enable if TickTargetForm is Mfrm
'
'NOTE: the target project can call GFInfoTrailer_TargetFrom_Enable()
'to make GFInfoTrailer call GFInfoTrailer_Tick for every drawing loop.
'Public Sub GFInfoTrailer_Tick()
' 'on error resume next
'End Sub
'
'DrawLoop
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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) As Long
'GFInfoTrailer_GetAuthorization
Public Declare Function GFInfoTrailer_GetForegroundWindow Lib "user32" Alias "GetForegroundWindow" () As Long 'must be public (use special name to avoid conflict with other plug‑in modules
'version
Private Const Version As String = "v1.0 beta"
'ObjectType constants
Public Const OBJECTTYPE_TEXT As Integer = 1
Public Const CONST_TEXT As Integer = OBJECTTYPE_TEXT
Public Const OBJECTTYPE_PICTURE As Integer = 2
Public Const CONST_PICTURE As Integer = OBJECTTYPE_PICTURE
Public Const OBJECTTYPE_AVI As Integer = 3 'not supported yet
Public Const CONST_AVI As Integer = OBJECTTYPE_AVI
Public Const OBJECTTYPE_WAVE As Integer = 4
Public Const CONST_WAVE As Integer = OBJECTTYPE_WAVE
Public Const OBJECTTYPE_SPEEDCONTROL As Integer = 5
Public Const CONST_SPEEDCONTROL As Integer = OBJECTTYPE_SPEEDCONTROL
Public Const OBJECTTYPE_PAUSE As Integer = 6
Public Const CONST_PAUSE As Integer = OBJECTTYPE_PAUSE
Public Const OBJECTTYPE_QUAKE As Integer = 7
Public Const CONST_QUAKE As Integer = OBJECTTYPE_QUAKE
Public Const OBJECTTYPE_SAVEDRAWSPEED As Integer = 100
Public Const OBJECTTYPE_RECOVERDRAWSPEED As Integer = 101
Public Const OBJECTTYPE_QUAKEENABLE As Integer = 102
Public Const OBJECTTYPE_QUAKEDISABLE As Integer = 103
'ObjectPos constants
'x position
Public Const OBJECTXPOS_CENTERED As Integer = (‑2)
Public Const CONST_CENTERED As Integer = OBJECTXPOS_CENTERED
Public Const OBJECTXPOS_LEFT As Integer = (‑3)
Public Const CONST_LEFT = OBJECTXPOS_LEFT
Public Const OBJECTXPOS_RIGHT As Integer = (‑4)
Public Const CONST_RIGHT = OBJECTXPOS_RIGHT
'y position
'none
'ObjectName constants
Public Const LASTADDEDOBJECT As String = "CONSTANT LAST ADDED OBJECT"
Public Const LASTADDEDSIZEOBJECT As String = "CONSTANT LAST ADDED SIZE OBJECT"
'NOTE: LASTADDEDSIZEOBJECT must be an object with a special height (e.g. no pause or speed control)
'other constants
Public Const GFINFOTRAILER_ANIMATIONCONTROL As Integer = 1 'should be 8, but does not work
'Layers
Public l1 As New GFInfoTrailer_Layercls
Public L2 As New GFInfoTrailer_Layercls
Public L3 As New GFInfoTrailer_Layercls
'Program
Private Type ProgramStruct
AuthorizationExistingFlag As Boolean
InitializedFlag As Boolean
End Type
Dim ProgramStructVar As ProgramStruct
'Tick
Dim TickTargetFormEnabledFlag As Boolean
Dim TickTargetForm As Object
'other
Dim DrawCollectingPicture As PictureBox
Dim DrawTargetPicture As PictureBox
Dim DrawLoopCancelFlag As Boolean
'
'NOTE: how the whole stuff works:
'The GFInfoTrailer is a 'plug‑in' module that allows to display a slide show
'in a dedicated picture box, the 'TargetPicture'. First call GFInfoTrailer_Initialize()
'to set the TargetPicture. Then you should add a standard font by calling
'GFIT_AddFont(). After that you can add objects.
'Object types available at the time are (object type followed by annotations):
'‑Text: if the font name is "" the standard font will be used, use GetTextBlock()
' to create a multi‑line text block that has not a larger x size than the passed
' value (min. 75).
'‑Picture: the picture must fit in the visible area of the TargetPicture,
' split it up into two pictures using any graphics program if this isn't the case.
'‑AVI: the size of the Animation Control used to play the AVI cannot be determined.
' Note that the Animation Control image is not BitBlted, but the control
' is shown in the TargetPicture. Only one AVI clip can be played at a time.
'‑Wave: wave files are played by the OS asynchronously, note that
' in some tests playing a wave file did hang up Windows when Winamp
' was operating at the same time.
'‑SpeedControl: the passed wParam is the number if pixels the whole
' TargetPicture content is moved within one second.
'‑Pause: wParam is the pause time in seconds, valid values go from 0 to 3600.
'
'When adding objects the following auxiliary functions might be usable:
'‑GetObject[X/Y][Pos/Size]([object name]): returns position or size information
' about an object, you can pass the constant LASTADDEDOBJECT to retrieve
' information about the object previously added.
'‑GetTrailer[Width/Height]: returns size information about the maximum visible
' area.
'‑Pass OBJECTXPOS_CENTERED as object x position to display an object
' centered in the visible area.
'‑Use GFIT_MoveYPos() to set the y position of the next object.
' Note that there are some functions to get special move positions
' (e.g. GETLASTADDEDOBJECTHEIGHT).
'
'Note that invisible objects (e.g. AVI, WAVE, SPEEDCONTROL, PAUSE) have
'the width and height 1 (0 did not work) by default.
'
'NOTE: x pos constants are allocated in ObjectImage_Create(),
'y pos constants are allocated 'earlier', in GFIT_MoveYPos().
'Object type constants are already allocated in GFInfoTrailer_AddObject()
'(interface sub).
'
'NOTE: special tips:
'‑create frames by placing pictures 'around' text
'‑create a 'text desk' by adding a large picture before (!) adding
' a text object within the area of the picture (text will be displayed on picture)
'‑give an important object a special name
' (do not make the system use the default name),
' you then can refer to this object's position (useful for creating frames)
'
'************************************INTERFACE SUBS*************************************
'NOTE: the target project should first call GFInfoTrailer_Initialize() before using the trailer.
'Then the target project can 'program' the trailer by using the layer subs/functions,
'accessible over the Layer object (L1, L2 or L3).
'Note that the current version of GFInfoTrailer supports L1 only.
Public Sub GFInfoTrailer_Initialize(ByRef CollectingPicture As PictureBox, ByRef TargetPicture As PictureBox)
'On Error Resume Next
If ProgramStructVar.InitializedFlag = False Then
'
Set DrawCollectingPicture = CollectingPicture
DrawCollectingPicture.AutoRedraw = False 'reset
DrawCollectingPicture.ScaleMode = vbPixels
Set DrawTargetPicture = TargetPicture
DrawTargetPicture.AutoRedraw = False 'reset
DrawTargetPicture.ScaleMode = vbPixels
Call l1.Layer_Initialize(DrawCollectingPicture, DrawTargetPicture, 1)
Call L2.Layer_Initialize(DrawCollectingPicture, DrawTargetPicture, 2)
Call L3.Layer_Initialize(DrawCollectingPicture, DrawTargetPicture, 3)
'
'NOTE: it is important to check if the InfoTrailer has already been initialized
'as the procedures Load and Unload are used, which must not be called twice.
'
ProgramStructVar.InitializedFlag = True
End If
End Sub
Public Sub GFInfoTrailer_TargetForm_Enable(ByRef TargetForm As Object)
'on error resume next
TickTargetFormEnabledFlag = True
Set TickTargetForm = TargetForm
End Sub
Public Sub GFInfoTrailer_TargetForm_Disable()
'on error resume next
TickTargetFormEnabledFlag = False 'reset
Set TickTargetForm = Nothing 'reset
End Sub
Public Function GFInfoTrailer_IsInitialized() As Boolean
'on error resume next
GFInfoTrailer_IsInitialized = ProgramStructVar.InitializedFlag
End Function
Public Sub DrawLoop(ByVal YDrawStartPos As Long)
'On Error Resume Next 'call this sub to start the trailer show
Dim TimerOld As Single
Dim TimerCurrent As Single
Dim StructLoop As Integer
'verify
If VerifyAuthorization() = False Then Exit Sub
If ProgramStructVar.InitializedFlag = False Then
MsgBox "internal error in DrawLoop() (GFInfoTrailer): initialize first !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'reset
GFInfoTrailerfrm.CreationPicture(1).Cls 'one picture box per layer
GFInfoTrailerfrm.CreationPicture(2).Cls
GFInfoTrailerfrm.CreationPicture(3).Cls
GFInfoTrailerfrm.ObjectImagePicture(1).Cls 'one picture box per layer
GFInfoTrailerfrm.ObjectImagePicture(2).Cls
GFInfoTrailerfrm.ObjectImagePicture(3).Cls
DrawCollectingPicture.Cls
DrawTargetPicture.Cls
'preset
DrawLoopCancelFlag = False
l1.YDrawStartPosMax = l1.YDrawStartPosMax_Calculate
L2.YDrawStartPosMax = L2.YDrawStartPosMax_Calculate
L3.YDrawStartPosMax = L3.YDrawStartPosMax_Calculate
'NOTE: to save memory we enable the AutoRedraw only when necessary.
GFInfoTrailerfrm.CreationPicture(1).AutoRedraw = True
GFInfoTrailerfrm.CreationPicture(2).AutoRedraw = True
GFInfoTrailerfrm.CreationPicture(3).AutoRedraw = True
GFInfoTrailerfrm.ObjectImagePicture(1).AutoRedraw = True
GFInfoTrailerfrm.ObjectImagePicture(2).AutoRedraw = True
GFInfoTrailerfrm.ObjectImagePicture(3).AutoRedraw = True
DrawCollectingPicture.AutoRedraw = True
DrawTargetPicture.AutoRedraw = False
'begin
l1.YDrawStartPos = YDrawStartPos
L2.YDrawStartPos = YDrawStartPos
L3.YDrawStartPos = YDrawStartPos
Call l1.Draw(True) 'initialize
Call L2.Draw(True) 'initialize
Call L3.Draw(True) 'initialize
'
'NOTE: at a frame rate of 25 one frame takes 0.04 seconds.
'The system must use 25 frames per second or misc. time calculations
'are wrong.
'
Do
DrawCollectingPicture.Refresh
GFInfoTrailerfrm.CreationPicture(1).Refresh
TimerOld = Timer
l1.YDrawStartPos = l1.YDrawStartPos + l1.YDrawSpeed
L2.YDrawStartPos = L2.YDrawStartPos + L2.YDrawSpeed
L3.YDrawStartPos = L3.YDrawStartPos + L3.YDrawSpeed
If l1.YDrawStartPos > l1.YDrawStartPosMax Then l1.YDrawStartPos = 0 'reset
If L2.YDrawStartPos > L2.YDrawStartPosMax Then L2.YDrawStartPos = 0 'reset
If L3.YDrawStartPos > L3.YDrawStartPosMax Then L3.YDrawStartPos = 0 'reset
If (L3.ObjectCount) Then Call L3.Draw(False)
If (L2.ObjectCount) Then Call L2.Draw(False)
If (l1.ObjectCount) Then Call l1.Draw(False)
TimerCurrent = Timer
If (TimerCurrent ‑ TimerOld) < 0.04! Then
Call Sleep(40 ‑ (TimerCurrent ‑ TimerOld)) 'passed value must not be 0
End If
Call BitBlt(DrawTargetPicture.hDC, 0, 0, DrawTargetPicture.ScaleWidth, DrawTargetPicture.ScaleHeight, DrawCollectingPicture.hDC, 0, 0, vbSrcCopy)
DoEvents
If TickTargetFormEnabledFlag = True Then
#If TickTargetFormIsMfrmFlag = True Then 'against nasty slow‑downs
'NOTE: the target project can now update animated logos, etc.
Call Mfrm.GFInfoTrailer_Tick
#Else
'NOTE: the target project can now update animated logos, etc.
Call TickTargetForm.GFInfoTrailer_Tick
#End If
End If
Loop Until (DrawLoopCancelFlag = True)
' 'NOTE: disable AutoRedraw again to save memory.
' GFInfoTrailerfrm.CreationPicture(1).AutoRedraw = False 'already unloaded by GFInfoTrailer_Destroy
' GFInfoTrailerfrm.CreationPicture(2).AutoRedraw = False 'already unloaded by GFInfoTrailer_Destroy
' GFInfoTrailerfrm.CreationPicture(3).AutoRedraw = False 'already unloaded by GFInfoTrailer_Destroy
' GFInfoTrailerfrm.ObjectImagePicture(1).AutoRedraw = False 'already unloaded by GFInfoTrailer_Destroy
' GFInfoTrailerfrm.ObjectImagePicture(2).AutoRedraw = False 'already unloaded by GFInfoTrailer_Destroy
' GFInfoTrailerfrm.ObjectImagePicture(3).AutoRedraw = False 'already unloaded by GFInfoTrailer_Destroy
DrawCollectingPicture.AutoRedraw = False
DrawTargetPicture.AutoRedraw = False
Exit Sub
End Sub
Public Sub DrawLoop_Exit()
'On Error Resume Next
DrawLoopCancelFlag = True
End Sub
Public Sub GFInfoTrailer_Destroy()
'On Error Resume Next 'call when unloading target project
If ProgramStructVar.InitializedFlag = True Then
Call DrawLoop_Exit 'exit draw loop if not done yet
'
'NOTE: destroy layers in reverse direction to unload
'GFInfoTrailerfrm.CreationPicture(3) at first, then
'#2 and finally #1.
'
Call L3.Layer_Destroy
Call L2.Layer_Destroy
Call l1.Layer_Destroy
'
ProgramStructVar.InitializedFlag = False 'reset
End If
End Sub
'*********************************END OF INTERFACE SUBS*********************************
'*************************************AUTHORIZATION*************************************
'NOTE: the target project must have the authorization to use GFInfoTrailer.
'The authorization is gained by passing a string created by the function
'GFInfoTrailer_CreateAuthorizationString to the function
'GFInfoTrailer_GetAuthorization.
'The authorization was implemented at the time when GFInfoTrailer should
'be released as an OCX control, when GFInfoTrailer is compiled into the target
'project the authorization is useless but still necessary.
Public Function GFInfoTrailer_GetAuthorization(ByVal AuthorizationString As String) As Boolean
'On Error Resume Next 'returns True if the target project is allowed to use the GFInfoTrailer code, False if not
Dim EncryptionKeyWord As String
EncryptionKeyWord = Chr$(77) + Chr$(97) + Chr$(116) + Chr$(116) + Chr$(105) + Chr$(97) + Chr$(115) + Chr$(32) + Chr$(77) + Chr$(117) + Chr$(101) + Chr$(108) + Chr$(108) + Chr$(101) + Chr$(114)
'
'NOTE: the target project needs an authorization for using the GFInfoTrailer code.
'See bottom of this module for the code to generate the authorization string.
'The authorization string is created in the following way:
's = Date$ + " " + Time$
's = XOR_Encryption(s, "Matthias Mueller") 'use from now on in every project, no one can steal the copyright anymore
's = XOR_Encryption(s, Str$(Screen.FontCount)) 'hahaha
's = XOR_Encryption(s, Str$(CLng(Sqr(GFInfoTrailer_GetForegroundWindow()) * 3.14!))) 'hohohihihaha
'
'Debug.Print GFInfoTrailer_CreateAuthorizationString
'begin
If EncryptString(EncryptString(EncryptString(AuthorizationString, Str$(CLng(Sqr(GFInfoTrailer_GetForegroundWindow()) * 3.14!))), Str$(Screen.FontCount)), EncryptionKeyWord) = Date$ + " " + time$ Then
ProgramStructVar.AuthorizationExistingFlag = True
GFInfoTrailer_GetAuthorization = True 'ok
Else
ProgramStructVar.AuthorizationExistingFlag = False
GFInfoTrailer_GetAuthorization = False 'error
End If
End Function
Private Function GFInfoTrailer_CreateAuthorizationString() As String
'On Error Resume Next 'copy to the target project, together with EncryptString()
Dim EncryptionKeyWord As String
EncryptionKeyWord = Chr$(77) + Chr$(97) + Chr$(116) + Chr$(116) + Chr$(105) + Chr$(97) + Chr$(115) + Chr$(32) + Chr$(77) + Chr$(117) + Chr$(101) + Chr$(108) + Chr$(108) + Chr$(101) + Chr$(114)
'begin
GFInfoTrailer_CreateAuthorizationString = EncryptString(EncryptString(EncryptString(Date$ + " " + time$, EncryptionKeyWord), Str$(Screen.FontCount)), Str$(CLng(Sqr(GFInfoTrailer_GetForegroundWindow()) * 3.14!)))
End Function
Private Function VerifyAuthorization() As Boolean
'On Error Resume Next 'every important (!) interface sub should contain the line 'If VerifyAuthorization() = False Then Exit Sub'
If ProgramStructVar.AuthorizationExistingFlag = False Then
MsgBox "Sorry, you don't have the authorization to use GFInfoTrailer !", vbOKOnly + vbCritical
VerifyAuthorization = False
Else
VerifyAuthorization = True
End If
End Function
Private Function EncryptString(ByVal EncryptionString As String, ByVal EncryptionKeyWord As String) As String
'On Error Resume Next 'copy to target project, too
Dim KeyWordPos As Long
Dim Temp As Long
'verify
If Len(EncryptionKeyWord) = 0 Then
EncryptString = EncryptionString
End If
'preset
EncryptString = String$(Len(EncryptionString), Chr$(0))
'begin
For Temp = 1 To Len(EncryptionString)
KeyWordPos = KeyWordPos + 1
If KeyWordPos > Len(EncryptionKeyWord) Then KeyWordPos = 1
Mid$(EncryptString, Temp, 1) = Chr$(Asc(Mid$(EncryptionString, Temp, 1)) Xor Asc(Mid$(EncryptionKeyWord, KeyWordPos, 1)))
Next Temp
End Function
'*********************************END OF AUTHORIZATION**********************************
[END OF FILE]