GFContextHelp/GFContextHelpfrm.frm
VERSION 5.00
Begin VB.Form GFContextHelpfrm
BorderStyle = 0 'Kein
Caption = "GFContextHelpfrm"
ClientHeight = 3300
ClientLeft = 0
ClientTop = 0
ClientWidth = 4740
LinkTopic = "Form1"
ScaleHeight = 3300
ScaleWidth = 4740
ShowInTaskbar = 0 'False
StartUpPosition = 3 'Windows‑Standard
Begin VB.PictureBox ContextHelpHeaderPicture
AutoRedraw = ‑1 'True
BorderStyle = 0 'Kein
Enabled = 0 'False
Height = 315
Left = 0
ScaleHeight = 315
ScaleWidth = 4635
TabIndex = 0
Top = 0
Visible = 0 'False
Width = 4635
Begin VB.Image CloseButtonImage
Height = 195
Left = 4320
Picture = "GFContextHelpfrm.frx":0000
Top = 60
Width = 225
End
Begin VB.Image CloseDownImage
Enabled = 0 'False
Height = 195
Left = 2880
Picture = "GFContextHelpfrm.frx":02B2
Top = 60
Visible = 0 'False
Width = 225
End
Begin VB.Image CloseUpImage
Enabled = 0 'False
Height = 195
Left = 3180
Picture = "GFContextHelpfrm.frx":0564
Top = 60
Visible = 0 'False
Width = 225
End
End
Begin VB.PictureBox ImagePicture
AutoRedraw = ‑1 'True
AutoSize = ‑1 'True
Enabled = 0 'False
Height = 315
Left = 4620
ScaleHeight = 255
ScaleWidth = 135
TabIndex = 3
Top = 0
Visible = 0 'False
Width = 195
End
Begin VB.PictureBox ContextHelpPicture
AutoRedraw = ‑1 'True
BorderStyle = 0 'Kein
Height = 2715
Left = 0
ScaleHeight = 2715
ScaleWidth = 4575
TabIndex = 1
Top = 420
Width = 4575
Begin VB.Label LinkLabel
BackStyle = 0 'Transparent
Caption = "LinkLabel"
Height = 165
Index = 0
Left = 0
MouseIcon = "GFContextHelpfrm.frx":0816
MousePointer = 99 'Benutzerdefiniert
TabIndex = 2
Top = 0
UseMnemonic = 0 'False
Visible = 0 'False
Width = 1350
End
End
End
Attribute VB_Name = "GFContextHelpfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Use to display a context help window.
'
#Const GFSkinEngineAvailableFlag = True
'
'NOTE: if the Skin Engine is enabled, then:
'‑the target project must define SECONTROLPALETTE_CONTEXTHELPFRM
'‑disable ContextHelpPicture's frame by setting the frameindex property to 0.
'
'NOTE: ScaleModes:
'GFContextHelpfrm: vbTwips
'ContextHelpPictrue: vbTwips
'ImagePicture: vbTwips
'
'ContextHelp_ShowEx
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'ContextHelp_MakeSureVisible
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
'Image_DrawImages
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
'GFMouseGuide
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'GFPopUpWindow_CreateShadow
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'GFSetWindowOnTop
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long
'ProgramGetMousePos[X, Y]
'Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
'[LO/HI]WORD
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'GFMouseGuide
Private Type POINTAPI
X As Long
Y As Long
End Type
'GFPopUpWindowStruct
Private Type GFPopUpWindowStruct
PopUpWindowRgnHandle As Long
End Type
Dim GFPopUpWindowStructVar As GFPopUpWindowStruct
'ProgramGetMousePos[X, Y]
'Private Type POINTAPI
' x As Long
' y As Long
'End Type
'GFSetWindowOnTop
Private Const HWND_TOPMOST As Long = ‑1
Private Const HWND_NOTOPMOST As Long = ‑2
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOMOVE As Long = &H2
'GFContextHelpStruct
Private Type GFContextHelpStruct
ContextHelpFile As String
ContextHelpString As String 'string that is to be displayed
ContextDefaultControlName As String
ImageDirectory As String 'may be "" if not set by target project
LineLengthFixed As Long 'system will set line length of any displayed help text to this value
End Type
Dim GFContextHelpStructVar As GFContextHelpStruct
'ContextHelpHeaderStruct
Private Type ContextHelpHeaderStruct
HeaderEnabledFlag As Boolean
HeaderHeight As Single 'format: pixels
HeaderText As String
HeaderTextColor As Long 'text color
HeaderTextFont As FontStruct
HeaderTextOffsetX As Single 'format: twips
HeaderTextOffsetY As Single 'format: twips
End Type
Dim ContextHelpHeaderStructVar As ContextHelpHeaderStruct
'ContextHelpRestoreStruct ‑ stores data to allow redrawing help text, links and images
'NOTE: store data that was first time passed to ContextHelpString_Display().
Private Type ContextHelpRestoreStruct
ContextHelpStringUnchanged As String
WindowXPos As Long
WindowYPos As Long
End Type
Dim ContextHelpRestoreStructVar As ContextHelpRestoreStruct
'ProgramTwoLongStruct (former: ProgramTwoLongVar)
Private Type ProgramTwoLongStruct
Long1 As Long
Long2 As Long
End Type
'FilterStruct ‑ contains data for filtering links and images
Private Type FilterStruct
FilterItemAlignment As Integer
End Type
Dim FilterStructVar As FilterStruct
'link and image position constants
Private Const POS_DEFAULT As Integer = 0
Private Const POS_LEFT As Integer = 1
Private Const POS_CENTER As Integer = 2
Private Const POS_RIGHT As Integer = 3
'MarkType constants
Private Const MARKTYPE_LINKSTRUCTPOINTER As Integer = 1
Private Const MARKTYPE_IMAGESTRUCTPOINTER As Integer = 2
'LinkStruct
Private Type LinkStruct
LinkControlName As String
LinkText As String
X As Long
Y As Long
LinkSpecialPos As Integer
End Type
Dim LinkStructNumber As Integer
Dim LinkStructArray() As LinkStruct
'LinkLabelStruct ‑ information for handling link labels
Private Type LinkLabelStruct
LinkLabelIndexMax As Integer
End Type
Dim LinkLabelStructVar As LinkLabelStruct
'LinkClickStruct ‑ used when the user clicked on a label, link‑related data must be stored for later processing
Private Type LinkClickStruct
LinkClickedFlag As Boolean
LinkClickedIndex As Integer
End Type
Dim LinkClickStructVar As LinkClickStruct
'LinkColorStruct ‑ information about the original color of a link
Private Type LinkColorStruct
LinkForeColorChangedFlag As Boolean
LinkForeColorUnchanged As Long 'a link's color is changed when it's clicked
End Type
Dim LinkColorStructVar As LinkColorStruct
'ImageStruct
Private Type ImageStruct
ImageName As String 'path to picture file
X As Long 'format: twips
Y As Long 'format: twips
XSize As Long 'format: pixels
YSize As Long 'format: pixels
ImageSpecialPos As Integer
End Type
Dim ImageStructNumber As Integer
Dim ImageStructArray() As ImageStruct
'CHSMarkStruct ‑ contains ContextHelpString pointers to allow inserting links, images, etc.
Private Type CHSMarkStruct
MarkPos As Long 'position in ContextHelpString
MarkType As Integer 'see MarkType constants
MarkStructIndex As Integer 'pointer to a LinkStructArray() or ImageStructArray() item (depending on type)
End Type
Dim CHSMarkStructNumber As Integer
Dim CHSMarkStructArray() As CHSMarkStruct
'FormMoveStruct
Private Type FormMoveStruct
FormMoveEnabledFlag As Boolean
FormXPos As Long
FormYPos As Long
MousePosX As Long
MousePosY As Long
End Type
Dim FormMoveStructVar As FormMoveStruct
'other
Dim CallBackForm As Object
Dim ContinueFlag As Boolean
Dim StayOnTopFlag As Boolean 'if True then GFContextHelpfrm can only be hidden by the target project
Dim StayOnTopFlagTemp As Boolean 'for temporary use within code
Private Sub Form_Load()
'on error resume next
'do nothing
End Sub
'************************************INTERFACE SUBS*************************************
'
'NOTE: when loading the target project, first call GFContextHelp_Initialize().
'Then you may call ContextHelp_ShowEx() at any time to open the help window.
'The help text will be read in real time from the ContextHelpFile.
'
Public Sub GFContextHelp_Initialize(ByVal ContextHelpFile As String, ByVal DefaultControlName As String, Optional ByVal CallBackFormPassed As Object = Nothing, Optional ByVal LineLengthFixedOrZero As Long = 450)
'on error resume next
'
'NOTE: the help text to display is read out of the context help file.
'If a help text is requested for a control that does not exist,
'the help text of the default control will be displayed.
'
GFContextHelpStructVar.ContextDefaultControlName = DefaultControlName
GFContextHelpStructVar.ContextHelpFile = ContextHelpFile
If GFContextHelpStructVar.ImageDirectory = "" Then 'don't overwrite previous settings, merely preset
GFContextHelpStructVar.ImageDirectory = GetDirectoryName(GFContextHelpStructVar.ContextHelpFile)
End If
GFContextHelpStructVar.LineLengthFixed = LineLengthFixedOrZero
Set CallBackForm = CallBackFormPassed 'calls CallBackForm.GFContextHelp_ReceiveEvent(Event, String)
'
End Sub
Public Sub GFContextHelp_SetHelpFile(ByVal ContextHelpFileNew As String)
'on error resume next 'use to change help file (already set in GFContextHelp_Initialize())
GFContextHelpStructVar.ContextHelpFile = ContextHelpFileNew
End Sub
Public Function GFContextHelp_GetHelpFile() As String
'on error resume next 'returns full path to current help file
GFContextHelp_GetHelpFile = GFContextHelpStructVar.ContextHelpFile
End Function
Public Sub GFContextHelp_SetImageDirectory(ByVal ImageDirectory As String)
'on error resume next
GFContextHelpStructVar.ImageDirectory = ImageDirectory
End Sub
Public Function GFContextHelp_GetImageDirectory() As String
'on error resume next 'image directory is preset to ProgramPath
GFContextHelp_GetImageDirectory = GFContextHelpStructVar.ImageDirectory
End Function
Public Sub ContextHelp_ShowEx(ByVal ControlName As String, Optional ByVal WindowXPos As Long = GFCONTEXTHELP_CENTERED, Optional ByVal WindowYPos As Long = GFCONTEXTHELP_CENTERED, Optional ByVal StayOnTopFlagPassed As Boolean = False)
'on error resume next 'shows GFContextHelpfrm at given position with ControlName‑related help text
Dim ContextHelpString As String
Dim SEControlStructIndex1 As Integer 'for mouse pointer animation
Dim SEControlStructIndex2 As Integer 'for mouse pointer animation
Dim AnimationXPos As Long 'for mouse pointer animation
Dim AnimationYPos As Long 'for mouse pointer animation
'
'NOTE: the following special values can be used for Window[X/Y]Pos (value: meaning):
'
'‑GFCONTEXTHELP_ATMOUSEPOINTERPOS: the help window x/y position
' is equal to the current mouse pointer x/y position.
'‑GFCONTEXTHELP_CENTERED: the context help window is displayed x/y‑centered on the screen.
'‑GFCONTEXTHELP_ATSECONTROLPOS: if the Skin Engine is available this value
' affects that the help window is displayed at the right bottom corner of an SE Control.
' The HIWORD of WindowYPos contains the SE Control's parent form index,
' the LOWORD of WindowYPos contains the SE Control's index (in SEControlStructArray()).
' The control's index and the control's parent form index may be equal.
' A GFMouseGuide animation is played that makes the mouse pointer point
' into the center of the SEControl before the help window is opened.
'
'NOTE: this sub returns True if the user clicked into ContextHelpPicture to close
'the context help, False if he/she clicked somewhere else (any other application).
'Use this return value to determine if the target project should get the focus
'after the context help has been closed or if not.
'
'If StayOnTopFlagPassed is True then GFContextHelpfrm will not disappear
'until the target project called ContextHelp_Hide.
'To make StayOnTopFlagPassed = True work at least one link must be existing
'in the help text to display.
'
StayOnTopFlag = StayOnTopFlagPassed
ReDo: 'used if user clicked on a link label
'reset
ContinueFlag = False
'preset; resize window and picture box
#If GFSkinEngineAvailableFlag = True Then
'
'NOTE: the back picture can be changed for the form only,
'the picture must be transferred to the picture box manually.
'
Call GFSubClass_ReSubClassByTargetObjectDescriptionPrefix("GFContextHelpfrm")
Call SECB_AddCallBackForm(Me)
Call SE_LoadPalette(SECONTROLPALETTE_CONTEXTHELPFRM, True)
#End If
'play mouse animation
If WindowXPos = GFCONTEXTHELP_ATSECONTROLPOS Then
#If GFSkinEngineAvailableFlag = True Then
SEControlStructIndex1 = HIWORD(WindowYPos)
SEControlStructIndex2 = LOWORD(WindowYPos)
'make sure control is visible
Call ContextHelp_MakeSureVisible( _
SEControlStructArray(SEControlStructIndex2).SEControl, _
SEControlStructArray(SEControlStructIndex1).SEControl)
'set location of animation
AnimationXPos = GetSEControlXPos(SEControlStructIndex1) + GetSEControlXPos(SEControlStructIndex2) + (GetSEControlXSize(SEControlStructIndex2) / 2)
AnimationYPos = GetSEControlYPos(SEControlStructIndex1) + GetSEControlYPos(SEControlStructIndex2) + (GetSEControlYSize(SEControlStructIndex2) / 2)
'play a mouse guide animation on control
Call GFMouseGuide_PlayAnimation(AnimationXPos, AnimationYPos, 0, 0)
#Else
MsgBox "internal error in ContextHelp_ShowEx(): Skin Engine not available !", vbOKOnly + vbExclamation
#End If
End If
'read (unchanged) context help string
With GFContextHelpStructVar
'
'NOTE: <copy from="some other control name"> can be used to copy a help text from an other control.
'No further chars may appear after <copy from="">.
'
.ContextHelpString = ContextHelpString_Read(ControlName, GFContextHelpStructVar.ContextHelpFile)
Call RemoveBorderBelow32(.ContextHelpString) 'important (or empty lines could be displayed instead of default help text)
If (LCase$(Left$(.ContextHelpString, 12)) = "<copy from=""") And (LCase$(Right$(.ContextHelpString, 2)) = """>") Then
.ContextHelpString = ContextHelpString_Read(Mid$(.ContextHelpString, 13, Len(.ContextHelpString) ‑ 13 ‑ 2 + 1), GFContextHelpStructVar.ContextHelpFile)
End If
Call RemoveBorderBelow32(.ContextHelpString) 'important (or empty lines could be displayed instead of default help text)
If Len(.ContextHelpString) = 0 Then
.ContextHelpString = ContextHelpString_Read(GFContextHelpStructVar.ContextDefaultControlName, GFContextHelpStructVar.ContextHelpFile)
End If
Call RemoveBorderBelow32(.ContextHelpString) 'important (or empty lines could be displayed instead of default help text)
If Len(.ContextHelpString) = 0 Then 'still no help text available
.ContextHelpString = "Sorry, no context help available."
End If
ContextHelpRestoreStructVar.ContextHelpStringUnchanged = .ContextHelpString
End With
'
ContextHelpRestoreStructVar.WindowXPos = WindowXPos
ContextHelpRestoreStructVar.WindowYPos = WindowYPos
'
'display context help string (the first time)
Call ContextHelpString_Display(ContextHelpRestoreStructVar.ContextHelpStringUnchanged, _
ContextHelpRestoreStructVar.WindowXPos, _
ContextHelpRestoreStructVar.WindowYPos, _
ContextHelpHeaderStructVar) 'also called when user clicks on a link label
Call GFPopUpWindow_PolyRgn_Enable(GFPopUpWindowStructVar, GFContextHelpfrm)
Call GFPopUpWindow_CreateShadow(GFContextHelpfrm)
'show window
GFContextHelpfrm.Enabled = True
GFContextHelpfrm.Visible = True
GFContextHelpfrm.Refresh
Call GFSetWindowOnTop(GFContextHelpfrm)
'enter wait loop
Do
Call Sleep(10) 'avoid jerking when moving window
DoEvents
#If GFSkinEngineAvailableFlag = True Then
If Not ( _
(GetForegroundWindow() = GFContextHelpfrm.hwnd) Or _
(GetForegroundWindow() = GFSkinEngine_UserMoveInfofrm.hwnd)) Then
'NOTE: during the UserMove mode GFSkinEngine_UserMoveInfofrm
'can temporarily get the focus, do then not (!) close GFContextHelpfrm.
#Else
If Not (GetForegroundWindow() = GFContextHelpfrm.hwnd) Then
#End If
If (StayOnTopFlag = False) Or (LinkStructNumber = 0) Then
'
'NOTE: if a context help string contains no links then the
'context help window will not automatically stay on top to verify
'that the user still can close it.
'
ContinueFlag = True
End If
End If
Loop Until (ContinueFlag = True)
'hide window
GFContextHelpfrm.Visible = False
GFContextHelpfrm.Enabled = False
GFContextHelpfrm.Refresh
Call Link_HideLinks
Call GFPopUpWindow_PolyRgn_Disable(GFPopUpWindowStructVar, GFContextHelpfrm)
Call GFRemoveWindowFromTop(GFContextHelpfrm)
If LinkClickStructVar.LinkClickedFlag = True Then
LinkClickStructVar.LinkClickedFlag = False 'reset
#If GFSkinEngineAvailableFlag = True Then
'
'NOTE: if the Skin Engine is available, make the target project open the new
'help window as the ContextHelpFile could be encrypted.
'
If LCase$(Left$(LinkStructArray(LinkClickStructVar.LinkClickedIndex).LinkControlName, 13)) = "<raise event=" Then
'
'NOTE: an event line MUST have the following format: <raise event=event name>.
'Do not use additional space chars (except within the event description).
'There are no quotation marks as they would lead to errors when filtering link lines.
'
Call SE_ForwardCallBackMessage(SECBMSG_CONTEXTHELP_EVENT, Mid$(LinkStructArray(LinkClickStructVar.LinkClickedIndex).LinkControlName, 14, Len(LinkStructArray(LinkClickStructVar.LinkClickedIndex).LinkControlName) ‑ 13 ‑ 1), "")
Else
Call SE_ForwardCallBackMessage(SECBMSG_CONTEXTHELP_REQUESTED, LinkStructArray(LinkClickStructVar.LinkClickedIndex).LinkControlName, "‑2") 'propose to show form centered
End If
#Else
ControlName = LinkStructArray(LinkClickStructVar.LinkClickedIndex).LinkControlName
WindowXPos = GFCONTEXTHELP_CENTERED
WindowYPos = GFCONTEXTHELP_CENTERED
GoTo ReDo:
#End If
End If
End Sub
Public Sub ContextHelp_Hide()
'on error resume next
ContinueFlag = True
End Sub
'*********************************END OF INTERFACE SUBS*********************************
'*************************************CALLBACK SUBS*************************************
Public Sub SE_ReceiveCallBackMessage(ByVal Msg As Integer, ByVal wParam As String, ByVal lParam As String, ByRef ReturnValueUsedFlag As Boolean, ByRef ReturnValue As Long)
'on error resume next
#If GFSkinEngineAvailableFlag = True Then
Select Case Msg
Case SECBMSG_POPUPMENUCLICK_PROCESSING_START
If (Me.Enabled = True) And (Me.Visible = True) Then 'verify
Call GFRemoveWindowFromTop(GFContextHelpfrm) 'important, or message boxes of the Skin Engine will be hidden an no one knows what's going on
End If
Case SECBMSG_POPUPMENUCLICK_PROCESSING_END
If (Me.Enabled = True) And (Me.Visible = True) Then 'verify
Call GFSetWindowOnTop(GFContextHelpfrm) 'reset
End If
Case SECBMSG_PICTUREBOX_REDRAW
Select Case wParam
Case "GFContextHelpfrm.ContextHelpPicture", "GFContextHelpfrm.ContextHelpHeaderPicture"
'
'NOTE: when changing a picture box's back color (what is the case when mark is set/removed),
'the box's content will be cleared, let's redraw the whole stuff.
'
Call ContextHelpString_Display(ContextHelpRestoreStructVar.ContextHelpStringUnchanged, _
ContextHelpRestoreStructVar.WindowXPos, _
ContextHelpRestoreStructVar.WindowYPos, _
ContextHelpHeaderStructVar)
Call GFPopUpWindow_PolyRgn_Enable(GFPopUpWindowStructVar, GFContextHelpfrm)
Call GFPopUpWindow_CreateShadow(GFContextHelpfrm)
End Select
End Select
#End If
End Sub
'*********************************END OF CALLBACK SUBS**********************************
'************************************CONTROL EVENTS*************************************
'NOTE: the context help text window is removed if it (the picture box)
'lost the focus or if the user clicks into the window (picture box).
Private Sub CloseButtonImage_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
'
'NOTE: CloseButtonImage is only visible if ContextHeaderPicture is visible (i.e. if the header is enabled).
'CloseButtomImage is positioned by ContextHelpHeaderString_Print().
'
If Button = vbLeftButton Then
CloseButtonImage.Picture = CloseDownImage.Picture
End If
End Sub
Private Sub CloseButtonImage_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
If Button = vbLeftButton Then
If Not ((X < 0) Or (X > (CloseButtonImage.Width ‑ Screen.TwipsPerPixelX)) Or (Y < 0) Or (Y > (CloseButtonImage.Height ‑ Screen.TwipsPerPixelY))) Then
If Not (CloseButtonImage.Picture Is CloseDownImage.Picture) Then _
CloseButtonImage.Picture = CloseDownImage.Picture
Else
If Not (CloseButtonImage.Picture Is CloseUpImage.Picture) Then _
CloseButtonImage.Picture = CloseUpImage.Picture
End If
End If
End Sub
Private Sub CloseButtonImage_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
'
'NOTE: ContextHelpfrm can be closed at any time via the CloseButtonImage.
'
If Button = vbLeftButton Then
CloseButtonImage.Picture = CloseUpImage.Picture
If Not ((X < 0) Or (X > (CloseButtonImage.Width ‑ Screen.TwipsPerPixelX)) Or (Y < 0) Or (Y > (CloseButtonImage.Height ‑ Screen.TwipsPerPixelY))) Then
Call ContextHelp_Hide
Else
'do nothing
End If
End If
End Sub
Private Sub ContextHelpPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Select Case Button
Case vbLeftButton
FormMoveStructVar.FormMoveEnabledFlag = True
FormMoveStructVar.FormXPos = GFContextHelpfrm.Left
FormMoveStructVar.FormYPos = GFContextHelpfrm.Top
FormMoveStructVar.MousePosX = ProgramGetMousePosX
FormMoveStructVar.MousePosY = ProgramGetMousePosY
End Select
End Sub
Private Sub ContextHelpPicture_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
'
'NOTE: even if the Skin Engine is enabled and GFContextHelpfrm
'is a registered control moving does not work as messages seem
'to disappear because of the DoEvents loop the program control
'stays in when this form is displayed.
'
If FormMoveStructVar.FormMoveEnabledFlag = True Then
StayOnTopFlagTemp = True 'when the window is moved then it will not be closed although having been clicked
Call Me.Move( _
FormMoveStructVar.FormXPos + (ProgramGetMousePosX ‑ FormMoveStructVar.MousePosX) * Screen.TwipsPerPixelX, _
FormMoveStructVar.FormYPos + (ProgramGetMousePosY ‑ FormMoveStructVar.MousePosY) * Screen.TwipsPerPixelY)
Call Me.Refresh
Call GFPopUpWindow_CreateShadow(GFContextHelpfrm)
End If
End Sub
Private Sub ContextHelpPicture_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Dim SEControlStructIndex As Integer
'begin
If FormMoveStructVar.FormMoveEnabledFlag = True Then 'check if form was moved
FormMoveStructVar.FormMoveEnabledFlag = False 'reset
#If GFSkinEngineAvailableFlag = True Then
SEControlStructIndex = GetSEControlStructIndex("GFContextHelpfrm")
If Not (SEControlStructIndex = 0) Then 'verify
Call SEFormSystem_SaveFormPos("GFContextHelpfrm", GetSEControlXPos(SEControlStructIndex), GetSEControlYPos(SEControlStructIndex))
ContextHelpRestoreStructVar.WindowXPos = GetSEControlXPos(SEControlStructIndex) 'avoid that window 'jumps around'...
ContextHelpRestoreStructVar.WindowYPos = GetSEControlYPos(SEControlStructIndex) '...when setting or removing mark in UserMove mode
Else
MsgBox "internal error in ContextHelpPicture_MouseUp() (GFContextHelp): GetSEControlStructIndex(""GFContextHelpfrm"") failed (control not registered) !", vbOKOnly + vbExclamation
End If
#End If
End If
End Sub
Private Sub ContextHelpHeaderPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Call ContextHelpPicture_MouseDown(Button, Shift, X, Y)
End Sub
Private Sub ContextHelpHeaderPicture_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Call ContextHelpPicture_MouseMove(Button, Shift, X, Y)
End Sub
Private Sub ContextHelpHeaderPicture_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
Call ContextHelpPicture_MouseUp(Button, Shift, X, Y)
End Sub
Private Sub ContextHelpHeaderPicture_KeyDown(KeyCode As Integer, Shift As Integer)
'on error resume next
Call ContextHelpPicture_KeyDown(KeyCode, Shift)
End Sub
Private Sub ContextHelpPicture_KeyDown(KeyCode As Integer, Shift As Integer)
'on error resume next
Select Case KeyCode
Case vbKeyEscape
Call ContextHelp_Hide
Case vbKeyLeft
Call Me.Move(Me.Left ‑ 5 * Screen.TwipsPerPixelX, Me.Top)
Case vbKeyUp
Call Me.Move(Me.Left, Me.Top ‑ 5 * Screen.TwipsPerPixelY)
Case vbKeyRight
Call Me.Move(Me.Left + 5 * Screen.TwipsPerPixelX, Me.Top)
Case vbKeyDown
Call Me.Move(Me.Left, Me.Top + 5 * Screen.TwipsPerPixelY)
End Select
End Sub
Private Sub ContextHelpHeaderPicture_Click()
'on error resume next
Call ContextHelpPicture_Click
End Sub
Private Sub ContextHelpPicture_Click()
'on error resume next
'NOTE: as there is the CloseButtonImage we don't need the code below anymore.
' If StayOnTopFlagTemp = False Then
' If (StayOnTopFlag = False) Or (LinkStructNumber = 0) Then
' 'NOTE: if there is no link then StayOnTopFlag is not treated as True in any case.
' ContinueFlag = True
' End If
' Else
' StayOnTopFlagTemp = False 'reset
' End If
End Sub
'*********************************END OF CONTROL EVENTS*********************************
'**********************************CONTEXT HELP STRING**********************************
Private Function ContextHelpString_Read(ByVal ControlName As String, ByVal ContextHelpFile As String) As String
'on error resume next 'returns control specific help string or "" for error
Dim ContextHelpFileEncryptedFlag As Boolean
Dim ContextHelpFileNumber As Integer
Dim ContextHelpFileString As String
Dim HelpStringStartPos As Long
Dim HelpStringEndPos As Long
'
'NOTE: the context help string is read out of the ContextHelpFile,
'which must contain the help text in the following form:
'
'[ControlName]
'help text
'blah blah
'
'Note that every line must be bordered by Chr$(13) AND Chr$(10).
'Spaces, tabs, etc. within the help text will not be removed
'(layout will be transferred to context help window).
'
'preset
ContextHelpFileNumber = FreeFile(0)
'begin
If Not ((Dir$(ContextHelpFile) = "") Or (Right$(ContextHelpFile, 1) = "\") Or (ContextHelpFile = "")) Then 'verify
#If GFSkinEngineAvailableFlag = True Then
ContextHelpFileEncryptedFlag = SE_IsFileEncrypted(ContextHelpFile)
Call SE_DecryptFile(ContextHelpFile, SE_CONTEXTHELPFILE_PASSWORD)
#End If
Open ContextHelpFile For Binary As #ContextHelpFileNumber
ContextHelpFileString = String$(LOF(ContextHelpFileNumber), Chr$(0))
Get #ContextHelpFileNumber, 1, ContextHelpFileString
Close #ContextHelpFileNumber
'search for control name
HelpStringStartPos = InStr(1, ContextHelpFileString, "[" + ControlName + "]", vbBinaryCompare)
If Not (HelpStringStartPos = 0) Then
HelpStringEndPos = InStr(HelpStringStartPos, ContextHelpFileString, Chr$(13) + Chr$(10) + "[", vbBinaryCompare)
If HelpStringEndPos = 0 Then HelpStringEndPos = Len(ContextHelpFileString)
ContextHelpString_Read = Mid$(ContextHelpFileString, _
HelpStringStartPos + Len(ControlName) + 2, _
HelpStringEndPos ‑ (HelpStringStartPos + Len(ControlName) + 2)) 'ok
Else
ContextHelpString_Read = "" 'reset (error)
End If
#If GFSkinEngineAvailableFlag = True Then
'If ContextHelpFileEncryptedFlag = True Then 'always encrypt; the target project might contain any 'cheat' that decrypts the file for debugging purposes
Call SE_EncryptFile(ContextHelpFile, SE_CONTEXTHELPFILE_PASSWORD, "")
'End If
#End If
Else
MsgBox "internal error in ContextHelpString_Read() (GFContextHelp): file '" + ContextHelpFile + "' not found !", vbOKOnly + vbExclamation
End If
End Function
Private Sub ContextHelpString_Display(ByVal ContextHelpStringUnchanged As String, ByRef WindowXPosPassed As Long, ByRef WindowYPosPassed As Long, ByRef ContextHelpHeaderStructVar As ContextHelpHeaderStruct)
'on error resume next 'position value format: pixels
Dim WindowWidth As Long 'format: twips
Dim WindowHeight As Long 'format: twips
Dim WindowLeft As Long 'format: twips
Dim WindowTop As Long 'format: twips
Dim SEControlStructIndex As Integer
Dim SEReloadFlag As Boolean
Dim TextWidth As Long
Dim TextWidthCountingDisabledFlag As Boolean
Dim StructLoop As Integer
Dim TempProgramTwoLongStruct As ProgramTwoLongStruct
Dim Temp As Long
'preset
'
Call RemoveBorderBelow32(ContextHelpStringUnchanged)
Call ContextHelpString_FixLineLength(ContextHelpStringUnchanged)
Call ContextHelpString_Filter(ContextHelpStringUnchanged)
'
TempProgramTwoLongStruct = _
ContextHelpString_GetWindowSize(ContextHelpStringUnchanged, _
LinkStructNumber, LinkStructArray(), ImageStructNumber, ImageStructArray(), _
ContextHelpHeaderStructVar)
'
WindowWidth = TempProgramTwoLongStruct.Long1
WindowHeight = TempProgramTwoLongStruct.Long2
'
TempProgramTwoLongStruct = _
ContextHelpString_GetWindowPos(WindowXPosPassed, WindowYPosPassed, _
WindowWidth / Screen.TwipsPerPixelX, WindowHeight / Screen.TwipsPerPixelY, _
ContextHelpHeaderStructVar)
'
WindowLeft = TempProgramTwoLongStruct.Long1
WindowTop = TempProgramTwoLongStruct.Long2
'
'NOTE: this sub is called for several SE events. To avoid that
'GFContextHelpfrm is moved as WindowXPosPassed is a constant
'like GFCONTEXTHELP_ATSECONTROLPOS we convert the position
'into 'normal' screen coordinates (Window[X/Y]PosPassed passed ByRef).
'
WindowXPosPassed = WindowLeft / Screen.TwipsPerPixelX
WindowYPosPassed = WindowTop / Screen.TwipsPerPixelY
'
'verify
If (WindowLeft + WindowWidth ‑ TX(1)) > (Screen.Width ‑ TX(1)) Then WindowLeft = (Screen.Width ‑ TX(1)) ‑ WindowWidth + (TX(1))
If WindowLeft < 0 Then WindowLeft = 0
If (WindowTop + WindowHeight ‑ TY(1)) > (Screen.Height ‑ TY(1)) Then WindowTop = (Screen.Height ‑ TY(1)) ‑ WindowHeight + TY(1)
If WindowTop < 0 Then WindowTop = 0
'begin; move window
If ContextHelpHeaderStructVar.HeaderEnabledFlag = True Then
Call GFContextHelpfrm.Move(WindowLeft, WindowTop, WindowWidth, WindowHeight)
Call ContextHelpHeaderPicture.Move(0, 0, Me.Width ‑ (15 * Screen.TwipsPerPixelX), (ContextHelpHeaderStructVar.HeaderHeight * Screen.TwipsPerPixelY))
Call ContextHelpPicture.Move(0, _
ContextHelpHeaderStructVar.HeaderHeight * Screen.TwipsPerPixelY, _
Me.Width ‑ (15 * Screen.TwipsPerPixelX), _
Me.Height ‑ (15 * Screen.TwipsPerPixelY) ‑ (ContextHelpHeaderStructVar.HeaderHeight * Screen.TwipsPerPixelY))
Else
Call GFContextHelpfrm.Move(WindowLeft, WindowTop, WindowWidth, WindowHeight)
Call ContextHelpPicture.Move(0, _
0, _
Me.Width ‑ (15 * Screen.TwipsPerPixelX), _
Me.Height ‑ (15 * Screen.TwipsPerPixelY))
End If
#If GFSkinEngineAvailableFlag = True Then
SEControlStructIndex = GetSEControlStructIndex("GFContextHelpfrm.ContextHelpHeaderPicture")
If (SEControlStructIndex) Then 'verify
SEReloadFlag = Not ( _
(GetSEControlXSize(SEControlStructIndex) = SEControlStructArray(SEControlStructIndex).SEControl_XSize) And _
(GetSEControlYSize(SEControlStructIndex) = SEControlStructArray(SEControlStructIndex).SEControl_YSize))
Call SetSEControlXSize(SEControlStructIndex, GetSEControlXSize(SEControlStructIndex), 0, False)
Call SetSEControlYSize(SEControlStructIndex, GetSEControlYSize(SEControlStructIndex), 0, False)
If SEReloadFlag = True Then 'verify (important for several reasons, tested)
'NOTE: refresh the header picture to fit the back picture to the new dimensions (if necessary only)
Call SE_UnloadControl("GFContextHelpfrm.ContextHelpHeaderPicture")
Call SE_LoadControl("GFContextHelpfrm.ContextHelpHeaderPicture", True)
Call SE_RefreshControl("GFContextHelpfrm.ContextHelpHeaderPicture", 0)
End If
End If
SEControlStructIndex = GetSEControlStructIndex("GFContextHelpfrm.ContextHelpPicture")
If (SEControlStructIndex) Then 'verify
SEReloadFlag = Not ( _
(GetSEControlXSize(SEControlStructIndex) = SEControlStructArray(SEControlStructIndex).SEControl_XSize) And _
(GetSEControlYSize(SEControlStructIndex) = SEControlStructArray(SEControlStructIndex).SEControl_YSize))
Call SetSEControlXSize(SEControlStructIndex, GetSEControlXSize(SEControlStructIndex), 0, False)
Call SetSEControlYSize(SEControlStructIndex, GetSEControlYSize(SEControlStructIndex), 0, False)
'NOTE: refresh the context help picture to fit the back picture to the new control dimensions (if necessary only).
If SEReloadFlag = True Then 'verify (important for several reasons, tested)
Call SE_UnloadControl("GFContextHelpfrm.ContextHelpPicture")
Call SE_LoadControl("GFContextHelpfrm.ContextHelpPicture", True)
Call SE_RefreshControl("GFContextHelpfrm.ContextHelpPicture", 0)
End If
End If
#End If
'print to window
Call ContextHelpHeaderString_Print(ContextHelpHeaderStructVar)
Call ContextHelpString_Print(ContextHelpStringUnchanged, ContextHelpHeaderStructVar)
Call Link_SetLinkPos(LinkStructNumber, LinkStructArray(), CHSMarkStructNumber, CHSMarkStructArray(), ContextHelpStringUnchanged)
Call Link_ShowLinks(LinkStructNumber, LinkStructArray())
Call Image_SetImagePos(ImageStructNumber, ImageStructArray(), CHSMarkStructNumber, CHSMarkStructArray(), ContextHelpStringUnchanged)
Call Image_DrawImages(ImageStructNumber, ImageStructArray())
End Sub
Private Function ContextHelpString_GetWindowSize(ByVal ContextHelpString As String, ByVal LinkStructNumber As Integer, ByRef LinkStructArray() As LinkStruct, ByVal ImageStructNumber As Integer, ByRef ImageStructArray() As ImageStruct, ByRef ContextHelpHeaderStructVar As ContextHelpHeaderStruct) As ProgramTwoLongStruct
'on error resume next 'returns size that ContextHelpPicture must have to display the context help string and all links and images; output format: twips
Dim WindowWidthMin As Long 'format: twips
Dim WindowHeightMin As Long 'format: twips
Dim StructLoop As Integer
'
'NOTE: the window size is the largest of the following values:
'‑'furthest' image right bottom position
'‑ContextHelpString Text[Width/Height]
'
'If the ContextHelpHeader is enabled then the y size is increased
'by the height of the ContextHeaderPicture.
'
'begin
For StructLoop = 1 To ImageStructNumber
If (ImageStructArray(StructLoop).X + ((ImageStructArray(StructLoop).XSize + 15)) * Screen.TwipsPerPixelX) > WindowWidthMin Then
WindowWidthMin = ImageStructArray(StructLoop).X + ((ImageStructArray(StructLoop).XSize + 15) * Screen.TwipsPerPixelX)
End If
If (ImageStructArray(StructLoop).Y + ((ImageStructArray(StructLoop).YSize + 15)) * Screen.TwipsPerPixelY) > WindowHeightMin Then
WindowHeightMin = ImageStructArray(StructLoop).Y + ((ImageStructArray(StructLoop).YSize + 15) * Screen.TwipsPerPixelY)
End If
Next StructLoop
'
ContextHelpString_GetWindowSize.Long1 = MAX(WindowWidthMin, ContextHelpPicture.TextWidth(ContextHelpString) + 30 * Screen.TwipsPerPixelX)
ContextHelpString_GetWindowSize.Long2 = MAX(WindowHeightMin, ContextHelpPicture.TextHeight(Chr$(32)) * LineCount(ContextHelpString) + 30 * Screen.TwipsPerPixelY)
'
If ContextHelpHeaderStructVar.HeaderEnabledFlag = True Then
'
'NOTE: if the header is enabled then another y pixels must be added to
'the current window height.
'
ContextHelpString_GetWindowSize.Long2 = ContextHelpString_GetWindowSize.Long2 + _
ContextHelpHeaderStructVar.HeaderHeight * Screen.TwipsPerPixelY
'
End If
End Function
Private Function ContextHelpString_GetWindowPos(ByVal WindowXPosPassed As Long, ByVal WindowYPosPassed As Long, ByVal WindowXSizeNew As Long, ByVal WindowYSizeNew As Long, ByRef ContextHelpHeaderStructVar As ContextHelpHeaderStruct) As ProgramTwoLongStruct
'on error resume next 'input format: pixels, output format: twips
Dim WindowXPosNew As Long 'format: twips
Dim WindowYPosNew As Long 'format: twips
Dim SEControlStructIndex1 As Integer 'parent control index
Dim SEControlStructIndex2 As Integer 'control index
'preset
WindowXPosNew = WindowXPosPassed * Screen.TwipsPerPixelX
WindowYPosNew = WindowYPosPassed * Screen.TwipsPerPixelY
'begin
Select Case WindowXPosPassed
Case GFCONTEXTHELP_ATSECONTROLPOS
#If GFSkinEngineAvailableFlag = True Then
SEControlStructIndex1 = HIWORD(WindowYPosPassed)
SEControlStructIndex2 = LOWORD(WindowYPosPassed)
WindowXPosNew = (GetSEControlXPos(SEControlStructIndex1) + GetSEControlXPos(SEControlStructIndex2) + GetSEControlXSize(SEControlStructIndex2) ‑ 2) * Screen.TwipsPerPixelX
WindowYPosNew = (GetSEControlYPos(SEControlStructIndex1) + GetSEControlYPos(SEControlStructIndex2) + GetSEControlYSize(SEControlStructIndex2) ‑ 2) * Screen.TwipsPerPixelY
#Else
MsgBox "internal error in ContextHelpString_Display(): Skin Engine not available !", vbOKOnly + vbExclamation
#End If
Case GFCONTEXTHELP_CENTERED
WindowXPosNew = (Screen.Width / 2) ‑ ((WindowXSizeNew * Screen.TwipsPerPixelX) / 2)
Case GFCONTEXTHELP_ATMOUSEPOINTERPOS
WindowXPosNew = (ProgramGetMousePosX * Screen.TwipsPerPixelX)
End Select
If Not (WindowXPosPassed = GFCONTEXTHELP_ATSECONTROLPOS) Then
Select Case WindowYPosPassed
Case GFCONTEXTHELP_CENTERED
WindowYPosNew = (Screen.Height / 2) ‑ ((WindowYSizeNew * Screen.TwipsPerPixelY) / 2)
Case GFCONTEXTHELP_ATMOUSEPOINTERPOS
WindowYPosNew = (ProgramGetMousePosY * Screen.TwipsPerPixelY)
End Select
End If
ContextHelpString_GetWindowPos.Long1 = WindowXPosNew
ContextHelpString_GetWindowPos.Long2 = WindowYPosNew
End Function
Private Sub ContextHelpString_FixLineLength(ByRef ContextHelpString As String)
'on error resume next 'slow VB string manipulations used ‑ don't pass more than a few KB of text
Dim TextWidth As Long
Dim TextWidthCountingDisabledFlag As Boolean
Dim Temp As Long
'begin
For Temp = 1 To Len(ContextHelpString) ‑ 3 'replace newline by space
If Mid$(ContextHelpString, Temp, 2) = Chr$(13) + Chr$(10) Then
If Mid$(ContextHelpString, Temp, 4) <> Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) Then
ContextHelpString = Left$(ContextHelpString, Temp ‑ 1) + " " + Mid$(ContextHelpString, Temp + 2)
Else
Temp = Temp + 2 'second newline is never followed by another newline
End If
End If
Next Temp
For Temp = 1 To Len(ContextHelpString) ‑ 3 'replace forced newlines
If Mid$(ContextHelpString, Temp, 5) = "<br> " Then 'newline in original string was set to space
ContextHelpString = Left$(ContextHelpString, Temp ‑ 1) + Chr$(13) + Chr$(10) + Mid$(ContextHelpString, Temp + 5)
End If
If Mid$(ContextHelpString, Temp, 4) = "<br>" Then
ContextHelpString = Left$(ContextHelpString, Temp ‑ 1) + Chr$(13) + Chr$(10) + Mid$(ContextHelpString, Temp + 4)
End If
Next Temp
For Temp = 1 To Len(ContextHelpString) 'insert newline after min. LineLengthFixed line width
Select Case Mid$(ContextHelpString, Temp, 1)
Case Chr$(13), Chr$(10)
TextWidth = 0 'reset
Case "<" '<a disables counting, < without 'a' could appear in help text
If Temp < Len(ContextHelpString) Then If LCase$(Mid$(ContextHelpString, Temp + 1, 1)) = "a" Then TextWidthCountingDisabledFlag = True
Case ">"
TextWidthCountingDisabledFlag = False
Case Else
If TextWidthCountingDisabledFlag = False Then
TextWidth = TextWidth + ContextHelpPicture.TextWidth(Mid$(ContextHelpString, Temp, 1))
If TextWidth > GFContextHelpStructVar.LineLengthFixed * Screen.TwipsPerPixelX Then
If Mid$(ContextHelpString, Temp, 1) = " " Then
TextWidth = 0 'reset
ContextHelpString = Left$(ContextHelpString, Temp ‑ 1) + Chr$(13) + Chr$(10) + Mid$(ContextHelpString, Temp + 1)
End If
End If
End If
End Select
Next Temp
End Sub
Private Sub ContextHelpString_Filter(ByRef ContextHelpString As String)
'on error resume next
'
'IMPORTANT: always use the CHS subs/functions to edit the context help string.
'If a link or an image has been filtered then its x/y pos will not be set instantly
'but a 'mark' is inserted into the context help string.
'When filtering has finished then the x/y positions of the links and images
'are determined by the position of the related mark in the context help string.
'It is not possible to set any x/y pos instantly when filtering as the context help
'string could still contain any link/image lines that are still to be removed
'(what would change the length of the string and thus also any already set link/image x/y pos).
'
Call Mark_Reset
Call Image_FilterImages(ContextHelpString)
Call Link_FilterContextLinks(ContextHelpString)
End Sub
Private Sub ContextHelpString_Print(ByVal ContextHelpString As String, ByRef ContextHelpHeaderStructVar As ContextHelpHeaderStruct)
'on error resume next
Dim ForeColorUnchanged As Long
'preset
ContextHelpPicture.Cls 'reset
ContextHelpPicture.AutoRedraw = True 'set to False in Form_Unload() event to save memory
'begin; print text shadow
'ForeColorUnchanged = ContextHelpPicture.ForeColor
'ContextHelpPicture.ForeColor = 0 'GFColor_InvertColorSave(ForeColorUnchanged)
'ContextHelpPicture.CurrentX = 0
'ContextHelpPicture.CurrentY = TY(1)
'ContextHelpPicture.Print (ContextHelpString)
'ContextHelpPicture.ForeColor = ForeColorUnchanged 'reset
'print actual text
ContextHelpPicture.CurrentX = 0
ContextHelpPicture.CurrentY = 0
ContextHelpPicture.Print (ContextHelpString)
ContextHelpPicture.Refresh 'important
If Not (CallBackForm Is Nothing) Then Call CallBackForm.GFContextHelp_ReceiveEvent("ContextHelpString_Print", ContextHelpString)
End Sub
'******************************END OF CONTEXT HELP STRING*******************************
'**********************************CONTEXT HELP HEADER**********************************
'NOTE: if the ContextHelpHeader is enabled then another picture box
'(ContextHelpHeaderPicture) is displayed above the ContextHelpPicture.
'In the header picture box the header string (set by target project) is displayed.
Public Sub ContextHelpHeader_Enable(ByVal HeaderHeight As Single)
'on error resume next 'format: pixels
ContextHelpHeaderStructVar.HeaderEnabledFlag = True
ContextHelpHeaderStructVar.HeaderHeight = HeaderHeight
'display ContextHelpHeaderPicture
ContextHelpHeaderPicture.Enabled = True
ContextHelpHeaderPicture.Visible = True
End Sub
Public Sub ContextHelpHeader_Refresh(ByVal HeaderText As String, ByVal HeaderTextColor As Long, ByVal HeaderTextFontName As String, ByVal HeaderTextFontSize As Single, ByVal HeaderTextFontBoldFlag As Boolean, ByVal HeaderTextFontItalicFlag As Boolean, ByVal HeaderTextFontUnderlineFlag As Boolean, ByVal HeaderTextFontStrikeThroughFlag As Boolean)
'on error resume next
ContextHelpHeaderStructVar.HeaderText = HeaderText
ContextHelpHeaderStructVar.HeaderTextColor = HeaderTextColor
ContextHelpHeaderStructVar.HeaderTextFont.Name = HeaderTextFontName
ContextHelpHeaderStructVar.HeaderTextFont.Size = HeaderTextFontSize
ContextHelpHeaderStructVar.HeaderTextFont.Bold = HeaderTextFontBoldFlag
ContextHelpHeaderStructVar.HeaderTextFont.Italic = HeaderTextFontItalicFlag
ContextHelpHeaderStructVar.HeaderTextFont.Underline = HeaderTextFontUnderlineFlag
ContextHelpHeaderStructVar.HeaderTextFont.StrikeThrough = HeaderTextFontStrikeThroughFlag
End Sub
Public Sub ContextHelpHeader_Disable()
'on error resume next
ContextHelpHeaderStructVar.HeaderEnabledFlag = False
'hide ContextHelpHeaderPicture
ContextHelpHeaderPicture.Visible = False
ContextHelpHeaderPicture.Enabled = False
End Sub
Private Sub ContextHelpHeaderString_Print(ByRef ContextHelpHeaderStructVar As ContextHelpHeaderStruct)
'on error resume next
Dim ForeColorUnchanged As Long
'verify
If ContextHelpHeaderStructVar.HeaderEnabledFlag = False Then Exit Sub
'preset
ContextHelpHeaderPicture.Cls 'reset
ContextHelpHeaderPicture.AutoRedraw = True 'reset in Form_Unload() event
'begin; print text shadow
'ForeColorUnchanged = ContextHelpHeaderPicture.ForeColor
'ContextHelpHeaderPicture.ForeColor = 0 'GFColor_InvertColorSave(ForeColorUnchanged)
'ContextHelpHeaderPicture.CurrentX = (ContextHelpHeaderPicture.Width / 2!) ‑ (ContextHelpPicture.TextWidth(ContextHelpHeaderStructVar.HeaderText) / 2!)
'ContextHelpHeaderPicture.CurrentY = TY(1) + (ContextHelpHeaderPicture.Height / 2!) ‑ (ContextHelpPicture.TextHeight(ContextHelpHeaderStructVar.HeaderText) / 2!)
'ContextHelpHeaderPicture.Print ContextHelpHeaderStructVar.HeaderText
'ContextHelpHeaderPicture.ForeColor = ForeColorUnchanged 'reset
'print actual text
ContextHelpHeaderPicture.CurrentX = (ContextHelpHeaderPicture.Width / 2!) ‑ (ContextHelpPicture.TextWidth(ContextHelpHeaderStructVar.HeaderText) / 2!)
ContextHelpHeaderPicture.CurrentY = (ContextHelpHeaderPicture.Height / 2!) ‑ (ContextHelpPicture.TextHeight(ContextHelpHeaderStructVar.HeaderText) / 2!)
ContextHelpHeaderPicture.Print ContextHelpHeaderStructVar.HeaderText
CloseButtonImage.Top = (ContextHelpHeaderPicture.Height / 2!) ‑ (CloseButtonImage.Height / 2!)
CloseButtonImage.Left = ContextHelpHeaderPicture.Width ‑ Screen.TwipsPerPixelX ‑ CloseButtonImage.Width ‑ ((ContextHelpHeaderPicture.Height ‑ CloseButtonImage.Height) / 2!)
Exit Sub
End Sub
'******************************END OF CONTEXT HELP HEADER*******************************
'*************************************CONTEXT LINKS*************************************
'NOTE: there is the opportunity to display 'links', i.e. labels which lead to a displaying of
'another context help topic when it is clicked by the user.
'Links are created by inserting '<a href="ControlName">LinkText</a>' into the
'ContextHelpFile at the position the link shall appear.
'The help text related to ControlName is shown when the user clicks on the LinkText.
Private Sub Link_FilterContextLinks(ByRef ContextHelpString As String)
'on error resume next
Dim LinkLineStartPos As Long 'LinkLine = complete link expression including tag
Dim LinkLineEndPos As Long
Dim LinkLine As String
Dim LinkControlName As String
Dim LinkText As String
Dim LineCount As Long
Dim StartPos As Long 'general use
Dim EndPos As Long
Dim Temp As Long
'
'NOTE: this sub searches 'link lines' in the passed string.
'Link lines have the format '<a href="ControlName">LinkText</a>'.
'If a link line is found, it is replaced by a special number of spaces,
'which have the same length as the link text, and the data of the link line
'(ControlName, LinkText) is transferred to LinkStructArray().
'
'NOTE: ContextHelpPicture.[TextWidth()/TextHeight()] is used, verify
'that the font of ContextHelpPicture is the final label font.
'
'NOTE: this sub does not set the LinkStructArray().[X/Y]
'coordinates, this is done by Link_SetLinkPos.
'
'reset
LinkStructNumber = 0 'reset
ReDim LinkStructArray(1 To 1) As LinkStruct
'begin
Do
LinkLineStartPos = InStr(1, ContextHelpString, "<a href", vbTextCompare)
If LinkLineStartPos = 0 Then Exit Do
LinkLineEndPos = InStr(LinkLineStartPos, ContextHelpString, "</a>", vbTextCompare)
If LinkLineEndPos = 0 Then Exit Do
LinkLineEndPos = LinkLineEndPos + 3
LinkLine = Mid$(ContextHelpString, LinkLineStartPos, (LinkLineEndPos ‑ LinkLineStartPos + 1))
'allocate link line
If Not (LinkStructNumber = 32766) Then 'verify
LinkStructNumber = LinkStructNumber + 1
Else
MsgBox "internal error in Link_FilterContextLinks(): overflow !", vbOKOnly + vbExclamation
Exit Sub
End If
ReDim Preserve LinkStructArray(1 To LinkStructNumber) As LinkStruct
'get control name
For Temp = 1 To Len(LinkLine)
If Mid$(LinkLine, Temp, 1) = """" Then
StartPos = Temp + 1
Exit For
End If
Next Temp
If StartPos = 0 Then GoTo Error:
EndPos = 0 'reset
For Temp = StartPos To Len(LinkLine)
If Mid$(LinkLine, Temp, 1) = """" Then
EndPos = Temp ‑ 1
Exit For
End If
Next Temp
If EndPos = 0 Then GoTo Error: 'verify
LinkStructArray(LinkStructNumber).LinkControlName = Mid$(LinkLine, StartPos, (EndPos ‑ StartPos + 1))
StartPos = 0 'reset
For Temp = (EndPos + 2) To Len(LinkLine)
If Mid$(LinkLine, Temp, 1) = ">" Then
StartPos = Temp + 1
Exit For
End If
Next Temp
If StartPos = 0 Then GoTo Error: 'verify
EndPos = 0 'reset
For Temp = StartPos To Len(LinkLine)
If Mid$(LinkLine, Temp, 4) = "</a>" Then '< and > may appear in link text
EndPos = Temp ‑ 1
Exit For
End If
Next Temp
If EndPos = 0 Then GoTo Error: 'verify
LinkStructArray(LinkStructNumber).LinkText = Mid$(LinkLine, StartPos, (EndPos ‑ StartPos + 1))
'
'NOTE: if the link text contains <left>, <center> or <right> at its beginning then
'the link will be displayed at the specified position.
'
If LCase$(Left$(LinkStructArray(LinkStructNumber).LinkText, 6)) = "<left>" Then
LinkStructArray(LinkStructNumber).LinkText = Right$(LinkStructArray(LinkStructNumber).LinkText, Len(LinkStructArray(LinkStructNumber).LinkText) ‑ 6)
LinkStructArray(LinkStructNumber).X = GFCONTEXTHELP_LEFT
End If
If LCase$(Left$(LinkStructArray(LinkStructNumber).LinkText, 8)) = "<center>" Then
LinkStructArray(LinkStructNumber).LinkText = Right$(LinkStructArray(LinkStructNumber).LinkText, Len(LinkStructArray(LinkStructNumber).LinkText) ‑ 8)
LinkStructArray(LinkStructNumber).X = GFCONTEXTHELP_CENTER
End If
If LCase$(Left$(LinkStructArray(LinkStructNumber).LinkText, 7)) = "<right>" Then
LinkStructArray(LinkStructNumber).LinkText = Right$(LinkStructArray(LinkStructNumber).LinkText, Len(LinkStructArray(LinkStructNumber).LinkText) ‑ 7)
LinkStructArray(LinkStructNumber).X = GFCONTEXTHELP_RIGHT
End If
Call CHS_CutString(ContextHelpString, LinkLineStartPos, LinkLineEndPos)
Call CHS_InsertString(ContextHelpString, LinkLineStartPos, _
Link_ReplaceLinkLine(LinkStructArray(LinkStructNumber).LinkText))
Call Mark_Set(ContextHelpString, LinkLineStartPos, MARKTYPE_LINKSTRUCTPOINTER, LinkStructNumber)
GoTo Jump:
Error:
'cut out link line
LinkStructArray(LinkStructNumber).LinkControlName = "" 'reset (error)
LinkStructArray(LinkStructNumber).LinkText = "" 'reset (error)
LinkStructArray(LinkStructNumber).X = 0 'reset (error)
LinkStructArray(LinkStructNumber).Y = 0 'reset (error)
'NOTE: the system will ignore the reset structure element.
ContextHelpString = _
Left$(ContextHelpString, LinkLineStartPos ‑ 1) + _
Right$(ContextHelpString, Len(ContextHelpString) ‑ LinkLineEndPos)
Jump:
Loop
End Sub
Private Function Link_ReplaceLinkLine(ByVal LinkLine As String) As String
'on error resume next 'returns a string consisting of a special number of spaces that are at least as width as the passed string
Dim LinkLineWidth As Long
Dim SpaceWidth As Long
Dim Temp As Long
'
'NOTE: ContextHelpPicture.[TextWidth()/TextHeight()] is used, verify
'that the font of ContextHelpPicture has been set to the final label font.
'
'preset
LinkLineWidth = ContextHelpPicture.TextWidth(LinkLine)
SpaceWidth = ContextHelpPicture.TextWidth(Chr$(32))
'begin
Link_ReplaceLinkLine = String$(‑Int(‑LinkLineWidth / SpaceWidth), Chr$(32))
End Function
Private Sub Link_SetLinkPos(ByVal LinkStructNumber As Integer, ByRef LinkStructArray() As LinkStruct, ByVal CHSMarkStructNumber As Integer, ByRef CHSMarkStructArray() As CHSMarkStruct, ByVal ContextHelpString As String)
'on error resume next
Dim LinkXPos As Long
Dim LinkYPos As Long
Dim StructLoop As Integer
'
'NOTE: this sub finally sets the link's position in ContextHelpPicture.
'The link's position cannot be set when filtering the images as the
'length of the ContextHelpString is not constant, once an link position
'has been set it would be invalid when space chars are inserted into the
'context help string to create space for the next link.
'
For StructLoop = 1 To CHSMarkStructNumber
If CHSMarkStructArray(StructLoop).MarkType = MARKTYPE_LINKSTRUCTPOINTER Then
Call GetDisplayPosFromStringPos(ContextHelpString, CHSMarkStructArray(StructLoop).MarkPos, LinkXPos, LinkYPos)
Select Case LinkStructArray(CHSMarkStructArray(StructLoop).MarkStructIndex).X
Case GFCONTEXTHELP_LEFT, GFCONTEXTHELP_CENTER, GFCONTEXTHELP_RIGHT
'retain special pos
LinkStructArray(CHSMarkStructArray(StructLoop).MarkStructIndex).Y = LinkYPos
Case Else
LinkStructArray(CHSMarkStructArray(StructLoop).MarkStructIndex).X = LinkXPos
LinkStructArray(CHSMarkStructArray(StructLoop).MarkStructIndex).Y = LinkYPos
End Select
End If
Next StructLoop
End Sub
Private Sub Link_ShowLinks(ByVal LinkStructNumber As Integer, ByRef LinkStructArray() As LinkStruct)
'on error resume next
Dim StructLoop As Integer
Dim Temp As Long
'reset
For StructLoop = LinkLabelStructVar.LinkLabelIndexMax To 1 Step (‑1)
'NOTE: label 0 is not displayed and also not unloaded.
Unload LinkLabel(StructLoop)
Next StructLoop
LinkLabelStructVar.LinkLabelIndexMax = 0 'reset
'begin
For StructLoop = 1 To LinkStructNumber
If Not ((LinkStructArray(StructLoop).LinkControlName = "") Or (LinkStructArray(StructLoop).LinkText = "")) Then 'verify
LinkLabelStructVar.LinkLabelIndexMax = LinkLabelStructVar.LinkLabelIndexMax + 1
Load LinkLabel(LinkLabelStructVar.LinkLabelIndexMax)
'update label style
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Alignment = vbCenter
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).ForeColor = _
GFColor_ChangeContrast( _
GFColor_MixColor( _
GFColor_InvertColor(ContextHelpPicture.ForeColor), _
GFColor_InvertColor(ContextHelpPicture.BackColor), 0.66!), 1.25!) 'fore ground color 'has more power'
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Font.Name = ContextHelpPicture.Font.Name
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Font.Size = ContextHelpPicture.Font.Size
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Font.Bold = ContextHelpPicture.Font.Bold
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Font.Italic = ContextHelpPicture.Font.Italic
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Font.Underline = True
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Font.StrikeThrough = ContextHelpPicture.Font.StrikeThrough
'size label
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Width = ContextHelpPicture.TextWidth(LinkStructArray(StructLoop).LinkText)
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Height = ContextHelpPicture.TextHeight(LinkStructArray(StructLoop).LinkText)
'update label caption
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Caption = LinkStructArray(StructLoop).LinkText
'verify label position
Select Case LinkStructArray(StructLoop).X
Case GFCONTEXTHELP_LEFT
LinkStructArray(StructLoop).X = 0
Case GFCONTEXTHELP_CENTER
LinkStructArray(StructLoop).X = ContextHelpPicture.Width / 2 ‑ LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Width / 2
Case GFCONTEXTHELP_RIGHT
LinkStructArray(StructLoop).X = ContextHelpPicture.Width ‑ LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Width
End Select
If LinkStructArray(StructLoop).X < 0 Then LinkStructArray(StructLoop).X = 0
If LinkStructArray(StructLoop).X > (ContextHelpPicture.Width ‑ LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Width) Then LinkStructArray(StructLoop).X = ContextHelpPicture.Width ‑ LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Width
If LinkStructArray(StructLoop).Y < 0 Then LinkStructArray(StructLoop).Y = 0
If LinkStructArray(StructLoop).Y > (ContextHelpPicture.Height ‑ LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Height) Then LinkStructArray(StructLoop).Y = ContextHelpPicture.Height ‑ LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Height
'move label
Call LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Move( _
LinkStructArray(StructLoop).X, _
LinkStructArray(StructLoop).Y)
'display label
LinkLabel(LinkLabelStructVar.LinkLabelIndexMax).Visible = True
'raise event
If Not (CallBackForm Is Nothing) Then Call CallBackForm.GFContextHelp_ReceiveEvent("Link_ShowLink", LinkStructArray(StructLoop).LinkText)
End If
Next StructLoop
End Sub
Private Sub LinkLabel_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
'verify
If Button = vbRightButton Then Exit Sub
'begin
If LinkColorStructVar.LinkForeColorChangedFlag = False Then
LinkColorStructVar.LinkForeColorChangedFlag = True
LinkColorStructVar.LinkForeColorUnchanged = LinkLabel(Index).ForeColor
LinkLabel(Index).ForeColor = ContextHelpPicture.ForeColor
End If
End Sub
Private Sub LinkLabel_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
If (Button = vbLeftButton) And (LinkColorStructVar.LinkForeColorChangedFlag = True) Then
If (X < 0) Or (X > LinkLabel(Index).Width) Or (Y < 0) Or (Y > LinkLabel(Index).Height) Then
If Not (LinkLabel(Index).ForeColor = LinkColorStructVar.LinkForeColorUnchanged) Then _
LinkLabel(Index).ForeColor = LinkColorStructVar.LinkForeColorUnchanged
Else
If Not (LinkLabel(Index).ForeColor = ContextHelpPicture.ForeColor) Then _
LinkLabel(Index).ForeColor = ContextHelpPicture.ForeColor
End If
End If
End Sub
Private Sub LinkLabel_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next 'displays another help text
Dim StructLoop As Integer
'verify
If Button = vbRightButton Then Exit Sub
'begin
If LinkColorStructVar.LinkForeColorChangedFlag = True Then
LinkColorStructVar.LinkForeColorChangedFlag = False 'reset
LinkLabel(Index).ForeColor = LinkColorStructVar.LinkForeColorUnchanged
End If
If Not ((X < 0) Or (X > LinkLabel(Index).Width) Or (Y < 0) Or (Y > LinkLabel(Index).Height)) Then
'a link is not clicked outside its label boundaries
For StructLoop = 1 To LinkStructNumber 'number of labels and number of structure elements needn't to be equal
If LinkStructArray(StructLoop).LinkText = LinkLabel(Index).Caption Then
'forward event
If Not (CallBackForm Is Nothing) Then Call CallBackForm.GFContextHelp_ReceiveEvent("LinkLabel_MouseUp", LinkLabel(Index).Caption)
'get out of here
Call Link_HideLinks 'reset
LinkClickStructVar.LinkClickedFlag = True
LinkClickStructVar.LinkClickedIndex = StructLoop
ContinueFlag = True
Exit Sub 'important (link labels have been unloaded)
End If
Next StructLoop
Call Link_HideLinks 'reset
End If
Exit Sub
End Sub
Private Sub Link_HideLinks()
'on error resume next 'call to unload all displayed LinkLabels
Dim LabelLoop As Integer
'begin
For LabelLoop = LinkLabelStructVar.LinkLabelIndexMax To 1 Step (‑1)
'NOTE: label 0 is not unloaded (also not visible)
LinkLabel(LabelLoop).Visible = False
Unload LinkLabel(LabelLoop)
Next LabelLoop
LinkLabelStructVar.LinkLabelIndexMax = 0 'reset
End Sub
'*********************************END OF CONTEXT LINKS**********************************
'****************************************IMAGES*****************************************
'NOTE: there is the possibility to display images (pictures) in the ContextHelpPicture.
'Images can just be displayed, not stretched and they also cannot serve as a link.
'To display an image the following line must be added as a single line (!) to the ContextHelpFile:
'<img src="ImageName">.
Private Sub Image_FilterImages(ByRef ContextHelpString As String)
'on error resume next
Dim ProgramPath As String
Dim ImageLineStartPos As Long 'ImageLine = complete link expression including tag
Dim ImageLineEndPos As Long
Dim ImageLine As String
Dim ImageControlName As String
Dim ImageText As String
Dim ImageXSize As Long
Dim ImageYSize As Long
Dim LineCount As Long
Dim StartPos As Long 'general use
Dim EndPos As Long
Dim Temp As Long
'
'NOTE: this sub does not set the ImageStructArray().[X/Y]
'coordinates, this is done by Image_SetImagePos().
'
'preset
ProgramPath = App.Path
If Not (Right$(ProgramPath, 1) = "\") Then ProgramPath = ProgramPath + "\" 'verify
'reset
ImageStructNumber = 0 'reset
ReDim ImageStructArray(1 To 1) As ImageStruct
'begin
Do
ImageLineStartPos = InStr(1, ContextHelpString, "<img src=", vbTextCompare)
If ImageLineStartPos = 0 Then Exit Do
ImageLineEndPos = InStr(ImageLineStartPos, ContextHelpString, ">", vbTextCompare)
If ImageLineEndPos = 0 Then Exit Do
ImageLine = Mid$(ContextHelpString, ImageLineStartPos, (ImageLineEndPos ‑ ImageLineStartPos + 1))
'allocate link line
If Not (ImageStructNumber = 32766) Then 'verify
ImageStructNumber = ImageStructNumber + 1
Else
MsgBox "internal error in Image_FilterContextImages(): overflow !", vbOKOnly + vbExclamation
Exit Sub
End If
ReDim Preserve ImageStructArray(1 To ImageStructNumber) As ImageStruct
'get control name
For Temp = 1 To Len(ImageLine)
If Mid$(ImageLine, Temp, 1) = """" Then
StartPos = Temp + 1
Exit For
End If
Next Temp
If StartPos = 0 Then GoTo Error:
EndPos = 0 'reset
For Temp = StartPos To Len(ImageLine)
If Mid$(ImageLine, Temp, 1) = """" Then
EndPos = Temp ‑ 1
Exit For
End If
Next Temp
If EndPos = 0 Then GoTo Error: 'verify
ImageStructArray(ImageStructNumber).ImageName = Mid$(ImageLine, StartPos, (EndPos ‑ StartPos + 1))
If GetDirectoryName(ImageStructArray(ImageStructNumber).ImageName) = "" Then
'
'NOTE: if there's no directory name associated to an image,
'the directory set by GFContextHelp_SetImageDirectory() will be used.
'This directory is by default the ContextHelpFile's directory.
'
ImageStructArray(ImageStructNumber).ImageName = GFContextHelpStructVar.ImageDirectory + ImageStructArray(ImageStructNumber).ImageName
End If
'load image into ImagePicture to allow determining the image's dimensions
If Image_LoadImage(ImageStructArray(ImageStructNumber).ImageName, ImageXSize, ImageYSize) = False Then GoTo Error:
ImageStructArray(ImageStructNumber).XSize = ImageXSize
ImageStructArray(ImageStructNumber).YSize = ImageYSize
ImageStructArray(ImageStructNumber).ImageSpecialPos = GFCONTEXTHELP_CENTERED 'default, cannot be changed
'link line has been cut, search again
Call CHS_CutString(ContextHelpString, ImageLineStartPos, ImageLineEndPos)
'
'NOTE: as replacing an image line with space chars is more complicated than replacing
'a link line with space chars a special sub is called.
'This sub may only use the CHS functions to edit the context help string.
'
Call Image_ReplaceImageLine(ContextHelpString, ImageStructArray(ImageStructNumber).X, ImageLineStartPos, ImageXSize, ImageYSize)
Call Mark_Set(ContextHelpString, ImageLineStartPos, MARKTYPE_IMAGESTRUCTPOINTER, ImageStructNumber)
GoTo Jump:
Error:
'cut out link line
ImageStructArray(ImageStructNumber).ImageName = "" 'reset (error)
ImageStructArray(ImageStructNumber).X = 0 'reset (error)
ImageStructArray(ImageStructNumber).Y = 0 'reset (error)
ImageStructArray(ImageStructNumber).XSize = 0 'reset (error)
ImageStructArray(ImageStructNumber).YSize = 0 'reset (error)
ImageStructArray(ImageStructNumber).ImageSpecialPos = 0 'reset (error)
'NOTE: the system will ignore the reset structure element.
ContextHelpString = _
Left$(ContextHelpString, ImageLineStartPos ‑ 1) + _
Right$(ContextHelpString, Len(ContextHelpString) ‑ ImageLineEndPos)
Jump:
Loop
End Sub
Private Sub Image_ReplaceImageLine(ByRef ContextHelpString As String, ByRef ImageXPos As Long, ByVal ImageLineStartPos As Long, ByVal ImageXSize As Long, ByVal ImageYSize As Long)
'on error resume next 'format: pixels
Dim InsertSpaceNumber As Long 'how many spaces must be inserted to create space for the image
Dim InsertSpaceNumberFinal As Long 'how many space chars must be inserted to create space for the image and the gap in front of it that was created as a word was moved behind the image
Dim InsertLineNumber As Long 'how many lines are covered by the image
Dim IsImageInOwnLineFlag As Boolean
Dim LineLoop As Integer
Dim Temp1 As Long
Dim Temp2 As Long
Dim Temp3 As Long
Dim Tempstr$
'
'NOTE: this sub will insert spaces at the 'location' in the context help string where the image is located at.
'The spaces have at least the width of the image. In the next line the same procedure is done, until all lines the
'that image covers have been manipulated.
'Note that the font of ContextHelpPicture must be the final font as Text[Width/Height]() will be used.
'
'preset
InsertSpaceNumber = ‑Int(‑(ImageXSize * Screen.TwipsPerPixelX / ContextHelpPicture.TextWidth(Chr$(32))))
InsertLineNumber = ‑Int(‑(ImageYSize * Screen.TwipsPerPixelY / ContextHelpPicture.TextHeight(Chr$(32))))
'
'NOTE: the whole display‑image‑between‑text stuff didn't work, so
'just display every image in one or more empty lines.
'
IsImageInOwnLineFlag = True
'begin
Select Case IsImageInOwnLineFlag
Case True
'
'NOTE: the image line itself created one empty line.
'NOTE: add two invisible space chars at beginning and end of the
'empty lines‑string to avoid that CHS_RemoveBorderBelow32() cuts
'the added empty lines that are necessary to verify the ContextHelpPicture is
'dimensioned large enough to display all images, even at the very
'bottom of the window.
'
Tempstr$ = Chr$(32)
For Temp1 = 1 To (InsertLineNumber ‑ 1)
Tempstr$ = Tempstr$ + Chr$(13) + Chr$(10)
Next Temp1
Tempstr$ = Tempstr$ + Chr$(32)
Call CHS_InsertString(ContextHelpString, ImageLineStartPos, Tempstr$)
Call CHS_RemoveBorderBelow32(ContextHelpString) 'remove start sign
Case False
For Temp1 = ImageLineStartPos To 1 Step (‑1)
If Mid$(ContextHelpString, Temp1, 1) = Chr$(10) Then 'seek back to find line start (following code requires that ImageLineStartPos points to line start pos)
ImageLineStartPos = Temp1
GoTo Jump1:
End If
Next Temp1
Call CHS_InsertString(ContextHelpString, 1, Chr$(10)) 'add start sign (will be removed later)
ImageLineStartPos = 1
Jump1:
'
'NOTE: it may happen that the text start pos after (!) the image varies,
'this is no error but a result of the fact that a space char has a greater width than 1 ("kgv").
'
For LineLoop = 1 To InsertLineNumber
For Temp1 = ImageLineStartPos To Len(ContextHelpString)
If Mid$(ContextHelpString, Temp1, 1) = Chr$(10) Then 'line must be bordered by Chr$(13) + Chr$(10) or at least Chr$(10)
ImageLineStartPos = Temp1 + 1 'start pos of next line in ContextHelpString
For Temp3 = ImageLineStartPos To Len(ContextHelpString)
If Mid$(ContextHelpString, Temp3, 1) = Chr$(10) Then GoTo Jump: 'current line does not 'reach' 'till image
If (ContextHelpPicture.TextWidth(Mid$(ContextHelpString, ImageLineStartPos, (Temp3 ‑ ImageLineStartPos + 1)))) > (ImageXPos) Then
'string 'before' image found, loop back to find a space gap in string
For Temp2 = Temp3 To ImageLineStartPos Step (‑1)
If Mid$(ContextHelpString, Temp2, 1) = Chr$(32) Then
ImageLineStartPos = Temp2
InsertSpaceNumberFinal = InsertSpaceNumber + ‑Int(‑ContextHelpPicture.TextWidth(Mid$(ContextHelpString, Temp2, (Temp3 ‑ Temp2 + 1))) / ContextHelpPicture.TextWidth(Chr$(32))) 'insert spaces as width as the word in front of the image that will be moved behind the image
InsertSpaceNumberFinal = InsertSpaceNumberFinal ‑ 1 'subtracts current space char (see condition above)
Call CHS_InsertString(ContextHelpString, ImageLineStartPos, _
String$(InsertSpaceNumberFinal, Chr$(32)))
GoTo Jump: 'finished
End If
Next Temp2
ImageLineStartPos = ImageLineStartPos 'leave unchanged, at start of line
InsertSpaceNumberFinal = InsertSpaceNumber + ‑Int(‑ContextHelpPicture.TextWidth(Mid$(ContextHelpString, ImageLineStartPos, (Temp1 ‑ ImageLineStartPos + 1))) / ContextHelpPicture.TextWidth(Chr$(32))) 'insert spaces as width as the word in front of the image that will be moved behind the image
Call CHS_InsertString(ContextHelpString, ImageLineStartPos, _
String$(InsertSpaceNumberFinal, Chr$(32)))
GoTo Jump:
End If
Next Temp3
End If
Next Temp1
Jump:
Next LineLoop
Call CHS_RemoveBorderBelow32(ContextHelpString) 'remove start sign
End Select
End Sub
Private Sub Image_SetImagePos(ByVal ImageStructNumber As Integer, ByRef ImageStructArray() As ImageStruct, ByVal CHSMarkStructNumber As Integer, ByRef CHSMarkStructArray() As CHSMarkStruct, ByVal ContextHelpString As String)
'on error resume next
Dim ImageXPos As Long
Dim ImageYPos As Long
Dim StructLoop As Integer
'
'NOTE: this sub finally sets the image's position in ContextHelpPicture.
'The image's position cannot be set when filtering the images as the
'length of the ContextHelpString is not constant, once an image position
'has been set it would be invalid when spaces are inserted into the
'ContextHelpString to create space for the next image.
'
For StructLoop = 1 To CHSMarkStructNumber
If CHSMarkStructArray(StructLoop).MarkType = MARKTYPE_IMAGESTRUCTPOINTER Then
Call GetDisplayPosFromStringPos(ContextHelpString, CHSMarkStructArray(StructLoop).MarkPos, ImageXPos, ImageYPos)
If Not (ImageStructArray(CHSMarkStructArray(StructLoop).MarkStructIndex).ImageSpecialPos) = GFCONTEXTHELP_CENTERED Then
ImageStructArray(CHSMarkStructArray(StructLoop).MarkStructIndex).X = ImageXPos
Else
ImageStructArray(CHSMarkStructArray(StructLoop).MarkStructIndex).X = GFCONTEXTHELP_CENTERED
End If
ImageStructArray(CHSMarkStructArray(StructLoop).MarkStructIndex).Y = ImageYPos
End If
Next StructLoop
End Sub
Private Sub Image_DrawImages(ByVal ImageStructNumber As Integer, ByRef ImageStructArray() As ImageStruct)
'on error resume next
Dim ImageXSize As Long
Dim ImageYSize As Long
Dim ImageLoop As Integer
'begin
For ImageLoop = 1 To ImageStructNumber
If (Len(ImageStructArray(ImageLoop).ImageName)) Then 'verify
If Image_LoadImage(ImageStructArray(ImageLoop).ImageName, ImageXSize, ImageYSize) = True Then
If Not (ImagePicture.ScaleMode = vbTwips) Then ImagePicture.ScaleMode = vbTwips 'verify
If Not (ImageStructArray(ImageLoop).X = GFCONTEXTHELP_CENTERED) Then
'display image at set X/Y pos
Call BitBlt(ContextHelpPicture.hDC, ImageStructArray(ImageLoop).X / Screen.TwipsPerPixelX, ImageStructArray(ImageLoop).Y / Screen.TwipsPerPixelY, _
ImagePicture.ScaleWidth / Screen.TwipsPerPixelX, ImagePicture.ScaleHeight / Screen.TwipsPerPixelY, _
ImagePicture.hDC, 0, 0, vbSrcCopy)
Else
'display image x centered at set Y pos
Call BitBlt(ContextHelpPicture.hDC, (ContextHelpPicture.ScaleWidth / 2 ‑ ImagePicture.ScaleWidth / 2) / Screen.TwipsPerPixelX, ImageStructArray(ImageLoop).Y / Screen.TwipsPerPixelY, _
ImagePicture.ScaleWidth / Screen.TwipsPerPixelX, ImagePicture.ScaleHeight / Screen.TwipsPerPixelY, _
ImagePicture.hDC, 0, 0, vbSrcCopy)
End If
ContextHelpPicture.Refresh 'important
End If
End If
Next ImageLoop
End Sub
Private Function Image_LoadImage(ByVal ImageName As String, ByRef ImageXSizeReturned As Long, ByRef ImageYSizeReturned As Long) As Boolean
On Error GoTo Error: 'returns True if ImageName has been loaded into ImagePicture, False if not
If Not ((Dir$(ImageName) = "") Or (Right$(ImageName, 1) = "\") Or (ImageName = "")) Then 'verify
ImagePicture.Cls 'reset
ImagePicture.AutoRedraw = True 'important (tested)
ImagePicture.AutoSize = True
ImagePicture.Picture = LoadPicture(ImageName)
ImageXSizeReturned = ImagePicture.ScaleWidth / Screen.TwipsPerPixelX
ImageYSizeReturned = ImagePicture.ScaleHeight / Screen.TwipsPerPixelY
Image_LoadImage = True 'ok
Else
Image_LoadImage = False 'error
End If
Exit Function
Error:
Image_LoadImage = False 'error
Exit Function
End Function
Private Sub GetDisplayPosFromStringPos(ByVal ContextHelpString As String, ByVal ContextHelpStringPos As Long, ByRef ContextHelpPictureXPos As Long, ByRef ContextHelpPictureYPos As Long)
'on error resume next
Dim LineStartPos As Long
Dim Temp As Long
'begin
LineStartPos = 1 'preset
For Temp = ContextHelpStringPos To 1 Step (‑1)
Select Case Asc(Mid$(ContextHelpString, Temp, 1))
Case 10, 13
LineStartPos = (Temp + 1)
Exit For 'important
End Select
Next Temp
ContextHelpPictureXPos = ContextHelpPicture.TextWidth(Mid$(ContextHelpString, MIN(LineStartPos, Len(ContextHelpString)), MAX(ContextHelpStringPos ‑ LineStartPos, 0))) 'width of chars between Chr$(10) of line start and label/image (may be 0)
ContextHelpPictureYPos = (LineCount(Left$(ContextHelpString, ContextHelpStringPos)) ‑ 1) * ContextHelpPicture.TextHeight(Chr$(32))
End Sub
'*************************************END OF IMAGES*************************************
'**************************************MARK SYSTEM**************************************
'NOTE: the following subs/functions are used to edit the ContextHelpString.
'Always use them to change the string as maybe marks must be moved.
Private Sub Mark_Reset()
'on error resume next
CHSMarkStructNumber = 0 'reset
ReDim CHSMarkStructArray(1 To 1) As CHSMarkStruct 'reset
End Sub
Private Sub Mark_Set(ByVal ContextHelpString As String, ByVal MarkPos As Long, ByVal MarkType As Integer, ByVal MarkStructIndex As Integer)
'on error resume next
'verify
If (MarkPos < 1) Or (MarkPos > Len(ContextHelpString)) Then
MsgBox "internal error in Mark_Set(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
If Not (CHSMarkStructNumber = 32766) Then 'verify
CHSMarkStructNumber = CHSMarkStructNumber + 1
Else
MsgBox "internal error in Mark_Set(): overflow !", vbOKOnly + vbExclamation
End If
ReDim Preserve CHSMarkStructArray(1 To CHSMarkStructNumber) As CHSMarkStruct
CHSMarkStructArray(CHSMarkStructNumber).MarkPos = MarkPos
CHSMarkStructArray(CHSMarkStructNumber).MarkType = MarkType
CHSMarkStructArray(CHSMarkStructNumber).MarkStructIndex = MarkStructIndex
End Sub
Private Sub CHS_CutString(ByRef ContextHelpString As String, ByVal CutStartPos As Long, ByVal CutEndPos As String)
'on error resume next
Dim ContextHelpStringLength As Long
Dim CutLength As Long
Dim StructLoop As Integer
'preset
ContextHelpStringLength = Len(ContextHelpString)
CutLength = CutEndPos ‑ CutStartPos + 1
'verify
If (CutLength < 0) Or (CutStartPos < 1) Or (CutStartPos > (ContextHelpStringLength ‑ CutLength + 1)) Then 'verify (also CutEndPos)
MsgBox "internal error in CHS_CutString(): passed value invalid !�", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'move marks
For StructLoop = 1 To CHSMarkStructNumber
If Not (CHSMarkStructArray(StructLoop).MarkPos < CutStartPos) Then
'NOTE: a mark should not be set in the string to cut.
CHSMarkStructArray(StructLoop).MarkPos = CHSMarkStructArray(StructLoop).MarkPos ‑ CutLength
End If
Next StructLoop
'edit string
ContextHelpString = Left$(ContextHelpString, CutStartPos ‑ 1) + Right$(ContextHelpString, ContextHelpStringLength ‑ CutEndPos)
End Sub
Private Sub CHS_InsertString(ByRef ContextHelpString As String, ByVal InsertStartPos As Long, ByVal InsertString As String)
'on error resume next
Dim ContextHelpStringLength As Long
Dim InsertStringLength As Long
Dim StructLoop As Integer
'preset
ContextHelpStringLength = Len(ContextHelpString)
InsertStringLength = Len(InsertString)
'verify
If (InsertStartPos < 1) Or (InsertStartPos > ContextHelpStringLength + 1) Then
MsgBox "internal error in CHS_InsertString() (GFContextHelp): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'move marks
For StructLoop = 1 To CHSMarkStructNumber
If Not (CHSMarkStructArray(StructLoop).MarkPos < InsertStartPos) Then
CHSMarkStructArray(StructLoop).MarkPos = CHSMarkStructArray(StructLoop).MarkPos + InsertStringLength
End If
Next StructLoop
'edit string
ContextHelpString = Left$(ContextHelpString, InsertStartPos ‑ 1) + InsertString + Right$(ContextHelpString, ContextHelpStringLength ‑ InsertStartPos + 1)
End Sub
Private Sub CHS_RemoveBorderBelow32(ByRef ContextHelpString As String)
'on error resume next 'use to cut empty lines at a string's start or end; pass short strings only (slow)
'
'NOTE: call this sub instead of RemoveBorderBelow32() when at least
'one mark has been set yet.
'
If Len(ContextHelpString) Then 'verify
Do While Asc(Left$(ContextHelpString, 1)) < 32
Call CHS_CutString(ContextHelpString, 1, 1)
If Len(ContextHelpString) = 0 Then Exit Do 'verify
Loop
End If
If Len(ContextHelpString) Then 'verify
Do While Asc(Right$(ContextHelpString, 1)) < 32
Call CHS_CutString(ContextHelpString, Len(ContextHelpString), Len(ContextHelpString))
If Len(ContextHelpString) = 0 Then Exit Do 'verify
Loop
End If
End Sub
'**********************************END OF MARK SYSTEM***********************************
'****************************************EVENTS*****************************************
'NOTE: if the text of a link has a special format, an
'SECBMSG_CONTEXTHELP_EVENT message will be posted.
'See code of LinkLabel_Click() for further information.
'*************************************END OF EVENTS*************************************
'*************************************GFMOUSEGUIDE**************************************
'NOTE: use GFMouseGuide to show the user the screen position of any object.
Private Sub GFMouseGuide_PlayAnimation(ByVal AnimationTargetPosX As Long, ByVal AnimationTargetPosY As Long, ByVal AnimationIndexOrZero As Integer, ByVal AnimationNumberOrZero As Integer)
'on error resume next 'format: pixels
Dim POINTAPIVar As POINTAPI
Dim AnimationLoop As Integer
Dim ScreenMousePointerUnchanged As Integer
'preset
Call GetCursorPos(POINTAPIVar) 'save to allow restoring original cursor pos
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbArrow 'important (if located over text boxes)
'begin
If AnimationIndexOrZero = 0 Then
AnimationIndexOrZero = Int((5 ‑ 1 + 1) * Rnd(1) + 1) 'randomly select one of three available animations
Select Case AnimationIndexOrZero 'adjust possibility
Case 1, 2, 3
AnimationIndexOrZero = 1
Case 4
AnimationIndexOrZero = 2
Case 5
AnimationIndexOrZero = 3
End Select
End If
Select Case AnimationIndexOrZero
Case 1 'looks serious
If AnimationNumberOrZero = 0 Then AnimationNumberOrZero = 3
For AnimationLoop = 1 To AnimationNumberOrZero
Call GFMouseGuide_PerformAnimation1(AnimationTargetPosX, AnimationTargetPosY)
Next AnimationLoop
Case 2
If AnimationNumberOrZero = 0 Then AnimationNumberOrZero = 2
For AnimationLoop = 1 To AnimationNumberOrZero
Call GFMouseGuide_PerformAnimation2(AnimationTargetPosX, AnimationTargetPosY)
Next AnimationLoop
Case 3 'looks funny
If AnimationNumberOrZero = 0 Then AnimationNumberOrZero = 1
For AnimationLoop = 1 To AnimationNumberOrZero
Call GFMouseGuide_PerformAnimation3(AnimationTargetPosX, AnimationTargetPosY)
Next AnimationLoop
End Select
Screen.MousePointer = ScreenMousePointerUnchanged 'reset
Call SetCursorPos(POINTAPIVar.X, POINTAPIVar.Y) 'reset
End Sub
Private Sub GFMouseGuide_PerformAnimation1(ByVal AnimationTargetPosX As Long, ByVal AnimationTargetPosY As Long)
'on error resume next 'mouse pointer draws a circle around target
Dim AnimationDirection As Single
Dim Temp As Long
'preset
If Rnd(1) < 0.05! Then
AnimationDirection = ‑1 'clockwise
Else
AnimationDirection = 1 'counter‑clockwise
End If
'begin
For Temp = 1 To 360 Step 5
Call SetCursorPos( _
AnimationTargetPosX ‑ Sin(CSng(Temp) / 360! * 2! * 3.14! * AnimationDirection) * 10, _
AnimationTargetPosY ‑ Cos(CSng(Temp) / 360! * 2! * 3.14! * AnimationDirection) * 10)
Call Sleep(3)
Next Temp
End Sub
Private Sub GFMouseGuide_PerformAnimation2(ByVal AnimationTargetPosX As Long, ByVal AnimationTargetPosY As Long)
'on error resume next 'pointer shoots towards target and bounces back
Dim Temp As Long
For Temp = 31 To 0 Step (‑1)
Call SetCursorPos(AnimationTargetPosX + Temp, AnimationTargetPosY + Temp)
Call Sleep(3 + CLng(CSng(Temp) / 5!)) 'never use Sleep(0)
Next Temp
For Temp = 0 To 9
Call SetCursorPos(AnimationTargetPosX + Temp, AnimationTargetPosY + Temp)
Call Sleep(2 + Temp) 'never use Sleep(0)
Next Temp
For Temp = 9 To 0 Step (‑1)
Call SetCursorPos(AnimationTargetPosX + Temp, AnimationTargetPosY + Temp)
Call Sleep(2 + CLng(CSng(Temp) / 2!)) 'never use Sleep(0)
Next Temp
If Rnd(1) < 0.25! Then
For Temp = 0 To 9 'bounce again
Call SetCursorPos(AnimationTargetPosX + Temp, AnimationTargetPosY + Temp)
Call Sleep(2 + Temp) 'never use Sleep(0)
Next Temp
For Temp = 9 To 0 Step (‑1)
Call SetCursorPos(AnimationTargetPosX + Temp, AnimationTargetPosY + Temp)
Call Sleep(2 + CLng(CSng(Temp) / 2!)) 'never use Sleep(0)
Next Temp
End If
For Temp = 1 To 50
Call SetCursorPos(AnimationTargetPosX, AnimationTargetPosY)
Call Sleep(2)
Next Temp
For Temp = 0 To 31
Call SetCursorPos(AnimationTargetPosX + Temp, AnimationTargetPosY + Temp)
Call Sleep(3 + CLng(CSng(Temp) / 6!)) 'never use Sleep(0)
Next Temp
End Sub
Private Sub GFMouseGuide_PerformAnimation3(ByVal AnimationTargetPosX As Long, ByVal AnimationTargetPosY As Long)
'on error resume next 'mouse pointer is shaking over target
Dim Temp As Long
For Temp = 1 To 100
Call SetCursorPos( _
AnimationTargetPosX + Int((15 ‑ 1 + 1) * Rnd(1) + 1) ‑ 7, _
AnimationTargetPosY + Int((15 ‑ 1 + 1) * Rnd(1) + 1) ‑ 7)
Call Sleep(3)
Next Temp
For Temp = 1 To 50
Call SetCursorPos(AnimationTargetPosX, AnimationTargetPosY)
Call Sleep(3)
Next Temp
End Sub
'**********************************END OF GFMOUSEGUIDE**********************************
'*****************************************OTHER*****************************************
Public Sub ContextHelp_MakeSureVisible(ByRef ControlObject As Object, ByRef ControlParentWindow As Form) 'can be used by target project, too
'on error resume next 'makes sure ControlObject whose parent is ControlParentWindow is visible on the screen (task bar pos/size is not processed)
Dim ParentWindowMovedFlag As Boolean
Dim ParentWindowXPosNew As Long
Dim ParentWindowYPosNew As Long
Dim VisibleAreaLeft As Long
Dim VisibleAreaTop As Long
Dim VisibleAreaRight As Long
Dim VisibleAreaBottom As Long
Dim ControlPosCurrent As POINTAPI
Dim ControlXPos As Long
Dim ControlYPos As Long
Dim ControlXSize As Long
Dim ControlYSize As Long
'preset
Call GFTaskBarInfomod.GFTaskBarInfo_GetVisibleScreenArea(VisibleAreaLeft, VisibleAreaTop, VisibleAreaRight, VisibleAreaBottom)
ControlPosCurrent.X = ControlObject.Left / Screen.TwipsPerPixelX
ControlPosCurrent.Y = ControlObject.Top / Screen.TwipsPerPixelY
ParentWindowXPosNew = ControlParentWindow.Left
ParentWindowYPosNew = ControlParentWindow.Top
'begin
Call ClientToScreen(ControlParentWindow.hwnd, ControlPosCurrent)
'
ControlXPos = ControlPosCurrent.X
ControlYPos = ControlPosCurrent.Y
ControlXSize = ControlObject.Width / Screen.TwipsPerPixelX
ControlYSize = ControlObject.Height / Screen.TwipsPerPixelY
'
If ControlXPos < (VisibleAreaLeft / Screen.TwipsPerPixelX) Then
ParentWindowXPosNew = ControlParentWindow.Left + (VisibleAreaLeft ‑ (ControlXPos) * Screen.TwipsPerPixelX)
ParentWindowMovedFlag = True
End If
If ControlYPos < (VisibleAreaTop / Screen.TwipsPerPixelY) Then
ParentWindowYPosNew = ControlParentWindow.Top + (VisibleAreaTop ‑ (ControlYPos) * Screen.TwipsPerPixelY)
ParentWindowMovedFlag = True
End If
If (ControlXPos + ControlXSize ‑ 1&) > (VisibleAreaRight / Screen.TwipsPerPixelX) Then
ParentWindowXPosNew = ControlParentWindow.Left + ((VisibleAreaRight / Screen.TwipsPerPixelX) ‑ (ControlXPos + ControlXSize ‑ 1&)) * Screen.TwipsPerPixelX
ParentWindowMovedFlag = True
End If
If (ControlYPos + ControlYSize ‑ 1&) > (VisibleAreaBottom / Screen.TwipsPerPixelY) Then
ParentWindowYPosNew = ControlParentWindow.Top + ((VisibleAreaBottom / Screen.TwipsPerPixelY) ‑ (ControlYPos + ControlYSize ‑ 1&)) * Screen.TwipsPerPixelY
ParentWindowMovedFlag = True
End If
'
If ParentWindowMovedFlag = True Then
#If GFSkinEngineAvailableFlag = True Then
Dim ReturnValue As Long
Dim ReturnValueUsedFlag As Boolean
Dim ParentWindowControlStructIndex As Integer
Dim ParentWindowName As String
ParentWindowControlStructIndex = GetSEControlStructIndexFromControlObject(ControlParentWindow, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
If (ParentWindowControlStructIndex) Then 'verify
ParentWindowName = SEControlStructArray(ParentWindowControlStructIndex).SEControlName
Else 'should not happen
ParentWindowName = "ERROR"
End If
Call SE_SendCustomMessageEx( _
SE_CUSTOMMESSAGE_CONTEXTHELP_MOVES_WINDOW, _
SE_PackString_3(ParentWindowName, LTrim$(Str$(ParentWindowXPosNew / Screen.TwipsPerPixelX)), LTrim$(Str$(ParentWindowYPosNew / Screen.TwipsPerPixelY))), _
ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = False) Or ((ReturnValueUsedFlag = True) And Not (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call ControlParentWindow.Move(ParentWindowXPosNew, ParentWindowYPosNew)
Else
'target project moved form
End If
Call SE_RefreshForms 'god bless the Skin Engine :‑)
#Else
Call ControlParentWindow.Move(ParentWindowXPosNew, ParentWindowYPosNew)
#End If
End If
'
End Sub
'*************************************END OF OTHER**************************************
'***********************************GENERAL FUNCTIONS***********************************
Private Sub GFPopUpWindow_CreateShadow(ByRef PopUpWindow As Form)
'on error resume next 'call to create a window frame
'
'NOTE: this form must be at least 15 pixels 'larger' than its context because
'there will be a 'shadow' around the window that has a thickness of 15 pixels
'(at right and bottom form side only).
'
'begin
PopUpWindow.AutoRedraw = True
PopUpWindow.ScaleMode = vbTwips
PopUpWindow.Line (PopUpWindow.Width ‑ 15 * Screen.TwipsPerPixelX, 15 * Screen.TwipsPerPixelY)‑(PopUpWindow.Width, PopUpWindow.Height), 0, BF
PopUpWindow.Line (15 * Screen.TwipsPerPixelX, PopUpWindow.Height ‑ 15 * Screen.TwipsPerPixelY)‑(PopUpWindow.Width, PopUpWindow.Height), 0, BF
PopUpWindow.Refresh
End Sub
Private Sub GFPopUpWindow_PolyRgn_Enable(ByRef GFPopUpWindowStructVar As GFPopUpWindowStruct, ByRef PopUpWindow As Form)
'on error resume next 'call to create and apply poly rgn to passed window
Dim PopUpWindowRgnPointArray(0 To 7) As POINTAPI
'preset
PopUpWindowRgnPointArray(0).X = 0: PopUpWindowRgnPointArray(0).Y = 0
PopUpWindowRgnPointArray(1).X = (PopUpWindow.Width / Screen.TwipsPerPixelX) ‑ 15: PopUpWindowRgnPointArray(1).Y = 0
PopUpWindowRgnPointArray(2).X = (PopUpWindow.Width / Screen.TwipsPerPixelX) ‑ 15: PopUpWindowRgnPointArray(2).Y = 15
PopUpWindowRgnPointArray(3).X = (PopUpWindow.Width / Screen.TwipsPerPixelX): PopUpWindowRgnPointArray(3).Y = 15
PopUpWindowRgnPointArray(4).X = (PopUpWindow.Width / Screen.TwipsPerPixelX): PopUpWindowRgnPointArray(4).Y = (PopUpWindow.Height / Screen.TwipsPerPixelY)
PopUpWindowRgnPointArray(5).X = 15: PopUpWindowRgnPointArray(5).Y = (PopUpWindow.Height / Screen.TwipsPerPixelY)
PopUpWindowRgnPointArray(6).X = 15: PopUpWindowRgnPointArray(6).Y = (PopUpWindow.Height / Screen.TwipsPerPixelY) ‑ 15
PopUpWindowRgnPointArray(7).X = 0: PopUpWindowRgnPointArray(7).Y = (PopUpWindow.Height / Screen.TwipsPerPixelY) ‑ 15
'reset
If Not (GFPopUpWindowStructVar.PopUpWindowRgnHandle = 0) Then Call DeleteObject(GFPopUpWindowStructVar.PopUpWindowRgnHandle) 'reset
'begin
GFPopUpWindowStructVar.PopUpWindowRgnHandle = CreatePolygonRgn(PopUpWindowRgnPointArray(0), 8, 1)
Call SetWindowRgn(PopUpWindow.hwnd, GFPopUpWindowStructVar.PopUpWindowRgnHandle, True)
End Sub
Private Sub GFPopUpWindow_PolyRgn_Disable(ByRef GFPopUpWindowStructVar As GFPopUpWindowStruct, ByRef PopUpWindow As Form)
'on error resume next 'call to free up some GDI memory
Call SetWindowRgn(PopUpWindow.hwnd, 0, True)
If Not (GFPopUpWindowStructVar.PopUpWindowRgnHandle = 0) Then Call DeleteObject(GFPopUpWindowStructVar.PopUpWindowRgnHandle) 'reset
End Sub
Private Sub RemoveBorderBelow32(ByRef InputString As String)
'on error resume next 'use to cut empty lines at a string's start or end; pass short strings only (slow)
If Len(InputString) Then 'verify
Do While Asc(Left$(InputString, 1)) < 32
InputString = Right$(InputString, Len(InputString) ‑ 1)
If Len(InputString) = 0 Then Exit Do 'verify
Loop
End If
If Len(InputString) Then 'verify
Do While Asc(Right$(InputString, 1)) < 32
InputString = Left$(InputString, Len(InputString) ‑ 1)
If Len(InputString) = 0 Then Exit Do 'verify
Loop
End If
End Sub
Private Function LineCount(ByVal InputString As String) As Integer
'on error resume next 'pass short strings only (slow)
Dim CharLoop As Integer
'
'NOTE: the passed string must contain either Chr$(10) or
'Chr$(13) + Chr$(10) as line start/end string.
'If the passed string is not nothing ("") LineCount is at least 1.
'
'preset
If Len(InputString) Then 'verify
Do While Asc(Left$(InputString, 1)) < 32
InputString = Right$(InputString, Len(InputString) ‑ 1)
If Len(InputString) = 0 Then Exit Do 'verify
Loop
End If
If Len(InputString) Then 'verify
Do While Asc(Right$(InputString, 1)) < 32
InputString = Left$(InputString, Len(InputString) ‑ 1)
If Len(InputString) = 0 Then Exit Do 'verify
Loop
End If
If Not (Len(InputString) = 0) Then
LineCount = 1
Else
LineCount = 0
End If
'begin
For CharLoop = 1 To Len(InputString)
If Asc(Mid$(InputString, CharLoop, 1)) = 10 Then LineCount = LineCount + 1
Next CharLoop
End Function
Private Function GetDirectoryName(ByVal GetDirectoryNameName As String) As String
'On Error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
Dim GetDirectoryNameLoop As Integer
GetDirectoryName = "" 'reset
For GetDirectoryNameLoop = Len(GetDirectoryNameName) To 1 Step (‑1)
If Mid$(GetDirectoryNameName, GetDirectoryNameLoop, 1) = "\" Then
GetDirectoryName = Left$(GetDirectoryNameName, GetDirectoryNameLoop)
Exit For
End If
Next GetDirectoryNameLoop
End Function
Private Function ProgramGetMousePosX() As Long
'On Error Resume Next 'the format is: pixels
Dim ProgramGetMousePosXTemp As Long
Dim CurrentMousePos As POINTAPI
ProgramGetMousePosXTemp = GetCursorPos(CurrentMousePos)
ProgramGetMousePosX = CurrentMousePos.X
End Function
Private Function ProgramGetMousePosY() As Long
'On Error Resume Next 'the format is: pixels
Dim ProgramGetMousePosYTemp As Long
Dim CurrentMousePos As POINTAPI
ProgramGetMousePosYTemp = GetCursorPos(CurrentMousePos)
ProgramGetMousePosY = CurrentMousePos.Y
End Function
Private Function GFSetWindowOnTop(ByVal WindowOrFormName As Form) As Long
'on error resume next
GFSetWindowOnTop = SetWindowPos(WindowOrFormName.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
WindowOrFormName.Refresh
End Function
Private Function GFRemoveWindowFromTop(ByVal WindowOrFormName As Form) As Long
'on error resume next
GFRemoveWindowFromTop = SetWindowPos(WindowOrFormName.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
WindowOrFormName.Refresh
End Function
Private Function LOWORD(ByVal n As Long) As Integer
'On Error Resume Next 'returns the low word of n
Call CopyMemory(LOWORD, ByVal VarPtr(n) + 2, 2)
End Function
Private Function HIWORD(ByVal n As Long) As Integer
'On Error Resume Next 'returns the low word of n
Call CopyMemory(HIWORD, ByVal VarPtr(n) + 0, 2)
End Function
Private Function TX(ByVal PixelsX As Long) As Long
'on error resume next
TX = PixelsX * Screen.TwipsPerPixelX
End Function
Private Function TY(ByVal PixelsY As Long) As Long
'on error resume next
TY = PixelsY * Screen.TwipsPerPixelY
End Function
Private Function MIN(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'On Error Resume Next
If Value1 < Value2 Then
MIN = Value1
Else
MIN = Value2
End If
End Function
Private Function MAX(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'On Error Resume Next
If Value1 > Value2 Then
MAX = Value1
Else
MAX = Value2
End If
End Function
Private Sub Form_Unload(Cancel As Integer)
'on error resume next
#If GFSkinEngineAvailableFlag = True Then
Call SE_UnloadPalette(SECONTROLPALETTE_CONTEXTHELPFRM)
Call SECB_RemoveCallBackForm(Me)
#End If
ContextHelpPicture.AutoRedraw = False 'reset (free up memory)
ContextHelpHeaderPicture.AutoRedraw = False 'reset (free up memory)
GFContextHelpfrm.AutoRedraw = False 'reset (free up memory) (enabled by GFPopUpWindow code)
GFContextHelpfrm.Visible = False
GFContextHelpfrm.Enabled = False
GFContextHelpfrm.Refresh
#If GFSkinEngineAvailableFlag = True Then
Call GFSubClass_ReSubClass_UnSubClassByTargetObjectDescriptionPrefix("GFContextHelpfrm")
#End If
End Sub
[END OF FILE]