GFSkinEngine/GFSkinEnginemod.bas
Attribute VB_Name = "GFSkinEnginemod"
Option Explicit
'(c)2001‑2004 by Louis.
'
#Const SE_ReceiveCallBackMessageExEnabledFlag = True
'
'NOTE: the switch above is similar to
''GFSubClassWidnowProcExEnabledFlag' in GFSubClassmod.
'As there were unexplainable slow‑downs when calling a sub/function
'of a form whose reference is saved in an array, we call one
'callback sub only, located in Mfrm.
'This callback sub forwards any call back message to the original
'form that is to receive the message.
'
'Public Sub SE_ReceiveCallBackMessageEx(ByVal TargetFormName As String, ByVal Msg As Integer, ByVal wParam As String, ByVal lParam As String, ByRef ReturnValueUsedFlag As Boolean, ByRef ReturnValue As Long)
' 'on error resume next
'End Sub
'
'IMPORTANT: all used picture boxes must have set AutoRedraw to True.
'Then the content will be retained, but also .Refresh must be used on the
'target picture box to make its content visible.
'
'NOTE: 'On Error [...]' is to be used:
'‑in any sub/function that uses Kill,
'‑in any sub/function that uses LoadPicture().
'‑in any sub/function that uses Dir$() (except those that use DirSave())
'
'NOTE: the menu item 'Allow Picture Import' is disabled and hidden
'so that the user cannot use this feature (did not work correctly).
'
'NOTE: this module can use the GFSM system to detect memory leaks.
'The target application should call GFSM_Terminate to check for leaks.
'
'NOTE: the following prototype of the Skin Engine callback sub can be
'copied to the target project if wanting to inform the target project about
'e.g. a SkinDataFile change.
'Multiple callback subs can be used, call SECB_AddCallBackForm()
'to add another target form that owns a callback sub.
'The return value can be used to avoid special actions.
'
'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
'End Sub
'
'NOTE: reserved system texts:
'‑#201‑210: random STAuthor
'‑#211‑220: random STLocation
'‑#221‑230: random STMotto
'‑#231‑240: random STDedication
'‑#241‑250: random STComment
'‑#251‑260: random STImportPasswordHintText
'‑#261‑270: random STEditPasswordHintText
'
'NOTE: the length of a skin name is limited to 50 chars.
'
'NOTE: to verify GUI memory is freed use DeleteObject() on picture box
'pictures and images when no longer needing them.
'Locations in code where it is verified that GUI memory is freed are
'marked with 'msbugsave'.
'To make sure a DC and its content is deleted correctly do the following:
'Temp = SelectObject(DC, Handle)
'Call DeleteObject(Temp)
'Call DeleteDC(Temp)
'Call DeleteObject(DC)
'Call DeleteDC(DC)
'
'UpdateCheck
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'SEM_UserMove_Enable
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
'SEM_PolyRgn_Enable
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
'SEM_PolyRgn_BackPicture_Transfer
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
'SE_OpenPopUpMenu
Private Declare Function GetMenu Lib "user32.dll" (ByVal hwnd As Long) As Long 'source: VB sample 'CallDlls'
Private Declare Function GetSubMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function TrackPopupMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lpReserved As Any) As Long
'SE_DCStructToSECommand
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
'SE_DeletePictureBox
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
'FrameBrushCache_Create
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
'FrameBrushCache_Reset
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'GFSetWindowStyle
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'GFReceiveFile (GFSubClassWindowProc)
Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)
'GFDCToStdPicture
'Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
'Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
'Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
'Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'GFShrinkFile
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'GFCDGetFileName
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
'GFCDSetFileName
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
'GFCDGetColor
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLORSTRUCT) As Long
'GFSelectDirectory
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
'GFCreateDirectory
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
'GFCursor_Reset
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'GetTempDir
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'ProgramGetMousePos[X, Y]
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
'other
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) 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
'NOTE: use FileCopy() rather than CopyFile to save 'On Error Resume Next.
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
'NOTE: do not use LockWindowUpdate() as it leads to desktop flickering.
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
'
'****GENERAL FUNCTION CONSTANTS*****
'NOTE: general functions are sorted by their 'popularity',
'the functions used the most comes last.
'
'GFSetWindowStyle
Private Const GWL_STYLE As Long = (‑16)
'NOTE: some constants have been removed to save memory.
Private Const WS_SYSMENU = &H80000
'GFDCToStdPicture
Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
'GFShrinkFile
Private Const OFS_MAXPATHNAME = 128
Private Const OF_READWRITE = &H2
Private Const FILE_BEGIN = 0
'GFCDGetFileName
Private Const OFN_HIDEREADONLY = &H4
Dim NULLARRAYSTRING(0 To 0) As String 'disable if already existing in target project
'GFCDGetColor
Private Const CC_RGBINIT = &H1
'GFSelectDirectory
Private Const MAX_PATH = 260
Private Const ERROR_SUCCESS As Long = 0
Private Const CSIDL_DESKTOP As Long = &H0
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_STATUSTEXT As Long = &H4
Private Const BIF_RETURNFSANCESTORS As Long = &H8
'GFSetWindowOnTop
Private Const HWND_TOPMOST = ‑1
Private Const HWND_NOTOPMOST = ‑2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
'
'***END OF GENERAL FUNCTION CONSTANTS***
'***SE CONSTANTS***
'
'SE_DeletePictureBox
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
'
'***END OF SE CONSTANTS***
'***GENERAL FUNCTION VARS***
'
'GFCreateDirectory
Dim GFCreateDirectorySubCallNumber As Integer
'GFCursor
Dim CursorNumber As Integer
Dim CursorNameArray() As String
Dim CursorPictureArray() As New StdPicture
'
'***END OF GENERAL FUNCTION VARS***
'***GENERAL FUNCTION STRUCTURES***
'
'GFDCToStdPicture
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
'GFDCToStdPicture
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
'GFDCToStdPicture
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'GFDCToStdPicture
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
'GFShrinkFile
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
'GFSelectDirectory
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'GFCreateDirectory
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
'GFCDGetFileName
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'GFCDGetColor
Private Type CHOOSECOLORSTRUCT
lStructSize As Long
hWndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'ProgramGetMousePos[X, Y]
Private Type POINTAPI
X As Long
Y As Long
End Type
'
'***END OF GENERAL FUNCTION STRUCTURES***
'***SE STRUCTURES***
'NOTE: the SE structures are sorted by their importance,
'the most important (lowest‑level) structure comes first.
'
'DCStruct ‑ replaced memory wasting picture boxes
Public Type DCStruct 'user‑defined
DC As Long
Width As Long 'PictureBox width (not picture width)
Height As Long 'PictureBox height (not picture height)
ObjectOldHandle As Long
End Type
'FontStruct
Public Type FontStruct
Name As String
Size As Single
Bold As Boolean
Italic As Boolean
Underline As Boolean
StrikeThrough As Boolean
End Type
'SEControlColorStruct ‑ saves information for creating Windows‑like commands
Private Type SEControlColorStruct
ControlColor As Long
ControlTextColor As Long
LockedTextColor As Long
ControlMarkingColor As Long
ControlShadowColor As Long
DarkShadowColor As Long
LightShadowColor As Long
End Type
'FormStateToggleStruct ‑ for saving maximized/restored size and position information
Private Type FormStateToggleStruct 'within SEResizeStruct
FormXPos As Long
FormYPos As Long
FormXSize As Long
FormYSize As Long
FormState As Integer 'for what state the values above are valid for
FormStateMessageSentLast As Integer 'last sent message that describes the current form state
End Type
'SEResizeStruct ‑ information for the form sizing
Private Type SEResizeStruct
ResizeEnabledFlag As Boolean
ResizeStep As Long
ResizeMouseIcon As String
Resize_XSizeMin As Long
Resize_YSizeMin As Long
Resize_XSizeMax As Long
Resize_YSizeMax As Long
Resize_TopFixedFlag As Boolean
Resize_LeftFixedFlag As Boolean
Resize_BottomFixedFlag As Boolean
Resize_RightFixedFlag As Boolean
Resize_ParentFormName As String
Resize_ParentFormXSize As Long 'saved by system in SkinDataFile when a control pisition/size was saved
Resize_ParentFormYSize As Long 'saved by system in SkinDataFile when a control pisition/size was saved
FormStateToggleStructVar As FormStateToggleStruct 'for maximizing/restoring
End Type
'SESystemStruct ‑ stores general data
Public Type SESystemStruct
SystemGFAlphaBlendAvailableFlag As Boolean 'False on a Win95 machine
SystemTempPicture As PictureBox
SystemTempPicture2 As PictureBox
SystemForeColor As Long
SystemBackColor As Long
SystemFont As FontStruct
SystemControlFont As FontStruct
SystemControlColorStruct As SEControlColorStruct
SystemMouseIcon As String 'default normal mouse icon
SystemColorArray(1 To 256) As Long
SystemTextArray(1 To 296) As String 'texts above #200 (201...) are system‑exclusive (not to be used by target project), see top notes of this module
SystemFrameColorArrayIndexMin As Integer 'makes checking with slower LBound() unnecessary
SystemFrameColorArrayIndexMax As Integer 'makes checking with slower UBound() unnecessary
SystemFrameColorArray(1 To 16) As Long
SystemFrameBrushHandleArray(1 To 16, 0 To 24) As Long
SystemUseTransparencyFlag As Boolean
SystemSkinBaseDirectory As String
SystemSkinDirectory As String
SystemSkinNameCurrent As String
SystemSkinRandomSelectFlag As Boolean
SystemSkinRandomSelectDisplayNameFlag As Boolean
SystemAskForPictureImportFlag As Boolean 'if these annoying 'copy to skin directory' messages appear
SystemSkinEncryptedFlag As Boolean 'if a password is required for editing current skin
SystemSkinUserEditPassword As String 'password the user needs to manipulate current skin
SystemSkinUserEditPasswordEnteredFlag As Boolean 'if user entered the correct password to edit the current skin
SystemSkinUserEditPasswordHintText As String
SystemPaletteNumberCurrent As Integer
SystemPaletteNumberChangingFlag As Boolean 'True during SE_DisplayPalette()
SystemIgnore_WM_PAINT_Flag As Boolean
SystemIgnore_WM_LBUTTONDOWN_Flag As Boolean 'some flags implemented for compatibility reasons
SystemIgnore_WM_LBUTTONUP_Flag As Boolean
SystemIgnore_WM_RBUTTONDOWN_Flag As Boolean
SystemIgnore_WM_RBUTTONUP_Flag As Boolean
SystemDump_WM_SIZE_Flag As Boolean
SystemIgnore_WM_ENABLED_Flag As Boolean 'means that control will not be redrawn, enabled flag is always changed
SystemNoSkinDataFileWriteFlag As Boolean 'if True then SkinDataFile will not be written (but memory string is still updated)
ColorSchemeEnabledFlag As Boolean
ColorSchemeColor As Long
RegMainKey As Long
RegRootKey As String
ContextHelpCommandObject As Object
ContextHelpFile As String
End Type
Public SESystemStructVar As SESystemStruct
Dim SESystemStructVarUnchanged As SESystemStruct
'SERelationStruct ‑ use to assign a control name to a control object
Private Type SERelationStruct
SEControlName As String
SEControlObject As Object
SEControlType As Integer
End Type
Dim SERelationStructNumber As Integer
Dim SERelationStructArray() As SERelationStruct
'SEControlInfoStruct ‑ contains any possible information about an object
'
'NOTE: not every control type uses all struct members.
'
Public Type SEControlInfoStruct
ControlName As String
ControlNoFileDropFlag As Boolean
ControlGridLinesEnabledFlag As Boolean
ControlCaption As String
ControlEnabledFlag As Boolean
ControlUpPicture As String
ControlDownPicture As String
ControlMoveOverPicture As String
ControlBackPicture As String
ControlBackPictureEnabledFlag As Boolean
ControlTitleBarPicture As String
ControlTitleBarSpawnStartPos As Long
ControlTitleBarSpawnLength As Long
ControlTitleBarHeight As Long
ControlForeColor As Long
ControlBackColor As Long
ControlFont As FontStruct
ControlFrameIndex As Integer
ControlMouseIcon As String
ControlPolyRgnPointNumber As Integer
ControlPolyRgnPointXArray() As Long
ControlPolyRgnPointYArray() As Long
ControlToolTipText As String
ControlPaletteNumber As Integer
ControlPaletteArray() As Integer
ControlXPos As Long
ControlYPos As Long
ControlXSize As Long
ControlYSize As Long
ControlResizeStruct As SEResizeStruct
End Type
'SEControlStruct ‑ stores control data
Public Type SEControlStruct
SEControlName As String 'must be first structure element (CopyMemory() used)
SEControlNameLength As Long 'used to increase string comparison
SEControlType As Integer
SEControlState As Integer
SEControl As Object
SEControl_LoadedFlag As Boolean 'True if SE_LoadControl() was used at last/False if not or if SE_UnloadControl() has been used at last
SEControl_TransparencyFlag As Boolean 'label only
SEControl_NoFileFropFlag As Boolean 'if True then DragAcceptFiles() is not used (form, se command, picture box only)
SEControl_GridLinesEnabledFlag As Boolean 'for GFReportViews only
SEControl_Caption As String 'SECommand only
SEControl_UpPicture As String
SEControl_UpPictureDCStruct As DCStruct
SEControl_DisabledPicture As String 'created by the SE system
SEControl_DisabledPictureDCStruct As DCStruct 'created by the SE system
SEControl_DownPicture As String
SEControl_DownPictureDCStruct As DCStruct
SEControl_MoveOverPicture As String
SEControl_MoveOverPictureDCStruct As DCStruct
SEControl_LastProcessedMessage As Long 'for subclassing
SEControl_BackPicture As String
SEControl_BackPictureDCStruct As DCStruct
SEControl_BackPictureEnabledFlag As Boolean
SEControl_TitleBarPicture As String
SEControl_TitleBarPictureDCStruct As DCStruct
SEControl_TitleBarSpawnStartPos As Long 'where piece to fit gap when enlarging form starts
SEControl_TitleBarSpawnLength As Long 'length of piece used to fill the gap
SEControl_TitleBarHeight As Long 'height of area that can be used to move form
SEControl_DisplayPictureDCStruct As DCStruct 'created out of the back‑ and title bar picture
SEControl_ForeColor As Long
SEControl_BackColor As Long
SEControl_Font As FontStruct
SEControl_FrameIndex As Integer
SEControl_MouseIcon As String
SEControl_MouseIconOld As String 'see Graphics_SetSEControlMouseIcon()
SEControl_MouseIconUsageOld As Integer 'see Graphics_SetSEControlMouseIcon()
SEControl_PolyRgnEnabledFlag As Boolean 'read also annotations in SEM_PolyRgn_Enable()
SEControl_PolyRgnPointNumber As Integer
SEControl_PolyRgnPointXArray() As Long 'format: pixels
SEControl_PolyRgnPointYArray() As Long 'format: pixels
SEControl_PolyRgnHandle As Long
SEControl_ToolTipText As String
SEControl_PaletteNumber As Integer
SEControl_PaletteArray() As Integer
SEControl_DragAcceptFilesEnabledFlag As Boolean
SEControl_XPos As Long
SEControl_YPos As Long
SEControl_XSize As Long
SEControl_YSize As Long
SEControl_EnabledFlag As Boolean 'if control is enabled or disabled
SEControl_ResizeStruct As SEResizeStruct
End Type
Public SEControlStructNumber As Integer
Public SEControlStructArray() As SEControlStruct
Dim UpdateCheckStructNumber As Integer
Dim UpdateCheckStructArray() As SEControlStruct
'SEControlStructIndexCacheStruct ‑ used mainly in GetSEControlStructIndex
Private Type SEControlStructIndexCacheStruct
SEControlName As String
SEControlNameLength As Long 'used to speed up string comparison
SEControlStructIndex As Integer
End Type
Dim SEControlStructIndexCacheStructArray(1 To 16) As SEControlStructIndexCacheStruct 'fixes array size
Dim SEControlStructIndexCacheStructPointer As Integer 'where next update is done when a SourceDescription and its related index was not in the cache
'LoadedControlStruct ‑ information about controls that is important when processing received control messages
Private Type LoadedControlStruct
ControlName As String
ControlNameLength As Long 'used to increase comparing speed
ControlType As Integer
ControlInPaletteFlag As Boolean 'if control is in current, ‑1 or an external palette
End Type
Dim LoadedControlStructNumber As Integer
Dim LoadedControlStructArray() As LoadedControlStruct
'UserMoveControlStruct
Public Type UserMoveControlStruct
UserMoveSystemEnabledFlag As Boolean
End Type
Public UserMoveControlStructVar As UserMoveControlStruct
'UserMoveStruct
Public Type UserMoveStruct
MoveEnabledFlag As Boolean
MoveControlStructIndex As Integer
SizeEnabledFlag As Boolean
SizeControlStructIndex As Integer
SizeAndMoveFlag As Boolean 'for e.g. sizing via upper left corner
ControlXPosOriginal As Long 'position before moving was begun
ControlYPosOriginal As Long
ControlXSizeOriginal As Long 'size before sizing was begun
ControlYSizeOriginal As Long
MouseXPos As Long
MouseYPos As Long
GridEnabledFlag As Boolean
GridXSize As Long
GridYSize As Long
ControlInfoEnabledFlag As Boolean 'if the UMI code is to be used
MousePointerControlName As String 'name of last control whose mouse pointer was changed
MousePointerUnchanged As Integer 'original value of MousePointer property
End Type
Public UserMoveStructVar As UserMoveStruct
'MarkStruct
Public Type MarkStruct
MarkControlStructIndex As Integer
MarkControlType As Integer
MarkControlBackStyleUnchanged As Integer
MarkControlBackColorUnchanged As Long
MarkControlForeColorUnchanged As Long
End Type
Public MarkStructVar As MarkStruct
'SEFormSizeGroupStruct
Private Type SEFormSizeGroupStruct
FormNameNumber As Integer
FormNameArray() As String
FormControlStructIndexArray() As Integer
End Type
Dim SEFormSizeGroupStructNumber As Integer
Dim SEFormSizeGroupStructArray() As SEFormSizeGroupStruct
'SEFormSystemStruct ‑ data for customizing operations done on registered forms
Private Type SEFormSystemStruct
DisableAutoRefreshFlag As Boolean
DisableAutoMoveFlag As Boolean
DisableAutoMoveExFlag As Boolean
UserMove_DisableAutoRefreshFlag As Boolean
UserMove_DisableAutoMoveFlag As Boolean
UserMove_DisableAutoMoveExFlag As Boolean
SEFormSystem_MoveFormCalledFlag As Boolean 'avoid recursive calling
SEFormSystem_ResizeFormCalledFlag As Boolean 'avoid recursive calling
End Type
Public SEFormSystemStructVar As SEFormSystemStruct
'SEExternalPaletteStruct ‑ stores palette numbers of currently loaded external palettes
Private Type SEExternalPaletteStruct
PaletteNumber As Integer
End Type
Dim SEExternalPaletteStructNumber As Integer
Dim SEExternalPaletteStructArray() As SEExternalPaletteStruct
'SECBStruct ‑ contains callback sub information
Private Type SECBStruct
CallBackForm As Object
CallBackFormName As String
End Type
Dim SECBStructNumber As Integer
Dim SECBStructArray() As SECBStruct
'StickControlStruct ‑ information about the state of the Stick system
Private Type StickControlStruct
StickSystemEnabledFlag As Boolean
End Type
Dim StickControlStructVar As StickControlStruct
'SEFormPosGroupStruct
Private Type SEFormPosGroupStruct
FormNameNumber As Integer
FormNameArray() As String
FormControlStructIndexArray() As Integer
End Type
Dim SEFormPosGroupStructNumber As Integer
Dim SEFormPosGroupStructArray() As SEFormPosGroupStruct
'SkinNameListStruct ‑ information about available skins
Private Type SkinNameListStruct
SkinName As String
SkinDirectory As String
End Type
'SkinTransferStruct ‑ contains the whole data the user can enter for exporting a skin
Public Type SkinTransferStruct
SkinName As String
Author As String
Dedicated As String
Date As String
CurrentLocation As String
Motto As String
Comment As String
ImportPassword As String
ImportPasswordHintText As String
EditPassword As String
EditPasswordHintText As String
FileEx As String
FileExSaveExFlag As Boolean
SkinTransferFile As String 'internal use only, do not display or write to registry
RequestOrInfoPaletteFlag As Boolean 'internal use only, do not display or write to registry
End Type
Public SkinTransferStructVar As SkinTransferStruct
'SkinDataFileStruct
Private Type SkinDataFileStruct
SEControlStructIndex As Integer
SEPaletteNumber As Integer
SEControlInfoStructVar As SEControlInfoStruct
End Type
Dim SkinDataFileStructVar As SkinDataFileStruct
'SkinDataFileCacheStruct ‑ used to store SkinDataFileString to save reading processes
Private Type SkinDataFileCacheStruct
SkinDataFile As String 'SkinDataFile the string was originally read from
SkinDataFileString As String
End Type
Dim SkinDataFileCacheStructVar As SkinDataFileCacheStruct
'SEFontListStruct
Private Type SEFontListStruct
FontName As String
FontFrequency As Integer 'how often font appears in SEControlStructArray()
End Type
'SE_DeletePictureBox
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
'SE_OpenPopUpMenu
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'SE_FormMenuStruct ‑ data for processing pop up menu clicks
Private Type SE_FormMenuStruct
SourceFormName As String
SourceFormObject As Object
PopUpMenuClickInProcessingFlag As Boolean 'if SE_ReceivePopUpMenu_Click() has been left or not
ForcePopUpMenuClickProcessingFlag As Boolean 'if flag above is seen as False also it is True
End Type
Public SE_FormMenuStructVar As SE_FormMenuStruct
'SE_ControlMenuStruct ‑ data for processing ControlMenu clicks
Private Type SE_ControlMenuStruct
SEControlName As String
SEControlObject As Object
SEControlType As Boolean 'usable when setting back picture
SEControlStructIndex As Integer
PopUpMenuClickInProcessingFlag As Boolean 'if SE_ReceivePopUpMenu_Click() has been left or not
End Type
Public SE_ControlMenuStructVar As SE_ControlMenuStruct
'SE_DebugMenuStruct ‑ data for processing Debug Menu clicks
Private Type SE_DebugMenuStruct
DecryptionNameDefault As String
DecryptionPasswordDefault As String
EncryptionNameDefault As String
EncryptionPasswordDefault As String
End Type
Dim SE_DebugMenuStructVar As SE_DebugMenuStruct
'SE_KeyHookStructVar ‑ misc. data about key hook
Private Type SE_KeyHookStruct
ShortCutKeyPressInProcessingFlag As Boolean
End Type
Public SE_KeyHookStructVar As SE_KeyHookStruct
'SEM_PolyRgn_Enable
'Private Type POINTAPI
' X As Long
' Y As Long
'End Type
'ContextHelpStruct ‑ data about the context help
Private Type ContextHelpStruct
ContextHelpEnabledFlag As Boolean
ScreenMousePointerUnchanged As Integer
End Type
Public ContextHelpStructVar As ContextHelpStruct
'VerifySystemLinesStruct ‑ used by SkinDataFile_VerifySystemLines()
Private Type VerifySystemLinesStruct
ByteStringLength As Long
ByteString() As Byte
End Type
Dim VerifySystemLinesStructNumber As Integer
Dim VerifySystemLinesStructArray() As VerifySystemLinesStruct
'
'***END OF SE STRUCTURES***
'***OTHER***
'
'Version
Const Version As String = "v1.1"
'SEM_ExportFileArray
Dim SEM_ExportFileNumber As Integer
Dim SEM_ExportFileArray() As String
'AutoRedraw simulation (SECommands), SEM_PolyRgn_BackPicture_Transfer
Public Const WM_PAINT = &HF
Public Const WM_ERASEBKGND = &H14
Public Const WM_NCPAINT = &H85
Public Const WM_SETREDRAW = &HB
'MousePointerUsage constants ‑ used in SE_RefreshMousePointer
Public Const MOUSEPOINTERUSAGE_NORMAL As Integer = 0
Public Const MOUSEPOINTERUSAGE_RESIZE As Integer = 1
'other
Dim ProgramPath As String
Dim WinTempDir As String
'other
Dim NULLARRAYLONG(0 To 0) As Long
Dim NullDCStructVar As DCStruct 'use to reset any DCStruct var
'
'NOTE: how the whole stuff works:
'The target project first calls SE_RegisterControl() to 'tell' the SkinEngine
'which control objects are to be used and how they are named.
'Then the target projects calls SE_Reload() to enable skinning.
'
'NOTE: about sub/function naming:
'All subs/functions that have the prefix 'SE_' are mainly interface subs/functions
'that serve as an interface between the Skin Engine and the target project.
'
'********************************INITIALIZING FUNCTIONS*********************************
'NOTE: the following subs/functions are used to initialize the SkinEngine
'(used to make it fit to the target project).
'All these subs/functions should be called once at target program start up.
'The SkinEngine will not work properly if the initialization functions
'have not been called.
'
'NOTE: about registry access:
'The Skin Engine will save the current skin and options in the registry.
'Pass the reg main‑ and root key of the target project (not of the Skin Engine).
'Two of the used registry keys are (example):
'\SkinEngine\current skin name
'\SkinEngine\random skin select
Public Sub SE_Initialize(ByVal SystemForeColor As Long, ByVal SystemBackColor As Long, ByRef SystemFont As FontStruct, ByVal SystemMouseIcon As String, ByVal SystemUseTransparencyFlag As Boolean, ByVal SystemSkinBaseDirectory As String, ByVal RegMainKey As Long, ByVal RegRootKey As String, Optional ByRef ContextHelpCommandObject As Object = Nothing, Optional ByVal ContextHelpFile As String = "")
'On Error Resume Next 'call first of all
'preset
ProgramPath = App.Path
If Not (Right$(ProgramPath, 1) = "\") Then ProgramPath = ProgramPath + "\" 'verify
WinTempDir = GetTempDir
If Not (Right$(WinTempDir, 1) = "\") Then WinTempDir = WinTempDir + "\" 'verify
If SystemSkinBaseDirectory = "" Then SystemSkinBaseDirectory = App.Path
If Not (Right$(SystemSkinBaseDirectory, 1) = "\") Then SystemSkinBaseDirectory = SystemSkinBaseDirectory + "\" 'verify
'verify
If ISFONTAVAILABLE(SystemFont.Name) = False Then
MsgBox "internal error in SE_Initialize() (GFSkinEngine): font '" + SystemFont.Name + "' not available, default font will be used !", vbOKOnly + vbExclamation
If ISFONTAVAILABLE("Arial") = True Then
SystemFont.Name = "Arial"
Else
SystemFont.Name = Screen.Fonts(0) 'any font must be installed
End If
End If
If (SystemFont.Size < 2) Or (SystemFont.Size > 128) Then
MsgBox "internal error in SE_Initialize() (GFSkinEngine): font size '" + LTrim$(Str$(SystemFont.Size)) + "' invalid, default font size 8 will be used !", vbOKOnly + vbExclamation
SystemFont.Size = 8
End If
If DirSave(SystemSkinBaseDirectory, vbDirectory) = "" Then
MsgBox "internal error in SE_Initialize() (GFSkinEngine): system skin directory '" + SystemSkinBaseDirectory + "' not found, please reinstall this application !", vbOKOnly + vbCritical
'continue, the total error may happen
End If
'begin
SESystemStructVar.SystemGFAlphaBlendAvailableFlag = GFAlphaBlendfrm.GFAlphaBlend_IsAlphaBlendAvailable
Set SESystemStructVar.SystemTempPicture = GFSkinEnginefrm.GFSkinEngineTempPicture
SESystemStructVar.SystemTempPicture.AutoRedraw = True 'important
SESystemStructVar.SystemTempPicture.AutoSize = False
SESystemStructVar.SystemTempPicture.ScaleMode = vbTwips
SESystemStructVar.SystemFrameColorArrayIndexMin = LBound(SESystemStructVar.SystemFrameColorArray())
SESystemStructVar.SystemFrameColorArrayIndexMax = UBound(SESystemStructVar.SystemFrameColorArray())
Set SESystemStructVar.SystemTempPicture2 = GFSkinEnginefrm.GFSkinEngineTempPicture2
SESystemStructVar.SystemTempPicture2.AutoRedraw = True 'important
SESystemStructVar.SystemTempPicture2.AutoSize = False
SESystemStructVar.SystemTempPicture2.ScaleMode = vbTwips
'
'NOTE: the system may use the temp pictures only within one sub/function,
'when a sub/function is left the temp pictures must be available for other use.
'
SESystemStructVarUnchanged.SystemForeColor = SystemForeColor
SESystemStructVarUnchanged.SystemBackColor = SystemBackColor
SESystemStructVarUnchanged.SystemFont = SystemFont
SESystemStructVarUnchanged.SystemControlFont = SystemFont
SESystemStructVarUnchanged.SystemControlColorStruct.ControlColor = SYSTEM_CONTROLCOLOR 'preset
SESystemStructVarUnchanged.SystemControlColorStruct.ControlMarkingColor = SYSTEM_CONTROLMARKINGCOLOR 'preset
SESystemStructVarUnchanged.SystemControlColorStruct.ControlTextColor = SYSTEM_CONTROLTEXTCOLOR 'preset
SESystemStructVarUnchanged.SystemControlColorStruct.LockedTextColor = SYSTEM_LOCKEDTEXTCOLOR 'preset
SESystemStructVarUnchanged.SystemControlColorStruct.DarkShadowColor = SYSTEM_DARKSHADOWCOLOR 'preset
SESystemStructVarUnchanged.SystemControlColorStruct.LightShadowColor = SYSTEM_LIGHTSHADOWCOLOR 'preset
SESystemStructVarUnchanged.SystemMouseIcon = SystemMouseIcon
SESystemStructVarUnchanged.SystemUseTransparencyFlag = SystemUseTransparencyFlag
Call SE_SESystemStruct_Reset(SESystemStructVar, SESystemStructVarUnchanged)
SESystemStructVar.SystemSkinBaseDirectory = SystemSkinBaseDirectory
SESystemStructVar.SystemPaletteNumberCurrent = ‑1 'not to be used by target project
SESystemStructVar.RegMainKey = RegMainKey
SESystemStructVar.RegRootKey = RegRootKey
'load form
Load GFSkinEnginefrm
Load GFSkinEngine_MENUfrm
'other
Call SEM_UserMove_EnableGrid 'enabled by default
UserMoveStructVar.ControlInfoEnabledFlag = True
Call StickSystem_Enable 'allow moving/sizing controls when their parent form is sized
SESYSTEM_FONT.Name = "SESYSTEM_FONT"
Set SESystemStructVar.ContextHelpCommandObject = ContextHelpCommandObject
SESystemStructVar.ContextHelpFile = ContextHelpFile
Call SE_DeleteTempFiles(WinTempDir) 'also done when terminating
Call SE_DeleteTempFiles(ProgramPath) 'also done when terminating
End Sub
'*****************************END OF INITIALIZING FUNCTIONS*****************************
'************************************INTERFACE SUBS*************************************
'NOTE: the target project can call the following subs/functions after initializing the Skin Engine.
'NOTE: all forms whose references were passed to SECB_AddCallBackForm()
'must have a public sub called SE_ReceiveCallBackMessage(), see top of this form
'for further information.
'When a form is hidden or even unloaded then it should call SECB_RemoveCallBackForm()
'so that it doesn't process messages when it isn't visible anymore.
Public Sub SECB_AddCallBackForm(ByRef CallBackForm As Object)
'on error resume next
Dim StructLoop As Integer
'verify
For StructLoop = 1 To SECBStructNumber
If SECBStructArray(StructLoop).CallBackForm Is CallBackForm Then
'
'NOTE: a call back form must not be added twice.
'Create no error messages as other general functions could call this sub permanently.
'
Exit Sub
End If
Next StructLoop
'begin
If Not (SECBStructNumber = 32766) Then 'verify
SECBStructNumber = SECBStructNumber + 1
Else
MsgBox "internal error in SECB_AddCallBackForm() (GFSkinEngine): overflow !", vbOKOnly + vbExclamation
End If
ReDim Preserve SECBStructArray(1 To SECBStructNumber) As SECBStruct
Set SECBStructArray(SECBStructNumber).CallBackForm = CallBackForm
Let SECBStructArray(SECBStructNumber).CallBackFormName = CallBackForm.Name
'report immediately if Skin Engine is not available
If SESystemStructVar.SystemSkinNameCurrent = "ERROR" Then
Call SE_ForwardCallBackMessage(SECBMSG_SKIN_ENGINE_NOT_AVAILABLE, "", "")
End If
End Sub
Public Sub SECB_RemoveCallBackForm(ByRef CallBackForm As Object)
'on error resume next
Dim StructIndex As Integer
Dim StructLoop As Integer
'preset
For StructLoop = 1 To SECBStructNumber
If SECBStructArray(StructLoop).CallBackForm Is CallBackForm Then
StructIndex = StructLoop
Exit For
End If
Next StructLoop
If StructIndex = 0 Then Exit Sub 'verify
For StructLoop = StructIndex To SECBStructNumber
If Not (StructLoop = SECBStructNumber) Then
SECBStructArray(StructLoop) = SECBStructArray(StructLoop + 1)
Else
SECBStructNumber = SECBStructNumber ‑ 1
StructLoop = SECBStructNumber
If StructLoop < 1 Then StructLoop = 1 'verify
ReDim Preserve SECBStructArray(1 To StructLoop) As SECBStruct
Exit For 'important
End If
Next StructLoop
End Sub
'NOTE: the target project can use the SE_[Un]PackString() functions to be able
'to send more than one parameter using SE_SendCustomMessage[Ex]().
Public Function SE_PackString_2(ByVal String1 As String, ByVal String2 As String) As String
'on error resume next 'passed strings must not contain Chr$(0)
SE_PackString_2 = String1 + Chr$(0) + String2
End Function
Public Function SE_PackString_3(ByVal String1 As String, ByVal String2 As String, ByVal String3 As String) As String
'on error resume next 'passed strings must not contain Chr$(0)
SE_PackString_3 = String1 + Chr$(0) + String2 + Chr$(0) + String3
End Function
Public Function SE_PackString_4(ByVal String1 As String, ByVal String2 As String, ByVal String3 As String, ByVal String4 As String) As String
'on error resume next 'passed strings must not contain Chr$(0)
SE_PackString_4 = String1 + Chr$(0) + String2 + Chr$(0) + String3 + Chr$(0) + String4
End Function
Public Function SE_UnpackString(ByVal PackedString As String, ByVal StringIndex As Integer) As String
'on error resume next 'returns requested packed string or nothing ("") for error
Dim StringLoop As Integer
Dim Temp As Long
'preset
If Not (Right$(PackedString, 1) = Chr$(0)) Then PackedString = PackedString + Chr$(0) 'add end sign
'begin
For StringLoop = 1 To StringIndex
Temp = InStr(1, PackedString, Chr$(0), vbBinaryCompare)
If (Temp) Then
If StringLoop = StringIndex Then
SE_UnpackString = Left$(PackedString, Temp ‑ 1)
Exit Function
Else
PackedString = Mid$(PackedString, Temp + 1)
End If
Else
GoTo Error:
End If
Next StringLoop
GoTo Error:
Exit Function
Error:
SE_UnpackString = "" 'error
Exit Function
End Function
Public Sub SE_SendCustomMessage(ByVal CustomMessageName As String, ByVal CustomMessagelParam As String)
'on error resume next
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'
'NOTE: to be called by the target project only, only one parameter can be forwarded.
'Example: Call SE_SendCustomMessage(SE_CUSTOMMESSAGE_SETFOCUS, FocusFormName).
'SE_CUSTOMMESSAGE_SETFOCUS must be defined by the target project.
'
Call SE_ForwardCallBackMessageEx(SECBMSG_CUSTOMMESSAGE, CustomMessageName, CustomMessagelParam, ReturnValueUsedFlag, ReturnValue)
End Sub
Public Sub SE_SendCustomMessageEx(ByVal CustomMessageName As String, ByVal CustomMessagelParam As String, ByRef ReturnValueUsedFlag As Boolean, ByRef ReturnValue As Long)
'on error resume next
'
'NOTE: to be called by the target project only, only one parameter can be forwarded.
'Example: Call SE_SendCustomMessage(SE_CUSTOMMESSAGE_SETFOCUS, FocusFormName, ReturnValueUsedFlag, ReturnValue).
'SE_CUSTOMMESSAGE_SETFOCUS must be defined by the target project.
'
Call SE_ForwardCallBackMessageEx(SECBMSG_CUSTOMMESSAGE, CustomMessageName, CustomMessagelParam, ReturnValueUsedFlag, ReturnValue)
End Sub
Public Sub SE_ForwardCallBackMessage(ByVal CallBackMessage As Integer, ByVal CallBackMessagewParam As String, ByVal CallBackMessagelParam As String)
'on error resume next 'this sub does not support a return value
Dim TempBool As Boolean
Dim Temp As Long
'begin
Call SE_ForwardCallBackMessageEx(CallBackMessage, CallBackMessagewParam, CallBackMessagelParam, TempBool, Temp)
End Sub
Public Sub SE_ForwardCallBackMessageEx(ByVal CallBackMessage As Integer, ByVal CallBackMessagewParam As String, ByVal CallBackMessagelParam As String, ByRef ReturnValueUsedFlag As Boolean, ByRef ReturnValue As Long)
'on error resume next 'informs the target project about changes
Dim SEControlStructIndex As Integer
Dim StructLoop As Integer
'
'NOTE: see constant declarations for possible messages.
'
'reset
ReturnValueUsedFlag = False 'reset (important)
ReturnValue = 0 'reset (important)
'verify
'
'NOTE: do special message preprocessing (verifying) here.
'
Select Case CallBackMessage
Case SECBMSG_FORM_MAXIMIZED
'
'NOTE: the SECBMSG_FORM_[MAXIMIZED/RESTORED] message
'was originally sent by SEFormSystem_[Maximize/Restore](),
'but as the system does not really maximize a form but just the form size
'is manipulated these messages would not be sent when the maximized
'form is 'restored' or 'maximized' by the system instead of the user.
'Therefore SEFormSystem_ResizeForm() sends the mentioned messages,
'but this sub cannot decide if any of the both messages have been sent
'yet, this is done by the code below (oof).
'Generally do such message verifying here in SE_ForwardCallBackMessage().
'
SEControlStructIndex = Val(CallBackMessagelParam)
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormStateMessageSentLast = _
SECBMSG_FORM_MAXIMIZED Then
Exit Sub
Else
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormStateMessageSentLast = _
SECBMSG_FORM_MAXIMIZED
End If
End If
Case SECBMSG_FORM_RESTORED
SEControlStructIndex = Val(CallBackMessagelParam)
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormStateMessageSentLast = _
SECBMSG_FORM_RESTORED Then
Exit Sub
Else
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormStateMessageSentLast = _
SECBMSG_FORM_RESTORED
End If
End If
End Select
'begin
For StructLoop = 1 To SECBStructNumber
'
#If SE_ReceiveCallBackMessageExEnabledFlag = True Then
Call Mfrm.SE_ReceiveCallBackMessageEx(SECBStructArray(StructLoop).CallBackFormName, CallBackMessage, CallBackMessagewParam, CallBackMessagelParam, ReturnValueUsedFlag, ReturnValue)
#Else
Call SECBStructArray(StructLoop).CallBackForm.SE_ReceiveCallBackMessage(CallBackMessage, CallBackMessagewParam, CallBackMessagelParam, ReturnValueUsedFlag, ReturnValue)
#End If
'
Next StructLoop
Exit Sub
End Sub
'NOTE: two steps are necessary to make the Skin Engine 'use' a control:
'‑add the control name to the SkinDataFile (e.g. '[ProgramCloseCommand]')
'‑call SE_RegisterControl() (e.g. SE_RegisterControl("ProgramCloseCommand", _
' PropgramCloseCommand, SECONTROLTYPE_SECOMMAND))
Public Sub SE_RegisterControl(ByVal ControlName As String, ByRef ControlObject As Object, ByVal SEControlType As Integer)
'On Error Resume Next 'to be called by the target project at start up, pass all control names and objects that are to be 'skinned'
'
'NOTE: no control that hasn't been passed to this sub can be skinned.
'
If Not (SERelationStructNumber = 32766) Then 'verify
SERelationStructNumber = SERelationStructNumber + 1
Else
Exit Sub 'error
End If
ReDim Preserve SERelationStructArray(1 To SERelationStructNumber) As SERelationStruct
SERelationStructArray(SERelationStructNumber).SEControlName = ControlName
Set SERelationStructArray(SERelationStructNumber).SEControlObject = ControlObject
SERelationStructArray(SERelationStructNumber).SEControlType = SEControlType
End Sub
'NOTE: call the following sub to avoid that a control name is displayed in SEPE
'(Skin Engine Property Edit).
Public Sub SEPE_HideControl_AddItem(ByVal ControlName As String)
'on error resume next
Call GFSkinEngine_PropertyEditfrm.SEPE_HideControl_Add(ControlName)
End Sub
Public Sub SE_DefineHotKeys()
'On Error Resume Next
'
'NOTE: the target project can call this sub to reserve the default SE hot keys.
'These hot keys all use the key combination Shift + Ctrl + Fx‑key.
'When a hot key combination is pressed by the user, the engine simulates
'a click on a menu item of the SE pop up menu.
'The key hook messages are sent to GFSkinEnginefrm (target must be a form).
'
'Note that the short cuts are displayed in the SE pop up menu, even
'if they do not work.
'
'IMPORTANT: the target project must remove the key hook when unloading!
'
Call GFKeyHook_SetKeyHook("GFSkinEngineTargetForm", GFSkinEnginefrm)
End Sub
Public Function SE_IsSystemBusy() As Boolean
'on error resume next
'
'NOTE: this function returns True if some SE code is executed at the moment.
'This can be the case if e.g. a color choosing box is opened.
'To determine if any code is executed at the moment this function
'checks if any pop up menu click or short cut key press is processed
'at the moment.
'The target project should check the return value of this function right before
'changing the current palette number. If this function does not return
'False, the palette change must be aborted.
'
If (SE_FormMenuStructVar.PopUpMenuClickInProcessingFlag = False) And _
(SE_ControlMenuStructVar.PopUpMenuClickInProcessingFlag = False) And _
(SE_KeyHookStructVar.ShortCutKeyPressInProcessingFlag = False) Then
SE_IsSystemBusy = False
Else
SE_IsSystemBusy = True
End If
End Function
Public Function SE_GetVersion() As String
'On Error Resume Next
SE_GetVersion = Version
End Function
'*********************************END OF INTERFACE SUBS*********************************
'*************************************STICK SYSTEM**************************************
'NOTE: the Stick system allows moving/sizing controls when their parent form
'is sized (usable e.g. for a ListView that can be resized with the form like seen in Explorer).
'The stick system 'operates' at three location:
'‑SEFormSystem_ResizeForm(): all sticky controls are moved/sized when the parent form
' is sized
'‑SE_RefreshControlPos(): not the control position saved in SkinDataFile is set in this sub
' (by calling SetSEControl[X/Y]Pos()), but a new control position is calculated
' and set if the control is a sticky control.
'‑SE_RefreshControlSize(): not the control size saved in SkinDataFile is set in this sub
' (by calling SetSEControl[X/Y]Size()), but a new control size is calculated
' and set if the control is a sticky control.
'
'NOTE: the Stick system should only be disabled when:
'‑a form is resized in UserMove mode (see GFSkinEnginefrm code)
'
'NOTE: it is important that SaveSEControl[X/Y][Pos/Size] is ONLY called
'when the user releases the left mouse button in UserMove mode.
'The system may never save a control's position as the control could have been
'moved by the Stick system.
Public Sub StickSystem_Enable()
'on error resume next 'called the first time by SE_Initialize
StickControlStructVar.StickSystemEnabledFlag = True
End Sub
Public Sub StickSystem_Disable()
'on error resume next
StickControlStructVar.StickSystemEnabledFlag = False
End Sub
'**********************************END OF STICK SYSTEM**********************************
'************************************SE FORM SYSTEM*************************************
'NOTE: by default, when a form is a pool object and it is moved, all instances of the
'pool object are moved, too. That means, if e.g. a form has threee 'pool instances',
'Form1_1, Form1_2 and Form1_3 then if Form1_1 is moved, the final position is also
'saved for Form1_2 and Form1_3.
'By default, when Form1_1 is resized, its final size is saved for Form1_1 ONLY.
'By using the SEFormSystem the target project can set which pool instances
'have a 'shared' position, and which a shared size.
'
'NOTE: SEFormSystem[Move/Size]Form do not save a form's position/size,
'but should be called to move controls that have the resize_[top/left/right/bottom]fixed
'flag set to True.
'SetSEControl[X/Y][Pos/Size] set a control's pos/size for the control object and
'in SEControlStructArray().
'Only SaveSEControl[X/Y][Pos/Size] change SkinDataFile values.
'
'NOTE: if a form is minimized or maximized then the form pos/size must not be
'changed, and the new form pos/size must not be saved in structure array.
'A call back message is sent in any case.
Public Sub SEFormSystem_AddFormPosGroup(ByVal FormNameNumber As Integer, ByRef FormNameArray() As String)
'on error resume next
Dim FormLoop As Integer
'
'NOTE: if the position of a form control is set, this sub checks if the passed form name
'belongs to any registered form pos group. If the form does belong to a group,
'the passed position is set for all the controls within the group, if not,
'the form position is set for ALL forms that are not in a form pos group and are
'instances of the pool object.
'
If Not (SEFormPosGroupStructNumber = 32766) Then 'verify
SEFormPosGroupStructNumber = SEFormPosGroupStructNumber + 1
Else
MsgBox "internal error in SEFormSystem_CreateFormPosGroup(): overflow !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
ReDim Preserve SEFormPosGroupStructArray(1 To SEFormPosGroupStructNumber) As SEFormPosGroupStruct
SEFormPosGroupStructArray(SEFormPosGroupStructNumber).FormNameNumber = FormNameNumber
ReDim SEFormPosGroupStructArray(SEFormPosGroupStructNumber).FormNameArray(1 To FormNameNumber) As String
ReDim SEFormPosGroupStructArray(SEFormPosGroupStructNumber).FormControlStructIndexArray(1 To FormNameNumber) As Integer
For FormLoop = 1 To FormNameNumber
SEFormPosGroupStructArray(SEFormPosGroupStructNumber).FormNameArray(FormLoop) = FormNameArray(FormLoop)
SEFormPosGroupStructArray(SEFormPosGroupStructNumber).FormControlStructIndexArray(FormLoop) = GetSEControlStructIndex(FormNameArray(FormLoop))
Next FormLoop
End Sub
Public Sub SEFormSystem_SaveFormPos(ByVal FormName As String, ByVal FormXPos As Long, ByVal FormYPos As Long)
'on error resume next 'call this sub to save a form's position
Dim FormPosGroupIndex As Integer
Dim SEControlStructIndex As Integer
Dim SkinDataFileString As String
Dim StructLoop As Integer
Dim FormNameLoop As Integer
'preset
SEControlStructIndex = GetSEControlStructIndex(FormName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'verify
If Not (SEControlStructArray(SEControlStructIndex).SEControl.WindowState = vbNormal) Then GoTo Leave:
'begin
If IsPoolObject(SEControlStructArray(SEControlStructIndex).SEControl, SECONTROLTYPE_FORM) = True Then
FormPosGroupIndex = GetSEFormPosGroupIndex(FormName)
If (FormPosGroupIndex = 0) Then
'
'NOTE: the passed form is not in any form pos group, save the position of all forms
'that are instances of the current form pool object and do not appear in any form pos group.
'
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString)
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControl Is SEControlStructArray(SEControlStructIndex).SEControl Then
If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_FORM Then 'skip poly rgns
If GetSEFormPosGroupIndex(SEControlStructArray(StructLoop).SEControlName) = 0 Then 'verify current form is in no form pos group
Call SkinDataFile_ChangePropertySub( _
SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"xpos", LTrim$(Str$(FormXPos)), False, False)
Call SetSEControlXPos(StructLoop, FormXPos)
Call SkinDataFile_ChangePropertySub( _
SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"ypos", LTrim$(Str$(FormYPos)), False, False)
Call SetSEControlYPos(StructLoop, FormYPos)
End If
End If
End If
Next StructLoop
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
Else
'
'NOTE: the passed form is in the form pos group #FormPosGroupIndex,
'save position of all forms in the current form pos group.
'
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString)
For FormNameLoop = 1 To SEFormPosGroupStructArray(FormPosGroupIndex).FormNameNumber
If SEFormPosGroupStructArray(FormPosGroupIndex).FormControlStructIndexArray(FormNameLoop) = 0 Then
'
'NOTE: if the form pos group has been added before the SkinDataFile was read,
'then the control struct index could not be defined, thus do this now (once to increase speed).
'
SEFormPosGroupStructArray(FormPosGroupIndex).FormControlStructIndexArray(FormNameLoop) = _
GetSEControlStructIndex(SEFormPosGroupStructArray(FormPosGroupIndex).FormNameArray(FormNameLoop))
End If
Call SkinDataFile_ChangePropertySub( _
SkinDataFileString, SEFormPosGroupStructArray(FormPosGroupIndex).FormNameArray(FormNameLoop), _
"xpos", LTrim$(Str$(FormXPos)), False, False)
Call SetSEControlXPos(SEFormPosGroupStructArray(FormPosGroupIndex).FormControlStructIndexArray(FormNameLoop), FormXPos)
Call SkinDataFile_ChangePropertySub( _
SkinDataFileString, SEFormPosGroupStructArray(FormPosGroupIndex).FormNameArray(FormNameLoop), _
"ypos", LTrim$(Str$(FormYPos)), False, False)
Call SetSEControlYPos(SEFormPosGroupStructArray(FormPosGroupIndex).FormControlStructIndexArray(FormNameLoop), FormYPos)
Next FormNameLoop
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
End If
Else
Call SaveSEControlPos(SEControlStructIndex, FormXPos, FormYPos, 1, 1)
Call SetSEControlXPos(SEControlStructIndex, FormXPos) 'update se control struct values
Call SetSEControlYPos(SEControlStructIndex, FormYPos) 'update se control struct values
End If
Leave:
Exit Sub
End Sub
Private Function GetSEFormPosGroupIndex(ByVal FormName As String) As Integer
'on error resume next 'returns an index of SEFormPosGroupStructArray() or 0 for form is in no group
Dim StructLoop As Integer
Dim FormNameLoop As Integer
'begin
For StructLoop = 1 To SEFormPosGroupStructNumber
For FormNameLoop = 1 To SEFormPosGroupStructArray(StructLoop).FormNameNumber
If SEFormPosGroupStructArray(StructLoop).FormNameArray(FormNameLoop) = FormName Then
GetSEFormPosGroupIndex = StructLoop
Exit Function 'ok
End If
Next FormNameLoop
Next StructLoop
GetSEFormPosGroupIndex = 0
Exit Function 'error
End Function
Public Sub SEFormSystem_AddFormSizeGroup(ByVal FormNameNumber As Integer, ByRef FormNameArray() As String)
'on error resume next
Dim FormLoop As Integer
'
'NOTE: if the size of a form control is set, this sub checks if the passed form name
'belongs to any registered form size group. If the form does belong to a group,
'the passed size is set for all the controls within the group, if not,
'the form position is set for THE PASSED FORM ONLY.
'
If Not (SEFormSizeGroupStructNumber = 32766) Then 'verify
SEFormSizeGroupStructNumber = SEFormSizeGroupStructNumber + 1
Else
MsgBox "internal error in SEFormSystem_CreateFormSizeGroup(): overflow !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
ReDim Preserve SEFormSizeGroupStructArray(1 To SEFormSizeGroupStructNumber) As SEFormSizeGroupStruct
SEFormSizeGroupStructArray(SEFormSizeGroupStructNumber).FormNameNumber = FormNameNumber
ReDim SEFormSizeGroupStructArray(SEFormSizeGroupStructNumber).FormNameArray(1 To FormNameNumber) As String
ReDim SEFormSizeGroupStructArray(SEFormSizeGroupStructNumber).FormControlStructIndexArray(1 To FormNameNumber) As Integer
For FormLoop = 1 To FormNameNumber
SEFormSizeGroupStructArray(SEFormSizeGroupStructNumber).FormNameArray(FormLoop) = FormNameArray(FormLoop)
SEFormSizeGroupStructArray(SEFormSizeGroupStructNumber).FormControlStructIndexArray(FormLoop) = GetSEControlStructIndex(FormNameArray(FormLoop))
Next FormLoop
End Sub
Public Sub SEFormSystem_SaveFormSize(ByVal FormName As String, ByVal FormXSize As Long, ByVal FormYSize As Long)
'on error resume next 'call this sub to save a form's Size, changed by user (not by a WM_SIZE message)
Dim FormSizeGroupIndex As Integer
Dim SEControlStructIndex As Integer
Dim SkinDataFileString As String
Dim StructLoop As Integer
Dim FormNameLoop As Integer
'
'NOTE:
'‑UpdateControlParentFormSizeFlag = True: form size is saved, but sticky controls
' will stay at their original position.
'‑UpdateControlParentFormSizeFlag = False: form size is saved, sticky controls will be moved
' so that the original distance control <‑> form border is retained.
'
'preset
SEControlStructIndex = GetSEControlStructIndex(FormName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'verify
If Not (SEControlStructArray(SEControlStructIndex).SEControl.WindowState = vbNormal) Then GoTo Leave:
'begin
If IsPoolObject(SEControlStructArray(SEControlStructIndex).SEControl, SECONTROLTYPE_FORM) = True Then
FormSizeGroupIndex = GetSEFormSizeGroupIndex(FormName)
If (FormSizeGroupIndex = 0) Then
'
'NOTE: the passed form is not in any form size group, save the size
'for the passed form only.
'
Call SaveSEControlSize(SEControlStructIndex, FormXSize, FormYSize, 1, 1)
Call SetSEControlXSize(SEControlStructIndex, FormXSize) 'update se control struct values
Call SetSEControlYSize(SEControlStructIndex, FormYSize) 'update se control struct values
Else
'
'NOTE: the passed form group is in the form size group #FormSizeGroupIndex,
'save size of all forms in the current form size group.
'
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString)
For FormNameLoop = 1 To SEFormSizeGroupStructArray(FormSizeGroupIndex).FormNameNumber
If SEFormSizeGroupStructArray(FormSizeGroupIndex).FormControlStructIndexArray(FormNameLoop) = 0 Then
'
'NOTE: if the form size group has been added before the SkinDataFile was read,
'then the control struct index could not be defined, thus do this now (once to increase speed).
'
SEFormSizeGroupStructArray(FormSizeGroupIndex).FormControlStructIndexArray(FormNameLoop) = _
GetSEControlStructIndex(SEFormSizeGroupStructArray(FormSizeGroupIndex).FormNameArray(FormNameLoop))
End If
If Not ((SEFormSizeGroupStructArray(FormSizeGroupIndex).FormControlStructIndexArray(FormNameLoop) < 1) Or (SEFormSizeGroupStructArray(FormSizeGroupIndex).FormControlStructIndexArray(FormNameLoop) > SEControlStructNumber)) Then 'verify
Call SkinDataFile_ChangePropertySub( _
SkinDataFileString, SEFormSizeGroupStructArray(FormSizeGroupIndex).FormNameArray(FormNameLoop), _
"xsize", LTrim$(Str$(FormXSize)), False, False)
Call SetSEControlXSize(SEFormSizeGroupStructArray(FormSizeGroupIndex).FormControlStructIndexArray(FormNameLoop), FormXSize)
Call SkinDataFile_ChangePropertySub( _
SkinDataFileString, SEFormSizeGroupStructArray(FormSizeGroupIndex).FormNameArray(FormNameLoop), _
"ysize", LTrim$(Str$(FormYSize)), False, False)
Call SetSEControlYSize(SEFormSizeGroupStructArray(FormSizeGroupIndex).FormControlStructIndexArray(FormNameLoop), FormYSize)
End If
Next FormNameLoop
'update parent form size of all loaded controls
' For StructLoop = 1 To SEControlStructNumber 'too slow, to be done by calling procedure only if necessary
' 'NOTE: SDFString will be read and written multiple times.
' If (LoadedControl_IsLoaded(SEControlStructArray(StructLoop).SEControlName)) Then
' Call SaveSEControlPos(StructLoop, GetSEControlXPos(StructLoop), GetSEControlYPos(StructLoop), 1, 1, False, False) 'will update parent form size if there is one
' End If
' Next StructLoop
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
End If
Else
Call SaveSEControlSize(SEControlStructIndex, FormXSize, FormYSize, 1, 1)
Call SetSEControlXSize(SEControlStructIndex, FormXSize) 'update se control struct values
Call SetSEControlYSize(SEControlStructIndex, FormYSize) 'update se control struct values
'update parent form size of all loaded controls
' For StructLoop = 1 To SEControlStructNumber 'too slow, to be done by calling procedure only if necessary
' 'NOTE: SDFString will be read and written multiple times.
' If (LoadedControl_IsLoaded(SEControlStructArray(StructLoop).SEControlName)) Then
' Call SaveSEControlPos(StructLoop, GetSEControlXPos(StructLoop), GetSEControlYPos(StructLoop), 0, 0, False, False) 'will update parent form size if there is one
' End If
' Next StructLoop
End If
Leave:
Exit Sub
End Sub
Private Function GetSEFormSizeGroupIndex(ByVal FormName As String) As Integer
'on error resume next 'returns an index of SEFormSizeGroupStructArray() or 0 for form is in no group
Dim StructLoop As Integer
Dim FormNameLoop As Integer
'begin
For StructLoop = 1 To SEFormSizeGroupStructNumber
For FormNameLoop = 1 To SEFormSizeGroupStructArray(StructLoop).FormNameNumber
If SEFormSizeGroupStructArray(StructLoop).FormNameArray(FormNameLoop) = FormName Then
GetSEFormSizeGroupIndex = StructLoop
Exit Function 'ok
End If
Next FormNameLoop
Next StructLoop
GetSEFormSizeGroupIndex = 0
Exit Function 'error
End Function
Public Sub SEFormSystem_MoveForm(ByVal SEControlStructIndex As Integer, ByVal FormLeftNew As Long, ByVal FormTopNew As Long)
'on error resume next 'format: pixels; always call this sub to move a form
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'verify
If ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then GoTo Leave:
If SEFormSystemStructVar.SEFormSystem_MoveFormCalledFlag = True Then
Exit Sub
Else
SEFormSystemStructVar.SEFormSystem_MoveFormCalledFlag = True
End If
If FormLeftNew = SE_POS_NOT_DEFINED Then GoTo Leave: 'verify (important)
If FormTopNew = SE_POS_NOT_DEFINED Then GoTo Leave: 'verify (important)
If Not (SEControlStructArray(SEControlStructIndex).SEControl.WindowState = vbNormal) Then GoTo Leave: 'verify
'begin
Call SE_ForwardCallBackMessageEx(SECBMSG_FORM_BEFORE_MOVING, _
SEControlStructArray(SEControlStructIndex).SEControlName, "", _
ReturnValueUsedFlag, ReturnValue)
'
'NOTE: by responding to the call back message with SECBMSG_REPLY_CANCEL
'the target project can avoid moving the form is e.g. GFWindowStick is in use.
'
If (ReturnValueUsedFlag = False) Or ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Then 'only move when target project allows
'
SEControlStructArray(SEControlStructIndex).SEControl_XPos = FormLeftNew
SEControlStructArray(SEControlStructIndex).SEControl_YPos = FormTopNew
'
If SEFormSystem_GetFormState(SEControlStructArray(SEControlStructIndex).SEControlName) = vbMaximized Then
'
'NOTE: we must 'force' moving the form into the upper left corner of the desktop
'and cannot used the saved maximized position as a skin could have been passed
'to an other machine (by skin exporting/importing) and there we have an other
'screen resolution or/and task bar position.
'
Call SEFormSystem_FitMaximizedFormPos(SEControlStructArray(SEControlStructIndex).SEControl_XPos, SEControlStructArray(SEControlStructIndex).SEControl_YPos)
Call SEFormSystem_FitMaximizedFormSize(SEControlStructArray(SEControlStructIndex).SEControl_XSize, SEControlStructArray(SEControlStructIndex).SEControl_YSize)
Call SEFormSystem_VerifyFormPos(SEControlStructArray(SEControlStructIndex).SEControl_XPos, SEControlStructArray(SEControlStructIndex).SEControl_YPos, SEControlStructArray(SEControlStructIndex).SEControl_XSize, SEControlStructArray(SEControlStructIndex).SEControl_YSize)
Call SEFormSystem_VerifyFormSize(SEControlStructArray(SEControlStructIndex).SEControl_XPos, SEControlStructArray(SEControlStructIndex).SEControl_YPos, SEControlStructArray(SEControlStructIndex).SEControl_XSize, SEControlStructArray(SEControlStructIndex).SEControl_YSize)
End If
'
Call SEControlStructArray(SEControlStructIndex).SEControl.Move( _
SEControlStructArray(SEControlStructIndex).SEControl_XPos * Screen.TwipsPerPixelX, _
SEControlStructArray(SEControlStructIndex).SEControl_YPos * Screen.TwipsPerPixelY) 'use Move() to increase speed
'
Call SE_ForwardCallBackMessage(SECBMSG_FORM_MOVED, _
SEControlStructArray(SEControlStructIndex).SEControlName, "")
'
End If
Leave:
SEFormSystemStructVar.SEFormSystem_MoveFormCalledFlag = False 'reset
Exit Sub
End Sub
'NOTE: about control positions/sizes related to a resizable form's size:
'The SEControlStruct contains another structure ‑ ResizeStruct ‑ that is used to
'store data required for form sizing/control moving when a form is sized.
'All vars of the ResizeStruct are used to configure form sizing, except:
'‑resize_topfixed
'‑resize_bottomfixed
'‑resize_leftfixed
'‑resize_rightfixed
'‑resize_parentform
'‑resize_parentformxsize
'‑resize_parentformysize
'
'The SkinDataFile commands above are to be used as properties of controls
'that are to be moved or sized when the parent form is sized.
'The first 5 property values are to be set by the user, they are used to determine
'in 'what way' the controls are to be changed when the parent form is resized.
'The last 2 property values are set by the Skin Engine, they are used to avoid
'that controls are moved starting at the wrong start pos.
'A control must be moved from its original location by (formsizecurrent ‑ formsizenormal)
'(formsizecurrent is the new form width/height when resizing a form,
'and formsizenormal is the resize_parentform[x/y]size).
'
'How the whole stuff looks in the code:
'When SaveSEControl[Pos/Size] is called, this sub checks if the resize_parentform
'values of the control whose size/position is to be saved is not nothing.
'If this is the case, SaveSEControl[Pos/Size] updates the resize_parentform[x/y]size
'values using the current parent form's width/height.
'Note that the system will only call SaveSEControl[Pos/Size] when the UserMove system
'is enabled and the user moves the control (a control cannot save its position 'itself').
'When SEFormSystem_ResizeForm() is called, the system calculates the new control's
'position using the original position/size of the control and its parent form,
'and the current parent form's size.
'
'NOTE: is resize_parentform[x/y]size is smaller than 1 (preset to ‑1 by default),
'the related control must not be moved as then data is missing
'(will be set when moving the control via the UserMove system).
Public Sub SEFormSystem_ResizeForm(ByVal SEControlStructIndex As Integer, ByVal ParentFormWidthCurrent As Long, ByVal ParentFormHeightCurrent As Long)
'on error resume next 'always call this sub to resize a form; format: pixels
Dim FormWidthOld As Long
Dim FormHeightOld As Long
Dim ParentFormWidthOriginal As Long
Dim ParentFormHeightOriginal As Long
Dim ControlLeft As Single
Dim ControlTop As Single
Dim ControlWidth As Single
Dim ControlHeight As Single
Dim ControlParentFormIndex As Integer
Dim ResizeFormIndex As Integer
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim StructLoop As Integer
'verify
If ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then Exit Sub
If SEFormSystemStructVar.SEFormSystem_ResizeFormCalledFlag = True Then
'
'NOTE: checking for recursive calls of this sub is important as when a form is
'resized a WM_SIZE message will receive in GFSkinEnginefrm, whose
'processing will instantly lead to another call of this sub.
'
Exit Sub
Else
SEFormSystemStructVar.SEFormSystem_ResizeFormCalledFlag = True
End If
If ParentFormWidthCurrent = SE_SIZE_NOT_DEFINED Then GoTo Leave: 'verify (important)
If ParentFormHeightCurrent = SE_SIZE_NOT_DEFINED Then GoTo Leave: 'verify (important)
If Not (SEControlStructArray(SEControlStructIndex).SEControl.WindowState = vbNormal) Then GoTo Leave: 'verify (important)
'preset
FormWidthOld = SEControlStructArray(SEControlStructIndex).SEControl.Width / Screen.TwipsPerPixelX
FormHeightOld = SEControlStructArray(SEControlStructIndex).SEControl.Height / Screen.TwipsPerPixelY
'begin
Call SE_ForwardCallBackMessageEx(SECBMSG_FORM_BEFORE_SIZING, _
SEControlStructArray(SEControlStructIndex).SEControlName, "", _
ReturnValueUsedFlag, ReturnValue)
'
'NOTE: the target project can avoid that any form is sized and that sticky controls
'are moved by returning SECBMSG_REPLY_CANCEL.
'
If (ReturnValueUsedFlag = False) Or ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Then 'only resize when target project allows
'
SEControlStructArray(SEControlStructIndex).SEControl_XSize = ParentFormWidthCurrent
SEControlStructArray(SEControlStructIndex).SEControl_YSize = ParentFormHeightCurrent
'
If SEFormSystem_GetFormState(SEControlStructArray(SEControlStructIndex).SEControlName, SEControlStructIndex) = vbMaximized Then
'
'NOTE: we must 'force' moving the form into the upper left corner of the desktop
'and cannot used the saved maximized position as a skin could have been passed
'to an other machine (by skin exporting/importing) and there we have an other
'screen resolution or/and task bar position.
'
Call SEFormSystem_FitMaximizedFormPos(SEControlStructArray(SEControlStructIndex).SEControl_XPos, SEControlStructArray(SEControlStructIndex).SEControl_YPos)
Call SEFormSystem_FitMaximizedFormSize(SEControlStructArray(SEControlStructIndex).SEControl_XSize, SEControlStructArray(SEControlStructIndex).SEControl_YSize)
Call SEFormSystem_VerifyFormPos(SEControlStructArray(SEControlStructIndex).SEControl_XPos, SEControlStructArray(SEControlStructIndex).SEControl_YPos, SEControlStructArray(SEControlStructIndex).SEControl_XSize, SEControlStructArray(SEControlStructIndex).SEControl_YSize)
Call SEFormSystem_VerifyFormSize(SEControlStructArray(SEControlStructIndex).SEControl_XPos, SEControlStructArray(SEControlStructIndex).SEControl_YPos, SEControlStructArray(SEControlStructIndex).SEControl_XSize, SEControlStructArray(SEControlStructIndex).SEControl_YSize)
End If
'
Call SEControlStructArray(SEControlStructIndex).SEControl.Move( _
SEControlStructArray(SEControlStructIndex).SEControl.Left, _
SEControlStructArray(SEControlStructIndex).SEControl.Top, _
SEControlStructArray(SEControlStructIndex).SEControl_XSize * Screen.TwipsPerPixelX, _
SEControlStructArray(SEControlStructIndex).SEControl_YSize * Screen.TwipsPerPixelY) 'use Move() to increase speed
'
Select Case SEFormSystem_GetFormState(SEControlStructArray(SEControlStructIndex).SEControlName, SEControlStructIndex)
Case vbNormal
Call SE_ForwardCallBackMessage(SECBMSG_FORM_RESTORED, SEControlStructArray(SEControlStructIndex).SEControlName, "")
Case vbMaximized
Call SE_ForwardCallBackMessage(SECBMSG_FORM_MAXIMIZED, SEControlStructArray(SEControlStructIndex).SEControlName, "")
End Select
'
If StickControlStructVar.StickSystemEnabledFlag = False Then GoTo NoStickyControlMove:
If SEControlStructArray(SEControlStructIndex).SEControl.Visible = False Then GoTo NoStickyControlMove:
'
'NOTE: use the real window size, not the desired one when moving controls
'(Windows limits window sizes, as well as the Skin Engine).
'
ParentFormWidthCurrent = GetSEControlXSize(SEControlStructIndex) * Screen.TwipsPerPixelX
ParentFormHeightCurrent = GetSEControlYSize(SEControlStructIndex) * Screen.TwipsPerPixelY
'
'NOTE: if the form is not visible, then no controls are moved automatically.
'This is necessary as the form is resized the first time at the target project
'start up by VB. This size is not valid.
'NOTE: by responding to the call back message with SECBMSG_REPLY_CANCEL
'the target project can avoid sizing the form is e.g. GFWindowStick is in use.
'
For StructLoop = 1 To SEControlStructNumber
'
'NOTE: do not move controls that are currently loaded.
'LoadedControl_IsLoaded() cannot be used as data is updated too late when changing palette.
'
If ((IsControlPaletteEqual(‑1, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray())) Or _
(IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray())) Or _
(IsControlInExternalPalette(StructLoop))) Then
'
With SEControlStructArray(StructLoop).SEControl
If (Len(SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_ParentFormName)) Then 'verify to increase speed
ControlParentFormIndex = GetSEControlStructIndex(SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_ParentFormName) 'a special pool instance of parent form
ResizeFormIndex = SEControlStructIndex 'current pool instance of parent form
'NOTE: StructLoop is the index of the control to move/size.
ParentFormWidthOriginal = SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_ParentFormXSize * Screen.TwipsPerPixelX 'the parent form size must have been saved once so that the saved control's position/size is valid
ParentFormHeightOriginal = SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_ParentFormYSize * Screen.TwipsPerPixelY 'the parent form size must have been saved once so that the saved control's position/size is valid
If Not ((ParentFormWidthOriginal < 1) Or (ParentFormHeightOriginal < 1)) Then 'verify (important)
If SEControlStructArray(ControlParentFormIndex).SEControl Is SEControlStructArray(ResizeFormIndex).SEControl Then
'
'NOTE: the parent form name can be the name of a pool object (form).
'If the passed form is any 'pool instance' of this form, then the control will be moved.
'
'NOTE: it is not save that the current control has the pos/size it
'should have, but if the control's pos/size is not saved in
'SEControlStructArray() then use the current control pos/size.
'
If SEControlStructArray(StructLoop).SEControl_XPos = (‑1) Then
ControlLeft = SEControlStructArray(StructLoop).SEControl.Left
Else
ControlLeft = SEControlStructArray(StructLoop).SEControl_XPos * Screen.TwipsPerPixelX 'preset
End If
If SEControlStructArray(StructLoop).SEControl_YPos = (‑1) Then
ControlTop = SEControlStructArray(StructLoop).SEControl.Top
Else
ControlTop = SEControlStructArray(StructLoop).SEControl_YPos * Screen.TwipsPerPixelY 'preset
End If
If SEControlStructArray(StructLoop).SEControl_XSize = (‑1) Then
ControlWidth = SEControlStructArray(StructLoop).SEControl.Width
Else
ControlWidth = SEControlStructArray(StructLoop).SEControl_XSize * Screen.TwipsPerPixelX 'preset
End If
If SEControlStructArray(StructLoop).SEControl_YSize = (‑1) Then
ControlHeight = SEControlStructArray(StructLoop).SEControl.Height
Else
ControlHeight = SEControlStructArray(StructLoop).SEControl_YSize * Screen.TwipsPerPixelY 'preset
End If
'
If SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_RightFixedFlag = True Then
If SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_LeftFixedFlag = True Then
ControlWidth = ((SEControlStructArray(StructLoop).SEControl_XSize * Screen.TwipsPerPixelX) + (ParentFormWidthCurrent ‑ ParentFormWidthOriginal))
Else
ControlLeft = ((SEControlStructArray(StructLoop).SEControl_XPos * Screen.TwipsPerPixelX) + (ParentFormWidthCurrent ‑ ParentFormWidthOriginal))
End If
End If
If SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_BottomFixedFlag = True Then
If SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_TopFixedFlag = True Then
ControlHeight = ((SEControlStructArray(StructLoop).SEControl_YSize * Screen.TwipsPerPixelY) + (ParentFormHeightCurrent ‑ ParentFormHeightOriginal))
Else
ControlTop = ((SEControlStructArray(StructLoop).SEControl_YPos * Screen.TwipsPerPixelY) + (ParentFormHeightCurrent ‑ ParentFormHeightOriginal))
End If
End If
'verify new control size (important)
If ControlWidth < (GetXGrid * Screen.TwipsPerPixelX) Then ControlWidth = (GetXGrid * Screen.TwipsPerPixelX) 'verify
If ControlWidth > Screen.Width Then ControlWidth = Screen.Width
If ControlHeight < (GetYGrid * Screen.TwipsPerPixelY) Then ControlHeight = (GetYGrid * Screen.TwipsPerPixelY)
If ControlHeight > Screen.Height Then ControlHeight = Screen.Height
'apply new control size
Call SEControlStructArray(StructLoop).SEControl.Move( _
ControlLeft, ControlTop, ControlWidth, ControlHeight) 'use Move() to increase speed
End If
End If
End If
End With
End If
Next StructLoop
NoStickyControlMove:
Call SE_ForwardCallBackMessage(SECBMSG_FORM_SIZED, _
SEControlStructArray(SEControlStructIndex).SEControlName, "")
End If
Leave:
SEFormSystemStructVar.SEFormSystem_ResizeFormCalledFlag = False 'reset
Exit Sub
End Sub
'NOTE: about form maximizing/restoring:
'Generally the target project maximizes/restores a form by calling
'SEFormSystem_Maximize()/SEFormSystem_Restore() as soon
'as a SECBMSG_FORMTITLEBAR_LBUTTONDBLCLK message arrives (wParam: form name)
'The target project should check the return value of SEFormSystem_GetFormState()
'to determine if a form is to be maximized or restored.
'
'NOTE: the FormSystem will automatically restore a maximized window when the
'user starts resizing it. A maximized form cannot be moved by the user
'(neither by the auto move, nor by the auto move ex).
Public Sub SEFormSystem_Maximize(ByVal FormName As String)
'on error resume next
Dim StructLoop As Integer
Dim FormStructIndex As Integer
Dim FormMaximizedFlag As Boolean 'if form control has been maximized
Dim FormPosGroupIndex As Integer
Dim FormSizeGroupIndex As Integer
Dim FormXPos As Long
Dim FormYPos As Long
Dim FormXSize As Long
Dim FormYSize As Long
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'preset
FormStructIndex = GetSEControlStructIndex(FormName)
If FormStructIndex = 0 Then Exit Sub 'verify
FormPosGroupIndex = GetSEFormPosGroupIndex(FormName)
FormSizeGroupIndex = GetSEFormSizeGroupIndex(FormName)
'begin
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_FORM Then
If SEControlStructArray(StructLoop).SEControl Is SEControlStructArray(FormStructIndex).SEControl Then 'StructLoop and FormStructIndex can be equal
If (GetSEFormPosGroupIndex(SEControlStructArray(StructLoop).SEControlName) = FormPosGroupIndex) And _
(GetSEFormSizeGroupIndex(SEControlStructArray(StructLoop).SEControlName) = FormSizeGroupIndex) Then
'
'NOTE: the form to maximize and the currently checked form must be in the
'same pos AND size group (could be group 0 for no group).
'
'NOTE: the form always (!) has .WindowState = vbNormal, the Skin Engine
'uses its own WindowState (FormState) system.
'
If Not (SEControlStructArray(StructLoop).SEControl.WindowState = vbNormal) Then _
SEControlStructArray(StructLoop).SEControl.WindowState = vbNormal 'verify
'
FormXPos = GetSEControlXPos(StructLoop)
FormYPos = GetSEControlXPos(StructLoop)
FormXSize = GetSEControlXSize(StructLoop)
FormYSize = GetSEControlYSize(StructLoop)
'
'NOTE: the FormState must be saved for all pool instances of the
'current form to maximize.
'
Call FormStateToggle_ExchangeStateInfo( _
vbNormal, vbMaximized, _
FormXPos, FormYPos, FormXSize, FormYSize, StructLoop) 'call for every (!) pool instance
'
If FormMaximizedFlag = False Then 'do once only (pool object)
FormMaximizedFlag = True
'
'NOTE: we must 'force' moving the form into the upper left corner of the desktop
'and cannot used the saved maximized position as a skin could have been passed
'to an other machine (by skin exporting/importing) and there we have an other
'screen resolution or/and task bar position.
'
Call SEFormSystem_FitMaximizedFormPos(FormXPos, FormYPos)
Call SEFormSystem_FitMaximizedFormSize(FormXSize, FormYSize)
Call SEFormSystem_VerifyFormPos(FormXPos, FormYPos, FormXSize, FormYSize)
Call SEFormSystem_VerifyFormSize(FormXPos, FormYPos, FormXSize, FormYSize)
Call SEFormSystem_MoveForm(StructLoop, FormXPos, FormYPos)
Call SEFormSystem_ResizeForm(StructLoop, FormXSize, FormYSize)
End If
If IsControlPaletteEqualEx( _
SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray(), _
SEControlStructArray(FormStructIndex).SEControl_PaletteNumber, SEControlStructArray(FormStructIndex).SEControl_PaletteArray()) = True Then
'NOTE: recreate back picture of current palette only.
Call SE_ForwardCallBackMessageEx(SECBMSG_FORM_BACKPICTURERECREATE, SEControlStructArray(StructLoop).SEControlName, LTrim$(Str$(StructLoop)), ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = False) Or ((ReturnValueUsedFlag = True) And Not (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SE_UnloadControl(SEControlStructArray(StructLoop).SEControlName, StructLoop) 'recreate back picture
Call SE_LoadControl(SEControlStructArray(StructLoop).SEControlName, True, StructLoop)
Call SE_RefreshControl(SEControlStructArray(StructLoop).SEControlName, 0, StructLoop)
End If
End If
Call SEFormSystem_SaveFormPos(SEControlStructArray(StructLoop).SEControlName, GetSEControlXPos(StructLoop), GetSEControlYPos(StructLoop))
Call SEFormSystem_SaveFormSize(SEControlStructArray(StructLoop).SEControlName, GetSEControlXSize(StructLoop), GetSEControlYSize(StructLoop))
End If
End If
End If
Next StructLoop
If FormMaximizedFlag = True Then Call SE_ForwardCallBackMessage(SECBMSG_FORM_MAXIMIZED, FormName, "")
End Sub
Public Function SEFormSystem_GetFormState(ByVal FormName As String, Optional ByVal SEControlStructIndex As Integer = 0) As Integer
'on error resume next 'returns form state (VB constants) (returns vbNormal if unknown)
Dim WindowState As Integer
'
'NOTE: SEControlStructIndex can be passed to increase speed.
'
'begin
If SEControlStructIndex = 0 Then SEControlStructIndex = GetSEControlStructIndex(FormName)
If SEControlStructIndex = 0 Then
SEFormSystem_GetFormState = True 'error
Exit Function
End If
WindowState = SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormState
'
'NOTE: the form state that is saved in FormStateToggleStructVar is the
'state that is NOT currently used, but the form state for which the
'other FormStateToggleStructVar values are valid.
'The saved form state can either be vbNormal or vbMaximized, nothing else.
'If the saved form state is ‑1 then no form state information was saved in
'the SkinDataFile.
'
Select Case WindowState
Case SE_FORMTOGGLESTATE_NOT_DEFINED
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormState = vbMaximized
SEFormSystem_GetFormState = vbNormal 'form state was not saved yet
Case vbNormal
SEFormSystem_GetFormState = vbMaximized
Case vbMaximized
SEFormSystem_GetFormState = vbNormal
Case Else
'
'NOTE: if a stupid user opened the SkinDataFile and typed in garbage
'as form state then nothing special will happen (tested).
'
SEFormSystem_GetFormState = True 'error
End Select
Exit Function
End Function
Public Function SEFormSystem_VerifyFormPos(ByRef FormXPos As Long, ByRef FormYPos As Long, ByRef FormXSize As Long, ByRef FormYSize As Long) As Boolean 'also used by GFSkinEnginefrm
'on error resume next 'function returns True if form position has been changed (calling sub may save new form pos), False if not
Dim VisibleScreenAreaLeft As Long
Dim VisibleScreenAreaRight As Long
Dim VisibleScreenAreaTop As Long
Dim VisibleScreenAreaBottom As Long
Dim VisibleScreenAreaWidth As Long
Dim VisibleScreenAreaHeight As Long
'
'NOTE: this sub is used on maximized forms ONLY as for normal‑stated forms
'there were problems with sticky windows (GFWindowStick),
'they are often located outside the screen boundaries.
'
'preset
SEFormSystem_VerifyFormPos = False
'begin
If Not (FormXPos = SE_POS_NOT_DEFINED) Then
If Not (FormYPos = SE_POS_NOT_DEFINED) Then
'use GFTaskBarInfo code
Call GFTaskBarInfo_GetWindowPosSize(VisibleScreenAreaLeft, VisibleScreenAreaTop, VisibleScreenAreaWidth, VisibleScreenAreaHeight)
'convert Twips to pixels
VisibleScreenAreaLeft = VisibleScreenAreaLeft / Screen.TwipsPerPixelX
VisibleScreenAreaTop = VisibleScreenAreaTop / Screen.TwipsPerPixelY
VisibleScreenAreaWidth = VisibleScreenAreaWidth / Screen.TwipsPerPixelX
VisibleScreenAreaHeight = VisibleScreenAreaHeight / Screen.TwipsPerPixelY
'calculate bottom and right
VisibleScreenAreaRight = VisibleScreenAreaLeft + VisibleScreenAreaWidth 'xpos + xsize
VisibleScreenAreaBottom = VisibleScreenAreaTop + VisibleScreenAreaHeight 'ypos + ysize
'verify form pos (10 pixels of form must be visible)
If (FormXPos + FormXSize) < (VisibleScreenAreaLeft + 10) Then
SEFormSystem_VerifyFormPos = True 'form pos changed
FormXPos = ‑FormXSize + 10 + VisibleScreenAreaLeft
End If
If (FormYPos + FormYSize) < (VisibleScreenAreaTop + 10) Then
SEFormSystem_VerifyFormPos = True 'form pos changed
FormYPos = ‑FormYSize + 10 + VisibleScreenAreaTop
End If
If FormXPos > (VisibleScreenAreaRight ‑ 10) Then
SEFormSystem_VerifyFormPos = True 'form pos changed
FormXPos = VisibleScreenAreaRight ‑ 10
End If
If FormYPos > (VisibleScreenAreaBottom ‑ 10) Then
SEFormSystem_VerifyFormPos = True 'form pos changed
FormYPos = VisibleScreenAreaBottom ‑ 10
End If
End If
End If
Exit Function
End Function
Public Function SEFormSystem_VerifyFormSize(ByRef FormXPos As Long, ByRef FormYPos As Long, ByRef FormXSize As Long, ByRef FormYSize As Long) As Boolean 'also used by GFSkinEnginefrm
'on error resume next 'function returns True if form position has been changed (calling sub may save new form size), False if not
Dim VisibleScreenAreaLeft As Long
Dim VisibleScreenAreaRight As Long
Dim VisibleScreenAreaTop As Long
Dim VisibleScreenAreaBottom As Long
Dim VisibleScreenAreaWidth As Long
Dim VisibleScreenAreaHeight As Long
'
'NOTE: see SEFormSystem_VerifyFormPos().
'
'preset
SEFormSystem_VerifyFormSize = False
'begin
If Not (FormXSize = SE_SIZE_NOT_DEFINED) Then
If Not (FormYSize = SE_SIZE_NOT_DEFINED) Then
'use GFTaskBarInfo code
Call GFTaskBarInfo_GetWindowPosSize(VisibleScreenAreaLeft, VisibleScreenAreaTop, VisibleScreenAreaWidth, VisibleScreenAreaHeight)
'convert Twips to pixels
VisibleScreenAreaLeft = VisibleScreenAreaLeft / Screen.TwipsPerPixelX
VisibleScreenAreaTop = VisibleScreenAreaTop / Screen.TwipsPerPixelY
VisibleScreenAreaWidth = VisibleScreenAreaWidth / Screen.TwipsPerPixelX
VisibleScreenAreaHeight = VisibleScreenAreaHeight / Screen.TwipsPerPixelY
'calculate bottom and right
VisibleScreenAreaRight = VisibleScreenAreaLeft + VisibleScreenAreaWidth 'xpos + xsize
VisibleScreenAreaBottom = VisibleScreenAreaTop + VisibleScreenAreaHeight 'ypos + ysize
'verify form pos (10 pixels of form must be visible)
If (FormXPos + FormXSize ‑ 1) > (VisibleScreenAreaRight) Then
SEFormSystem_VerifyFormSize = True 'form size changed
FormXSize = VisibleScreenAreaRight ‑ FormXPos + 1
End If
If (FormYPos + FormYSize ‑ 1) > (VisibleScreenAreaBottom) Then
SEFormSystem_VerifyFormSize = True 'form size changed
FormYSize = VisibleScreenAreaBottom ‑ FormYPos + 1
End If
End If
End If
Exit Function
End Function
Public Function SEFormSystem_FitMaximizedFormPos(ByRef FormXPos As Long, ByRef FormYPos As Long)
'on error resume next
Dim VisibleScreenAreaLeft As Long
Dim VisibleScreenAreaRight As Long
Dim VisibleScreenAreaTop As Long
Dim VisibleScreenAreaBottom As Long
Dim VisibleScreenAreaWidth As Long
Dim VisibleScreenAreaHeight As Long
'
'NOTE: this sub verifies a form's position is the upper left corner of the
'(visible) desktop. If the function changed one of the two passed value then
'the return value is True, if no changes were done it is False.
'
'preset
SEFormSystem_FitMaximizedFormPos = False
'begin
If Not (FormXPos = SE_POS_NOT_DEFINED) Then
If Not (FormYPos = SE_POS_NOT_DEFINED) Then
'use GFTaskBarInfo code
Call GFTaskBarInfo_GetWindowPosSize(VisibleScreenAreaLeft, VisibleScreenAreaTop, VisibleScreenAreaWidth, VisibleScreenAreaHeight)
'convert Twips to pixels
VisibleScreenAreaLeft = VisibleScreenAreaLeft / Screen.TwipsPerPixelX
VisibleScreenAreaTop = VisibleScreenAreaTop / Screen.TwipsPerPixelY
VisibleScreenAreaWidth = VisibleScreenAreaWidth / Screen.TwipsPerPixelX
VisibleScreenAreaHeight = VisibleScreenAreaHeight / Screen.TwipsPerPixelY
'calculate bottom and right
VisibleScreenAreaRight = VisibleScreenAreaLeft + VisibleScreenAreaWidth 'xpos + xsize
VisibleScreenAreaBottom = VisibleScreenAreaTop + VisibleScreenAreaHeight 'ypos + ysize
'fit form pos
If Not (FormXPos = VisibleScreenAreaLeft) Then
SEFormSystem_FitMaximizedFormPos = True
FormXPos = VisibleScreenAreaLeft
End If
If Not (FormYPos = VisibleScreenAreaLeft) Then
SEFormSystem_FitMaximizedFormPos = True
FormYPos = VisibleScreenAreaTop
End If
End If
End If
End Function
Public Function SEFormSystem_FitMaximizedFormSize(ByRef FormXSize As Long, ByRef FormYSize As Long)
'on error resume next
Dim VisibleScreenAreaLeft As Long
Dim VisibleScreenAreaRight As Long
Dim VisibleScreenAreaTop As Long
Dim VisibleScreenAreaBottom As Long
Dim VisibleScreenAreaWidth As Long
Dim VisibleScreenAreaHeight As Long
'
'NOTE: this sub verifies a form's size is the size of the visible area of the
'desktop. If the function changed one of the two passed value then
'the return value is True, if no changes were done it is False.
'
'preset
SEFormSystem_FitMaximizedFormSize = False
'begin
If Not (FormXSize = SE_SIZE_NOT_DEFINED) Then
If Not (FormYSize = SE_SIZE_NOT_DEFINED) Then
'use GFTaskBarInfo code
Call GFTaskBarInfo_GetWindowPosSize(VisibleScreenAreaLeft, VisibleScreenAreaTop, VisibleScreenAreaWidth, VisibleScreenAreaHeight)
'convert Twips to pixels
VisibleScreenAreaLeft = VisibleScreenAreaLeft / Screen.TwipsPerPixelX
VisibleScreenAreaTop = VisibleScreenAreaTop / Screen.TwipsPerPixelY
VisibleScreenAreaWidth = VisibleScreenAreaWidth / Screen.TwipsPerPixelX
VisibleScreenAreaHeight = VisibleScreenAreaHeight / Screen.TwipsPerPixelY
'calculate bottom and right
VisibleScreenAreaRight = VisibleScreenAreaLeft + VisibleScreenAreaWidth 'xpos + xsize
VisibleScreenAreaBottom = VisibleScreenAreaTop + VisibleScreenAreaHeight 'ypos + ysize
'fit form pos
If Not (FormXSize = VisibleScreenAreaWidth) Then
SEFormSystem_FitMaximizedFormSize = True
FormXSize = VisibleScreenAreaWidth
End If
If Not (FormYSize = VisibleScreenAreaHeight) Then
SEFormSystem_FitMaximizedFormSize = True
FormYSize = VisibleScreenAreaHeight
End If
End If
End If
End Function
Public Sub SEFormSystem_Restore(ByVal FormName As String, ByVal RestorePosFlag As Boolean, ByVal RestoreSizeFlag As Boolean)
'on error resume next
Dim StructLoop As Integer
Dim FormStructIndex As Integer
Dim FormRestoredFlag As Boolean
Dim FormPosGroupIndex As Integer
Dim FormSizeGroupIndex As Integer
Dim FormXPos As Long
Dim FormYPos As Long
Dim FormXSize As Long
Dim FormYSize As Long
Dim FormXPosUnchanged As Long
Dim FormYPosUnchanged As Long
Dim FormXSizeUnchanged As Long
Dim FormYSizeUnchanged As Long
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'
'NOTE: RestorePosFlag and RestoreSizeFlag should only be False
'if the user starts resizing a maximized window.
'
'preset
FormStructIndex = GetSEControlStructIndex(FormName)
If FormStructIndex = 0 Then Exit Sub 'verify
FormPosGroupIndex = GetSEFormPosGroupIndex(FormName)
FormSizeGroupIndex = GetSEFormSizeGroupIndex(FormName)
'begin
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_FORM Then
If SEControlStructArray(StructLoop).SEControl Is SEControlStructArray(FormStructIndex).SEControl Then 'StructLoop and FormStructIndex can be equal
If (GetSEFormPosGroupIndex(SEControlStructArray(StructLoop).SEControlName) = FormPosGroupIndex) And _
(GetSEFormSizeGroupIndex(SEControlStructArray(StructLoop).SEControlName) = FormSizeGroupIndex) Then
'
'NOTE: the form to maximize and the currently checked form must be in the
'same pos AND size group (could be group 0 for no group).
'
If Not (SEControlStructArray(StructLoop).SEControl.WindowState = vbNormal) Then _
SEControlStructArray(StructLoop).SEControl.WindowState = vbNormal 'verify
'
FormXPos = GetSEControlXPos(StructLoop)
FormYPos = GetSEControlXPos(StructLoop)
FormXSize = GetSEControlXSize(StructLoop)
FormYSize = GetSEControlYSize(StructLoop)
FormXPosUnchanged = FormXPos
FormYPosUnchanged = FormYPos
FormXSizeUnchanged = FormXSize
FormYSizeUnchanged = FormYSize
'
Call FormStateToggle_ExchangeStateInfo( _
vbMaximized, vbNormal, _
FormXPos, FormYPos, FormXSize, FormYSize, StructLoop) 'call for every (!) pool instance
'
'NOTE: FormStateToggle_ExchangeStateInfo() manipulated the passed
'position and size variable values so that the new form size and position
'is that the form had before it was maximized.
'If Restore[Pos/Size]Flag is False then the current pos/size of the
'maximized form is retained although the form is not maximized
'anymore.
'
If RestorePosFlag = False Then
FormXPos = FormXPosUnchanged
FormXPos = FormYPosUnchanged
End If
If RestoreSizeFlag = False Then
FormXSize = FormXSizeUnchanged
FormXSize = FormYSizeUnchanged
End If
'
If FormRestoredFlag = False Then
FormRestoredFlag = True
'NOTE: verifying is important to avoid that the form gets out of screen boundaries when restored.
Call SEFormSystem_VerifyFormPos(FormXPos, FormYPos, FormXSize, FormYSize)
Call SEFormSystem_VerifyFormSize(FormXPos, FormYPos, FormXSize, FormYSize)
'verify a restored form does not have a size the user couldn't set
If Not (SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_XSizeMin = SE_SIZE_NOT_DEFINED) Then
If FormXSize < SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_XSizeMin Then
FormXSize = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_XSizeMin
End If
End If
If Not (SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_YSizeMin = SE_SIZE_NOT_DEFINED) Then
If FormYSize < SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_YSizeMin Then
FormYSize = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_YSizeMin
End If
End If
If Not (SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_XSizeMax = SE_SIZE_NOT_DEFINED) Then
If FormXSize > SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_XSizeMax Then
FormXSize = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_XSizeMax
End If
End If
If Not (SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_YSizeMax = SE_SIZE_NOT_DEFINED) Then
If FormYSize > SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_YSizeMax Then
FormYSize = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.Resize_YSizeMax
End If
End If
'finally move and size form
Call SEFormSystem_MoveForm(StructLoop, FormXPos, FormYPos)
Call SEFormSystem_ResizeForm(StructLoop, FormXSize, FormYSize)
End If
If IsControlPaletteEqualEx( _
SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray(), _
SEControlStructArray(FormStructIndex).SEControl_PaletteNumber, SEControlStructArray(FormStructIndex).SEControl_PaletteArray()) = True Then
'NOTE: recreate back picture of current palette only.
Call SE_ForwardCallBackMessageEx(SECBMSG_FORM_BACKPICTURERECREATE, SEControlStructArray(StructLoop).SEControlName, LTrim$(Str$(StructLoop)), ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = False) Or ((ReturnValueUsedFlag = True) And Not (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SE_UnloadControl(SEControlStructArray(StructLoop).SEControlName, StructLoop) 'recreate back picture
Call SE_LoadControl(SEControlStructArray(StructLoop).SEControlName, True, StructLoop)
Call SE_RefreshControl(SEControlStructArray(StructLoop).SEControlName, 0, StructLoop)
End If
End If
Call SEFormSystem_SaveFormPos(SEControlStructArray(StructLoop).SEControlName, GetSEControlXPos(StructLoop), GetSEControlYPos(StructLoop))
Call SEFormSystem_SaveFormSize(SEControlStructArray(StructLoop).SEControlName, GetSEControlXSize(StructLoop), GetSEControlYSize(StructLoop))
End If
End If
End If
Next StructLoop
If FormRestoredFlag = True Then Call SE_ForwardCallBackMessage(SECBMSG_FORM_RESTORED, FormName, "")
End Sub
Public Sub SEFormSystem_Initialize(ByVal DisableAutoRefreshFlag As Boolean, ByVal DisableAutoMoveFlag As Boolean, ByVal DisableAutoMoveExFlag As Boolean, ByVal UserMove_DisableAutoRefreshFlag As Boolean, ByVal UserMove_DisableAutoMoveFlag As Boolean, ByVal UserMove_DisableAutoMoveExFlag As Boolean)
'on error resume next
'
'NOTE: the target application can optionally use this sub to disable
'auto moving and resizing if it handles this operations on its own.
'The target project can also temporarily disable the auto refresh flag so
'that no form is refreshed when a WM_SIZE message arrives.
'
'NOTE: the form behavior in the UserMove mode may differ from that in
'non‑UserMove modus, i.e. a form could be resized in UserMove mode only.
'
SEFormSystemStructVar.DisableAutoRefreshFlag = DisableAutoRefreshFlag
SEFormSystemStructVar.DisableAutoMoveFlag = DisableAutoMoveFlag
SEFormSystemStructVar.DisableAutoMoveExFlag = DisableAutoMoveExFlag
SEFormSystemStructVar.UserMove_DisableAutoRefreshFlag = UserMove_DisableAutoRefreshFlag
SEFormSystemStructVar.UserMove_DisableAutoMoveFlag = UserMove_DisableAutoMoveFlag
SEFormSystemStructVar.UserMove_DisableAutoMoveExFlag = UserMove_DisableAutoMoveExFlag
End Sub
'*********************************END OF SE FORM SYSTEM*********************************
'************************************FORMSTATETOGGLE************************************
'NOTE: the FormStateToggle sub system is used to allow saving both maximized and restored
'size and position data for a form, and also if the form is currently maximized or restored.
'When a form is maximized, its new position and size will be saved as if
'it would have been resized and moved by the user, what makes the system to move
'and size sticky controls automatically.
'To allow restoring the form the old position and size value is saved in FormStateToggleStruct
'within the FormResizeStruct. When the user wants to restore the form, the values in
'FormStateToggleStruct and the current form size/pos values are 'just exchanged'.
Public Sub FormStateToggle_ExchangeStateInfo(ByVal FormStateOld As Integer, ByVal FormStateNew As Integer, ByRef FormXPos As Long, ByRef FormYPos As Long, ByRef FormXSize As Long, ByRef FormYSize As Long, ByVal FormStructIndex As Integer)
'on error resume next
Dim TempFormStateToggleStruct As FormStateToggleStruct
'
'NOTE: pass the current state of the window and the new state.
'Valid values therefore are vbNormal, vbMaximized and vbMinimized.
'This sub will save the passed data for the old state and return the
'data related to the new state.
'
'verify
If (FormStructIndex < 1) Or (FormStructIndex > SEControlStructNumber) Then
MsgBox "internal error in FormStateToggle_ExchangeStateInfo() (GFSkinEngine): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub
End If
'begin
If (FormStateOld = vbMinimized) Or (FormStateNew = vbMinimized) Then
'
'NOTE: vbMinimized is ignored as in minimized state the form
'position and size is unimportant and cannot be changed anyway.
'
Exit Sub
End If
If (FormStateOld = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormState) Then
If FormStateNew = vbMaximized Then
'recalculate maximized size to be able to ract on a task bar pos/size change.
Call GFTaskBarInfo_GetWindowPosSize(FormXPos, FormYPos, FormXSize, FormYSize)
FormXPos = FormXPos / Screen.TwipsPerPixelX
FormYPos = FormYPos / Screen.TwipsPerPixelY
FormXSize = FormXSize / Screen.TwipsPerPixelX
FormYSize = FormYSize / Screen.TwipsPerPixelY
End If
Exit Sub 'do not save the same form state twice to avoid overwriting information
End If
If Not (FormStateNew = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormState) Then
If Not (FormStateNew = vbMaximized) Then 'no stored info necessary for maximizing
Exit Sub 'we don't have the requested information :‑(
End If
End If
'store old form pos/size/state
TempFormStateToggleStruct.FormState = FormStateOld
TempFormStateToggleStruct.FormXPos = FormXPos
TempFormStateToggleStruct.FormYPos = FormYPos
TempFormStateToggleStruct.FormXSize = FormXSize
TempFormStateToggleStruct.FormYSize = FormYSize
'determine new form pos/size/state to be returned
FormXPos = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormXPos
FormYPos = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormYPos
FormXSize = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormXSize
FormYSize = SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormYSize
If FormStateNew = vbMaximized Then
'no, return new stuff
Call GFTaskBarInfo_GetWindowPosSize(FormXPos, FormYPos, FormXSize, FormYSize)
FormXPos = FormXPos / Screen.TwipsPerPixelX
FormYPos = FormYPos / Screen.TwipsPerPixelY
FormXSize = FormXSize / Screen.TwipsPerPixelX
FormYSize = FormYSize / Screen.TwipsPerPixelY
End If
'save old form pos/size/state
Call FormStateToggle_SetToggleData(FormStructIndex, FormStateOld, _
TempFormStateToggleStruct.FormXPos, TempFormStateToggleStruct.FormYPos, _
TempFormStateToggleStruct.FormXSize, TempFormStateToggleStruct.FormYSize)
'so now get out of here and return whole stuff
End Sub
Public Sub FormStateToggle_SetToggleData(ByVal FormStructIndex As Integer, ByVal FormState As Integer, ByVal FormXPos As Long, ByVal FormYPos As Long, ByVal FormXSize As Long, ByVal FormYSize As Long)
'on error resume next 'overwrites current FormStateToggleStructVar data
Dim SkinDataFileString As String
'
'NOTE: the target project can use this sub to set the size and position a window
'will have when it is restored without restoring the form.
'
'verify
If (FormStructIndex < 1) Or (FormStructIndex > SEControlStructNumber) Then 'verify
MsgBox "internal error in FormStateToggle_SetToggleData() (GFSkinEngine): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub
End If
'begin
SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormState = FormState
SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormXPos = FormXPos
SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormYPos = FormYPos
SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormXSize = FormXSize
SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormYSize = FormYSize
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we manipulate the string and write it once only to increase speed
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(FormStructIndex).SEControlName, "formstatetoggle_formxpos", Val(SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormXPos))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(FormStructIndex).SEControlName, "formstatetoggle_formypos", Val(SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormYPos))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(FormStructIndex).SEControlName, "formstatetoggle_formxsize", Val(SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormXSize))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(FormStructIndex).SEControlName, "formstatetoggle_formysize", Val(SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormYSize))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(FormStructIndex).SEControlName, "formstatetoggle_formstate", Val(SEControlStructArray(FormStructIndex).SEControl_ResizeStruct.FormStateToggleStructVar.FormState))
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
Exit Sub
End Sub
'********************************END OF FORMSTATETOGGLE*********************************
'**********************************REGISTRY FUNCTIONS***********************************
Public Sub SEToReg() 'also used by GFSkinEnginefrm
'On Error Resume Next
'reset
Call RegDeleteSubKey(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\")
Call RegCreateSubKey(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\")
'begin
Call RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\", "current skin name", CVar(GetCurrentSkinName), REG_SZ)
Call RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\", "ask for picture import", CVar(BOOLTOSTRING(SESystemStructVar.SystemAskForPictureImportFlag)), REG_SZ)
Call RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\", "random skin select", CVar(BOOLTOSTRING(SESystemStructVar.SystemSkinRandomSelectFlag)), REG_SZ)
Call RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\", "random skin select display name", CVar(BOOLTOSTRING(SESystemStructVar.SystemSkinRandomSelectDisplayNameFlag)), REG_SZ)
'UserMoveStructVar values
Call RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\", "grid enabled", CVar(BOOLTOSTRING(UserMoveStructVar.GridEnabledFlag)), REG_SZ)
Call RegSetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\", "control info enabled", CVar(BOOLTOSTRING(UserMoveStructVar.ControlInfoEnabledFlag)), REG_SZ)
End Sub
Private Sub SEFromReg()
'On Error Resume Next
Dim Tempstr$
'
'NOTE: the SESystemStructVar values must also be valid if RegGetkeyValue () returns "" for error.
'NOTE: this sub does not call Skin_Change(SESystemStructVar.SystemSkinNameCurrent),
'what should be done by the system after calling SEFromReg.
'
SESystemStructVar.SystemSkinNameCurrent = RegGetKeyValue(SESystemStructVar.RegMainKey, _
SESystemStructVar.RegRootKey + "SkinEngine\", "current skin name")
SESystemStructVar.SystemAskForPictureImportFlag = STRINGTOBOOL(RegGetKeyValue(SESystemStructVar.RegMainKey, _
SESystemStructVar.RegRootKey + "SkinEngine\", "ask for picture import"))
SESystemStructVar.SystemSkinRandomSelectFlag = STRINGTOBOOL(RegGetKeyValue(SESystemStructVar.RegMainKey, _
SESystemStructVar.RegRootKey + "SkinEngine\", "random skin select"))
SESystemStructVar.SystemSkinRandomSelectDisplayNameFlag = STRINGTOBOOL(RegGetKeyValue(SESystemStructVar.RegMainKey, _
SESystemStructVar.RegRootKey + "SkinEngine\", "random skin select display name"))
'UserMoveStructVar values
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\", "grid enabled")
If Rmod.RegGetKeyValueErrorFlag = False Then UserMoveStructVar.GridEnabledFlag = STRINGTOBOOL(Tempstr$)
'
Rmod.RegGetKeyValueErrorFlag = False 'reset
Tempstr$ = Rmod.RegGetKeyValue(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey + "SkinEngine\", "control info enabled")
If Rmod.RegGetKeyValueErrorFlag = False Then UserMoveStructVar.ControlInfoEnabledFlag = STRINGTOBOOL(Tempstr$)
'
End Sub
'*******************************END OF REGISTRY FUNCTIONS*******************************
'***********************************PALETTE HANDLING************************************
'NOTE: the following subs/functions are on a high level and should be used by the target
'project to control the skinning.
'The target project should use:
'‑SE_DisplayPalette() to enable skinning for a special palette of controls
'‑SE_LoadPalette() to enable skinning for a set of controls of an external palette
'‑SE_UnloadPalette() to disable skinning for a set of controls of an external palette
Public Function SE_GetCurrentPaletteNumber() As Integer
'on error resume next 'to be used by target project when changing the palette (return value represents PaletteNumberOld)
SE_GetCurrentPaletteNumber = SESystemStructVar.SystemPaletteNumberCurrent
End Function
Public Sub SE_DisplayPalette(ByVal PaletteNumberOld As Integer, ByVal PaletteNumberNew As Integer, ByVal ForceRedrawFlag As Boolean, ByVal SkinDataFileChangedFlag As Boolean, Optional ByVal ReadSkinDataFileOnlyFlag As Boolean = False, Optional ByVal NoControlUnloadFlag As Boolean = False)
'on error resume next 'always call this sub to update the appearance of all controls
Dim ScreenMousePointerUnchanged As Integer
Dim StructLoop As Integer
'verify
If (ForceRedrawFlag = True) Or (SkinDataFileChangedFlag = True) Then
'
'NOTE: the target project can set NoControlUnloadFlag to True,
'show/hide controls and then call SE_UnloadPaletteControls()
'to unload the controls that are no longer to be displayed.
'
PaletteNumberOld = ‑32766 'force control unloading/loading/refreshing
NoControlUnloadFlag = False
End If
If (ReadSkinDataFileOnlyFlag = True) Then
'
'NOTE: the SkinDataFile is read, the default palette (‑1) and all
'loaded external palettes (at start up 0) are refreshed.
'Only the current palette is not refreshed.
'
PaletteNumberOld = ‑32766 'force control unloading/loading/refreshing
PaletteNumberNew = ‑1
ForceRedrawFlag = True
NoControlUnloadFlag = False
SkinDataFileChangedFlag = True
End If
'preset
SESystemStructVar.SystemPaletteNumberChangingFlag = True
SESystemStructVar.SystemPaletteNumberCurrent = PaletteNumberNew 'transfer value now
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'reset
Call SEM_Mark_Remove 'a control could be marked for UserMove, back color would not be restored correctly if user changed it
Call SEM_MouseCapture_Remove
Call SEM_FilterMessage_Reset
Call SEM_UserMove_Abort(UserMoveStructVar)
Call SEM_PolyRgn_Abort
If (SkinDataFileChangedFlag = True) Or (ReadSkinDataFileOnlyFlag = True) Then
Call SE_ForwardCallBackMessage(SECBMSG_BEFORE_SKINDATAFILE_RELOAD, SE_GetSkinDataFile, BOOLTOSTRING(SkinDataFileChangedFlag))
End If
'begin
If SkinDataFileChangedFlag = True Then
SkinDataFileCacheStructVar.SkinDataFile = "" 'reset to force re‑reading file
SkinDataFileCacheStructVar.SkinDataFileString = "" 'reset to realize errors when debugging
Call DisabledPictureCache_Reset(SEControlStructNumber, SEControlStructArray())
Call FrameBrushCache_Reset(SESystemStructVar)
Call SE_SubClass_Disable(SEControlStructNumber, SEControlStructArray())
Call SkinDataFile_Read(SE_GetSkinDataFile)
Call SE_SubClass_Enable(SEControlStructNumber, SEControlStructArray()) 'enable here to redraw control frames
For StructLoop = 1 To SEControlStructNumber
'
'NOTE: refreshing the position of all controls (also of palettes that are not loaded)
'does not need memory but avoids ugly flickering when the control is displayed
'the first time.
'Do not refresh sticky‑ or pool controls.
'
If (Len(SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_ParentFormName) = 0) And _
(IsPoolObject(SEControlStructArray(StructLoop).SEControl) = False) Then
Call SE_RefreshControlPos(StructLoop)
Call SE_RefreshControlSize(StructLoop)
End If
Next StructLoop
Call SE_ChangePalette(PaletteNumberOld, ‑1, ForceRedrawFlag, NoControlUnloadFlag)
For StructLoop = 1 To SEExternalPaletteStructNumber
'
'NOTE: if an external palette is not defined anymore in new SkinDataFile then it will be ignored.
'Only the target project should remove an external palette or reset the palette number buffer.
'As the SkinDataFile was reloaded the DCs were reset and thus the control pictures must be recreated.
'
Call SE_LoadPalette(SEExternalPaletteStructArray(StructLoop).PaletteNumber, True)
Next StructLoop
Call DisabledPictureCache_Create(SEControlStructNumber, SEControlStructArray())
Call FrameBrushCache_Create(SESystemStructVar)
End If
If Not ((SkinDataFileChangedFlag = True) And (PaletteNumberNew = ‑1)) Then 'do not load twice
Call SE_ChangePalette(PaletteNumberOld, PaletteNumberNew, ForceRedrawFlag, NoControlUnloadFlag)
End If
If (NoControlUnloadFlag = False) Then
Call LoadedControl_Collect(SEControlStructNumber, SEControlStructArray()) 'update IsInPaletteFlags
Else
Call LoadedControl_Collect(SEControlStructNumber, SEControlStructArray(), PaletteNumberOld) 'update IsInPaletteFlags
End If
Screen.MousePointer = ScreenMousePointerUnchanged 'reset (before forwarding call back messages)
If (SkinDataFileChangedFlag = True) Or (ReadSkinDataFileOnlyFlag = True) Then
Call SE_ForwardCallBackMessage(SECBMSG_AFTER_SKINDATAFILE_RELOAD, SE_GetSkinDataFile, BOOLTOSTRING(SkinDataFileChangedFlag))
End If
If ReadSkinDataFileOnlyFlag = False Then
Call SE_ForwardCallBackMessage(SECBMSG_PALETTECHANGE, LTrim$(Str$(PaletteNumberNew)), BOOLTOSTRING(ForceRedrawFlag))
End If
SESystemStructVar.SystemPaletteNumberChangingFlag = False 'reset
End Sub
Public Sub SE_LoadPalette(ByVal PaletteNumber As Integer, ByVal ForceRecreateFlag As Boolean)
'on error resume next 'call to load one palette, i.e. the controls of a second window that was opened
Dim ChangesExistingFlag As Boolean
Dim StructLoop As Integer
'
'NOTE: ONLY the target project should call this sub (SEExternalPalette buffer manipulated).
'
'preset
Call SEExternalPalette_Load(PaletteNumber) 'palette will be ignored if it is already existing
'begin
'
'LOAD CONTROLS
'
For StructLoop = 1 To SEControlStructNumber
If IsControlPaletteEqual(PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
'
'NOTE: external palettes are almost always used for windows that are
'not visible and not enabled by default at program start up.
'Windows will return Enabled = False for all controls of these windows,
'although the controls themselves are enabled ('disabled' state will be saved by SE).
'It is not sufficient to just enable the form before loading the window,
'the enabled flags of all its controls must be refreshed, too.
'
Call SE_RefreshControlEnabledFlag(StructLoop)
Call SE_LoadControl(SEControlStructArray(StructLoop).SEControlName, ForceRecreateFlag, StructLoop)
End If
Next StructLoop
'
'REFRESH CONTROL
'
SESystemStructVar.SystemIgnore_WM_PAINT_Flag = True
For StructLoop = 1 To SEControlStructNumber
If IsControlPaletteEqual(PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
ChangesExistingFlag = UpdateCheck_WasChanged(StructLoop)
If (ChangesExistingFlag = True) Or (ForceRecreateFlag = True) Then
'NOTE: pool objects could change position, just refresh them.
Call UpdateCheck_Save(StructLoop, SEControlStructNumber, SEControlStructArray())
If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_FORM Then
'Call LockWindowUpdate(0) 'reset 'no! (flickering)
'Call LockWindowUpdate(SEControlStructArray(StructLoop).SEControl.hwnd)
End If
Call SE_RefreshControl(SEControlStructArray(StructLoop).SEControlName, 0, StructLoop)
End If
If (ChangesExistingFlag = True) Or (ForceRecreateFlag = True) Or (IsPoolObject(SEControlStructArray(StructLoop).SEControl, SEControlStructArray(StructLoop).SEControlType) = True) Then
Call SE_RefreshControlPos(StructLoop)
Call SE_RefreshControlSize(StructLoop)
End If
End If
Next StructLoop
'
'SORT CONTROLS
Call SE_ZOrderSort(SEControlStructNumber, SEControlStructArray())
Call SE_TabStopSort(SEControlStructNumber, SEControlStructArray())
'
SESystemStructVar.SystemIgnore_WM_PAINT_Flag = False 'reset
Call LoadedControl_Collect(SEControlStructNumber, SEControlStructArray())
'Call LockWindowUpdate(0) 'reset 'no! (flickering)
End Sub
Public Sub SE_UnloadPalette(ByVal PaletteNumber As Integer)
'on error resume next 'call to unload one special palette
Dim StructLoop As Integer
'
'NOTE: ONLY the target project should call this sub (SEExternalPalette buffer manipulated).
'
'preset
Call SEExternalPalette_Unload(PaletteNumber) 'will be ignored is palette is not existing
'begin
'
'UNLOAD CONTROLS
'
For StructLoop = 1 To SEControlStructNumber
'
'NOTE: controls that have the palette number ‑1 will never be unloaded,
'all other controls will be unloaded if none of their palette array values match
'the current palette number.
'
If IsControlPaletteEqual(‑1, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = False Then
If IsControlPaletteEqual(PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
Call SE_UnloadControl(SEControlStructArray(StructLoop).SEControlName, StructLoop)
End If
End If
Next StructLoop
End Sub
Private Sub SE_ChangePalette(ByVal PaletteNumberOld As Integer, ByVal PaletteNumberNew As Integer, ByVal ForceRedrawFlag As Boolean, Optional ByVal NoControlUnloadFlag As Boolean = False)
'on error resume next
Dim ChangesExistingFlag As Boolean
Dim StructLoop As Integer
'
'UNLOAD CONTROLS
'
For StructLoop = 1 To SEControlStructNumber
If (Not (PaletteNumberNew = PaletteNumberOld)) Or (ForceRedrawFlag = True) Then
'
'NOTE: controls that have the palette number ‑1 will never be unloaded,
'all other controls will be unloaded if none of their palette array values match
'the current palette number.
'
If IsControlPaletteEqual(‑1, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = False Then
'NOTE: controls of the default palette are never unloaded.
If IsControlPaletteEqual(PaletteNumberOld, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
If IsControlPaletteEqual(PaletteNumberNew, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = False Then
'
'NOTE: unload all controls of old palette, but not (!) controls of any other than the new palette
'it is check if the old palette is equal to the new one (see above).
'NOTE: do NOT unload controls that are also in new palette, this is not necessary and decreases speed.
'
If (NoControlUnloadFlag = False) Or (IsPoolObject(SEControlStructArray(StructLoop).SEControl, SEControlStructArray(StructLoop).SEControlType)) Then
'
'NOTE: pool objects must be loaded for ONE palette only, or endless loops will
'appear when WM_PAINT messages for the related control are processed (tested).
'
Call SE_UnloadControl(SEControlStructArray(StructLoop).SEControlName, StructLoop)
End If
End If
End If
End If
End If
Next StructLoop
'
'LOAD CONTROLS
'
For StructLoop = 1 To SEControlStructNumber
If (Not (PaletteNumberNew = PaletteNumberOld)) Or (ForceRedrawFlag = True) Then
If IsControlPaletteEqual(PaletteNumberNew, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
If IsControlPaletteEqual(PaletteNumberOld, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = False Then 'refresh only if necessary
Call SE_RefreshControlEnabledFlag(StructLoop)
'
'NOTE: if the enabled flag in the structure did not fit the enabled state of the control
'then the control must be recreated in any case. Besides this checking when the control
'is loaded also WM_ENABLE messages are processed
'(to redraw additionally ‑1 controls or external controls when their enabled state has changed).
'
Call SE_LoadControl(SEControlStructArray(StructLoop).SEControlName, ForceRedrawFlag, StructLoop)
End If
End If
End If
Next StructLoop
'
'REFRESH CONTROL
'
SESystemStructVar.SystemIgnore_WM_PAINT_Flag = True
For StructLoop = 1 To SEControlStructNumber
If (Not (PaletteNumberNew = PaletteNumberOld)) Or (ForceRedrawFlag = True) Then
If IsControlPaletteEqual(PaletteNumberNew, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
If IsControlPaletteEqual(PaletteNumberOld, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = False Then 'refresh only if necessary
'current control is in current palette
ChangesExistingFlag = UpdateCheck_WasChanged(StructLoop)
If (ChangesExistingFlag = True) Then
Call UpdateCheck_Save(StructLoop, SEControlStructNumber, SEControlStructArray())
If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_FORM Then
'Call LockWindowUpdate(0) 'reset 'no! (flickering)
'Call LockWindowUpdate(SEControlStructArray(StructLoop).SEControl.hwnd)
End If
Call SE_RefreshControl(SEControlStructArray(StructLoop).SEControlName, 0, StructLoop)
End If
If (ChangesExistingFlag = True) Or (IsPoolObject(SEControlStructArray(StructLoop).SEControl, SEControlStructArray(StructLoop).SEControlType) = True) Then
'NOTE: pool objects could change position although not in current palette, just refresh them.
Call SE_RefreshControlPos(StructLoop)
Call SE_RefreshControlSize(StructLoop)
End If
End If
End If
End If
Next StructLoop
'
'SORT CONTROLS
Call SE_ZOrderSort(SEControlStructNumber, SEControlStructArray())
Call SE_TabStopSort(SEControlStructNumber, SEControlStructArray())
'
SESystemStructVar.SystemIgnore_WM_PAINT_Flag = False 'reset
Call LoadedControl_Collect(SEControlStructNumber, SEControlStructArray())
'Call LockWindowUpdate(0) 'reset 'no! (flickering)
End Sub
Public Sub SE_UnloadPaletteControls(ByVal PaletteNumberOld As Integer, ByVal PaletteNumberNew As Integer)
'on error resume next 'see annotations in SE_DisplayPalette()
Dim StructLoop As Integer
'begin
For StructLoop = 1 To SEControlStructNumber 'code copied from SE_ChangePalette()
If (Not (PaletteNumberNew = PaletteNumberOld)) Then 'Or (ForceRedrawFlag = True) Then
'
'NOTE: controls that have the palette number ‑1 will never be unloaded,
'all other controls will be unloaded if none of their palette array values match
'the current palette number.
'
If IsControlPaletteEqual(‑1, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = False Then
'NOTE: controls of the default palette are never unloaded.
If IsControlPaletteEqual(PaletteNumberOld, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
If IsControlPaletteEqual(PaletteNumberNew, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = False Then
'
'NOTE: unload all controls of old palette, but not (!) controls of any other than the new palette
'it is check if the old palette is equal to the new one (see above).
'NOTE: do NOT unload controls that are also in new palette as this sub is called
'AFTER loading the controls of the new palette (controls would never be loaded again).
'
Call SE_UnloadControl(SEControlStructArray(StructLoop).SEControlName, StructLoop)
End If
End If
End If
End If
Next StructLoop
Call LoadedControl_Collect(SEControlStructNumber, SEControlStructArray()) 'update IsInPaletteFlags
End Sub
'********************************END OF PALETTE HANDLING********************************
'*******************************EXTERNAL PALETTE HANDLING*******************************
'NOTE: an 'external palette' is a palette that was loaded by the target project manually,
'and is also unloaded manually. Its palette number does not fit to the current palette number,
'and changing the current palette number by calling SE_DisplayPalette() has no effect
'on an external palette. An external palette is usually used for e.g. any form of tool window.
'Note that extra code is necessary to update these palettes if the SkinDataFile has been
'changed. SE_LoadPalette() should call SEExternalPalette_Load() when an external
'palette has been loaded, and SE_UnloadPalette() should call SEExternalPalette_Unload()
'when an external palette has been unloaded.
'Any part of the SE code can directly access SEExternalPaletteStructArray().
Private Sub SEExternalPalette_Load(ByVal PaletteNumber As Integer)
'on error resume next
Dim StructLoop As Integer
'verify
For StructLoop = 1 To SEExternalPaletteStructNumber
If SEExternalPaletteStructArray(StructLoop).PaletteNumber = PaletteNumber Then Exit Sub
Next StructLoop
'begin
If Not (SEExternalPaletteStructNumber = 32766) Then 'verify
SEExternalPaletteStructNumber = SEExternalPaletteStructNumber + 1
Else
MsgBox "internal error in SEExternalPalette_Load(): verflow !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
ReDim Preserve SEExternalPaletteStructArray(1 To SEExternalPaletteStructNumber) As SEExternalPaletteStruct
SEExternalPaletteStructArray(SEExternalPaletteStructNumber).PaletteNumber = PaletteNumber
End Sub
Private Sub SEExternalPalette_Unload(ByVal PaletteNumber As Integer)
'on error resume next
Dim StructIndex As Integer
Dim StructLoop As Integer
'preset
For StructLoop = 1 To SEExternalPaletteStructNumber
If SEExternalPaletteStructArray(StructLoop).PaletteNumber = PaletteNumber Then
StructIndex = StructLoop
Exit For
End If
Next StructLoop
If StructIndex = 0 Then Exit Sub
'begin
For StructLoop = StructIndex To SEExternalPaletteStructNumber
If Not (StructLoop = SEExternalPaletteStructNumber) Then
SEExternalPaletteStructArray(StructLoop) = SEExternalPaletteStructArray(StructLoop + 1)
Else
SEExternalPaletteStructNumber = SEExternalPaletteStructNumber ‑ 1
StructLoop = SEExternalPaletteStructNumber
If StructLoop < 1 Then StructLoop = 1
ReDim Preserve SEExternalPaletteStructArray(1 To StructLoop) As SEExternalPaletteStruct
Exit For
End If
Next StructLoop
End Sub
Private Sub SEExternalPalette_Reset()
'on error resume next
SEExternalPaletteStructNumber = 0 'reset
ReDim SEExternalPaletteStructArray(1 To 1) As SEExternalPaletteStruct
End Sub
'NOTE: right now the target project must decide if an external palette is
'to be loaded or not, SE_LoadPalette() will load any external palette
'also if this external palette has already been loaded.
Public Function IsExternalPaletteLoaded(ByVal PaletteNumber As Integer) As Boolean
'on error resume next 'the target project needn't to call SE_LoadPalette(p) if external palette p is already loaded
Dim StructLoop As Integer
'begin
For StructLoop = 1 To SEExternalPaletteStructNumber
If SEExternalPaletteStructArray(StructLoop).PaletteNumber = PaletteNumber Then
IsExternalPaletteLoaded = True 'external palette is loaded
Exit Function
End If
Next StructLoop
IsExternalPaletteLoaded = False 'not loaded
Exit Function
End Function
Public Function IsControlInExternalPalette(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'returns True if passed control is in any external palette, False if not (external palette controls must be handled like palette ‑1 controls)
Dim StructLoop As Integer
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
IsControlInExternalPalette = False 'error
Exit Function 'verify
End If
'begin
For StructLoop = 1 To SEExternalPaletteStructNumber
If IsControlPaletteEqual(SEExternalPaletteStructArray(StructLoop).PaletteNumber, SEControlStructArray(SEControlStructIndex).SEControl_PaletteNumber, SEControlStructArray(SEControlStructIndex).SEControl_PaletteArray()) = True Then
IsControlInExternalPalette = True
Exit Function
End If
Next StructLoop
IsControlInExternalPalette = False
Exit Function
End Function
'***************************END OF EXTERNAL PALETTE HANDLING****************************
'***********************************CONTROL HANDLING************************************
'NOTE: the following subs/functions are one level below the palette handling functions.
'To enable a control's skinning you must call:
'‑SE_LoadControl(): creates data used by a control (e.g. back picture)
'‑SE_RefreshControl(): uses created data to change a control's appearance
'‑SE_UnlaodControl(): deletes created data to free up memory.
'
'NOTE: the target project should call SE_LoadControl() and SE_RefreshControl()
'manually if it changed the size of a skinned control
'(possibly the control's back picture, if any, needs to be recreated).
Public Sub SE_LoadControl(ByVal ControlName As String, ByVal ForceRecreateFlag As Boolean, Optional ByVal SEControlStructIndex As Integer = 0)
'on error resume next 'preset a control so that it can be refreshed
Dim SEPolyRgnPoints() As POINTAPI
Dim SEControlWidth As Long
Dim SEControlHeight As Long
Dim PictureEnabledFlagOld As Boolean
Dim DisabledPictureCacheDir As String
Dim ReloadedFlag As Boolean
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim TransferLoop As Integer
Dim Temp As Long
'
'NOTE: this sub has the task to create resources and transfer the
'resources' handles to the SEControlStructArray().
'
'preset
'NOTE: SEControlStructIndex should be passed if known to increase speed.
If SEControlStructIndex = 0 Then SEControlStructIndex = GetSEControlStructIndex(ControlName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'
'NOTE: when creating any kind of picture the related graphics function must
'accept the target control's size values instead of using the current control
'size, as the current control size may change when the control is refreshed.
'
Call SE_ForwardCallBackMessageEx(SECBMSG_SECONTROL_LOAD, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
BOOLTOSTRING(ForceRecreateFlag), ReturnValueUsedFlag, ReturnValue)
'NOTE: do not pass argument ControlName as this could be "" as control index is passed.
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND
Call DisabledPictureCache_GetCacheDir(DisabledPictureCacheDir)
Call DisabledPictureCache_CreateSub(SEControlStructIndex, DisabledPictureCacheDir, False)
End Select
'
If (ReturnValueUsedFlag = True) Then
If (ReturnValue = SECBMSG_REPLY_CANCEL) Then
Exit Sub 'after creating disabled picture
End If
End If
'
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_FORM, SECONTROLTYPE_SECOMMAND, SECONTROLTYPE_PICTUREBOX, SECONTROLTYPE_GFMSGBOX, SECONTROLTYPE_SEPOLYRGN
'NOTE: not all controls have a .Width and .Height property
If Not (SEControlStructArray(SEControlStructIndex).SEControl_XSize = SE_SIZE_NOT_DEFINED) Then
SEControlWidth = SEControlStructArray(SEControlStructIndex).SEControl_XSize
Else
SEControlWidth = SEControlStructArray(SEControlStructIndex).SEControl.Width / Screen.TwipsPerPixelX
End If
If Not (SEControlStructArray(SEControlStructIndex).SEControl_YSize = SE_SIZE_NOT_DEFINED) Then
SEControlHeight = SEControlStructArray(SEControlStructIndex).SEControl_YSize
Else
SEControlHeight = SEControlStructArray(SEControlStructIndex).SEControl.Height / Screen.TwipsPerPixelY
End If
End Select
'begin
'
SEControlStructArray(SEControlStructIndex).SEControl_LoadedFlag = True
'
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_FORM
If (SEControlStructArray(SEControlStructIndex).SEControl_DisplayPictureDCStruct.DC = 0) Or (ForceRecreateFlag = True) Then
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_DisplayPictureDCStruct)
PictureEnabledFlagOld = SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag
SEControlStructArray(SEControlStructIndex).SEControl_DisplayPictureDCStruct = _
Graphics_CreateDisplayPicture( _
SEControlStructArray(SEControlStructIndex).SEControl_BackPicture, _
SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag, _
SEControlStructArray(SEControlStructIndex).SEControl_TitleBarPicture, _
SEControlStructArray(SEControlStructIndex).SEControl_TitleBarSpawnStartPos, _
SEControlStructArray(SEControlStructIndex).SEControl_TitleBarSpawnLength, _
SEControlWidth, SEControlHeight)
If Not (PictureEnabledFlagOld = SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag) Then
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SEControlStructArray(SEControlStructIndex).SEControlName, _
"backpictureenabled", BOOLTOSTRING(SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag))
End If
'
'NOTE: to increase speed set muse cursor only when the related control is reloaded.
'It is guaranteed that this happens at least once, the mouse pointer is saved automatically
'by the related control.
'
Call Graphics_SetSEControlMouseIcon( _
SEControlStructArray(SEControlStructIndex).SEControl, _
SEControlStructArray(SEControlStructIndex).SEControlType, _
SEControlStructArray(SEControlStructIndex).SEControl_MouseIcon, _
MOUSEPOINTERUSAGE_NORMAL)
End If
Case SECONTROLTYPE_SECOMMAND
If (SEControlStructArray(SEControlStructIndex).SEControl_UpPictureDCStruct.DC = 0) Or (ForceRecreateFlag = True) Then
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_UpPictureDCStruct)
SEControlStructArray(SEControlStructIndex).SEControl_UpPictureDCStruct = _
Graphics_GetSECommandPictureDCStruct( _
SEControlStructIndex, SECONTROLSTATE_NORMAL, SEControlStructArray(SEControlStructIndex).SEControl_Caption, _
SEControlWidth, SEControlHeight)
ReloadedFlag = True
End If
If (SEControlStructArray(SEControlStructIndex).SEControl_DownPictureDCStruct.DC = 0) Or (ForceRecreateFlag = True) Then
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_DownPictureDCStruct)
'Call SE_RefreshControlSize(SEControlStructIndex) 'important for creating picture
SEControlStructArray(SEControlStructIndex).SEControl_DownPictureDCStruct = _
Graphics_GetSECommandPictureDCStruct( _
SEControlStructIndex, SECONTROLSTATE_PUSHED, SEControlStructArray(SEControlStructIndex).SEControl_Caption, _
SEControlWidth, SEControlHeight)
ReloadedFlag = True
End If
If (SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPictureDCStruct.DC = 0) Or (ForceRecreateFlag = True) Then
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPictureDCStruct)
SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPictureDCStruct = _
Graphics_GetSECommandPictureDCStruct( _
SEControlStructIndex, SECONTROLSTATE_MOVEOVER, SEControlStructArray(SEControlStructIndex).SEControl_Caption, _
SEControlWidth, SEControlHeight)
ReloadedFlag = True
End If
If (SEControlStructArray(SEControlStructIndex).SEControl_DisabledPictureDCStruct.DC = 0) Or (ForceRecreateFlag = True) Then
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_DisabledPictureDCStruct)
SEControlStructArray(SEControlStructIndex).SEControl_DisabledPictureDCStruct = _
Graphics_GetSECommandPictureDCStruct( _
SEControlStructIndex, SECONTROLSTATE_DISABLED, SEControlStructArray(SEControlStructIndex).SEControl_Caption, _
SEControlWidth, SEControlHeight)
ReloadedFlag = True
End If
If ReloadedFlag = True Then
Call Graphics_SetSEControlMouseIcon( _
SEControlStructArray(SEControlStructIndex).SEControl, _
SEControlStructArray(SEControlStructIndex).SEControlType, _
SEControlStructArray(SEControlStructIndex).SEControl_MouseIcon, _
MOUSEPOINTERUSAGE_NORMAL)
End If
Case SECONTROLTYPE_TEXTBOX, SECONTROLTYPE_LISTBOX, SECONTROLTYPE_COMBOBOX
Call Graphics_SetSEControlMouseIcon( _
SEControlStructArray(SEControlStructIndex).SEControl, _
SEControlStructArray(SEControlStructIndex).SEControlType, _
SEControlStructArray(SEControlStructIndex).SEControl_MouseIcon, _
MOUSEPOINTERUSAGE_NORMAL)
Case SECONTROLTYPE_CHECKBOX, SECONTROLTYPE_FRAME, SECONTROLTYPE_OPTIONBUTTON
Call Graphics_SetSEControlMouseIcon( _
SEControlStructArray(SEControlStructIndex).SEControl, _
SEControlStructArray(SEControlStructIndex).SEControlType, _
SEControlStructArray(SEControlStructIndex).SEControl_MouseIcon, _
MOUSEPOINTERUSAGE_NORMAL)
Case SECONTROLTYPE_LABEL
Call Graphics_SetSEControlMouseIcon( _
SEControlStructArray(SEControlStructIndex).SEControl, _
SEControlStructArray(SEControlStructIndex).SEControlType, _
SEControlStructArray(SEControlStructIndex).SEControl_MouseIcon, _
MOUSEPOINTERUSAGE_NORMAL)
Case SECONTROLTYPE_PICTUREBOX
If (SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct.DC = 0) Or (ForceRecreateFlag = True) Then
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct)
PictureEnabledFlagOld = SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag
SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct = _
Graphics_GetPictureBoxBackPicture( _
SEControlStructArray(SEControlStructIndex).SEControl_BackPicture, _
SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag, _
SEControlWidth, SEControlHeight)
If Not (PictureEnabledFlagOld = SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag) Then
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SEControlStructArray(SEControlStructIndex).SEControlName, _
"backpictureenabled", BOOLTOSTRING(SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag))
End If
Call Graphics_SetSEControlMouseIcon( _
SEControlStructArray(SEControlStructIndex).SEControl, _
SEControlStructArray(SEControlStructIndex).SEControlType, _
SEControlStructArray(SEControlStructIndex).SEControl_MouseIcon, _
MOUSEPOINTERUSAGE_NORMAL)
End If
Case SECONTROLTYPE_GFMSGBOX
If (SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct.DC = 0) Or (ForceRecreateFlag = True) Then
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct)
PictureEnabledFlagOld = SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag
SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct = _
Graphics_GetPictureBoxBackPicture( _
SEControlStructArray(SEControlStructIndex).SEControl_BackPicture, _
SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag, _
SEControlWidth, SEControlHeight)
If Not (PictureEnabledFlagOld = SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag) Then
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SEControlStructArray(SEControlStructIndex).SEControlName, _
"backpictureenabled", BOOLTOSTRING(SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag))
End If
Call Graphics_SetSEControlMouseIcon( _
SEControlStructArray(SEControlStructIndex).SEControl, _
SEControlStructArray(SEControlStructIndex).SEControlType, _
SEControlStructArray(SEControlStructIndex).SEControl_MouseIcon, _
MOUSEPOINTERUSAGE_NORMAL)
End If
Case SECONTROLTYPE_GFLISTVIEW
'
'NOTE: the ListView supports changing its back picture.
'As the ListView control expects a file name, not any DC handle we don't
'have to load anything to enable the back picture.
'
Case SECONTROLTYPE_SEPOLYRGN
If (SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle = 0) Or (ForceRecreateFlag = True) Then
If Not (SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointNumber < 3) Then 'verify
ReDim SEPolyRgnPoints(0 To SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointNumber ‑ 1) As POINTAPI
For TransferLoop = 1 To SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointNumber
SEPolyRgnPoints(TransferLoop ‑ 1).X = SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointXArray(TransferLoop)
SEPolyRgnPoints(TransferLoop ‑ 1).Y = SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointYArray(TransferLoop)
Next TransferLoop
Call DeleteObject(SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle)
SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle = CreatePolygonRgn(SEPolyRgnPoints(0), SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointNumber, 1)
Else
'NOTE: if the current region is invalid it is reset to 0, SE_RefreshControl() then must disable the region
Call DeleteObject(SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle)
SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle = 0 'reset
End If
End If
End Select
Exit Sub
End Sub
Public Sub SE_UnloadControl(ByVal ControlName As String, Optional ByVal SEControlStructIndex As Integer = 0)
'on error resume next
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim Temp As Long
'
'NOTE: this sub has the task to free resources ONLY, it must not reset
'any flags or values, except a value refers to a resource that was set free
'(i.e. a handle).
'
'preset
'NOTE: SEControlStructIndex should be passed if known to increase speed.
If SEControlStructIndex = 0 Then SEControlStructIndex = GetSEControlStructIndex(ControlName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'begin
'
Call SE_ForwardCallBackMessageEx(SECBMSG_SECONTROL_UNLOAD, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"", ReturnValueUsedFlag, ReturnValue)
'NOTE: do not pass argument ControlName as this could be "" as control index is passed.
If ReturnValueUsedFlag = True Then
If ReturnValue = SECBMSG_REPLY_CANCEL Then Exit Sub
End If
'
SEControlStructArray(SEControlStructIndex).SEControl_LoadedFlag = False 'reset
'
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_FORM
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_DisplayPictureDCStruct)
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_TitleBarPictureDCStruct)
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct)
If Not (UpdateCheckStructNumber < SEControlStructIndex) Then UpdateCheckStructArray(SEControlStructIndex).SEControlType = ‑32768 'force reloading of current control
Case SECONTROLTYPE_SECOMMAND
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_UpPictureDCStruct)
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_DownPictureDCStruct)
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPictureDCStruct)
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_DisabledPictureDCStruct)
If Not (UpdateCheckStructNumber < SEControlStructIndex) Then UpdateCheckStructArray(SEControlStructIndex).SEControlType = ‑32768 'force reloading of current control
Case SECONTROLTYPE_PICTUREBOX
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct)
If Not (UpdateCheckStructNumber < SEControlStructIndex) Then UpdateCheckStructArray(SEControlStructIndex).SEControlType = ‑32768 'force reloading of current control
Case SECONTROLTYPE_GFMSGBOX
Call SE_DeleteDCStruct(SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct)
If Not (UpdateCheckStructNumber < SEControlStructIndex) Then UpdateCheckStructArray(SEControlStructIndex).SEControlType = ‑32768 'force reloading of current control
Case SECONTROLTYPE_GFLISTVIEW
'
'NOTE: the ListView supports changing its back picture.
'As the ListView control expects a file name, not any DC handle we don't
'have to unload anything to enable the back picture.
'When a control is unloaded, its appearance is not changed directly
'but when the control is refreshed.
'
Case SECONTROLTYPE_SEPOLYRGN
Call DeleteObject(SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle)
SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle = 0 'reset
If Not (UpdateCheckStructNumber < SEControlStructIndex) Then UpdateCheckStructArray(SEControlStructIndex).SEControlType = ‑32768 'force reloading of current control
End Select
Exit Sub
End Sub
Private Function SE_RefreshControlState(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'returns True if control state was changed, False if not
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
SE_RefreshControlState = False 'reset (error)
Exit Function
End If
'begin
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND
If SEControlStructArray(SEControlStructIndex).SEControl_EnabledFlag = True Then
Select Case SEControlStructArray(SEControlStructIndex).SEControlState
Case 0, SECONTROLSTATE_DISABLED
SE_RefreshControlState = True 'changes existing
SEControlStructArray(SEControlStructIndex).SEControlState = SECONTROLSTATE_NORMAL 'verify (important)
Case Else
End Select
Else
Select Case SEControlStructArray(SEControlStructIndex).SEControlState
Case 0, SECONTROLSTATE_NORMAL, SECONTROLSTATE_DISABLED, SECONTROLSTATE_MOVEOVER, SECONTROLSTATE_PUSHED
SE_RefreshControlState = True 'changes existing
SEControlStructArray(SEControlStructIndex).SEControlState = SECONTROLSTATE_DISABLED
End Select
End If
Case Else
If SEControlStructArray(SEControlStructIndex).SEControlState = 0 Then
SE_RefreshControlState = True 'changes existing
SEControlStructArray(SEControlStructIndex).SEControlState = SECONTROLSTATE_NORMAL 'verify (important)
End If
End Select
Exit Function
End Function
Public Sub SE_RefreshControl(ByVal SEControlName As String, ByVal SEControlState As Integer, Optional ByVal SEControlStructIndex As Integer = 0)
'On Error Resume Next 'also called by GFSkinEnginefrm
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim TempFile As String
Dim DCStructVar As DCStruct
Dim TempStdPicture As New StdPicture
'
'NOTE: this sub has the task to update a control's appearance,
'therefore resources created by SE_LoadControl() may be used.
'NOTE: a control's property is only assigned if not done yet to
'increase speed by saving WM_PAINT messages.
'
'preset
'NOTE: SEControlStructIndex should be passed if known to increase speed.
If SEControlStructIndex = 0 Then SEControlStructIndex = GetSEControlStructIndex(SEControlName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'verify
If SEControlStructArray(SEControlStructIndex).SEControl_LoadedFlag = False Then Exit Sub
'
'NOTE: for se commands call SE_RefreshControl([...], 0),
'this sub will determine the correct control state of the se command.
'
If SEControlState = 0 Then
Call SE_RefreshControlState(SEControlStructIndex)
SEControlState = SEControlStructArray(SEControlStructIndex).SEControlState 'verify (important)
End If
'
Call SE_ForwardCallBackMessageEx(SECBMSG_SECONTROL_REFRESH, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
Val(SEControlState), ReturnValueUsedFlag, ReturnValue)
'NOTE: do not pass argument ControlName as this could be "" as control index is passed.
If ReturnValueUsedFlag = True Then
If ReturnValue = SECBMSG_REPLY_CANCEL Then Exit Sub
End If
'
'begin
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND
If SEControlState = SECONTROLSTATE_NORMAL Then
DCStructVar = SEControlStructArray(SEControlStructIndex).SEControl_UpPictureDCStruct
End If
If SEControlState = SECONTROLSTATE_PUSHED Then
DCStructVar = SEControlStructArray(SEControlStructIndex).SEControl_DownPictureDCStruct
End If
If SEControlState = SECONTROLSTATE_MOVEOVER Then
DCStructVar = SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPictureDCStruct
End If
If SEControlState = SECONTROLSTATE_DISABLED Then
DCStructVar = SEControlStructArray(SEControlStructIndex).SEControl_DisabledPictureDCStruct
End If
SEControlStructArray(SEControlStructIndex).SEControlState = SEControlState
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BorderStyle = 0) Then 'verify to increase speed
SEControlStructArray(SEControlStructIndex).SEControl.BorderStyle = 0 'verify (could have been reset by the reloading command)
End If
If Not (Len(SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) = 0) Then
'NOTE: do not reset the ToolTipText to allow setting it at design time (use a space char to reset ToolTipText).
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) Then 'verify
SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText
End If
End If
Call SE_DCStructToSECommand(DCStructVar, SEControlStructArray(SEControlStructIndex).SEControl)
'
'NOTE: the user cannot change a SECommand's size when it displays a picture,
'set the size automatically to avoid any errors when accessing the SEControl_[X/Y]Size values
'(tested, see SEFormSystem_ResizeForm()).
'
SEControlStructArray(SEControlStructIndex).SEControl_XSize = GetSEControlXSize(SEControlStructIndex)
SEControlStructArray(SEControlStructIndex).SEControl_YSize = GetSEControlYSize(SEControlStructIndex)
Case SECONTROLTYPE_FORM
If SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag = True Then
DCStructVar = SEControlStructArray(SEControlStructIndex).SEControl_DisplayPictureDCStruct
Set TempStdPicture = GFDCToStdPicture(DCStructVar.DC, (DCStructVar.Width / Screen.TwipsPerPixelX) ‑ 4, (DCStructVar.Height / Screen.TwipsPerPixelY) ‑ 4) 'DCStructVar.[Width/Height] is width/height of picture box control, not of picture
'don't change control AutoRedraw property value
SEControlStructArray(SEControlStructIndex).SEControl.Picture = TempStdPicture
Else
'disable picture box back picture
Set SEControlStructArray(SEControlStructIndex).SEControl.Picture = Nothing
End If
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor
'
'NOTE: originally VB forms without borders do not have a system menu.
'The Skin Engine enables this menu (see below) and processes WM_SYSCOMMAND
'messages.
'
Call GFSetWindowStyle(SEControlStructArray(SEControlStructIndex).SEControl.hwnd, WS_SYSMENU, True)
Case SECONTROLTYPE_PICTUREBOX
If SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag = True Then
'enable picture box back picture
DCStructVar = SEControlStructArray(SEControlStructIndex).SEControl_BackPictureDCStruct
Set TempStdPicture = GFDCToStdPicture(DCStructVar.DC, DCStructVar.Width / Screen.TwipsPerPixelX, DCStructVar.Height / Screen.TwipsPerPixelY)
'don't change control AutoRedraw property value
SEControlStructArray(SEControlStructIndex).SEControl.Picture = TempStdPicture
Else
'disable picture box back picture
Set SEControlStructArray(SEControlStructIndex).SEControl.Picture = Nothing
End If
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough
If Not (Len(SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) = 0) Then
'NOTE: do not reset the ToolTipText to allow setting it at design time (use a space char to reset ToolTipText).
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText
End If
Case SECONTROLTYPE_TEXTBOX, SECONTROLTYPE_LISTBOX, SECONTROLTYPE_COMBOBOX
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough
If Not (Len(SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) = 0) Then
'NOTE: do not reset the ToolTipText to allow setting it at design time (use a space char to reset ToolTipText).
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText
End If
If Not (Len(SEControlStructArray(SEControlStructIndex).SEControl_Caption) = 0) Then
'NOTE: do not reset the caption to allow setting it at design time (use a space char to reset caption).
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Caption = SEControlStructArray(SEControlStructIndex).SEControl_Caption) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Caption = SEControlStructArray(SEControlStructIndex).SEControl_Caption
End If
Case SECONTROLTYPE_CHECKBOX, SECONTROLTYPE_FRAME, SECONTROLTYPE_OPTIONBUTTON
'like above, but with caption
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough
If Not (Len(SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) = 0) Then
'NOTE: do not reset the ToolTipText to allow setting it at design time (use a space char to reset ToolTipText).
SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText
End If
If Not (Len(SEControlStructArray(SEControlStructIndex).SEControl_Caption) = 0) Then
'NOTE: do not reset the caption to allow setting it at design time (use a space char to reset caption).
SEControlStructArray(SEControlStructIndex).SEControl.Caption = SEControlStructArray(SEControlStructIndex).SEControl_Caption
End If
Case SECONTROLTYPE_LABEL
'NOTE: generally change the .BackStyle property BEFORE changing any other control property.
'NOTE: when a form was unloaded and loaded again the label's back style may have been reset, set them again (2nd line in if‑statement)
If (Not (SEControlStructArray(SEControlStructIndex).SEControl_TransparencyFlag = SESystemStructVar.SystemUseTransparencyFlag)) Or _
(Not (SEControlStructArray(SEControlStructIndex).SEControl_TransparencyFlag = (SEControlStructArray(SEControlStructIndex).SEControl.BackStyle = 0))) Then 'check to increase speed
If SESystemStructVar.SystemUseTransparencyFlag = True Then
SEControlStructArray(SEControlStructIndex).SEControl_TransparencyFlag = True
SEControlStructArray(SEControlStructIndex).SEControl.BackStyle = 0
Else
SEControlStructArray(SEControlStructIndex).SEControl_TransparencyFlag = False
SEControlStructArray(SEControlStructIndex).SEControl.BackStyle = 1
End If
End If
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough
If Not (Len(SEControlStructArray(SEControlStructIndex).SEControl_Caption) = 0) Then
'NOTE: do not reset the caption to allow setting it at design time (use a space char to reset caption).
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Caption = SEControlStructArray(SEControlStructIndex).SEControl_Caption) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Caption = SEControlStructArray(SEControlStructIndex).SEControl_Caption
End If
If Not (Len(SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) = 0) Then
'NOTE: do not reset the ToolTipText to allow setting it at design time (use a space char to reset ToolTipText).
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText
End If
Case SECONTROLTYPE_LINE
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BorderColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BorderColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
Case SECONTROLTYPE_GFLISTVIEW
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor
Call SEControlStructArray(SEControlStructIndex).SEControl.SetFont( _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Name, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Size, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough)
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BackPicture = _
SEControlStructArray(SEControlStructIndex).SEControl_BackPicture) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BackPicture = _
SEControlStructArray(SEControlStructIndex).SEControl_BackPicture
If Not (SEControlStructArray(SEControlStructIndex).SEControl.GridLines = _
SEControlStructArray(SEControlStructIndex).SEControl_GridLinesEnabledFlag) Then _
SEControlStructArray(SEControlStructIndex).SEControl.GridLines = _
SEControlStructArray(SEControlStructIndex).SEControl_GridLinesEnabledFlag
Case SECONTROLTYPE_GFTREEVIEW
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
If Not (SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.BackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor
Call SEControlStructArray(SEControlStructIndex).SEControl.SetFont( _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Name, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Size, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough)
Case SECONTROLTYPE_GFTABSTRING
If Not (SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor) Then _
SEControlStructArray(SEControlStructIndex).SEControl.ForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
Call SEControlStructArray(SEControlStructIndex).SEControl.SetFont( _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Name, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Size, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough)
Case SECONTROLTYPE_GFMSGBOX
'
'NOTE: the code to set the back picture is the one used to create
'a picture box's back picture.
'NOTE: the GFMsgBox must call SE_RefreshControl("GFMsgBoxfrm")
'before displaying its message to the user (the message box size could have changed).
'
If SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag = True Then
'enable picture box back picture
DCStructVar = SEControlStructArray(SEControlStructIndex).SEControl_DisplayPictureDCStruct
Set TempStdPicture = GFDCToStdPicture(DCStructVar.DC, DCStructVar.Width / Screen.TwipsPerPixelX, DCStructVar.Height / Screen.TwipsPerPixelY)
'don't change control AutoRedraw property value
SEControlStructArray(SEControlStructIndex).SEControl.Picture = TempStdPicture
Else
'disable picture box back picture
Set SEControlStructArray(SEControlStructIndex).SEControl.Picture = Nothing
End If
'NOTE: the control is GFMsgBoxfrm.
Call SEControlStructArray(SEControlStructIndex).SEControl.GFMsgBox_SetForeColor(SEControlStructArray(SEControlStructIndex).SEControl_ForeColor)
Call SEControlStructArray(SEControlStructIndex).SEControl.GFMsgBox_SetBackColor(SEControlStructArray(SEControlStructIndex).SEControl_BackColor)
Call SEControlStructArray(SEControlStructIndex).SEControl.GFMsgBox_SetFont( _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Name, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Size, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline, _
SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough)
Case SECONTROLTYPE_SEPOLYRGN
If SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnEnabledFlag = True Then
If Not (SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle = 0) Then 'verify
Call SetWindowRgn(SEControlStructArray(SEControlStructIndex).SEControl.hwnd, SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnHandle, True)
Else
'NOTE: if a region is enabled and its handle is 0 then the region was invalid and thus not loaded.
Call SetWindowRgn(SEControlStructArray(SEControlStructIndex).SEControl.hwnd, 0, True) 'use 0 to reset a window's region
End If
Else
Call SetWindowRgn(SEControlStructArray(SEControlStructIndex).SEControl.hwnd, 0, True) 'use 0 to reset a window's region
End If
End Select
Call SE_ForwardCallBackMessage(SECBMSG_SECONTROL_REFRESHED, _
SEControlStructArray(SEControlStructIndex).SEControlName, Val(SEControlState))
Exit Sub
End Sub
Private Sub SE_RefreshControlPos(ByVal SEControlStructIndex As Integer)
'on error resume next 'a control's position can be refreshed separately to update pool objects
Dim ParentFormWidth As Long 'parent form size at the time the control's position was saved in SkinDataFile
Dim ParentFormHeight As Long
Dim FormWidthNew As Long 'current parent form size
Dim FormHeightNew As Long
Dim ControlLeft As Single
Dim ControlTop As Single
Dim ControlWidth As Single
Dim ControlHeight As Single
Dim ControlParentFormIndex As Integer
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_SEPOLYRGN, SECONTROLTYPE_PSEUDOCONTROL
'cannot be moved
Case SECONTROLTYPE_FORM
If Not (SEControlStructArray(SEControlStructIndex).SEControl_XPos = SE_POS_NOT_DEFINED) Then
If Not (SEControlStructArray(SEControlStructIndex).SEControl_YPos = SE_POS_NOT_DEFINED) Then
'move form
Call SEFormSystem_MoveForm(SEControlStructIndex, _
SEControlStructArray(SEControlStructIndex).SEControl_XPos, _
SEControlStructArray(SEControlStructIndex).SEControl_YPos)
End If
End If
Case Else
'
'NOTE: it is important to check if the current control's position is dependent from
'its parent form's size. If this is the case the control position must be calculated
'out of the original control position saved in SkinDataFile, and the saved related parent
'form size and the current parent form size.
'If the control's position would just be set like written in the SkinDataFile, the control
'would be moved when the parent form is resized, what leads to flickering or
'a wrong position if the parent form is not sized anymore.
'
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)) Then 'verify to increase speed
'
'NOTE: the current control's position is dependent from the parent form size.
'
If StickControlStructVar.StickSystemEnabledFlag = False Then GoTo Jump:
'
ControlParentFormIndex = GetSEControlStructIndex(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName) 'a special pool instance of parent form
If Not (ControlParentFormIndex = 0) Then 'verify
'
'NOTE: as the code below this if‑statement was copied from SEFormSystem_ResizeForm()
'the following values must be set manually as not passed as argument.
'
ParentFormWidth = SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize * Screen.TwipsPerPixelX
FormWidthNew = GetSEControlXSize(ControlParentFormIndex) * Screen.TwipsPerPixelX
If ParentFormWidth = (‑1) Then ParentFormWidth = FormWidthNew
ParentFormHeight = SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize * Screen.TwipsPerPixelY
FormHeightNew = GetSEControlYSize(ControlParentFormIndex) * Screen.TwipsPerPixelY
If ParentFormHeight = (‑1) Then ParentFormHeight = FormHeightNew
End If
'NOTE: SEControlStructIndex is the index of the control to move/size, ControlParentFormIndex is the index of it's parent form.
'
'NOTE: it is not save that the current control has the pos/size it
'should have, but if the control's pos/size is not saved in
'SEControlStructArray() then use the current control pos/size.
'
If SEControlStructArray(SEControlStructIndex).SEControl_XPos = (‑1) Then
ControlLeft = SEControlStructArray(SEControlStructIndex).SEControl.Left
Else
ControlLeft = SEControlStructArray(SEControlStructIndex).SEControl_XPos * Screen.TwipsPerPixelX 'preset
End If
If SEControlStructArray(SEControlStructIndex).SEControl_YPos = (‑1) Then
ControlTop = SEControlStructArray(SEControlStructIndex).SEControl.Top
Else
ControlTop = SEControlStructArray(SEControlStructIndex).SEControl_YPos * Screen.TwipsPerPixelY 'preset
End If
If SEControlStructArray(SEControlStructIndex).SEControl_XSize = (‑1) Then
ControlWidth = SEControlStructArray(SEControlStructIndex).SEControl.Width
Else
ControlWidth = SEControlStructArray(SEControlStructIndex).SEControl_XSize * Screen.TwipsPerPixelX 'preset
End If
If SEControlStructArray(SEControlStructIndex).SEControl_YSize = (‑1) Then
ControlHeight = SEControlStructArray(SEControlStructIndex).SEControl.Height
Else
ControlHeight = SEControlStructArray(SEControlStructIndex).SEControl_YSize * Screen.TwipsPerPixelY 'preset
End If
'
If Not ((ParentFormWidth < 1) Or (ParentFormHeight < 1)) Then 'verify (important)
With SEControlStructArray(SEControlStructIndex).SEControl
ControlLeft = SEControlStructArray(SEControlStructIndex).SEControl_XPos * Screen.TwipsPerPixelX 'where control should be before 'extended moving' (do not use current control's pos/size)
ControlTop = SEControlStructArray(SEControlStructIndex).SEControl_YPos * Screen.TwipsPerPixelY
ControlWidth = SEControlStructArray(SEControlStructIndex).SEControl_XSize * Screen.TwipsPerPixelX
ControlHeight = SEControlStructArray(SEControlStructIndex).SEControl_YSize * Screen.TwipsPerPixelY
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_RightFixedFlag = True Then
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_LeftFixedFlag = True Then
'ControlWidth = (SEControlStructArray(SEControlStructIndex).SEControl_XSize + (FormWidthNew ‑ ParentFormWidth)) * Screen.TwipsPerPixelX
Else
ControlLeft = ((SEControlStructArray(SEControlStructIndex).SEControl_XPos * Screen.TwipsPerPixelX) + (FormWidthNew ‑ ParentFormWidth))
End If
End If
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_BottomFixedFlag = True Then
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_TopFixedFlag = True Then
'ControlHeight = (SEControlStructArray(SEControlStructIndex).SEControl_YSize + (FormHeightNew ‑ ParentFormHeight)) * Screen.TwipsPerPixelY
Else
ControlTop = ((SEControlStructArray(SEControlStructIndex).SEControl_YPos * Screen.TwipsPerPixelY) + (FormHeightNew ‑ ParentFormHeight))
End If
End If
'verify new control size (important)
If ControlWidth < (GetXGrid * Screen.TwipsPerPixelX) Then ControlWidth = (GetXGrid * Screen.TwipsPerPixelX) 'verify
If ControlWidth > Screen.Width Then ControlWidth = Screen.Width
If ControlHeight < (GetYGrid * Screen.TwipsPerPixelY) Then ControlHeight = (GetYGrid * Screen.TwipsPerPixelY)
If ControlHeight > Screen.Height Then ControlHeight = Screen.Height
'apply new control pos
'Call SetSEControlXPos(SEControlStructIndex, ControlLeft / Screen.TwipsPerPixelX, 0) 'don't use grid
'Call SetSEControlYPos(SEControlStructIndex, ControlTop / Screen.TwipsPerPixelY, 0) 'don't use grid
'NONONO!!! DAMN!!! DIDN'T I SAY DON'T SAVE CONTROL POS???
If Not ((SEControlStructArray(SEControlStructIndex).SEControl.Left = ControlLeft) And (SEControlStructArray(SEControlStructIndex).SEControl.Top = ControlTop)) Then
Call SEControlStructArray(SEControlStructIndex).SEControl.Move(ControlLeft, ControlTop)
End If
End With
Jump:
Else
'data missing, do not move current control
End If
Else
'
'NOTE: the current control's position is not dependent from the parent form size.
'
If Not (SEControlStructArray(SEControlStructIndex).SEControl_XPos = SE_POS_NOT_DEFINED) Then
Call SetSEControlXPos(SEControlStructIndex, SEControlStructArray(SEControlStructIndex).SEControl_XPos, 0) 'don't use grid
End If
If Not (SEControlStructArray(SEControlStructIndex).SEControl_YPos = SE_POS_NOT_DEFINED) Then
Call SetSEControlYPos(SEControlStructIndex, SEControlStructArray(SEControlStructIndex).SEControl_YPos, 0) 'don't use grid
End If
End If
End Select
End If
End Sub
Private Sub SE_RefreshControlSize(ByVal SEControlStructIndex As Integer)
'on error resume next 'a control's size can be refreshed separately to update pool objects
Dim ParentFormWidth As Long 'parent form size at the time the control's position was saved in SkinDataFile
Dim ParentFormHeight As Long
Dim FormWidthNew As Long 'current parent form size
Dim FormHeightNew As Long
Dim TaskBarWidth As Long
Dim TaskBarHeight As Long
Dim ControlLeft As Single
Dim ControlTop As Single
Dim ControlWidth As Single
Dim ControlHeight As Single
Dim ControlParentFormIndex As Integer
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_SEPOLYRGN, SECONTROLTYPE_PSEUDOCONTROL
'cannot be sized
Case SECONTROLTYPE_FORM
If Not (SEControlStructArray(SEControlStructIndex).SEControl_XSize = SE_SIZE_NOT_DEFINED) Then
If Not (SEControlStructArray(SEControlStructIndex).SEControl_YSize = SE_SIZE_NOT_DEFINED) Then
Call SEFormSystem_ResizeForm(SEControlStructIndex, _
SEControlStructArray(SEControlStructIndex).SEControl_XSize, _
SEControlStructArray(SEControlStructIndex).SEControl_YSize)
End If
End If
Case Else
'
'NOTE: it is important to check if the current control's position is dependent from
'its parent form's size. If this is the case the control position must be calculated
'out of the original control position saved in SkinDataFile, and the saved related parent
'form size and the current parent form size.
'If the control's position would just be set like written in the SkinDataFile, the control
'would be moved when the parent form is resized, what leads to flickering or
'a wrong position if the parent form is not sized anymore.
'
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)) Then 'verify to increase speed
'
'NOTE: the current control's position is dependent from the parent form size.
'
If StickControlStructVar.StickSystemEnabledFlag = False Then GoTo Jump:
'
ControlParentFormIndex = GetSEControlStructIndex(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName) 'a special pool instance of parent form
If Not (ControlParentFormIndex = 0) Then 'verify
'
'NOTE: as the code below this if‑statement was copied from SEFormSystem_ResizeForm()
'the following values must be set manually as not passed as argument.
'
ParentFormWidth = SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize * Screen.TwipsPerPixelX
FormWidthNew = GetSEControlXSize(ControlParentFormIndex) * Screen.TwipsPerPixelX
If ParentFormWidth = (‑1) Then ParentFormWidth = FormWidthNew
ParentFormHeight = SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize * Screen.TwipsPerPixelY
FormHeightNew = GetSEControlYSize(ControlParentFormIndex) * Screen.TwipsPerPixelY
If ParentFormHeight = (‑1) Then ParentFormHeight = FormHeightNew
End If
'NOTE: SEControlStructIndex is the index of the control to move/size, ControlParentFormIndex is the index of it's parent form.
'
'NOTE: it is not save that the current control has the pos/size it
'should have, but if the control's pos/size is not saved in
'SEControlStructArray() then use the current control pos/size.
'
If SEControlStructArray(SEControlStructIndex).SEControl_XPos = (‑1) Then
ControlLeft = SEControlStructArray(SEControlStructIndex).SEControl.Left
Else
ControlLeft = SEControlStructArray(SEControlStructIndex).SEControl_XPos * Screen.TwipsPerPixelX 'preset
End If
If SEControlStructArray(SEControlStructIndex).SEControl_YPos = (‑1) Then
ControlTop = SEControlStructArray(SEControlStructIndex).SEControl.Top
Else
ControlTop = SEControlStructArray(SEControlStructIndex).SEControl_YPos * Screen.TwipsPerPixelY 'preset
End If
If SEControlStructArray(SEControlStructIndex).SEControl_XSize = (‑1) Then
ControlWidth = SEControlStructArray(SEControlStructIndex).SEControl.Width
Else
ControlWidth = SEControlStructArray(SEControlStructIndex).SEControl_XSize * Screen.TwipsPerPixelX 'preset
End If
If SEControlStructArray(SEControlStructIndex).SEControl_YSize = (‑1) Then
ControlHeight = SEControlStructArray(SEControlStructIndex).SEControl.Height
Else
ControlHeight = SEControlStructArray(SEControlStructIndex).SEControl_YSize * Screen.TwipsPerPixelY 'preset
End If
'
If Not ((ParentFormWidth < 1) Or (ParentFormHeight < 1)) Then 'verify (important)
With SEControlStructArray(SEControlStructIndex).SEControl
ControlLeft = SEControlStructArray(SEControlStructIndex).SEControl_XPos * Screen.TwipsPerPixelX 'where control should be before 'extended moving' (do not use current control's pos/size)
ControlTop = SEControlStructArray(SEControlStructIndex).SEControl_YPos * Screen.TwipsPerPixelY
ControlWidth = SEControlStructArray(SEControlStructIndex).SEControl_XSize * Screen.TwipsPerPixelX
ControlHeight = SEControlStructArray(SEControlStructIndex).SEControl_YSize * Screen.TwipsPerPixelY
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_RightFixedFlag = True Then
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_LeftFixedFlag = True Then
ControlWidth = ((SEControlStructArray(SEControlStructIndex).SEControl_XSize * Screen.TwipsPerPixelX) + (FormWidthNew ‑ ParentFormWidth))
Else
'ControlLeft = (SEControlStructArray(SEControlStructIndex).SEControl_XPos + (FormWidthNew ‑ ParentFormWidth)) * Screen.TwipsPerPixelX
End If
End If
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_BottomFixedFlag = True Then
If SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_TopFixedFlag = True Then
ControlHeight = ((SEControlStructArray(SEControlStructIndex).SEControl_YSize * Screen.TwipsPerPixelY) + (FormHeightNew ‑ ParentFormHeight))
Else
'ControlTop = (SEControlStructArray(SEControlStructIndex).SEControl_YPos + (FormHeightNew ‑ ParentFormHeight)) * Screen.TwipsPerPixelY
End If
End If
'verify new control size (important)
If ControlWidth < (GetXGrid * Screen.TwipsPerPixelX) Then ControlWidth = (GetXGrid * Screen.TwipsPerPixelX) 'verify
If ControlWidth > Screen.Width Then ControlWidth = Screen.Width
If ControlHeight < (GetYGrid * Screen.TwipsPerPixelY) Then ControlHeight = (GetYGrid * Screen.TwipsPerPixelY)
If ControlHeight > Screen.Height Then ControlHeight = Screen.Height
'apply new control pos
'Call SetSEControlXPos(SEControlStructIndex, ControlLeft / Screen.TwipsPerPixelX, 0) 'don't use grid
'Call SetSEControlYPos(SEControlStructIndex, ControlTop / Screen.TwipsPerPixelY, 0) 'don't use grid
'NONONO!!! DAMN!!! DIDN'T I SAY DON'T SAVE CONTROL POS???
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Width = ControlWidth) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Width = ControlWidth
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Height = ControlHeight) Then _
SEControlStructArray(SEControlStructIndex).SEControl.Height = ControlHeight
End With
Jump:
Else
'data missing, do not move current control
End If
Else
'
'NOTE: the current control's position is not dependent from the parent form size.
'
If Not (SEControlStructArray(SEControlStructIndex).SEControl_XSize = SE_SIZE_NOT_DEFINED) Then
Call SetSEControlXSize(SEControlStructIndex, SEControlStructArray(SEControlStructIndex).SEControl_XSize, 0) 'don't use grid
End If
If Not (SEControlStructArray(SEControlStructIndex).SEControl_YSize = SE_SIZE_NOT_DEFINED) Then
Call SetSEControlYSize(SEControlStructIndex, SEControlStructArray(SEControlStructIndex).SEControl_YSize, 0) 'don't use grid
End If
End If
End Select
End If
End Sub
Public Function SE_RefreshControlEnabledFlag(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'refreshes the EnabledFlag, call if commands were seems as disabled because related form was disabled
'
'NOTE: if this function returns True then the current control's
'enabled flag was changed, what means that the control should be redrawn.
'
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_SEPOLYRGN, SECONTROLTYPE_PSEUDOCONTROL 'controls that have no .Enabled property or where it is not useful to check it
If Not (SEControlStructArray(SEControlStructIndex).SEControl_EnabledFlag = True) Then
SEControlStructArray(SEControlStructIndex).SEControl_EnabledFlag = True
SE_RefreshControlEnabledFlag = True
End If
Case Else
If Not (SEControlStructArray(SEControlStructIndex).SEControl_EnabledFlag = SEControlStructArray(SEControlStructIndex).SEControl.Enabled) Then
SEControlStructArray(SEControlStructIndex).SEControl_EnabledFlag = Not (SEControlStructArray(SEControlStructIndex).SEControl_EnabledFlag) 'do not access control property to save CPU time
SE_RefreshControlEnabledFlag = True
End If
End Select
End If
End Function
Public Function SE_RefreshMousePointer(ByVal SEControlStructIndex As Integer, ByVal SEControlMousePointer As String, ByVal MousePointerUsage As Integer)
'on error resume next
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
If Not ((SEControlStructArray(SEControlStructIndex).SEControl_MouseIconUsageOld = MousePointerUsage) And _
(SEControlStructArray(SEControlStructIndex).SEControl_MouseIconOld = SEControlMousePointer)) Then 'verify changes must be done
'
SEControlStructArray(SEControlStructIndex).SEControl_MouseIconUsageOld = MousePointerUsage
SEControlStructArray(SEControlStructIndex).SEControl_MouseIconOld = SEControlMousePointer
'
Call Graphics_SetSEControlMouseIcon(SEControlStructArray(SEControlStructIndex).SEControl, SEControlStructArray(SEControlStructIndex).SEControlType, SEControlMousePointer, MousePointerUsage)
End If
End If
End Function
Public Sub SE_RefreshForms()
'on error resume next 'refreshes all registered forms once
Dim FormNumber As Integer
Dim FormArray() As Form
Dim TestLoop As Integer
Dim StructLoop As Integer
'begin
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_FORM Then
For TestLoop = 1 To FormNumber 'verify form was not refreshed yet (pool object, poly rgn)
If FormArray(TestLoop) Is SEControlStructArray(StructLoop).SEControl Then GoTo Jump:
Next TestLoop
If SE_IsFormLoaded(SEControlStructArray(StructLoop).SEControl) = False Then GoTo Jump: 'don't load unnecessarily (important for large projects, e.g. Toricxs)
SEControlStructArray(StructLoop).SEControl.Refresh
FormNumber = FormNumber + 1
ReDim Preserve FormArray(1 To FormNumber) As Form
Set FormArray(FormNumber) = SEControlStructArray(StructLoop).SEControl
Jump:
End If
Next StructLoop
End Sub
Public Function SE_IsFormLoaded(ByRef FormObject As Form) As Boolean
'on error resume next 'check return value of this function before accessing Form.Visible or so to avoid permanent reloading
Dim FormLoop As Integer
'begin
For FormLoop = 0 To Forms.Count ‑ 1
If Forms(FormLoop) Is FormObject Then
SE_IsFormLoaded = True
Exit Function
End If
Next FormLoop
SE_IsFormLoaded = False
Exit Function
End Function
Private Sub SE_TabStopSort(ByVal SEControlStructNumber As Integer, ByRef SEControlStructArray() As SEControlStruct)
'on error resume next 'allocates all loaded controls' tab indices
Dim TabIndexNumber As Integer
Dim TabIndexCurrent As Integer
Dim ControlXPosArray() As Long
Dim ControlYPosArray() As Long
Dim ControlIndexArray() As Integer
Dim Loop1 As Integer
Dim Loop2 As Integer
Dim Tempdbl#
Dim Temp As Long
'preset
For Loop1 = 1 To SEControlStructNumber
Select Case SEControlStructArray(Loop1).SEControlType
Case SECONTROLTYPE_SECOMMAND, SECONTROLTYPE_PICTUREBOX, SECONTROLTYPE_TEXTBOX, SECONTROLTYPE_LISTBOX, SECONTROLTYPE_CHECKBOX, SECONTROLTYPE_COMBOBOX, _
SECONTROLTYPE_LABEL, SECONTROLTYPE_OPTIONBUTTON 'controls that have a TabIndex property
If SEControlStructArray(Loop1).SEControl_LoadedFlag = True Then
'
'NOTE: we only sort loaded controls.
'We do not use LoadedControl_IsLoaded() as it is not save that
'LoadedControl_Collect() was called before calling this sub.
'
'NOTE: controls that are in a container (i.e. option button in a frame)
'may not be sorted correctly, but also not chaotic (?!).
'
TabIndexNumber = TabIndexNumber + 1
ReDim Preserve ControlXPosArray(1 To TabIndexNumber) As Long
ReDim Preserve ControlYPosArray(1 To TabIndexNumber) As Long
ReDim Preserve ControlIndexArray(1 To TabIndexNumber) As Integer
'
If TypeOf SEControlStructArray(Loop1).SEControl.Container Is Form Then
ControlXPosArray(TabIndexNumber) = SEControlStructArray(Loop1).SEControl.Left / Screen.TwipsPerPixelX
ControlYPosArray(TabIndexNumber) = SEControlStructArray(Loop1).SEControl.Top / Screen.TwipsPerPixelY
Else
'NOTE: verify that all control types filtered by the Select Case statement above have a Container property.
ControlXPosArray(TabIndexNumber) = (SEControlStructArray(Loop1).SEControl.Left + SEControlStructArray(Loop1).SEControl.Container.Left) / Screen.TwipsPerPixelX
ControlYPosArray(TabIndexNumber) = (SEControlStructArray(Loop1).SEControl.Top + SEControlStructArray(Loop1).SEControl.Container.Top) / Screen.TwipsPerPixelY
End If
'
ControlIndexArray(TabIndexNumber) = Loop1
End If
End Select
Next Loop1
'sort controls by their position, from upper left to bottom right corner
Do
'get left top control
Tempdbl# = (256# ^ 3#) 'preset (position 'product')
For Loop1 = 1 To TabIndexNumber
If (CDbl(ControlXPosArray(Loop1)) + (CDbl(Screen.Width / Screen.TwipsPerPixelX) * CDbl(ControlYPosArray(Loop1)))) < Tempdbl# Then
Tempdbl# = (CDbl(ControlXPosArray(Loop1)) + (CDbl(Screen.Width / Screen.TwipsPerPixelX) * CDbl(ControlYPosArray(Loop1))))
End If
Next Loop1
For Loop1 = 1 To TabIndexNumber
If (CDbl(ControlXPosArray(Loop1)) + (CDbl(Screen.Width / Screen.TwipsPerPixelX) * CDbl(ControlYPosArray(Loop1)))) = _
Tempdbl# Then
TabIndexCurrent = TabIndexCurrent + 1
'NOTE: tab indices must be allocated in ascendenting order or VB will reallocate indices falsely.
SEControlStructArray(ControlIndexArray(Loop1)).SEControl.TabIndex = TabIndexCurrent ‑ 1
ControlXPosArray(Loop1) = (256# ^ 3#) 'reset
ControlYPosArray(Loop1) = (256# ^ 3#) 'reset
End If
Next Loop1
If TabIndexCurrent = TabIndexNumber Then Exit Do 'finished
Loop2 = Loop2 + 1
Loop Until (Loop2 = 32767) 'avoid endless loop
End Sub
Private Sub SE_ZOrderSort(ByVal SEControlStructNumber As Integer, ByRef SEControlStructArray() As SEControlStruct)
'on error resume next 'sets the smallest controls (by area) on top of the z order
Dim ControlXSize As Long
Dim ControlYSize As Long
Dim ControlNumber As Integer
Dim ControlAreaArray() As Long
Dim ControlAreaMax As Long
Dim ControlStructIndexArray() As Integer
Dim Loop1 As Integer
Dim Loop2 As Integer
Dim Temp As Long
Dim TempInt As Integer
'
'NOTE: it seems as if Labels cannot be z‑ordered.
'This is not a Skin Engine bug but by design.
'
'preset
If SEControlStructNumber = 0 Then
Exit Sub 'nothing to do
Else
ControlNumber = SEControlStructNumber
ReDim ControlAreaArray(1 To ControlNumber) As Long
ReDim ControlStructIndexArray(1 To ControlNumber) As Integer
End If
'begin; collect control data
For Loop1 = 1 To SEControlStructNumber
ControlXSize = GetSEControlXSize(Loop1)
ControlYSize = GetSEControlYSize(Loop1)
'
'NOTE: it is important to check if a control's size is defined.
'Use size 1 as default x/y size (not 0) for the case that one
'of the two control sizes (x or y size) is set and usable.
'
If ControlXSize = SE_SIZE_NOT_DEFINED Then ControlXSize = 1
If ControlYSize = SE_SIZE_NOT_DEFINED Then ControlYSize = 1
ControlAreaArray(Loop1) = ControlXSize * ControlYSize
ControlStructIndexArray(Loop1) = Loop1
Next Loop1
'sort controls by area
Do
ControlAreaMax = 0 'reset
For Loop1 = (Loop2 + 1) To ControlNumber
If ControlAreaArray(Loop1) > ControlAreaMax Then
ControlAreaMax = ControlAreaArray(Loop1)
End If
Next Loop1
For Loop1 = (Loop2 + 1) To ControlNumber
If ControlAreaArray(Loop1) = ControlAreaMax Then
Loop2 = Loop2 + 1
Temp = ControlAreaArray(Loop1)
ControlAreaArray(Loop1) = ControlAreaArray(Loop2)
ControlAreaArray(Loop2) = Temp
TempInt = ControlStructIndexArray(Loop1)
ControlStructIndexArray(Loop1) = ControlStructIndexArray(Loop2)
ControlStructIndexArray(Loop2) = TempInt
Exit For
End If
Next Loop1
If Loop2 = ControlNumber Then Exit Do
Loop
'set control z order
For Loop1 = ControlNumber To 1 Step (‑1)
'
'NOTE: we sort the control z order by setting controls AT THE END of the z order.
'So the target project can temporarily display a picture box that hides controls during palette change
'(the SE controls will not be positioned over this picture box).
'
Select Case SEControlStructArray(ControlStructIndexArray(Loop1)).SEControlType
Case SECONTROLTYPE_SECOMMAND, SECONTROLTYPE_PICTUREBOX, SECONTROLTYPE_TEXTBOX, _
SECONTROLTYPE_LISTBOX, SECONTROLTYPE_CHECKBOX, _
SECONTROLTYPE_LABEL, SECONTROLTYPE_FRAME, _
SECONTROLTYPE_OPTIONBUTTON
If SEControlStructArray(ControlStructIndexArray(Loop1)).SEControl_LoadedFlag = True Then
'
'NOTE: to save CPU time we only sort the currently loaded controls
'(we access the flag instead of LoadedControls_IsLoaded() as the loaded
'controls could not have been collected yet by LoadedControl_Collect()).
'
SEControlStructArray(ControlStructIndexArray(Loop1)).SEControl.ZOrder 1
End If
End Select
Next Loop1
End Sub
'********************************END OF CONTROL HANDLING********************************
'************************************CONTROL ADDING*************************************
'***CONTROL ADDING***
'NOTE: when registering a control, a relation control name ‑ control object is
'created. When adding a control, data to set the registered control's appearance
'is saved (will be used to change control's appearance when refreshing control).
Private Function SE_PrepareControl() As Boolean
'On Error Resume Next 'enlarges SEControlStructArray
If Not (SEControlStructNumber = 32766) Then 'verify
SEControlStructNumber = SEControlStructNumber + 1
If ((SEControlStructNumber ‑ 1) Mod 128) = 0 Then 'resize in steps to increase speed
ReDim Preserve SEControlStructArray(1 To (CLng(SEControlStructNumber) + 127&)) As SEControlStruct
End If
SE_PrepareControl = True 'ok
Else
SE_PrepareControl = False 'error
End If
End Function
Private Sub SE_AddControl(ByVal ControlName As String, ByVal SEControlType As Integer, SEControlInfoStructVarPassed As SEControlInfoStruct, ByVal SERelationStructIndex As Integer)
'On Error Resume Next
Dim SEControlInfoStructVar As SEControlInfoStruct
Dim SEControlStructNumberOld As Integer
Dim StructLoop As Integer
Dim TransferLoop As Integer
'preset
SEControlInfoStructVar = SEControlInfoStructVarPassed 'members changed, passed ByRef
If SEControlInfoStructVar.ControlForeColor = SESYSTEM_FORECOLOR Then SEControlInfoStructVar.ControlForeColor = SESystemStructVar.SystemForeColor
If SEControlInfoStructVar.ControlBackColor = SESYSTEM_BACKCOLOR Then SEControlInfoStructVar.ControlBackColor = SESystemStructVar.SystemBackColor
If SEControlInfoStructVar.ControlFont.Name = SESYSTEM_FONT.Name Then SEControlInfoStructVar.ControlFont = SESystemStructVar.SystemFont
'
'NOTE: this sub is to be called by the system when reading the SkinDataFile.
'As a control reference cannot be saved in a file, the system will use the
'SERelationStructArray() to get a control object from a control name read out of
'the SkinDataFile.
'Note that only controls can be added that were previously registered.
'Note that every control has its own sub for adding as the actions that
'must be performed to skin a control vary.
'
'preset
If SERelationStructIndex = 0 Then 'verify index has been passed to speed up control registration
For StructLoop = 1 To SERelationStructNumber
If SERelationStructArray(StructLoop).SEControlName = ControlName Then
SERelationStructIndex = StructLoop
Exit For
End If
Next StructLoop
End If
'begin
If Not (SERelationStructIndex = 0) Then
'control registered, add it to SEControlStructArray()
'
'NOTE: within this sub no control properties should be changed,
'only structure data. Control properties are changed when refreshing.
'
SEControlStructNumberOld = SEControlStructNumber
Select Case SEControlType
Case SECONTROLTYPE_SECOMMAND
Call SE_AddSECommand(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, _
SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlNoFileDropFlag, _
SEControlInfoStructVar.ControlCaption, _
SEControlInfoStructVar.ControlUpPicture, SEControlInfoStructVar.ControlDownPicture, _
SEControlInfoStructVar.ControlMoveOverPicture, _
SEControlInfoStructVar.ControlFont, _
SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_FORM
Call SE_AddForm(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlNoFileDropFlag, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlBackPicture, SEControlInfoStructVar.ControlBackPictureEnabledFlag, _
SEControlInfoStructVar.ControlTitleBarPicture, SEControlInfoStructVar.ControlTitleBarSpawnStartPos, _
SEControlInfoStructVar.ControlTitleBarSpawnLength, SEControlInfoStructVar.ControlTitleBarHeight, _
SERelationStructArray(SERelationStructIndex).SEControlObject.Width / Screen.TwipsPerPixelX, _
SERelationStructArray(SERelationStructIndex).SEControlObject.Height / Screen.TwipsPerPixelY)
Case SECONTROLTYPE_TEXTBOX
Call SE_AddTextBox(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlFont, SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_CHECKBOX
Call SE_AddCheckBox(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlFont, SEControlInfoStructVar.ControlCaption, SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_LISTBOX
Call SE_AddListBox(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlFont, SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_OPTIONBUTTON
Call SE_AddOptionButton(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlFont, SEControlInfoStructVar.ControlCaption, SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_COMBOBOX
Call SE_AddComboBox(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlFont, SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_LINE
Call SE_AddLine(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor)
Case SECONTROLTYPE_GFLISTVIEW
Call SE_AddGFListView(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlNoFileDropFlag, _
SEControlInfoStructVar.ControlGridLinesEnabledFlag, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlBackPicture, SEControlInfoStructVar.ControlBackPictureEnabledFlag, _
SEControlInfoStructVar.ControlFont)
Case SECONTROLTYPE_GFTREEVIEW
Call SE_AddGFTreeView(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, SEControlInfoStructVar.ControlFont)
Case SECONTROLTYPE_FRAME
Call SE_AddFrame(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlFont, SEControlInfoStructVar.ControlCaption, SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_PICTUREBOX
Call SE_AddPictureBox(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlNoFileDropFlag, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlBackPicture, SEControlInfoStructVar.ControlBackPictureEnabledFlag, _
SEControlInfoStructVar.ControlFont, SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_LABEL
Call SE_AddLabel(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlFont, _
SEControlInfoStructVar.ControlCaption, SEControlInfoStructVar.ControlToolTipText)
Case SECONTROLTYPE_GFTABSTRING
Call SE_AddGFTabString(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlFont)
Case SECONTROLTYPE_GFMSGBOX
Call SE_AddGFMsgBox(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlForeColor, SEControlInfoStructVar.ControlBackColor, _
SEControlInfoStructVar.ControlBackPicture, SEControlInfoStructVar.ControlBackPictureEnabledFlag, _
SEControlInfoStructVar.ControlFont)
Case SECONTROLTYPE_SEPOLYRGN
Call SE_AddPolyRgn(ControlName, SERelationStructArray(SERelationStructIndex).SEControlObject, _
SEControlInfoStructVar.ControlPolyRgnPointNumber, _
SEControlInfoStructVar.ControlPolyRgnPointXArray(), SEControlInfoStructVar.ControlPolyRgnPointYArray(), _
SEControlInfoStructVar.ControlXSize, SEControlInfoStructVar.ControlYSize, _
SEControlInfoStructVar.ControlEnabledFlag)
Case SECONTROLTYPE_PSEUDOCONTROL
Call SE_AddPseudoControl(ControlName)
Case Else
GoTo Jump:
End Select
'
'NOTE: if an error occurs during adding a control, SEControlStructIndex would not have been
'increased, and the current control's properties would be set for the control previously added.
'
If SEControlStructNumber = SEControlStructNumberOld Then GoTo Jump: 'verify
'
SEControlStructArray(SEControlStructNumber).SEControl_MouseIcon = SEControlInfoStructVar.ControlMouseIcon
SEControlStructArray(SEControlStructNumber).SEControl_FrameIndex = SEControlInfoStructVar.ControlFrameIndex
SEControlStructArray(SEControlStructNumber).SEControl_XPos = SEControlInfoStructVar.ControlXPos
SEControlStructArray(SEControlStructNumber).SEControl_YPos = SEControlInfoStructVar.ControlYPos
SEControlStructArray(SEControlStructNumber).SEControl_XSize = SEControlInfoStructVar.ControlXSize
SEControlStructArray(SEControlStructNumber).SEControl_YSize = SEControlInfoStructVar.ControlYSize
SEControlStructArray(SEControlStructNumber).SEControl_PaletteNumber = SEControlInfoStructVar.ControlPaletteNumber
SEControlStructArray(SEControlStructNumber).SEControl_ResizeStruct = SEControlInfoStructVar.ControlResizeStruct
If Not (SEControlStructArray(SEControlStructNumber).SEControl_PaletteNumber = 0) Then
ReDim SEControlStructArray(SEControlStructNumber).SEControl_PaletteArray(1 To SEControlStructArray(SEControlStructNumber).SEControl_PaletteNumber) As Integer
For TransferLoop = 1 To SEControlStructArray(SEControlStructNumber).SEControl_PaletteNumber
SEControlStructArray(SEControlStructNumber).SEControl_PaletteArray(TransferLoop) = SEControlInfoStructVar.ControlPaletteArray(TransferLoop)
Next TransferLoop
Else
MsgBox "internal error in SE_AddControl: palette number not set for control '" + SEControlStructArray(SEControlStructNumber).SEControlName + "' !", vbOKOnly + vbExclamation
ReDim SEControlStructArray(SEControlStructNumber).SEControl_PaletteArray(1 To 1) As Integer 'reset
End If
Call SE_RefreshControlEnabledFlag(SEControlStructNumber)
Jump:
End If
End Sub
Private Sub SE_AddForm(ByVal FormName As String, ByRef FormObject As Object, ByVal NoFileDropFlag As Boolean, ByVal FormForeColor As Long, ByVal FormBackColor As Long, ByVal FormBackPictureName As String, ByVal FormBackPictureEnabledFlag As Boolean, ByVal FormTitleBarPictureName As String, ByVal FormTitleBarSpawnStartPos As Long, ByVal FormTitleBarSpawnLength As Long, ByVal FormTitleBarHeight As Long, ByVal FormWidth As Long, ByVal FormHeight As Long)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
'NOTE: if any of the passed picture names is invalid the system will
'ignore it (no picture displayed).
'NOTE: the form is 'skinned' by setting it's Picture property to a
'picture created by the SkinEngine system out of the title bar and back picture.
'This new picture is called display picture.
'Note that the system must recreate this picture every time the form is
'resized.
'
Set SEControlStructArray(SEControlStructNumber).SEControl = FormObject
SEControlStructArray(SEControlStructNumber).SEControlName = FormName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(FormName)
SEControlStructArray(SEControlStructNumber).SEControl_NoFileFropFlag = NoFileDropFlag
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = FormBackColor
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = FormForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackPicture = FormBackPictureName
SEControlStructArray(SEControlStructNumber).SEControl_BackPictureDCStruct.DC = 0 'not in use (see annotation)
SEControlStructArray(SEControlStructNumber).SEControl_BackPictureEnabledFlag = FormBackPictureEnabledFlag
SEControlStructArray(SEControlStructNumber).SEControl_TitleBarPicture = FormTitleBarPictureName
SEControlStructArray(SEControlStructNumber).SEControl_TitleBarPictureDCStruct.DC = 0 'not in use (see annotation)
SEControlStructArray(SEControlStructNumber).SEControl_TitleBarSpawnStartPos = FormTitleBarSpawnStartPos
SEControlStructArray(SEControlStructNumber).SEControl_TitleBarSpawnLength = FormTitleBarSpawnLength
SEControlStructArray(SEControlStructNumber).SEControl_TitleBarHeight = FormTitleBarHeight
SEControlStructArray(SEControlStructNumber).SEControl_DisplayPictureDCStruct.DC = 0 'not in use (see annotation) 'Graphics_CreateDisplayPicture(FormBackPictureName, FormBackPictureEnabledFlag, FormTitleBarPictureName, FormTitleBarSpawnStartPos, FormTitleBarSpawnLength, FormWidth, FormHeight)
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_FORM
If NoFileDropFlag = False Then 'verify file drop is allowed
Call DragAcceptFiles(SEControlStructArray(SEControlStructNumber).SEControl.hwnd, 1)
SEControlStructArray(SEControlStructNumber).SEControl_DragAcceptFilesEnabledFlag = True
End If
End Sub
Private Sub SE_AddSECommand(ByVal SECommandName As String, ByRef SECommandObject As Object, ByVal SECommandForeColor As Long, ByVal SECommandBackColor As Long, ByVal NoFileDropFlag As Boolean, ByVal SECommandCaption As String, ByVal SECommandUpPictureName As String, ByVal SECommandDownPictureName As String, ByVal SECommandMoveOverPictureName As String, ByRef SECommandFont As FontStruct, ByVal SECommandToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
'NOTE: if the passed up‑ or down picture is invalid the system will
'create a default picture and return it's hDC (picture name stays invalid).
'NOTE: the picture DCs will first be created when the control related palette
'is enabled (call SE_RefreshAll() to do so).
'
'preset
SECommandObject.BorderStyle = 0 'no border
'begin
Set SEControlStructArray(SEControlStructNumber).SEControl = SECommandObject
SEControlStructArray(SEControlStructNumber).SEControlName = SECommandName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(SECommandName)
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = SECommandForeColor 'only implemented to make SECM_HasSpecialProperties() work
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = SECommandBackColor 'only implemented to make SECM_HasSpecialProperties() work
SEControlStructArray(SEControlStructNumber).SEControl_NoFileFropFlag = NoFileDropFlag
SEControlStructArray(SEControlStructNumber).SEControl_Caption = SECommandCaption
SEControlStructArray(SEControlStructNumber).SEControl_UpPicture = SECommandUpPictureName
SEControlStructArray(SEControlStructNumber).SEControl_UpPictureDCStruct.DC = 0 'Graphics_GetSECommandPictureDCStruct(SEControlStructNumber, SECONTROLSTATE_NORMAL, SECommandCaption)
SEControlStructArray(SEControlStructNumber).SEControl_DownPicture = SECommandDownPictureName
SEControlStructArray(SEControlStructNumber).SEControl_DownPictureDCStruct.DC = 0 'Graphics_GetSECommandPictureDCStruct(SEControlStructNumber, SECONTROLSTATE_PUSHED, SECommandCaption)
SEControlStructArray(SEControlStructNumber).SEControl_MoveOverPicture = SECommandMoveOverPictureName
SEControlStructArray(SEControlStructNumber).SEControl_MoveOverPictureDCStruct.DC = 0 'Graphics_GetSECommandPictureDCStruct(SEControlStructNumber, SECONTROLSTATE_MOVEOVER, SECommandCaption)
SEControlStructArray(SEControlStructNumber).SEControl_Font = SECommandFont
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = SECommandToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_SECOMMAND
If NoFileDropFlag = False Then 'verify file drop is allowed
Call DragAcceptFiles(SEControlStructArray(SEControlStructNumber).SEControl.hwnd, 1)
SEControlStructArray(SEControlStructNumber).SEControl_DragAcceptFilesEnabledFlag = True
End If
End Sub
Private Sub SE_AddPictureBox(ByVal PictureBoxName As String, ByRef PictureBoxObject As Object, ByVal NoFileDropFlag As Boolean, ByVal PictureBoxForeColor As Long, ByVal PictureBoxBackColor As Long, ByVal PictureBoxBackPictureName As String, ByVal PictureBoxBackPictureEnabledFlag As Boolean, ByRef PictureBoxFont As FontStruct, ByVal PictureBoxToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = PictureBoxName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(PictureBoxName)
Set SEControlStructArray(SEControlStructNumber).SEControl = PictureBoxObject
SEControlStructArray(SEControlStructNumber).SEControl_NoFileFropFlag = NoFileDropFlag
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = PictureBoxForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = PictureBoxBackColor
SEControlStructArray(SEControlStructNumber).SEControl_BackPicture = PictureBoxBackPictureName
SEControlStructArray(SEControlStructNumber).SEControl_BackPictureDCStruct.DC = 0 'will be set later
SEControlStructArray(SEControlStructNumber).SEControl_BackPictureEnabledFlag = PictureBoxBackPictureEnabledFlag
SEControlStructArray(SEControlStructNumber).SEControl_Font = PictureBoxFont
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = PictureBoxToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_PICTUREBOX
If NoFileDropFlag = False Then 'verify file drop is allowed
Call DragAcceptFiles(SEControlStructArray(SEControlStructNumber).SEControl.hwnd, 1)
SEControlStructArray(SEControlStructNumber).SEControl_DragAcceptFilesEnabledFlag = True
End If
End Sub
Private Sub SE_AddTextBox(ByVal TextBoxName As String, ByRef TextBoxObject As Object, ByVal TextBoxForeColor As Long, ByVal TextBoxBackColor As Long, ByRef TextBoxFont As FontStruct, ByVal TextBoxToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = TextBoxName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(TextBoxName)
Set SEControlStructArray(SEControlStructNumber).SEControl = TextBoxObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = TextBoxForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = TextBoxBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = TextBoxFont
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = TextBoxToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_TEXTBOX
End Sub
Private Sub SE_AddListBox(ByVal ListBoxName As String, ByRef ListBoxObject As Object, ByVal ListBoxForeColor As Long, ByVal ListBoxBackColor As Long, ByRef ListBoxFont As FontStruct, ByVal ListBoxToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = ListBoxName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(ListBoxName)
Set SEControlStructArray(SEControlStructNumber).SEControl = ListBoxObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = ListBoxForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = ListBoxBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = ListBoxFont
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = ListBoxToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_LISTBOX
End Sub
Private Sub SE_AddCheckBox(ByVal CheckBoxName As String, ByRef CheckBoxObject As Object, ByVal CheckBoxForeColor As Long, ByVal CheckBoxBackColor As Long, ByRef CheckBoxFont As FontStruct, ByVal CheckBoxCaption As String, ByVal CheckBoxToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = CheckBoxName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(CheckBoxName)
Set SEControlStructArray(SEControlStructNumber).SEControl = CheckBoxObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = CheckBoxForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = CheckBoxBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = CheckBoxFont
SEControlStructArray(SEControlStructNumber).SEControl_Caption = CheckBoxCaption
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = CheckBoxToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_CHECKBOX
End Sub
Private Sub SE_AddComboBox(ByVal ComboBoxName As String, ByRef ComboBoxObject As Object, ByVal ComboBoxForeColor As Long, ByVal ComboBoxBackColor As Long, ByRef ComboBoxFont As FontStruct, ByVal ComboBoxToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = ComboBoxName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(ComboBoxName)
Set SEControlStructArray(SEControlStructNumber).SEControl = ComboBoxObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = ComboBoxForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = ComboBoxBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = ComboBoxFont
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = ComboBoxToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_COMBOBOX
End Sub
Private Sub SE_AddLabel(ByVal LabelName As String, ByRef LabelObject As Object, ByVal LabelForeColor As Long, ByVal LabelBackColor As Long, ByRef LabelFont As FontStruct, ByVal LabelCaption As String, ByVal LabelToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'begin
SEControlStructArray(SEControlStructNumber).SEControlName = LabelName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(LabelName)
Set SEControlStructArray(SEControlStructNumber).SEControl = LabelObject
SEControlStructArray(SEControlStructNumber).SEControl_TransparencyFlag = CBool(LabelObject.BackStyle = 0)
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = LabelForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = LabelBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = LabelFont
SEControlStructArray(SEControlStructNumber).SEControl_Caption = LabelCaption
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = LabelToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_LABEL
End Sub
Private Sub SE_AddLine(ByVal LineName As String, ByRef LineObject As Object, ByVal LineForeColor As Long, ByVal LineBackColor As Long)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = LineName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(LineName)
Set SEControlStructArray(SEControlStructNumber).SEControl = LineObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = LineForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = LineBackColor
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_LINE
End Sub
Private Sub SE_AddFrame(ByVal FrameName As String, ByRef FrameObject As Object, ByVal FrameForeColor As Long, ByVal FrameBackColor As Long, ByRef FrameFont As FontStruct, ByVal FrameCaption As String, ByVal FrameToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = FrameName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(FrameName)
Set SEControlStructArray(SEControlStructNumber).SEControl = FrameObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = FrameForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = FrameBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = FrameFont
SEControlStructArray(SEControlStructNumber).SEControl_Caption = FrameCaption
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = FrameToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_FRAME
End Sub
Private Sub SE_AddOptionButton(ByVal OptionButtonName As String, ByRef OptionButtonObject As Object, ByVal OptionButtonForeColor As Long, ByVal OptionButtonBackColor As Long, ByRef OptionButtonFont As FontStruct, ByVal OptionButtonCaption As String, ByVal OptionButtonToolTipText As String)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = OptionButtonName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(OptionButtonName)
Set SEControlStructArray(SEControlStructNumber).SEControl = OptionButtonObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = OptionButtonForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = OptionButtonBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = OptionButtonFont
SEControlStructArray(SEControlStructNumber).SEControl_Caption = OptionButtonCaption
SEControlStructArray(SEControlStructNumber).SEControl_ToolTipText = OptionButtonToolTipText
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_OPTIONBUTTON
End Sub
Private Sub SE_AddGFListView(ByVal GFListViewName As String, ByRef GFListViewObject As Object, ByVal NoFileDropFlag As Boolean, ByVal GridLinesEnabledFlag As Boolean, ByVal GFListViewForeColor As Long, ByVal GFListViewBackColor As Long, ByVal GFListViewBackPicture As String, ByVal GFListViewBackPictureEnabledFlag As Boolean, ByRef GFListViewFont As FontStruct)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = GFListViewName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(GFListViewName)
Set SEControlStructArray(SEControlStructNumber).SEControl = GFListViewObject
SEControlStructArray(SEControlStructNumber).SEControl_BackPicture = GFListViewBackPicture
SEControlStructArray(SEControlStructNumber).SEControl_BackPictureEnabledFlag = GFListViewBackPictureEnabledFlag
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = GFListViewForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = GFListViewBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = GFListViewFont
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_GFLISTVIEW
SEControlStructArray(SEControlStructNumber).SEControl_GridLinesEnabledFlag = GridLinesEnabledFlag
If NoFileDropFlag = False Then 'verify file drop is allowed
Call DragAcceptFiles(SEControlStructArray(SEControlStructNumber).SEControl.hwnd, 1)
SEControlStructArray(SEControlStructNumber).SEControl_DragAcceptFilesEnabledFlag = True
End If
End Sub
Private Sub SE_AddGFTreeView(ByVal GFTreeViewName As String, ByRef GFTreeViewObject As Object, ByVal GFTreeViewForeColor As Long, ByVal GFTreeViewBackColor As Long, ByRef GFTreeViewFont As FontStruct)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
'NOTE: one cannot change the colors of a tree view (Windows 98 stinks).
'
SEControlStructArray(SEControlStructNumber).SEControlName = GFTreeViewName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(GFTreeViewName)
Set SEControlStructArray(SEControlStructNumber).SEControl = GFTreeViewObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = GFTreeViewForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = GFTreeViewBackColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = GFTreeViewFont
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_GFTREEVIEW
End Sub
Private Sub SE_AddGFTabString(ByVal GFTabStringName As String, ByRef GFTabStringObject As Object, ByVal GFTabStringForeColor As Long, ByRef GFTabStringFont As FontStruct)
'On Error Resume Next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = GFTabStringName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(GFTabStringName)
Set SEControlStructArray(SEControlStructNumber).SEControl = GFTabStringObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = GFTabStringForeColor
SEControlStructArray(SEControlStructNumber).SEControl_Font = GFTabStringFont
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_GFTABSTRING
End Sub
Private Sub SE_AddGFMsgBox(ByVal GFMsgBoxName As String, ByVal GFMsgBoxObject As Object, ByVal GFMsgBoxForeColor As Long, ByVal GFMsgBoxBackColor As Long, ByVal GFMsgBoxBackPictureName As String, ByVal GFMsgBoxBackPictureEnabledFlag As Boolean, ByRef GFMsgBoxFont As FontStruct)
'on error resume next
If SE_PrepareControl = False Then Exit Sub
'
SEControlStructArray(SEControlStructNumber).SEControlName = GFMsgBoxName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(GFMsgBoxName)
Set SEControlStructArray(SEControlStructNumber).SEControl = GFMsgBoxObject
SEControlStructArray(SEControlStructNumber).SEControl_ForeColor = GFMsgBoxForeColor
SEControlStructArray(SEControlStructNumber).SEControl_BackColor = GFMsgBoxBackColor
SEControlStructArray(SEControlStructNumber).SEControl_BackPicture = GFMsgBoxBackPictureName
SEControlStructArray(SEControlStructNumber).SEControl_BackPictureDCStruct.DC = 0 'set when refreshing
SEControlStructArray(SEControlStructNumber).SEControl_BackPictureEnabledFlag = GFMsgBoxBackPictureEnabledFlag
SEControlStructArray(SEControlStructNumber).SEControl_Font = GFMsgBoxFont
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_GFMSGBOX
End Sub
Private Sub SE_AddPolyRgn(ByVal PolyRgnName As String, ByRef PolyRgnForm As Object, ByVal PolyRgnPointNumber As Integer, ByRef PolyRgnPointXArray() As Long, ByRef PolyRgnPointYArray() As Long, ByVal PolyRgnWidthDefault As Long, ByVal PolyRgnHeightDefault As Long, ByVal PolyRgnEnabledFlag As Boolean)
'On Error Resume Next
Dim TransferLoop As Integer
'preset
If SE_PrepareControl = False Then Exit Sub
'begin
SEControlStructArray(SEControlStructNumber).SEControlName = PolyRgnName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(PolyRgnName)
Set SEControlStructArray(SEControlStructNumber).SEControl = PolyRgnForm
'
SEControlStructArray(SEControlStructNumber).SEControl_PolyRgnPointNumber = PolyRgnPointNumber
If Not (PolyRgnPointNumber = 0) Then 'verify
ReDim SEControlStructArray(SEControlStructNumber).SEControl_PolyRgnPointXArray(1 To PolyRgnPointNumber) As Long
ReDim SEControlStructArray(SEControlStructNumber).SEControl_PolyRgnPointYArray(1 To PolyRgnPointNumber) As Long
Else
ReDim SEControlStructArray(SEControlStructNumber).SEControl_PolyRgnPointXArray(1 To 1) As Long 'reset
ReDim SEControlStructArray(SEControlStructNumber).SEControl_PolyRgnPointYArray(1 To 1) As Long 'reset
End If
'
For TransferLoop = 1 To PolyRgnPointNumber
SEControlStructArray(SEControlStructNumber).SEControl_PolyRgnPointXArray(TransferLoop) = PolyRgnPointXArray(TransferLoop)
SEControlStructArray(SEControlStructNumber).SEControl_PolyRgnPointYArray(TransferLoop) = PolyRgnPointYArray(TransferLoop)
Next TransferLoop
SEControlStructArray(SEControlStructNumber).SEControl_PolyRgnEnabledFlag = PolyRgnEnabledFlag
SEControlStructArray(SEControlStructNumber).SEControl_XSize = PolyRgnWidthDefault 'note that this value will be set again in SE_AddControl()
SEControlStructArray(SEControlStructNumber).SEControl_YSize = PolyRgnHeightDefault 'note that this value will be set again in SE_AddControl()
'
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_SEPOLYRGN
End Sub
Private Sub SE_AddPseudoControl(ByVal PseudoControlName As String)
'on error resume next
'
'NOTE: a pseudo control is used to allow editing any SkinDataFile
'content by SEPE.
'
'preset
If SE_PrepareControl = False Then Exit Sub
'begin
SEControlStructArray(SEControlStructNumber).SEControlName = PseudoControlName
SEControlStructArray(SEControlStructNumber).SEControlNameLength = Len(PseudoControlName)
Set SEControlStructArray(SEControlStructNumber).SEControl = Nothing
'
SEControlStructArray(SEControlStructNumber).SEControlType = SECONTROLTYPE_PSEUDOCONTROL
End Sub
'*********************************END OF CONTROL ADDING*********************************
'************************************RESET FUNCTIONS************************************
'NOTE: the following functions are used to remove se data and ‑objects
'partially or completely.
'
'NOTE: about LockWindowUpdate() usage:
'LockWindowUpdate() is to lock a form that is to be refreshed.
'The lock is not removed before the refresh sub is left or an other
'form to refresh 'appears' (in control loop).
'Pay attention that controls related to form are
'‑registered coherently
'‑registered after the form has been registered
'The control order in the SkinDataFile is not important, the points above
'apply to the SE_RegisterControl() calls of the target project only.
'Note that WM_PAINT messages are ignored as long as the window is locked.
'
'IMPORTANT: we don't use LockWindowUpdate() anymore as it leads
'to heavy desktop flickering.
Private Sub SE_SESystemStruct_Reset(ByRef SESystemStructVar As SESystemStruct, ByRef SESystemStructVarUnchanged As SESystemStruct)
'on error resume next
'
'NOTE: this sub must transfer all SESystemStructVar values that
'can optionally be set in the SkinDataFile.
'This is important to avoid that i.e. SECommand picture colors
'are not reset when changing the current skin.
'
SESystemStructVar.SystemForeColor = SESystemStructVarUnchanged.SystemForeColor
SESystemStructVar.SystemBackColor = SESystemStructVarUnchanged.SystemBackColor
SESystemStructVar.SystemFont = SESystemStructVarUnchanged.SystemFont
SESystemStructVar.SystemControlFont = SESystemStructVarUnchanged.SystemControlFont
SESystemStructVar.SystemControlColorStruct.ControlColor = SESystemStructVarUnchanged.SystemControlColorStruct.ControlColor
SESystemStructVar.SystemControlColorStruct.ControlMarkingColor = SESystemStructVarUnchanged.SystemControlColorStruct.ControlMarkingColor
SESystemStructVar.SystemControlColorStruct.ControlTextColor = SESystemStructVarUnchanged.SystemControlColorStruct.ControlTextColor
SESystemStructVar.SystemControlColorStruct.LockedTextColor = SESystemStructVarUnchanged.SystemControlColorStruct.LockedTextColor
SESystemStructVar.SystemControlColorStruct.DarkShadowColor = SESystemStructVarUnchanged.SystemControlColorStruct.DarkShadowColor
SESystemStructVar.SystemControlColorStruct.LightShadowColor = SESystemStructVarUnchanged.SystemControlColorStruct.LightShadowColor
SESystemStructVar.SystemMouseIcon = SESystemStructVarUnchanged.SystemMouseIcon
SESystemStructVar.SystemUseTransparencyFlag = SESystemStructVarUnchanged.SystemUseTransparencyFlag
End Sub
Private Function SE_DeleteTempFiles(ByVal TempFileDir As String) As Boolean 'created out of NN99 sub KillGeneratedTempFiles
On Error Resume Next 'important (if a file cannot be deleted); deletes temp files created using GenerateTempFileName(), returns True if at least one temp file has been deleted, False if not
Dim TempFileNameSample As String
Dim TempFileLoop As Integer
'
'NOTE: the Skin Engine deletes temp files in the following directories:
'‑current skin directory (when changing skin)
'‑CompressionPackFile directory (when exporting skin)
'‑WinTempDir (in SE_Initialize)
'‑ProgramPath (in SE_Initialize)
'
'The target project should create temp files in these directories only.
'
'verify
If DirSave(TempFileDir, vbDirectory) = "" Then
SE_DeleteTempFiles = False 'error
Exit Function
End If
'preset
SE_DeleteTempFiles = False 'preset
'begin
TempFileNameSample = GetFileName(GenerateTempFileName(TempFileDir)) 'create file name only
GFSkinEnginefrm.GFSkinEngineFile.Path = TempFileDir
GFSkinEnginefrm.GFSkinEngineFile.Pattern = "*." + GetFileNameSuffix(TempFileNameSample) 'set pattern to file type of generated temp files
GFSkinEnginefrm.GFSkinEngineFile.Refresh
For TempFileLoop = 1 To GFSkinEnginefrm.GFSkinEngineFile.ListCount
If ((LTrim$(Str$(Val("1" + GetFileMainName(GFSkinEnginefrm.GFSkinEngineFile.List(TempFileLoop ‑ 1)))))) = _
("1" + GetFileMainName(GFSkinEnginefrm.GFSkinEngineFile.List(TempFileLoop ‑ 1)))) And _
(Len(GetFileMainName(GFSkinEnginefrm.GFSkinEngineFile.List(TempFileLoop ‑ 1))) = _
Len(GetFileMainName(TempFileNameSample))) Then 'add 1 to avoid error if any file has a '0' at beginning of its name
'
'NOTE: condition above: a file name must have an equal number of chars than
'the generated temp file name and its main name must consist of numbers only.
'
Kill TempFileDir + GFSkinEnginefrm.GFSkinEngineFile.List(TempFileLoop ‑ 1)
SE_DeleteTempFiles = True
End If
Next TempFileLoop
Exit Function
End Function
Private Function GetTempDir() As String
'On Error Resume Next 'returns OS temp directory (application path if not defined)
Dim Tempstr$
Tempstr$ = String$(260, Chr$(0))
Call GetTempPath(260, Tempstr$)
If Not (InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) = 0) Then 'verify
GetTempDir = Left$(Tempstr$, InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) ‑ 1)
Else
GetTempDir = Tempstr$
End If
End Function
Public Sub SE_Reset()
'On Error Resume Next 'resets the SEControlStruct vars
Dim StructLoop As Integer
'begin
For StructLoop = 1 To SEControlStructNumber
Call SE_UnloadControl(SEControlStructArray(StructLoop).SEControlName, StructLoop)
Next StructLoop
SEControlStructNumber = 0 'reset
ReDim SEControlStructArray(1 To 1) As SEControlStruct 'reset
Call GFCursor_Reset 'reset
'
'NOTE: do NOT reset UpdateCheckStructArray() here or mysterious erros
'will occur when using the UpdateCheck system.
'
End Sub
Public Sub SE_Terminate()
'On Error Resume Next 'call when unloading target project (important)
Dim StructLoop As Integer
'begin
Call SEM_Mark_Remove
Call SEM_UserMove_Abort(UserMoveStructVar)
Call SEM_PolyRgn_Abort
Call DisabledPictureCache_Reset(SEControlStructNumber, SEControlStructArray())
Call FrameBrushCache_Reset(SESystemStructVar)
For StructLoop = 1 To SEControlStructNumber
Call SE_UnloadControl(SEControlStructArray(StructLoop).SEControlName, StructLoop) 'free up memory
If SEControlStructArray(StructLoop).SEControl_DragAcceptFilesEnabledFlag = True Then
SEControlStructArray(StructLoop).SEControl_DragAcceptFilesEnabledFlag = False 'reset
Call DragAcceptFiles(SEControlStructArray(StructLoop).SEControl.hwnd, 0)
End If
Next StructLoop
Call GFSubClass_Terminate
Call SE_Reset
Call SE_DeleteTempFiles(WinTempDir) 'also done when initializing
Call SE_DeleteTempFiles(ProgramPath) 'also done when initializing
End Sub
'********************************END OF RESET FUNCTIONS*********************************
'**************************************SE SUBCLASS**************************************
'NOTE: it was necessary to create an own subclassing sub system to avoid stack overflows
'when changing skin (?) and to increase the skin changing speed.
'Disable the subclassing before changing the skin and re‑enable it afterwards.
Private Sub SE_SubClass_Enable(ByVal SEControlStructNumber As Integer, ByRef SEControlStructArray() As SEControlStruct)
'on error resume next
Dim StructLoop As Integer
'begin
For StructLoop = 1 To SEControlStructNumber
'NOTE: not all control types are subclassed.
Select Case SEControlStructArray(StructLoop).SEControlType
Case SECONTROLTYPE_FORM, SECONTROLTYPE_SECOMMAND, SECONTROLTYPE_PICTUREBOX, SECONTROLTYPE_TEXTBOX, _
SECONTROLTYPE_LISTBOX, SECONTROLTYPE_CHECKBOX, SECONTROLTYPE_COMBOBOX, _
SECONTROLTYPE_FRAME, SECONTROLTYPE_OPTIONBUTTON, _
SECONTROLTYPE_GFLISTVIEW, SECONTROLTYPE_GFTREEVIEW
'
'NOTE: GFSkinEnginefrm as sub class target form is added with
'CallTargetFormAtFirstFlag = True so that the Skin Engine will receive
'any subclassed message before all other target forms receive it.
'Other sub systems must not use CallTargetFormAtFirstFlag = True.
'
Call GFSubClass(SEControlStructArray(StructLoop).SEControl, _
SEControlStructArray(StructLoop).SEControlName, _
GFSkinEnginefrm, True, 0, True) 'will check if control is already subclassed
'
End Select
Next StructLoop
End Sub
Private Sub SE_SubClass_Disable(ByVal SEControlStructNumber As Integer, ByRef SEControlStructArray() As SEControlStruct)
'on error resume next
Dim StructLoop As Integer
'begin
For StructLoop = 1 To SEControlStructNumber
Call GFSubClass_UnSubclass(SEControlStructArray(StructLoop).SEControlName, GFSkinEnginefrm) 'remove subclassing (important)
Next StructLoop
End Sub
'**********************************END OF SE SUBCLASS***********************************
'************************************LOADED CONTROL*************************************
'NOTE: the LoadedControl sub system is used to determine if a control is loaded
'and thus if incoming messages have to be processed.
'To increase speed the names of the loaded controls are collected when
'LoadedControl_Collect() is called only. It is supposed that the number of
'loaded controls is higher than that of the unloaded controls.
'
'The system should call the LoadedControl functions in the following order:
'LoadedControl_IsLoaded()
'LoadedControl_IsInPalette()
'LoadedControl_MustProcess_WM_PAINT()
'If any of the functions return False the message processing sub should be left
'(not all LoadedControl functions need to be used for some messages).
'
'Pass strings ByRef to increase code processing speed.
'
'IMPORTANT: do not try to process hWnd instead of SourceDescription,
'it will not work for pool objects!
Public Function LoadedControl_IsLoaded(ByRef ControlName As String) As Boolean
'on error resume next 'returns True if control is loaded and thus its messages are to be processed, False if not; string is passed ByRef to increase speed
Dim ControlNameLength As Long
Dim StructLoop As Integer
'begin
ControlNameLength = Len(ControlName)
For StructLoop = 1 To LoadedControlStructNumber
If LoadedControlStructArray(StructLoop).ControlNameLength = ControlNameLength Then
If LoadedControlStructArray(StructLoop).ControlName = ControlName Then
LoadedControl_IsLoaded = True
Exit Function
End If
End If
Next StructLoop
LoadedControl_IsLoaded = False
Exit Function
End Function
Public Function LoadedControl_IsInPalette(ByRef ControlName As String) As Boolean
'on error resume next 'returns True if control is in any visible palette, False if not
Dim ControlNameLength As Long
Dim StructLoop As Integer
'begin
ControlNameLength = Len(ControlName)
For StructLoop = 1 To LoadedControlStructNumber
If LoadedControlStructArray(StructLoop).ControlNameLength = ControlNameLength Then
If LoadedControlStructArray(StructLoop).ControlName = ControlName Then
LoadedControl_IsInPalette = LoadedControlStructArray(StructLoop).ControlInPaletteFlag 'flag updated by LoadedControl_Collect() whenever the current palette is changed
Exit Function
End If
End If
Next StructLoop
LoadedControl_IsInPalette = False
Exit Function
End Function
Public Function LoadedControl_MustProcess_WM_PAINT(ByRef ControlName As String) As Boolean
'on error resume next 'returns True if WM_PAINT messages for control must be processed, False if not
Dim ControlNameLength As Long
Dim StructLoop As Integer
'begin
ControlNameLength = Len(ControlName)
For StructLoop = 1 To LoadedControlStructNumber
If LoadedControlStructArray(StructLoop).ControlNameLength = ControlNameLength Then
If LoadedControlStructArray(StructLoop).ControlName = ControlName Then
Select Case LoadedControlStructArray(StructLoop).ControlType
Case SECONTROLTYPE_SECOMMAND, SECONTROLTYPE_PICTUREBOX, SECONTROLTYPE_TEXTBOX, _
SECONTROLTYPE_LISTBOX, SECONTROLTYPE_COMBOBOX, _
SECONTROLTYPE_FRAME
LoadedControl_MustProcess_WM_PAINT = True
Case Else
LoadedControl_MustProcess_WM_PAINT = False
End Select
Exit Function
End If
End If
Next StructLoop
LoadedControl_MustProcess_WM_PAINT = False
Exit Function
End Function
Public Sub LoadedControl_Collect(ByVal SEControlStructNumber As Integer, ByRef SEControlStructArray() As SEControlStruct, Optional ByVal PaletteNumberOld As Integer = ‑32766)
'on error resume next
Dim StructLoop As Integer
'
'NOTE: call this sub whenever controls are loaded or unloaded.
'Note that this sub needn't to be called if a control is only loaded to update
'any of its pictures and this control has been already loaded before.
'Also call this sub after the current palette has changed.
'
'reset
LoadedControlStructNumber = 0 'reset
ReDim LoadedControlStructArray(1 To 1) As LoadedControlStruct 'reset
'begin
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControl_LoadedFlag = True Then
LoadedControlStructNumber = LoadedControlStructNumber + 1 'cannot overflow
ReDim Preserve LoadedControlStructArray(1 To LoadedControlStructNumber) As LoadedControlStruct
LoadedControlStructArray(LoadedControlStructNumber).ControlName = SEControlStructArray(StructLoop).SEControlName
LoadedControlStructArray(LoadedControlStructNumber).ControlNameLength = Len(SEControlStructArray(StructLoop).SEControlName)
LoadedControlStructArray(LoadedControlStructNumber).ControlType = SEControlStructArray(StructLoop).SEControlType
If PaletteNumberOld = ‑32766 Then 'ignore old palette number
LoadedControlStructArray(LoadedControlStructNumber).ControlInPaletteFlag = _
(IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray())) Or _
(IsControlPaletteEqual(‑1, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray())) Or _
(IsControlInExternalPalette(StructLoop))
Else
LoadedControlStructArray(LoadedControlStructNumber).ControlInPaletteFlag = _
(IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray())) Or _
(IsControlPaletteEqual(PaletteNumberOld, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray())) Or _
(IsControlPaletteEqual(‑1, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray())) Or _
(IsControlInExternalPalette(StructLoop))
'
'NOTE: when changing the current palette the unloading of 'old' controls
'can be delayed. To verify the 'old' controls are still redrawn PaletteNumberOld
'can be passed so that the SE message processing code still processes
'WM_PAINT messages of the controls of the 'old' palette that have not been
'unloaded yet.
'
End If
End If
Next StructLoop
End Sub
'*********************************END OF LOADED CONTROL*********************************
'*****************************************POOL******************************************
'NOTE: there was the problem that the target project required a form to have multiple
'background pictures, changing when the control palette is changed. Therefore the
'pool sub system was implemented.
'There is one control object, but several control names refer to it. Example:
'SE_RegisterControl("Form1_1", Form1)
'SE_RegisterControl("Form1_2", Form2)
'In SkinDataFile:
'system_palettenumber=1
'[Form1_1]
'backpicture=c:\claw.bmp
'system_palettenumber=2
'[Form2_2]
'backpicture=c:\billpie.bmp
'
'When the control palette changes, the back picture of Form1 changes, too.
'Note that every control name appears ONCE in SkinDataFile,
'but objects may be made related to control names SEVERAL TIMES.
'That's why we needn't to check the current palette number against a control's
'palette number when getting a control struct index from the control name.
'But we need to check if we get a control struct index from a control object.
'
'When getting a control struct index from a control object, the used function
'(see below) must returns the control name, whose palette number is
'closest 'below' the current palette number.
'
Public Function IsPoolObject(ByRef SEControlObject As Object, Optional ByVal SEControlType As Integer = ‑1) As Boolean
'on error resume next 'returns True if the same control object has several names, False if it has one name or if control is not existing
Dim SEControlObjectNameNumber As Integer
Dim StructLoop As Integer
'begin
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControl Is SEControlObject Then
If (SEControlStructArray(StructLoop).SEControlType = SEControlType) Or (SEControlType = ‑1) Then 'check of se control object serves as right object type
SEControlObjectNameNumber = SEControlObjectNameNumber + 1
End If
End If
Next StructLoop
If SEControlObjectNameNumber > 1 Then
IsPoolObject = True
Else
IsPoolObject = False
End If
End Function
Public Function GetSEControlNameFromControlObject(ByRef SEControlObject As Object, Optional ByVal SEControlType As Integer = ‑1, Optional ByVal SystemPaletteNumberNew As Integer = ‑32767) As String
'on error resume next 'use this function when opening a se pop up menu
Dim SEControlStructIndex As Integer
'verify
If SystemPaletteNumberNew = ‑32767 Then SystemPaletteNumberNew = SESystemStructVar.SystemPaletteNumberCurrent
'begin
SEControlStructIndex = GetSEControlStructIndexFromControlObject(SEControlObject, SEControlType, SystemPaletteNumberNew)
If Not (SEControlStructIndex = 0) Then 'verify
GetSEControlNameFromControlObject = SEControlStructArray(SEControlStructIndex).SEControlName
Else
GetSEControlNameFromControlObject = "" 'reset (error)
End If
End Function
Public Function GetSEControlStructIndexFromControlObject(ByRef SEControlObject As Object, Optional ByVal SEControlType As Integer = ‑1, Optional ByVal SystemPaletteNumberNew As Integer = 0) As Integer
'on error resume next 'returns SEControlStructIndex or 0 for error; read annotations about the pool sub system
Dim SEControlObjectNameNumber As Integer 'how many names are associated with the passed object
Dim SEControlObjectStructIndexFirst As Integer
Dim PaletteDistanceMin As Integer
Dim StructLoop As Integer
'preset
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControl Is SEControlObject Then
If (SEControlStructArray(StructLoop).SEControlType = SEControlType) Or (SEControlType = ‑1) Then 'check of se control object serves as right object type
SEControlObjectNameNumber = SEControlObjectNameNumber + 1
If SEControlObjectNameNumber = 1 Then
SEControlObjectStructIndexFirst = StructLoop
End If
End If
End If
Next StructLoop
'begin
If SEControlObjectNameNumber = 0 Then
GetSEControlStructIndexFromControlObject = 0 'error
'NOTE: do not create an error message as it would also be displayed if a form has no poly rgn.
Debug.Print "internal error in GetSEControlStructIndexFromControlObject(): pool object not found !"
Exit Function
End If
If SEControlObjectNameNumber = 1 Then
GetSEControlStructIndexFromControlObject = SEControlObjectStructIndexFirst 'ok
Exit Function
Else
'GetSEControlStructIndexFromControlObject = SEControlObjectStructIndexFirst 'preset
GetSEControlStructIndexFromControlObject = 0 'return 0 if no control is on current palette
PaletteDistanceMin = 32767
'search control whose palette array contains current palette
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControl Is SEControlObject Then
If (SEControlStructArray(StructLoop).SEControlType = SEControlType) Or (SEControlType = ‑1) Then 'check of se control object serves as right object type
If IsControlPaletteEqual(SystemPaletteNumberNew, SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
GetSEControlStructIndexFromControlObject = StructLoop 'ok
Exit For 'ok
End If
End If
End If
Next StructLoop
Exit Function
End If
End Function
Private Function GetPoolControlStructIndex(ByVal SEControlName As String) As Integer
'on error resume next 'returns palette‑dependent SEControlStructIndex, 0 for error
Dim SEControlStructIndex As Integer
'
'NOTE: use this function to get the index of the current pool instance of a pool control.
'
'begin
SEControlStructIndex = GetSEControlStructIndex(SEControlName)
If (SEControlStructIndex) Then 'verify
GetPoolControlStructIndex = GetSEControlStructIndexFromControlObject(SEControlStructArray(SEControlStructIndex).SEControl, SEControlStructArray(SEControlStructIndex).SEControlType, SESystemStructVar.SystemPaletteNumberCurrent) 'ok
Else
GetPoolControlStructIndex = 0 'error
End If
End Function
Public Function IsControlPaletteEqual(ByVal SystemPaletteNumberCurrent As Integer, ByVal ControlPaletteNumber As Integer, ByRef ControlPaletteArray() As Integer) As Boolean
'on error resume next
Dim TestLoop As Integer
'preset
IsControlPaletteEqual = False
'begin
For TestLoop = 1 To ControlPaletteNumber
If ControlPaletteArray(TestLoop) = SystemPaletteNumberCurrent Then
IsControlPaletteEqual = True
Exit Function
End If
Next TestLoop
Exit Function
End Function
Public Function IsControlPaletteEqualEx(ByVal ControlPaletteNumber1 As Integer, ByRef ControlPaletteArray1() As Integer, ByVal ControlPaletteNumber2 As Integer, ByRef ControlPaletteArray2() As Integer) As Boolean
'on error resume next 'use to check if two controls are in the same palette
Dim PaletteLoop1 As Integer
Dim PaletteLoop2 As Integer
'preset
IsControlPaletteEqualEx = False
'begin
For PaletteLoop1 = 1 To ControlPaletteNumber1
For PaletteLoop2 = 1 To ControlPaletteNumber2
If ControlPaletteArray2(PaletteLoop2) = ControlPaletteArray1(PaletteLoop1) Then
IsControlPaletteEqualEx = True
Exit Function
End If
Next PaletteLoop2
Next PaletteLoop1
Exit Function
End Function
Public Function GetSEControlStructIndex(ByVal SEControlName As String) As Integer
'On Error Resume Next 'important function
Dim SEControlNameLength As Long
Dim StructLoop As Integer
'preset
'
'NOTE: tests showed that around 60% of the requested indices are cached
'(so don't remove the cache).
'
SEControlNameLength = Len(SEControlName)
For StructLoop = 1 To 16 'loop through cache
If SEControlNameLength = SEControlStructIndexCacheStructArray(StructLoop).SEControlNameLength Then
If SEControlName = SEControlStructIndexCacheStructArray(StructLoop).SEControlName Then
GetSEControlStructIndex = SEControlStructIndexCacheStructArray(StructLoop).SEControlStructIndex
Exit Function
End If
End If
Next StructLoop
'begin
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControlNameLength = SEControlNameLength Then 'check first to increase speed
If SEControlStructArray(StructLoop).SEControlName = SEControlName Then
'update cache
SEControlStructIndexCacheStructPointer = SEControlStructIndexCacheStructPointer + 1 '0 ‑> 1 at start up
If SEControlStructIndexCacheStructPointer > 16 Then SEControlStructIndexCacheStructPointer = 1 'verify
SEControlStructIndexCacheStructArray(SEControlStructIndexCacheStructPointer).SEControlName = SEControlName
SEControlStructIndexCacheStructArray(SEControlStructIndexCacheStructPointer).SEControlNameLength = SEControlNameLength 'length has already been determined
SEControlStructIndexCacheStructArray(SEControlStructIndexCacheStructPointer).SEControlStructIndex = StructLoop
'end of updating cache
GetSEControlStructIndex = StructLoop
Exit Function
End If
End If
Next StructLoop
GetSEControlStructIndex = 0
Exit Function
End Function
Public Function GetSEControlState(ByVal SEControlName As String) As Integer
'on error resume next 'returns one of the control state constants or True for error
Dim SEControlStructIndex As Integer
'
'NOTE: the returned value could be 0 if no control state
'has been set for the current control yet.
'
'begin
SEControlStructIndex = GetSEControlStructIndex(SEControlName)
If Not (SEControlStructIndex = 0) Then 'verify
GetSEControlState = SEControlStructArray(SEControlStructIndex).SEControlState
Else
GetSEControlState = True 'error
End If
End Function
'**************************************END OF POOL**************************************
'***********************************SYSTEM INTERFACE************************************
'NOTE: the following subs/functions are interface functions between the Skin Engine
'and the target project, exchanging or setting 'small' data.
Public Function SE_GetSystemColor(ByVal SystemColorIndex As Integer) As Long
'On Error Resume Next 'get a system color set by a SkinDataFile entry
If Not ((SystemColorIndex < LBound(SESystemStructVar.SystemColorArray())) Or (SystemColorIndex > UBound(SESystemStructVar.SystemColorArray()))) Then 'verify
SE_GetSystemColor = SESystemStructVar.SystemColorArray(SystemColorIndex)
Else
SE_GetSystemColor = 0 'error
End If
End Function
Public Function SE_SetSystemColor(ByVal SystemColorIndex As Integer, ByVal SystemColor As Long, Optional ByVal AvoidSkinDataFileWriteFlag As Boolean = False) As Boolean
'on error resume next 'returns True if SystemColor has been saved, False if not
Dim SkinDataFileString As String
'
'NOTE: the SystemColor entry must already exist in the SkinDataFile.
'
'begin
If AvoidSkinDataFileWriteFlag = False Then
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString)
If (InStr(1, SkinDataFileString, "system_color" + LTrim$(Str$(SystemColorIndex)) + "=", vbTextCompare)) Then 'verify SystemColor entry is already existing
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_color" + LTrim$(Str$(SystemColorIndex)), COLORTOSTRING(SystemColor), False, False)
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
SESystemStructVar.SystemColorArray(SystemColorIndex) = SystemColor
SE_SetSystemColor = True 'ok
Else
SE_SetSystemColor = False 'error
End If
Else
SESystemStructVar.SystemColorArray(SystemColorIndex) = SystemColor
SE_SetSystemColor = False 'error (not saved)
End If
End Function
Public Function SE_GetSystemText(ByVal SystemTextIndex As Integer) As String
'On Error Resume Next 'get a system text set by a SkinDataFile entry
'
'NOTE: LineBreak() was already used, the returned text contains Chr$(13) + Chr$(10) instead of '|'.
'
If Not ((SystemTextIndex < LBound(SESystemStructVar.SystemTextArray())) Or (SystemTextIndex > UBound(SESystemStructVar.SystemTextArray()))) Then 'verify
SE_GetSystemText = LineBreak(SESystemStructVar.SystemTextArray(SystemTextIndex))
Else
SE_GetSystemText = "" 'reset (error)
End If
End Function
Public Function SE_SetSystemText(ByVal SystemTextIndex As Integer, ByVal SystemText As String, Optional ByVal AvoidSkinDataFileWriteFlag As Boolean = False) As Boolean
'on error resume next 'returns True if SystemText has been saved, False if not
Dim SkinDataFileString As String
'
'NOTE: the SystemText entry must already exist in the SkinDataFile.
'
'begin
If AvoidSkinDataFileWriteFlag = False Then
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString)
If (InStr(1, SkinDataFileString, "system_text" + LTrim$(Str$(SystemTextIndex)) + "=", vbTextCompare)) Then 'verify SystemText entry is already existing
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_text" + LTrim$(Str$(SystemTextIndex)), SystemText, False, False)
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
SESystemStructVar.SystemTextArray(SystemTextIndex) = SystemText
SE_SetSystemText = True 'ok
Else
SE_SetSystemText = False 'error
End If
Else
SESystemStructVar.SystemTextArray(SystemTextIndex) = ReLineBreak(SystemText)
SE_SetSystemText = False 'error (not saved)
End If
End Function
'********************************END OF SYSTEM INTERFACE********************************
'**********************************SE GRAPHICS SYSTEM***********************************
'NOTE: the following functions are used to create or handle graphics used for skinning.
'Graphics are used for either a form or an se command.
'The graphics system must provide a 'display picture' for the form and
'an 'up‑', 'down‑' and 'move over picture' for every se command.
Private Function Graphics_CreateDisplayPicture(ByVal FormBackPictureName As String, ByRef FormBackPictureEnabledFlag As Boolean, ByVal FormTitleBarPictureName As String, ByVal FormTitleBarSpawnStartPos As Long, ByVal FormTitleBarSpawnLength As Long, ByVal FormWidth As Long, ByVal FormHeight As Long) As DCStruct
'On Error Resume Next 'size format: pixels; creates a DC, fills it with the display picture and returns the handle of the DC
Dim DCStructVar As DCStruct
Dim Temp As Long
'
'NOTE: this sub will create the 'display picture' that will be used to 'skin' a form.
'The display picture is created by tiling the back picture so that it fits to the
'target form size. At the top of the display picture the title bar is placed,
'if the form has a largest width than the title bar picture, the title bar picture
'will be extended by copying around pieces of it (BLAHBLAH).
'NOTE: the system temp picture boxes must have set the ScaleMode to vbTwips.
'NOTE: this sub will disable the FormBackPictureEnabledFlag if
'FormBackPictureName is invalid.
'
'verify
If (DirSave(FormBackPictureName) = "") Or (Right$(FormBackPictureName, 1) = "\") Or (FormBackPictureName = "") Then
'NOTE: FormBackPictureEnabledFlag is passed ByRef.
'Debug.Print "Form back picture disabled as invalid"
FormBackPictureEnabledFlag = False 'reset (error)
End If
ReDo:
'begin
If FormBackPictureEnabledFlag = True Then
'back picture is enabled
If SE_FileToPictureBox(FormBackPictureName, SESystemStructVar.SystemTempPicture) = False Then GoTo BackPictureError::
SESystemStructVar.SystemTempPicture2.Width = (FormWidth + 4) * Screen.TwipsPerPixelX 'add 4 pixels for picture box frame
SESystemStructVar.SystemTempPicture2.Height = (FormHeight + 4) * Screen.TwipsPerPixelY 'add 4 pixels for picture box frame
Call GFTilePicture(SESystemStructVar.SystemTempPicture, SESystemStructVar.SystemTempPicture2)
Call SE_FileFromPictureBox(SESystemStructVar.SystemTempPicture) 'reset
SESystemStructVar.SystemTempPicture2.Refresh 'important (!!!)
Else
'back picture is disabled
Call SE_FileFromPictureBox(SESystemStructVar.SystemTempPicture2) 'reset (important)
SESystemStructVar.SystemTempPicture2.Width = (FormWidth + 4) * Screen.TwipsPerPixelX 'fit temp picture width to form width
SESystemStructVar.SystemTempPicture2.Height = (FormHeight + 4) * Screen.TwipsPerPixelY 'fit temp picture height to form height
End If
'
'NOTE: the system temp picture #2 now contains the back ground picture
'that was made fit to the target form size. Add the first bit of the title bar.
'
If Not ((DirSave(FormTitleBarPictureName) = "") Or (Right$(FormTitleBarPictureName, 1) = "\") Or (FormTitleBarPictureName = "")) Then 'verify
'
'NOTE: there is no need to use a title bar picture.
'
If SE_FileToPictureBox(FormTitleBarPictureName, SESystemStructVar.SystemTempPicture) = False Then GoTo TitleBarPictureError:
'copy the left part of the title bar picture to the display picture image
'
'NOTE: generally 1 must be subtracted from BitBlt() position coordinates
'as these coordinates are 0‑based (the values of the SkinDataFile aren't).
'
Call BitBlt(SESystemStructVar.SystemTempPicture2.hDC, 0, 0, _
FormTitleBarSpawnStartPos ‑ 1, SESystemStructVar.SystemTempPicture.ScaleHeight / Screen.TwipsPerPixelY, _
SESystemStructVar.SystemTempPicture.hDC, 0, 0, vbSrcCopy)
SESystemStructVar.SystemTempPicture2.Refresh 'important (!!!)
For Temp = 1 To Int((FormWidth ‑ (SESystemStructVar.SystemTempPicture.ScaleWidth / Screen.TwipsPerPixelX)) / FormTitleBarSpawnLength) + 2 'add one as one spawn piece is included in the picture box width, add 2 (tested, round down)
'
'NOTE: if the last spawn piece does not fit into the resting gap, the spawn piece is
'not shorted but printed anyway as the right title bar piece will 'overwrite'
'the surplus spawn piece area.
'NOTE: the spawning has been tested successfully.
'
Call BitBlt(SESystemStructVar.SystemTempPicture2.hDC, _
FormTitleBarSpawnStartPos + (Temp ‑ 1) * FormTitleBarSpawnLength ‑ 1, 0, _
FormTitleBarSpawnLength, SESystemStructVar.SystemTempPicture.ScaleHeight / Screen.TwipsPerPixelY, _
SESystemStructVar.SystemTempPicture.hDC, FormTitleBarSpawnStartPos ‑ 1, 0, vbSrcCopy)
SESystemStructVar.SystemTempPicture2.Refresh 'important (!!!)
Next Temp
'copy the right part if the title bar to the display picture image
'
'NOTE: the spawn piece (spawn start pos + spawn length) is not displayed in the
'left or right end of the final title bar (only in spawned area).
'
Call BitBlt(SESystemStructVar.SystemTempPicture2.hDC, _
(SESystemStructVar.SystemTempPicture2.ScaleWidth / Screen.TwipsPerPixelX) ‑ ((SESystemStructVar.SystemTempPicture.ScaleWidth / Screen.TwipsPerPixelX) ‑ (FormTitleBarSpawnStartPos + FormTitleBarSpawnLength)), 0, _
((SESystemStructVar.SystemTempPicture.ScaleWidth / Screen.TwipsPerPixelX) ‑ (FormTitleBarSpawnStartPos + FormTitleBarSpawnLength)), _
(SESystemStructVar.SystemTempPicture.ScaleHeight / Screen.TwipsPerPixelY), _
SESystemStructVar.SystemTempPicture.hDC, (FormTitleBarSpawnStartPos + FormTitleBarSpawnLength), 0, vbSrcCopy)
Call SE_FileFromPictureBox(SESystemStructVar.SystemTempPicture) 'reset
SESystemStructVar.SystemTempPicture2.Refresh 'important (!!!)
End If
If SESystemStructVar.ColorSchemeEnabledFlag = True Then 'hehe
Call GFAlphaBlendfrm.GFAlphaBlend_Colorize( _
SESystemStructVar.SystemTempPicture2.hDC, _
SESystemStructVar.SystemTempPicture2.ScaleWidth / Screen.TwipsPerPixelX, _
SESystemStructVar.SystemTempPicture2.ScaleHeight / Screen.TwipsPerPixelY, _
SESystemStructVar.ColorSchemeColor) 'slow, but looks cool
End If
SESystemStructVar.SystemTempPicture2.Picture = SESystemStructVar.SystemTempPicture2.Image
If SE_PictureBoxToDCStruct(SESystemStructVar.SystemTempPicture2, DCStructVar) = False Then GoTo BackPictureError::
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture) 'reset
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture2) 'reset
Graphics_CreateDisplayPicture = DCStructVar 'ok
Exit Function
BackPictureError::
Select Case MsgBox("internal error in Graphics_CreateDisplayPicture() (GFSkinEngine) !" + Chr$(10) + "Verify '" + FormBackPictureName + "' is available, or disable form back picture.", vbRetryCancel + vbExclamation)
Case vbCancel
Case vbRetry
GoTo ReDo:
End Select
Call SE_DeleteDCStruct(Graphics_CreateDisplayPicture) 'reset
Exit Function
TitleBarPictureError:
Select Case MsgBox("internal error in Graphics_CreateDisplayPicture() (GFSkinEngine) !" + Chr$(10) + "Verify '" + FormTitleBarPictureName + "' is available, or disable form title bar picture.", vbRetryCancel + vbExclamation)
Case vbCancel
Case vbRetry
GoTo ReDo:
End Select
Call SE_DeleteDCStruct(Graphics_CreateDisplayPicture) 'reset
Exit Function
End Function
Private Function Graphics_GetPictureBoxBackPicture(ByVal BackPictureName As String, ByRef BackPictureEnabledFlag As Boolean, ByVal PictureBoxWidth As Long, ByVal PictureBoxHeight As Long) As DCStruct
'on error resume next 'returns hDC to picture box back picture or 0 for error; size PictureBoxat: twips
Dim DCStructVar As DCStruct
'
'NOTE: the passed picture is loaded, tiled and the tiled image hDC is returned.
'NOTE: if BackPictureName is invalid, BackPictureEnabledFlag will be set to False.
'
'verify
If (DirSave(BackPictureName) = "") Or (Right$(BackPictureName, 1) = "\") Or (BackPictureName = "") Then
'NOTE: BackPictureEnabledFlag is passed ByRef.
'Debug.Print "PictureBox back picture disabled as invalid"
BackPictureEnabledFlag = False
End If
'begin
ReDo:
If BackPictureEnabledFlag = True Then
'back picture is enabled, tile back picture
If SE_FileToPictureBox(BackPictureName, SESystemStructVar.SystemTempPicture) = False Then GoTo Error:
SESystemStructVar.SystemTempPicture2.Width = (PictureBoxWidth + 4) * Screen.TwipsPerPixelX 'add 4 pixels for picture box frame
SESystemStructVar.SystemTempPicture2.Height = (PictureBoxHeight + 4) * Screen.TwipsPerPixelY 'add 4 pixels for picture box frame
Call GFTilePicture(SESystemStructVar.SystemTempPicture, SESystemStructVar.SystemTempPicture2)
SESystemStructVar.SystemTempPicture2.Refresh 'important (!!!)
If SESystemStructVar.ColorSchemeEnabledFlag = True Then 'hehe
Call GFAlphaBlendfrm.GFAlphaBlend_Colorize( _
SESystemStructVar.SystemTempPicture2.hDC, _
SESystemStructVar.SystemTempPicture2.ScaleWidth / Screen.TwipsPerPixelX, _
SESystemStructVar.SystemTempPicture2.ScaleHeight / Screen.TwipsPerPixelY, _
SESystemStructVar.ColorSchemeColor) 'slow, but looks cool
End If
SESystemStructVar.SystemTempPicture2.Picture = SESystemStructVar.SystemTempPicture2.Image
If SE_PictureBoxToDCStruct(SESystemStructVar.SystemTempPicture2, DCStructVar) = False Then GoTo Error:
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture) 'reset
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture2) 'reset
Graphics_GetPictureBoxBackPicture = DCStructVar 'ok
Exit Function
Else
'back picture is disabled
Call SE_DeleteDCStruct(Graphics_GetPictureBoxBackPicture)
Exit Function
End If
Exit Function
Error:
Select Case MsgBox("internal error in Graphics_GetPictureBoxBackPicture() (GFSkinEngine) !" + Chr$(10) + "Verify '" + BackPictureName + "' is available, or disable back picture.", vbRetryCancel + vbExclamation)
Case vbCancel
Case vbRetry
GoTo ReDo:
End Select
Call SE_DeleteDCStruct(Graphics_GetPictureBoxBackPicture)
Exit Function
End Function
Private Function Graphics_GetSECommandPictureDCStruct(ByVal SEControlStructIndex As Integer, ByVal SEControlState As Integer, ByVal SEControlCaption As String, ByVal SEControlWidth As Long, ByVal SEControlHeight As Long) As DCStruct
'On Error Resume Next 'Note that returned DCStruct can be saved in a variable for later use
Dim ErrorFlag As Boolean 'if loading original up/down picture failed
Dim DCStructVar As DCStruct
Dim Temp As Long
Dim Tempstr$
'
'NOTE: this function returns a DCStruct that 'contains' the up or down picture
'(depending on passed command state) for the se command, as well as its
'correct width and height (no further calculation necessary before displaying).
'Note that the DCStruct can be saved, thus call this function at start up only.
'NOTE: this function does not change the control's appearance, but
'returns a DCStruct only.
'If the passed bitmap name is invalid, the function will create a temporary
'picture, load it into memory and return the temp picture‑related DCStruct.
'
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
MsgBox "internal error in Graphics_GetSECommandPictureDCStruct() (GFSkinEngine): passed value invalid !", vbOKOnly + vbExclamation
Call SE_DeleteDCStruct(Graphics_GetSECommandPictureDCStruct)
Exit Function
End If
'begin
If SEControlState = SECONTROLSTATE_NORMAL Then
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_UpPicture)) Then 'verify to increase speed
' If SEControlStructArray(SEControlStructIndex).SEControl_EnabledFlag = True Then 'can't work, calling procedure could save disabled picture in UpPicture DCStruct (really happens, tested)
If SE_FileToPictureBox(SEControlStructArray(SEControlStructIndex).SEControl_UpPicture, SESystemStructVar.SystemTempPicture) = False Then ErrorFlag = True
' Else
' 'NOTE: take the image of a disabled command's picture from the DisabledPictureCache.
' If SE_FileToPictureBox(SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture, SESystemStructVar.SystemTempPicture) = False Then ErrorFlag = True
' End If
Else
ErrorFlag = True
End If
End If
If SEControlState = SECONTROLSTATE_PUSHED Then
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_DownPicture)) Then 'verify to increase speed
If SE_FileToPictureBox(SEControlStructArray(SEControlStructIndex).SEControl_DownPicture, SESystemStructVar.SystemTempPicture) = False Then ErrorFlag = True
Else
ErrorFlag = True
End If
End If
If SEControlState = SECONTROLSTATE_MOVEOVER Then
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPicture)) Then 'verify to increase speed
If SE_FileToPictureBox(SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPicture, SESystemStructVar.SystemTempPicture) = False Then ErrorFlag = True
Else
ErrorFlag = True
End If
End If
If (SEControlState = SECONTROLSTATE_DISABLED) Then
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture)) Then 'verify to increase speed
If SE_FileToPictureBox(SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture, SESystemStructVar.SystemTempPicture) = False Then ErrorFlag = True
Else
ErrorFlag = True
End If
End If
If ErrorFlag = False Then
'load command picture (any bitmap)
If SE_PictureBoxToDCStruct(SESystemStructVar.SystemTempPicture, DCStructVar) = False Then GoTo Error:
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture) 'reset
DCStructVar.Width = DCStructVar.Width ‑ TX(4) '4 pixels for borders
DCStructVar.Height = DCStructVar.Height ‑ TY(4) '4 pixels for borders
Graphics_GetSECommandPictureDCStruct = DCStructVar 'ok
Else
'create command picture (system control colors; command name printed)
DCStructVar = Graphics_CreateSECommandPicture(SEControlStructArray(SEControlStructIndex).SEControlName, _
SEControlStructIndex, _
SEControlState, SEControlCaption, _
SEControlWidth, SEControlHeight)
DCStructVar.Width = DCStructVar.Width ‑ TX(4) '4 pixels for borders
DCStructVar.Height = DCStructVar.Height ‑ TY(4) '4 pixels for borders
Graphics_GetSECommandPictureDCStruct = DCStructVar 'ok
End If
Exit Function
Error:
'NOTE: if a picture file was not found, a default command picture will be created.
MsgBox "internal error in Graphics_GetSECommandPictureDCStruct() (GFSkinEngine) !", vbOKOnly + vbExclamation
Call SE_DeleteDCStruct(Graphics_GetSECommandPictureDCStruct)
Exit Function
End Function
Private Function Graphics_CreateSECommandPicture(ByVal SECommandName As String, ByVal SEControlStructIndex As Integer, ByVal SECommandState As Integer, ByVal SECommandCaption As String, ByVal SECommandWidth As Long, ByVal SECommandHeight As Long) As DCStruct
'On Error Resume Next 'creates an image file that displays the command name in the system colors and returns the file name (full path); passed size values must have the format pixels
Dim SECommandText As String
Dim SECommandBackColor As Long
Dim TextLineNumber As Integer
Dim TextLineArray() As String
Dim CurrentXUnchanged As Single
Dim CurrentYUnchanged As Single
Dim FontBoldFlagUnchanged As Boolean
Dim XLoop As Integer
Dim YLoop As Integer
Dim TempFile As String
Dim Temp As Long
'preset
If SEControlStructIndex = 0 Then SEControlStructIndex = GetSEControlStructIndex(SECommandName)
If SEControlStructIndex = 0 Then GoTo Error: 'verify
If Not (SECommandCaption = "") Then
'print caption (if available) on command
SECommandText = SECommandCaption
Else
'print command name on command (if caption is not available)
SECommandText = SECommandName
End If
If (SECommandState = SECONTROLSTATE_NORMAL) Or _
(SECommandState = SECONTROLSTATE_DISABLED) Then
SECommandBackColor = SESystemStructVar.SystemControlColorStruct.ControlColor
End If
If (SECommandState = SECONTROLSTATE_MOVEOVER) Then
'NOTE: a move over command button is drawn slightly lighter.
SECommandBackColor = GFColor_ChangeBrightness(SESystemStructVar.SystemControlColorStruct.ControlColor, 12)
End If
If (SECommandState = SECONTROLSTATE_PUSHED) Then
'NOTE: a pushed command button is drawn darker.
SECommandBackColor = GFColor_ChangeBrightness(SESystemStructVar.SystemControlColorStruct.ControlColor, ‑24)
End If
'begin; print text
If SECM_HasSpecialFont(SEControlStructIndex) = True Then
'NOTE: also an SECommand can have a special font to display e.g. arrows (Wingdings).
SESystemStructVar.SystemTempPicture.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name
SESystemStructVar.SystemTempPicture.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size
SESystemStructVar.SystemTempPicture.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold
SESystemStructVar.SystemTempPicture.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic
SESystemStructVar.SystemTempPicture.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline
SESystemStructVar.SystemTempPicture.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough
Else
SESystemStructVar.SystemTempPicture.Font.Name = SESystemStructVar.SystemControlFont.Name
SESystemStructVar.SystemTempPicture.Font.Size = SESystemStructVar.SystemControlFont.Size
SESystemStructVar.SystemTempPicture.Font.Bold = SESystemStructVar.SystemControlFont.Bold
SESystemStructVar.SystemTempPicture.Font.Italic = SESystemStructVar.SystemControlFont.Italic
SESystemStructVar.SystemTempPicture.Font.Underline = SESystemStructVar.SystemControlFont.Underline
SESystemStructVar.SystemTempPicture.Font.StrikeThrough = SESystemStructVar.SystemControlFont.StrikeThrough
End If
SESystemStructVar.SystemTempPicture.Width = (SECommandWidth + 4) * Screen.TwipsPerPixelX 'add 4 pixels for picture box borders
SESystemStructVar.SystemTempPicture.Height = (SECommandHeight + 4) * Screen.TwipsPerPixelY 'add 4 pixels for picture box borders
SESystemStructVar.SystemTempPicture.BackColor = SECommandBackColor
SESystemStructVar.SystemTempPicture.ForeColor = SESystemStructVar.SystemControlColorStruct.ControlTextColor
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture) 'reset
Call GFGetLineArray(SECommandText, SESystemStructVar.SystemTempPicture.ScaleWidth, Chr$(32), TextLineArray(), TextLineNumber, SESystemStructVar.SystemTempPicture)
'linear gradient
With SESystemStructVar.SystemTempPicture
For XLoop = 1 To 32
For YLoop = 1 To 32
SESystemStructVar.SystemTempPicture.Line ((.ScaleWidth ‑ TX(1)) * CSng(XLoop ‑ 1) / 32! + TX(1), ((.ScaleHeight ‑ TY(1)) * CSng(YLoop ‑ 1) / 32! + TY(1)))‑((.ScaleWidth ‑ TX(1)) * CSng(XLoop) / 32! + TX(1), ((.ScaleHeight ‑ TY(1)) * CSng(YLoop) / 32! + TY(1))), _
GFColor_ChangeBrightness(SECommandBackColor, ((‑XLoop + 16) * 2 + (‑YLoop + 16) * 2)), BF 'use (XLoop ‑ 16) for inverse lightning (from bottom)
Next YLoop
Next XLoop
End With
'end of linear gradient
If SECommandState = SECONTROLSTATE_NORMAL Then
For Temp = 1 To TextLineNumber
'NOTE: use Int() to avoid displaying errors due to rounding errors.
SESystemStructVar.SystemTempPicture.CurrentX = TX(3) + Int( _
((SESystemStructVar.SystemTempPicture.ScaleWidth ‑ TX(6)) / 2) ‑ _
(SESystemStructVar.SystemTempPicture.TextWidth(TextLineArray(Temp)) / 2))
SESystemStructVar.SystemTempPicture.CurrentY = TY(3) + Int( _
((SESystemStructVar.SystemTempPicture.ScaleHeight ‑ TY(6)) / 2) ‑ _
(CSng(TextLineNumber) / 2!) * CSng(SESystemStructVar.SystemTempPicture.TextHeight(TextLineArray(Temp))) + _
(Temp ‑ 1) * (SESystemStructVar.SystemTempPicture.TextHeight(TextLineArray(Temp))))
'
SESystemStructVar.SystemTempPicture.ForeColor = SESystemStructVar.SystemControlColorStruct.ControlTextColor
SESystemStructVar.SystemTempPicture.Print TextLineArray(Temp)
'
Next Temp
End If
If SECommandState = SECONTROLSTATE_PUSHED Then
For Temp = 1 To TextLineNumber
SESystemStructVar.SystemTempPicture.CurrentX = TX(4) + Int( _
((SESystemStructVar.SystemTempPicture.ScaleWidth ‑ TX(6)) / 2) ‑ _
(SESystemStructVar.SystemTempPicture.TextWidth(TextLineArray(Temp)) / 2))
SESystemStructVar.SystemTempPicture.CurrentY = TY(4) + Int( _
((SESystemStructVar.SystemTempPicture.ScaleHeight ‑ TY(6)) / 2) ‑ _
(CSng(TextLineNumber) / 2!) * CSng(SESystemStructVar.SystemTempPicture.TextHeight(TextLineArray(Temp))) + _
(Temp ‑ 1) * (SESystemStructVar.SystemTempPicture.TextHeight(TextLineArray(Temp))))
SESystemStructVar.SystemTempPicture.Print TextLineArray(Temp)
Next Temp
End If
If SECommandState = SECONTROLSTATE_MOVEOVER Then
For Temp = 1 To TextLineNumber
FontBoldFlagUnchanged = SESystemStructVar.SystemTempPicture.Font.Bold
SESystemStructVar.SystemTempPicture.Font.Bold = True
SESystemStructVar.SystemTempPicture.CurrentX = TX(3) + _
((SESystemStructVar.SystemTempPicture.ScaleWidth ‑ TX(6)) / 2) ‑ _
(SESystemStructVar.SystemTempPicture.TextWidth(TextLineArray(Temp)) / 2)
SESystemStructVar.SystemTempPicture.CurrentY = TY(3) + _
((SESystemStructVar.SystemTempPicture.ScaleHeight ‑ TY(6)) / 2) ‑ _
(CSng(TextLineNumber) / 2!) * CSng(SESystemStructVar.SystemTempPicture.TextHeight(TextLineArray(Temp))) + _
(Temp ‑ 1) * (SESystemStructVar.SystemTempPicture.TextHeight(TextLineArray(Temp)))
SESystemStructVar.SystemTempPicture.Print TextLineArray(Temp)
If Not (SESystemStructVar.SystemTempPicture.Font.Bold = FontBoldFlagUnchanged) Then _
SESystemStructVar.SystemTempPicture.Font.Bold = FontBoldFlagUnchanged 'reset
Next Temp
End If
If SECommandState = SECONTROLSTATE_DISABLED Then
For Temp = 1 To TextLineNumber
'NOTE: use Int() to avoid displaying errors due to rounding errors.
SESystemStructVar.SystemTempPicture.CurrentX = TX(3) + Int( _
((SESystemStructVar.SystemTempPicture.ScaleWidth ‑ TX(6)) / 2) ‑ _
(SESystemStructVar.SystemTempPicture.TextWidth(TextLineArray(Temp)) / 2))
SESystemStructVar.SystemTempPicture.CurrentY = TY(3) + Int( _
((SESystemStructVar.SystemTempPicture.ScaleHeight ‑ TY(6)) / 2) ‑ _
(CSng(TextLineNumber) / 2!) * CSng(SESystemStructVar.SystemTempPicture.TextHeight(TextLineArray(Temp))) + _
(Temp ‑ 1) * (SESystemStructVar.SystemTempPicture.TextHeight(TextLineArray(Temp))))
'
CurrentXUnchanged = SESystemStructVar.SystemTempPicture.CurrentX
CurrentYUnchanged = SESystemStructVar.SystemTempPicture.CurrentY
SESystemStructVar.SystemTempPicture.ForeColor = SESystemStructVar.SystemControlColorStruct.LockedTextColor
SESystemStructVar.SystemTempPicture.Print TextLineArray(Temp)
SESystemStructVar.SystemTempPicture.ForeColor = SESystemStructVar.SystemControlColorStruct.LightShadowColor
SESystemStructVar.SystemTempPicture.CurrentX = CurrentXUnchanged ‑ TX(1)
SESystemStructVar.SystemTempPicture.CurrentY = CurrentYUnchanged ‑ TY(1)
SESystemStructVar.SystemTempPicture.Print TextLineArray(Temp)
'
Next Temp
End If
'draw frame
'
'NOTE: the code below creates a picture that looks almost exactly
'like a Windows 98 (damn!) command button.
'
If (SECommandState = SECONTROLSTATE_NORMAL) Or _
(SECommandState = SECONTROLSTATE_MOVEOVER) Or _
(SECommandState = SECONTROLSTATE_DISABLED) Then
With SESystemStructVar.SystemTempPicture
'top full
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, 0, 0, .ScaleWidth ‑ TX(1), 0, SESystemStructVar.SystemControlColorStruct.LightShadowColor, 12, ‑12, 12)
'right under top to bottom
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(1), 0, .ScaleWidth ‑ TX(1), .ScaleHeight ‑ TY(1), SESystemStructVar.SystemControlColorStruct.ControlShadowColor, 12, ‑12, 12)
'bottom left of right to left
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(1), .ScaleHeight ‑ TY(1), 0, .ScaleHeight ‑ TY(1), SESystemStructVar.SystemControlColorStruct.ControlShadowColor, 12, ‑12, 12)
'left over bottom to unde top
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, 0, .ScaleHeight ‑ TY(1), 0, 0, SESystemStructVar.SystemControlColorStruct.LightShadowColor, 12, ‑12, 12)
'under top right of left to left of right
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, TX(1), TY(1), .ScaleWidth ‑ TX(2), TY(1), SESystemStructVar.SystemControlColorStruct.LightShadowColor, 12, ‑12, 12)
'right under top to over bottom
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(2), TY(1), .ScaleWidth ‑ TX(2), .ScaleHeight ‑ TY(2), SESystemStructVar.SystemControlColorStruct.DarkShadowColor, 12, ‑12, 12)
'bottom left of right to right of left
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(2), .ScaleHeight ‑ TY(2), TX(1), .ScaleHeight ‑ TY(2), SESystemStructVar.SystemControlColorStruct.DarkShadowColor, 12, ‑12, 12)
'left over bottom to under top
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, TX(1), .ScaleHeight ‑ TY(2), TX(1), TY(1), SESystemStructVar.SystemControlColorStruct.LightShadowColor, 12, ‑12, 12)
' '? 'another frame layer inside command
' Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, TX(2), TY(2), .ScaleWidth ‑ TX(3), TY(2), SESystemStructVar.SystemControlColorStruct.LightShadowColor, 12, ‑12, 12)
' '?
' Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(3), TY(2), .ScaleWidth ‑ TX(3), .ScaleHeight ‑ TY(3), SESystemStructVar.SystemControlColorStruct.DarkShadowColor, 12, ‑12, 12)
' '?
' Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(3), .ScaleHeight ‑ TY(3), TX(2), .ScaleHeight ‑ TY(3), SESystemStructVar.SystemControlColorStruct.DarkShadowColor, 12, ‑12, 12)
' '?
' Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, TX(2), .ScaleHeight ‑ TY(3), TX(2), TY(2), SESystemStructVar.SystemControlColorStruct.LightShadowColor, 12, ‑12, 12)
End With
End If
If (SECommandState = SECONTROLSTATE_PUSHED) Then
With SESystemStructVar.SystemTempPicture
'see first frame creation for commands
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, 0, 0, .ScaleWidth ‑ TX(1), 0, 0, 12, ‑12, 12)
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(1), 0, .ScaleWidth ‑ TX(1), .ScaleHeight ‑ TY(1), 0, 12, ‑12, 12)
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(1), .ScaleHeight ‑ TY(1), 0, .ScaleHeight ‑ TY(1), 0, 12, ‑12, 12)
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, 0, .ScaleHeight ‑ TY(1), 0, 0, 0, 12, ‑12, 12)
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, TX(1), TY(1), .ScaleWidth ‑ TX(2), TY(1), SESystemStructVar.SystemControlColorStruct.ControlShadowColor, 12, ‑12, 12)
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(2), TY(1), .ScaleWidth ‑ TX(2), .ScaleHeight ‑ TY(2), SESystemStructVar.SystemControlColorStruct.ControlShadowColor, 12, ‑12, 12)
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, .ScaleWidth ‑ TX(2), .ScaleHeight ‑ TY(2), TX(1), .ScaleHeight ‑ TY(2), SESystemStructVar.SystemControlColorStruct.ControlShadowColor, 12, ‑12, 12)
Call Graphics_DrawGradientLine(SESystemStructVar.SystemTempPicture, TX(1), .ScaleHeight ‑ TY(2), TX(1), TY(1), SESystemStructVar.SystemControlColorStruct.ControlShadowColor, 12, ‑12, 12)
End With
End If
SESystemStructVar.SystemTempPicture.Picture = SESystemStructVar.SystemTempPicture.Image
Call SE_PictureBoxToDCStruct(SESystemStructVar.SystemTempPicture, Graphics_CreateSECommandPicture) 'ok
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture)
Exit Function
Error:
Call SE_DeleteDCStruct(Graphics_CreateSECommandPicture)
Exit Function
End Function
Private Sub Graphics_SetSEControlMouseIcon(ByVal SEControlObject As Object, ByVal SEControlType As Integer, ByVal SEControlMouseIcon As String, ByVal MousePointerUsage As Integer)
'On Error Resume Next
Dim Temp As Long
'
'NOTE: the passed control must have a MousePointer and MouseIcon property.
'If Val(SEControlMouseIcon) ranges from ‑1 to ‑15 the related VB mouse pointer
'is used (see mouse pointer constants). If SEControlMousePointer is a file name,
'the related icon file is used as cursor.
'If SEControlMouseIcon is "" or the file name is invalid, the default mouse pointer
'is used (MousePointer property of control is set to vbNormal).
'
'NOTE: the mouse icon will not be changed for the following controls:
'‑text box
'‑combo box (.Style = [0, 1])
'The mouse icon is not set as these controls have a special mouse icon
'displaying the possibility for text entry.
'
'This sub should not be used to temporarily change the mouse icon of a control
'in UserMove mode.
'
'This sub should not be called with a high frequency as its code is rather slow.
'
'verify
Select Case SEControlType
Case SECONTROLTYPE_TEXTBOX
Exit Sub
Case SECONTROLTYPE_COMBOBOX
Select Case SEControlObject.Style
Case 0, 1
Exit Sub
End Select
End Select
'begin
Select Case MousePointerUsage
Case MOUSEPOINTERUSAGE_NORMAL
Temp = Val(Left$(SEControlMouseIcon, 4)) 'use Left$() to avoid Integer overflow
If (Temp < ‑1) And (Temp > (‑15)) Then
SEControlObject.MousePointer = ‑Temp
Else
If Not ((DirSave(SEControlMouseIcon) = "") Or (Right$(SEControlMouseIcon, 1) = "\") Or (SEControlMouseIcon = "")) Then
Call Skin_DecryptFile(SEControlMouseIcon)
SEControlObject.MousePointer = 99 'user defined
SEControlObject.MouseIcon = GFCursor_Load(SEControlMouseIcon)
Call Skin_EncryptFile(SEControlMouseIcon)
Else
SEControlObject.MousePointer = vbDefault
End If
End If
Case MOUSEPOINTERUSAGE_RESIZE
SEControlObject.MousePointer = 99 'user defined
SEControlObject.MouseIcon = GFSkinEngine_MENUfrm.MouseIcon
End Select
Exit Sub
End Sub
Private Sub Graphics_DrawGradientLine(ByRef PictureBoxObject As PictureBox, ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single, ByVal Color As Long, ByVal ColorStartPlusMinus As Single, ByVal ColorEndPlusMinus As Single, ByVal ColorSteps As Single)
'on error resume next 'draws a line that does not have a solid color
Dim Tempsngl!
'begin
For Tempsngl! = 0! To (ColorSteps ‑ 1!)
PictureBoxObject.Line _
(X1 + (X2 ‑ X1) / ColorSteps * Tempsngl!, Y1 + (Y2 ‑ Y1) / ColorSteps * Tempsngl!)‑ _
(X1 + (X2 ‑ X1) / ColorSteps * (Tempsngl! + 1!), Y1 + (Y2 ‑ Y1) / ColorSteps * (Tempsngl! + 1!)), _
GFColor_ChangeBrightness(Color, ColorStartPlusMinus + (ColorEndPlusMinus ‑ ColorStartPlusMinus) / (ColorSteps ‑ 1!) * Tempsngl!)
Next Tempsngl!
End Sub
Private Function TX(ByVal PixelsX As Long) As Single
'On Error Resume Next 'converts pixels to twips (x)
TX = CSng(PixelsX) * Screen.TwipsPerPixelX
End Function
Private Function TY(ByVal PixelsY As Long) As Single
'On Error Resume Next 'converts pixels to twips (y)
TY = CSng(PixelsY) * Screen.TwipsPerPixelY
End Function
'***GRAPHICS SUB FUNCTIONS***
'NOTE: the graphics sub functions mainly transfer conversions between
'VB Picture Box images, Frames, Windows‑DCs and Bitmap files.
Public Function SE_PictureBoxToDCStruct(ByRef PictureBox As PictureBox, ByRef DCStructVar As DCStruct) As Boolean
'On Error Resume Next 'returns True if transformation was successful, False if not
'NOTE: the Microsoft article Q129887 gives some information about a picture box's Image and Picture properties.
DCStructVar.DC = CreateCompatibleDC(PictureBox.hDC)
If Not (DCStructVar.DC = 0) Then
DCStructVar.ObjectOldHandle = SelectObject(DCStructVar.DC, PictureBox.Picture.Handle) 'do not BitBlt(), SelectObject() works fine (see GFMDIBackGround)
DCStructVar.Width = PictureBox.Width
DCStructVar.Height = PictureBox.Height
SE_PictureBoxToDCStruct = True 'ok
Else
SE_PictureBoxToDCStruct = False 'error
End If
End Function
Public Sub SE_DCStructToSECommand(ByRef DCStructVar As DCStruct, ByRef SECommand As Frame)
'On Error Resume Next
Dim WindowDC As Long
'begin
If (DCStructVar.DC) Then 'verify
If Not (SECommand.Width = DCStructVar.Width) Then _
SECommand.Width = DCStructVar.Width
If Not (SECommand.Height = DCStructVar.Height) Then _
SECommand.Height = DCStructVar.Height
WindowDC = GetWindowDC(SECommand.hwnd)
Call BitBlt(WindowDC, 0, 0, SECommand.Width / Screen.TwipsPerPixelX, SECommand.Height / Screen.TwipsPerPixelY, DCStructVar.DC, 0, 0, vbSrcCopy)
Call ReleaseDC(SECommand.hwnd, WindowDC)
Else
MsgBox "internal error in SE_DCStructToSECommand(): 0 DC !", vbOKOnly + vbExclamation
End If
End Sub
Public Sub SE_DCStructToSECommand2(ByRef DCStructVar As DCStruct, ByVal SEControlStructIndex As Integer)
'On Error Resume Next '***TEMP***
Dim WindowDC As Long
Dim SECommand As Frame
'preset
Set SECommand = SEControlStructArray(SEControlStructIndex).SEControl
'begin
If (DCStructVar.DC) Then 'verify
If Not (SECommand.Width = DCStructVar.Width) Then _
SECommand.Width = DCStructVar.Width
If Not (SECommand.Height = DCStructVar.Height) Then _
SECommand.Height = DCStructVar.Height
WindowDC = GetWindowDC(SECommand.hwnd)
Call BitBlt(WindowDC, 0, 0, SECommand.Width / Screen.TwipsPerPixelX, SECommand.Height / Screen.TwipsPerPixelY, DCStructVar.DC, 0, 0, vbSrcCopy)
Call ReleaseDC(SECommand.hwnd, WindowDC)
Else
MsgBox "internal error in SE_DCStructToSECommand(): 0 DC !", vbOKOnly + vbExclamation
End If
End Sub
Public Sub SE_DCStructToPictureBox(ByRef DCStructVar As DCStruct, ByRef PictureBox As PictureBox)
'On Error Resume Next
If (DCStructVar.DC) Then 'verify
If Not (PictureBox.Width = DCStructVar.Width) Then _
PictureBox.Width = DCStructVar.Width
If Not (PictureBox.Height = DCStructVar.Height) Then _
PictureBox.Height = DCStructVar.Height
Call BitBlt(PictureBox.hDC, 0, 0, PictureBox.Width / Screen.TwipsPerPixelX, PictureBox.Height / Screen.TwipsPerPixelY, DCStructVar.DC, 0, 0, vbSrcCopy)
Else
MsgBox "internal error in SE_DCStructToPictureBox(): 0 DC !", vbOKOnly + vbExclamation
End If
End Sub
Public Function SE_PictureBoxToFile(ByRef PictureBox As Object, ByVal File As String) As Boolean
On Error GoTo Error: 'important; returns False if an error occurred
If Not ((DirSave(File) = "") Or (Right$(File, 1) = "\") Or (File = "")) Then Kill File
Call SavePicture(PictureBox.Image, File) 'BUGBUG: wastes memory!
SE_PictureBoxToFile = True 'ok
Exit Function
Error:
SE_PictureBoxToFile = False 'error
Exit Function
End Function
Public Function SE_FileToPictureBox(ByVal File As String, ByRef PictureBox As Object) As Boolean
On Error GoTo Error: 'important (if picture to load is invalid); returns False if File was not found or could not be loaded
If Not ((DirSave(File) = "") Or (Right$(File, 1) = "\") Or (File = "")) Then 'verify
Call Skin_DecryptFile(File)
PictureBox.AutoSize = True 'important
PictureBox.Picture = LoadPicture(File)
PictureBox.AutoSize = False 'important
Call Skin_EncryptFile(File)
Else
GoTo Error:
End If
SE_FileToPictureBox = True 'ok
Exit Function
Error:
SE_FileToPictureBox = False 'error
Exit Function
End Function
Public Function SE_FileFromPictureBox(ByRef PictureBox As Object)
'On Error Resume Next 'call to clear a PictureBox completely (back picture cannot be removed by using .Clear)
PictureBox.Picture = LoadPicture("") 'reset
End Function
Public Function SE_PictureBoxToPictureBox(ByRef InputPictureBox As Object, ByRef OutputPictureBox As Object) As Boolean
'On Error Resume Next 'format of output picture box must be either vbTwips or vbPixels
If Not (OutputPictureBox.Width = InputPictureBox.Width) Then _
OutputPictureBox.Width = InputPictureBox.Width
If Not (OutputPictureBox.Height = InputPictureBox.Height) Then _
OutputPictureBox.Height = InputPictureBox.Height
If OutputPictureBox.ScaleMode = vbTwips Then
SE_PictureBoxToPictureBox = _
CBool(BitBlt(OutputPictureBox.hDC, 0, 0, OutputPictureBox.ScaleWidth / Screen.TwipsPerPixelX, OutputPictureBox.ScaleHeight / Screen.TwipsPerPixelY, InputPictureBox.hDC, 0, 0, vbSrcCopy))
Else
SE_PictureBoxToPictureBox = _
CBool(BitBlt(OutputPictureBox.hDC, 0, 0, OutputPictureBox.ScaleWidth, OutputPictureBox.ScaleHeight, InputPictureBox.hDC, 0, 0, vbSrcCopy))
End If
End Function
Public Sub SE_DCStructToDCStruct(ByRef InputDCStructVar As DCStruct, ByRef OutputDCStructVar As DCStruct)
'On Error Resume Next
OutputDCStructVar.DC = InputDCStructVar.DC
OutputDCStructVar.ObjectOldHandle = InputDCStructVar.ObjectOldHandle
OutputDCStructVar.Height = InputDCStructVar.Height
OutputDCStructVar.Width = InputDCStructVar.Width
End Sub
Public Sub SE_BitBlt(ByRef TargetPictureBox As PictureBox, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByRef SourcePictureBox As PictureBox, ByVal XS As Long, ByVal YS As Long, ByVal Mode As Long)
'On Error Resume Next
Call BitBlt(TargetPictureBox.hDC, X, Y, Width, Height, SourcePictureBox.hDC, XS, YS, Mode)
TargetPictureBox.Refresh
End Sub
Public Sub SE_DCStructToBackPicture(ByRef DCStructVar As DCStruct, ByRef PictureBox As PictureBox)
'On Error Resume Next
'?
End Sub
Private Sub SE_DeleteDCStruct(ByRef DCStructVar As DCStruct)
'on error resume next 'NOTE: DCStructVar will not usable for BitBlt()ing anymore
Dim Temp As Long
Temp = SelectObject(DCStructVar.DC, DCStructVar.ObjectOldHandle)
Call DeleteObject(Temp)
Call DeleteDC(Temp)
Call DeleteObject(DCStructVar.DC)
Call DeleteDC(DCStructVar.DC)
DCStructVar = NullDCStructVar
End Sub
Public Sub SE_DeletePictureBox(ByRef PictureBox As PictureBox) 'copied from GFSkinEngine
'on error resume next 'verify MS's buggy picture box releases GUI memory
Dim OSVERSIONINFOVar As OSVERSIONINFO
'reset
PictureBox.Cls
Set PictureBox.Picture = Nothing
'verify
OSVERSIONINFOVar.dwOSVersionInfoSize = Len(OSVERSIONINFOVar)
Call GetVersionEx(OSVERSIONINFOVar)
If OSVERSIONINFOVar.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
'NOTE: the following line leads to errors in WinNT but is necessary in Win98.
Call DeleteObject(PictureBox.Image.Handle) 'msbugsave
Call DeleteObject(PictureBox.Picture.Handle) 'msbugsave
End If
End Sub
Public Sub SE_DrawFrame(ByVal SEControlName As String, Optional ByVal SEControlStructIndex As Integer)
'on error resume next 'to be called by the target project
'preset
If SEControlStructIndex = 0 Then SEControlStructIndex = GetSEControlStructIndex(SEControlName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'begin
Call GFSkinEnginefrm.SE_DrawFrame(SEControlName, SEControlStructIndex)
End Sub
'***END OF GRAPHICS SUB FUNCTIONS***
'*******************************END OF SE GRAPHICS SYSTEM*******************************
'*************************************SKINDATAFILE**************************************
'NOTE: the SkinDataFile saves the information that is necessary to create a skin.
'It does not contain any resources like bitmaps, etc.
'The following functions except SkinDataFile_Read() are not to be called by the
'target projects (internal functions only).
Public Function SE_GetSkinDataFile() As String
'On Error Resume Next 'returns full name of SkinDataFile or nothing ("") if there is any error
Dim SkinDataFile As String
'
'NOTE: the system requires that this sub merely uses the value of
'SESystemStructVar.SystemSkinDirectory to determine the SkinDataFileName.
'
'begin
SkinDataFile = SESystemStructVar.SystemSkinDirectory + "skin.dat"
If Not ((DirSave(SkinDataFile) = "") Or (Right$(SkinDataFile, 1) = "\") Or (SkinDataFile = "")) Then 'verify
SE_GetSkinDataFile = SkinDataFile
Else
SE_GetSkinDataFile = "" 'reset (error)
End If
End Function
Public Function SkinDataFile_Read(ByVal SkinDataFile As String) As Boolean
'On Error Resume Next 'updates SEControlStructArray(); returns True for success or False if a critical error occurred
Dim SkinDataFileString As String
'
'NOTE: the SkinDataFile will not be read if already done before.
'
'preset
If GetDirectoryName(SkinDataFile) = "" Then SkinDataFile = SESystemStructVar.SystemSkinDirectory + SkinDataFile
Call SkinDataFile_ReadString(SkinDataFile, SkinDataFileString) 'may use the 'memory SkinDataFile' to increase speed.
'verify
If SkinDataFile_VerifyString(SkinDataFileString) = True Then
Call SkinDataFile_WriteString(SkinDataFile, SkinDataFileString) 'write verified string
SkinDataFileCacheStructVar.SkinDataFileString = SkinDataFileString 'put verified string into memory
End If
If SkinDataFile_VerifySystemLines(SkinDataFileString) = True Then
Call SkinDataFile_WriteString(SkinDataFile, SkinDataFileString) 'write verified string
SkinDataFileCacheStructVar.SkinDataFileString = SkinDataFileString 'put verified string into memory
End If
'begin
SkinDataFile_Read = SkinDataFile_ReadSub(SkinDataFileString, False, 0)
End Function
Private Function SkinDataFile_ReadSub(ByVal SkinDataFileString As String, ByVal VerifyOnlyFlag As Boolean, ByRef VerifyControlNumber As Integer) As Boolean
'on error resume next 'transfers data from SkinDataFileString to SEControlStructArray(); returns True for success or False if a critical error occurred
Dim SkinDataFileLineStartPos As Long
Dim SkinDataFileLineEndPos As String
Dim SkinDataFileLine As String
Dim SkinDataFileCommand As String
Dim SkinDataFileValue As String
Dim StructLoop As Integer
Dim Temp As Long
Dim TempSkinDataFileStruct As SkinDataFileStruct
'
'NOTE: this function can either be used to transfer data from SkinDataFileString
'to SEControlStructArray() or to get the number of controls that appear in SkinDataFileString
'(for determining if a SkinDataFile is valid).
'
'preset
SkinDataFileStructVar.SEControlStructIndex = 0 'reset
SkinDataFileStructVar.SEPaletteNumber = ‑1 'reset
If VerifyOnlyFlag = False Then
Call SE_Reset 'reset SEControlStructArray()
End If
Call SE_SESystemStruct_Reset(SESystemStructVar, SESystemStructVarUnchanged)
Call SkinDataFile_Read_Preset(TempSkinDataFileStruct) 'will be used as default values
SkinDataFileLineStartPos = 0 'preset
SkinDataFileLineEndPos = 0 'preset
'verify
If Not (Left$(SkinDataFileString, 2) = Chr$(13) + Chr$(10)) Then SkinDataFileString = Chr$(13) + Chr$(10) + SkinDataFileString 'add start sign
If Not (Right$(SkinDataFileString, 2) = Chr$(13) + Chr$(10)) Then SkinDataFileString = SkinDataFileString + Chr$(13) + Chr$(10) 'add end sign
'begin
Do
SkinDataFileLineStartPos = InStr(SkinDataFileLineEndPos + 1, SkinDataFileString, Chr$(13) + Chr$(10), vbBinaryCompare)
If SkinDataFileLineStartPos = 0 Then
Exit Do
Else
SkinDataFileLineStartPos = SkinDataFileLineStartPos + 2 'seek over Chr$(13) + Chr$(10)
End If
SkinDataFileLineEndPos = InStr(SkinDataFileLineStartPos, SkinDataFileString, Chr$(13) + Chr$(10), vbBinaryCompare)
If SkinDataFileLineEndPos = 0 Then
Exit Do
Else
SkinDataFileLineEndPos = SkinDataFileLineEndPos ‑ 1
End If
SkinDataFileLine = Mid$(SkinDataFileString, SkinDataFileLineStartPos, (SkinDataFileLineEndPos ‑ SkinDataFileLineStartPos + 1))
'allocate data in SkinDataFileLine
If Mid$(SkinDataFileLine, 1, 1) = "[" Then
If Mid$(SkinDataFileLine, Len(SkinDataFileLine), 1) = "]" Then
SkinDataFileCommand = "add control"
SkinDataFileValue = Trim$(Mid$(SkinDataFileLine, 2, Len(SkinDataFileLine) ‑ 2))
If VerifyOnlyFlag = False Then
For StructLoop = 1 To SEControlStructNumber
'verify control does not appear twice in SkinDataFile before adding
If (Len(SEControlStructArray(StructLoop).SEControlName) = Len(SkinDataFileValue)) Or _
(Len(SkinDataFileStructVar.SEControlInfoStructVar.ControlName) = Len(SkinDataFileValue)) Then 'check first to increase speed
If (SEControlStructArray(StructLoop).SEControlName = SkinDataFileValue) Or _
(SkinDataFileStructVar.SEControlInfoStructVar.ControlName = SkinDataFileValue) Then
'NOTE: SkinDataFileStructVar.SEControlInfoStructVar.ControlName contains the cache name of the control that would now be added.
MsgBox "Warning (GFSkinEngine): the control '" + SkinDataFileValue + "' was registered more than once !" + Chr$(10) + "Only the first control's properties will be processed." + Chr$(10) + "Please verify settings in SkinDataFile !", vbOKOnly + vbExclamation
SkinDataFileCommand = "" 'reset (error)
SkinDataFileValue = "" 'reset (error)
End If
End If
Next StructLoop
End If
Else
SkinDataFileCommand = "" 'reset (error)
SkinDataFileValue = "" 'reset (error)
End If
Else
Temp = InStr(1, SkinDataFileLine, "=", vbBinaryCompare)
If Not (Temp = 0) Then
SkinDataFileCommand = Trim$(Left$(SkinDataFileLine, Temp ‑ 1))
SkinDataFileValue = Trim$(Right$(SkinDataFileLine, Len(SkinDataFileLine) ‑ Temp))
Else
SkinDataFileCommand = "" 'reset
SkinDataFileValue = "" 'reset
End If
End If
If SkinDataFile_Allocate(SkinDataFileCommand, SkinDataFileValue, TempSkinDataFileStruct, VerifyOnlyFlag, VerifyControlNumber) = False Then GoTo Error:
Loop
If SkinDataFile_Allocate("add control", "", TempSkinDataFileStruct, VerifyOnlyFlag, VerifyControlNumber) = False Then GoTo Error: 'add previous (last) control
SkinDataFile_ReadSub = True 'ok
Exit Function
Error:
SkinDataFile_ReadSub = False 'error
Exit Function
End Function
Private Function SkinDataFile_Allocate(ByVal SkinDataFileCommand As String, ByVal SkinDataFileValue As String, ByRef DefaultValueSet As SkinDataFileStruct, ByVal VerifyOnlyFlag As Boolean, ByRef VerifyControlNumber As Integer) As Boolean
On Error GoTo Error: 'important (if a class member is not existing); returns False if a critical error occurred, True if not
Dim StructLoop As Integer
Dim StructIndex As Integer
Dim Temp As Long
'
'NOTE: this sub sets the data of a SEControlInfoStruct variable.
'When a new control is to be added, the old one is created
'by calling SE_AddControl() and passing the SEControlInfoStruct
'data. The SEControlinfoStruct variable is initialized with default data
'every time a new object is to be added.
'
'NOTE: if any data required to create a control is not given, the system uses
'the values set by the 'system_' SkinDataFileCommands.
'If these commands have not been used, the system uses the values
'passed when initializing the Skin Engine.
'
'NOTE: the string that is below a command name is called the property string.
'A property string starts right after the control name and ends...
'‑either before the start of the next control name
'‑or at the end of the SkinDataFile
'‑or before a 'system_[...]' line
'This information is important for the SEPE system.
'
'Besides transferring the SkinDataFile content to SE_AddControl() this sub
'has also the task to verify the values in the SkinDataFile, if a value is
'invalid the a default value will be used and an error message will be created.
'
'‑no string may be longer than 850 chars
'‑font sizes may range from 2 to 128 (if invalid the default font size is used)
'‑the title bar spawn start pos must range from 0 to 10240
'‑the title bar spawn length from 1 to 10240
'‑sizes must not be smaller than 0, sometimes 1
'If any invalid value is found, the value set in SkinDataFile_Read_Preset() is used.
'
'verify
If (Len(SkinDataFileCommand) = 0) And (Len(SkinDataFileValue) = 0) Then
SkinDataFile_Allocate = True 'ok
Exit Function
Else
SkinDataFileCommand = Trim$(SkinDataFileCommand)
SkinDataFileValue = Trim$(SkinDataFileValue)
End If
'begin
Select Case LCase$(SkinDataFileCommand)
Case "system_forecolor"
SESystemStructVar.SystemForeColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_backcolor"
SESystemStructVar.SystemBackColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_fontname"
If ISFONTAVAILABLE(SkinDataFileValue) = True Then
SESystemStructVar.SystemFont.Name = SkinDataFileValue
Else
SESystemStructVar.SystemFont.Name = DefaultValueSet.SEControlInfoStructVar.ControlFont.Name
End If
Case "system_fontsize"
If Len(SkinDataFileValue) > 4 Then SkinDataFileValue = Left$(SkinDataFileValue, 4) 'verify to avoid overflow (important)
If Not ((Val(SkinDataFileValue) < 2) Or (Val(SkinDataFileValue) > 128)) Then
SESystemStructVar.SystemFont.Size = Val(SkinDataFileValue)
Else
SESystemStructVar.SystemFont.Size = DefaultValueSet.SEControlInfoStructVar.ControlFont.Size
End If
Case "system_fontbold"
SESystemStructVar.SystemFont.Bold = STRINGTOBOOL(SkinDataFileValue)
Case "system_fontitalic"
SESystemStructVar.SystemFont.Italic = STRINGTOBOOL(SkinDataFileValue)
Case "system_fontunderline"
SESystemStructVar.SystemFont.Underline = STRINGTOBOOL(SkinDataFileValue)
Case "system_fontstrikethrough"
SESystemStructVar.SystemFont.StrikeThrough = STRINGTOBOOL(SkinDataFileValue)
Case "system_mouseicon"
If (Val(Mid$(SkinDataFileValue, 1, 1)) = 0) And (Not (SkinDataFileValue = "")) Then 'verify number is not destroyed by directory name
If GetDirectoryName(SkinDataFileValue) = "" Then SkinDataFileValue = SESystemStructVar.SystemSkinDirectory + SkinDataFileValue
End If
SESystemStructVar.SystemMouseIcon = SkinDataFileValue
Case "system_controlfontname"
If ISFONTAVAILABLE(SkinDataFileValue) = True Then
SESystemStructVar.SystemControlFont.Name = SkinDataFileValue
Else
SESystemStructVar.SystemControlFont.Name = DefaultValueSet.SEControlInfoStructVar.ControlFont.Name
End If
Case "system_controlfontsize"
If Len(SkinDataFileValue) > 4 Then SkinDataFileValue = Left$(SkinDataFileValue, 4) 'verify to avoid overflow (important)
If Not ((Val(SkinDataFileValue) < 2) Or (Val(SkinDataFileValue) > 128)) Then
SESystemStructVar.SystemControlFont.Size = Val(SkinDataFileValue)
Else
SESystemStructVar.SystemControlFont.Size = DefaultValueSet.SEControlInfoStructVar.ControlFont.Size
End If
Case "system_controlfontbold"
SESystemStructVar.SystemControlFont.Bold = STRINGTOBOOL(SkinDataFileValue)
Case "system_controlfontitalic"
SESystemStructVar.SystemControlFont.Italic = STRINGTOBOOL(SkinDataFileValue)
Case "system_controlfontunderline"
SESystemStructVar.SystemControlFont.Underline = STRINGTOBOOL(SkinDataFileValue)
Case "system_controlfontstrikethrough"
SESystemStructVar.SystemControlFont.StrikeThrough = STRINGTOBOOL(SkinDataFileValue)
Case "system_controlcolor"
SESystemStructVar.SystemControlColorStruct.ControlColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_controltextcolor"
SESystemStructVar.SystemControlColorStruct.ControlTextColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_lockedtextcolor"
SESystemStructVar.SystemControlColorStruct.LockedTextColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_controlshadowcolor"
SESystemStructVar.SystemControlColorStruct.ControlShadowColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_lightshadowcolor"
SESystemStructVar.SystemControlColorStruct.LightShadowColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_darkshadowcolor"
SESystemStructVar.SystemControlColorStruct.DarkShadowColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_controlmarkingcolor"
SESystemStructVar.SystemControlColorStruct.ControlMarkingColor = STRINGTOCOLOR(SkinDataFileValue)
Case "system_usetransparency"
'
'NOTE: the transparency of label back grounds can be enabled/disabled by the
'SkinDataFile and by SE_Initialize. The SkinDataFile must be re‑read to display changes.
'(label transparency set in SE_AddLabel()).
'
SESystemStructVar.SystemUseTransparencyFlag = STRINGTOBOOL(SkinDataFileValue)
Case "system_colorschemeenabled"
SESystemStructVar.ColorSchemeEnabledFlag = STRINGTOBOOL(SkinDataFileValue)
Case "system_colorschemecolor"
SESystemStructVar.ColorSchemeColor = STRINGTOCOLOR(SkinDataFileValue)
Case "add control"
If Not (SkinDataFileStructVar.SEControlInfoStructVar.ControlName = "") Then 'verify a control has been created
'add old control
For StructLoop = 1 To SERelationStructNumber
If SERelationStructArray(StructLoop).SEControlName = SkinDataFileStructVar.SEControlInfoStructVar.ControlName Then
If VerifyOnlyFlag = False Then
Call SE_AddControl(SERelationStructArray(StructLoop).SEControlName, SERelationStructArray(StructLoop).SEControlType, _
SkinDataFileStructVar.SEControlInfoStructVar, StructLoop)
Exit For
Else
VerifyControlNumber = VerifyControlNumber + 1
Exit For
End If
End If
Next StructLoop
End If
'preset
Call SkinDataFile_Read_Preset(SkinDataFileStructVar)
'begin creating new control
SkinDataFileStructVar.SEControlInfoStructVar.ControlName = SkinDataFileValue
Case "copyfrom"
StructIndex = GetSEControlStructIndex(SkinDataFileValue)
If Not (StructIndex = 0) Then 'verify
Call SkinDataFile_Read_CopyFrom(SkinDataFileStructVar, StructIndex)
Else
MsgBox "internal error in SkinDataFile_Allocate() (GFSkinEngine): 'copy from' failed !", vbOKOnly + vbExclamation
End If
Case "nofiledrop"
SkinDataFileStructVar.SEControlInfoStructVar.ControlNoFileDropFlag = STRINGTOBOOL(SkinDataFileValue)
Case "gridlines"
SkinDataFileStructVar.SEControlInfoStructVar.ControlGridLinesEnabledFlag = STRINGTOBOOL(SkinDataFileValue)
Case "caption"
SkinDataFileStructVar.SEControlInfoStructVar.ControlCaption = FixMaxLineLength(SkinDataFileValue, 850)
Case "enabled"
SkinDataFileStructVar.SEControlInfoStructVar.ControlEnabledFlag = STRINGTOBOOL(SkinDataFileValue)
Case "fontname"
If ISFONTAVAILABLE(SkinDataFileValue) = True Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont.Name = SkinDataFileValue
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont.Name = DefaultValueSet.SEControlInfoStructVar.ControlFont.Name
End If
Case "fontsize"
If Len(SkinDataFileValue) > 4 Then SkinDataFileValue = Left$(SkinDataFileValue, 4) 'verify to avoid overflow (important)
If Not ((Val(SkinDataFileValue) < 2) Or (Val(SkinDataFileValue) > 128)) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont.Size = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont.Size = DefaultValueSet.SEControlInfoStructVar.ControlFont.Size
End If
Case "fontbold"
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont.Bold = STRINGTOBOOL(SkinDataFileValue)
Case "fontitalic"
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont.Italic = STRINGTOBOOL(SkinDataFileValue)
Case "fontunderline"
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont.Underline = STRINGTOBOOL(SkinDataFileValue)
Case "fontstrikethrough"
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont.StrikeThrough = STRINGTOBOOL(SkinDataFileValue)
Case "forecolor"
SkinDataFileStructVar.SEControlInfoStructVar.ControlForeColor = STRINGTOCOLOR(SkinDataFileValue)
Case "backcolor"
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackColor = STRINGTOCOLOR(SkinDataFileValue)
Case "uppicture"
If GetDirectoryName(SkinDataFileValue) = "" Then SkinDataFileValue = SESystemStructVar.SystemSkinDirectory + SkinDataFileValue
SkinDataFileStructVar.SEControlInfoStructVar.ControlUpPicture = SkinDataFileValue
Case "downpicture"
If Len(SkinDataFileValue) Then If GetDirectoryName(SkinDataFileValue) = "" Then SkinDataFileValue = SESystemStructVar.SystemSkinDirectory + SkinDataFileValue
SkinDataFileStructVar.SEControlInfoStructVar.ControlDownPicture = SkinDataFileValue
Case "moveoverpicture"
If Len(SkinDataFileValue) Then If GetDirectoryName(SkinDataFileValue) = "" Then SkinDataFileValue = SESystemStructVar.SystemSkinDirectory + SkinDataFileValue
SkinDataFileStructVar.SEControlInfoStructVar.ControlMoveOverPicture = SkinDataFileValue
Case "backpicture"
If Len(SkinDataFileValue) Then If GetDirectoryName(SkinDataFileValue) = "" Then SkinDataFileValue = SESystemStructVar.SystemSkinDirectory + SkinDataFileValue
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackPicture = SkinDataFileValue
Case "backpictureenabled"
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackPictureEnabledFlag = STRINGTOBOOL(SkinDataFileValue)
Case "titlebarpicture"
If Len(SkinDataFileValue) Then If GetDirectoryName(SkinDataFileValue) = "" Then SkinDataFileValue = SESystemStructVar.SystemSkinDirectory + SkinDataFileValue
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarPicture = SkinDataFileValue
Case "titlebarspawnstartpos"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not ((Val(SkinDataFileValue) < 0) Or (Val(SkinDataFileValue) > 10240)) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarSpawnStartPos = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarSpawnStartPos = DefaultValueSet.SEControlInfoStructVar.ControlTitleBarSpawnStartPos
End If
Case "titlebarspawnlength"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not ((Val(SkinDataFileValue) < 1) Or (Val(SkinDataFileValue) > 10240)) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarSpawnLength = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarSpawnLength = DefaultValueSet.SEControlInfoStructVar.ControlTitleBarSpawnLength
End If
Case "titlebarheight"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not ((Val(SkinDataFileValue) < 0) Or (Val(SkinDataFileValue) > 10240)) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarHeight = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarHeight = DefaultValueSet.SEControlInfoStructVar.ControlTitleBarHeight
End If
Case "tooltiptext"
SkinDataFileStructVar.SEControlInfoStructVar.ControlToolTipText = SkinDataFileValue
Case "system_palettenumber"
If Len(SkinDataFileValue) > 4 Then SkinDataFileValue = Left$(SkinDataFileValue, 4) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEPaletteNumber = Val(SkinDataFileValue)
Case "frameindex"
If Len(SkinDataFileValue) > 4 Then SkinDataFileValue = Left$(SkinDataFileValue, 4) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlFrameIndex = Val(SkinDataFileValue)
Case "mouseicon"
If (Val(Mid$(SkinDataFileValue, 1, 1)) = 0) And (Not (SkinDataFileValue = "")) Then 'verify number is not destroyed by directory name
If GetDirectoryName(SkinDataFileValue) = "" Then SkinDataFileValue = SESystemStructVar.SystemSkinDirectory + SkinDataFileValue
End If
SkinDataFileStructVar.SEControlInfoStructVar.ControlMouseIcon = SkinDataFileValue
Case "xpos"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlXPos = Val(SkinDataFileValue)
Case "ypos"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlYPos = Val(SkinDataFileValue)
Case "xsize"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not (Val(SkinDataFileValue) < 0) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlXSize = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlXSize = 0
End If
Case "ysize"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not (Val(SkinDataFileValue) < 0) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlYSize = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlYSize = 0
End If
Case "palettenumber"
Call SkinDataFile_Read_GetPaletteArray(SkinDataFileValue, SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteNumber, SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteArray())
Case "resize_enabled"
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.ResizeEnabledFlag = STRINGTOBOOL(SkinDataFileValue)
Case "resize_step"
If Len(SkinDataFileValue) > 4 Then SkinDataFileValue = Left$(SkinDataFileValue, 4) 'verify to avoid overflow (important)
If Not (Val(SkinDataFileValue) < 1) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.ResizeStep = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.ResizeStep = 1
End If
Case "resize_mouseicon"
If (Val(Mid$(SkinDataFileValue, 1, 1)) = 0) And (Not (SkinDataFileValue = "")) Then 'verify number is not destroyed by directory name
If GetDirectoryName(SkinDataFileValue) = "" Then SkinDataFileValue = SESystemStructVar.SystemSkinDirectory + SkinDataFileValue
End If
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.ResizeMouseIcon = SkinDataFileValue
Case "resize_xsizemin"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not (Val(SkinDataFileValue) < 0) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_XSizeMin = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_XSizeMin = 0
End If
Case "resize_xsizemax"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not (Val(SkinDataFileValue) < 1) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_XSizeMax = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_XSizeMax = 1
End If
Case "resize_ysizemin"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not (Val(SkinDataFileValue) < 0) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_YSizeMin = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_YSizeMin = 0
End If
Case "resize_ysizemax"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
If Not (Val(SkinDataFileValue) < 1) Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_YSizeMax = Val(SkinDataFileValue)
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_YSizeMax = 1
End If
Case "resize_topfixed"
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_TopFixedFlag = STRINGTOBOOL(SkinDataFileValue)
Case "resize_leftfixed"
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_LeftFixedFlag = STRINGTOBOOL(SkinDataFileValue)
Case "resize_bottomfixed"
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_BottomFixedFlag = STRINGTOBOOL(SkinDataFileValue)
Case "resize_rightfixed"
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_RightFixedFlag = STRINGTOBOOL(SkinDataFileValue)
Case "resize_parentform"
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_ParentFormName = SkinDataFileValue
Case "resize_parentformxsize"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_ParentFormXSize = Val(SkinDataFileValue)
Case "resize_parentformysize"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_ParentFormYSize = Val(SkinDataFileValue)
Case "formstatetoggle_formxpos"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormXPos = Val(SkinDataFileValue)
Case "formstatetoggle_formypos"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormYPos = Val(SkinDataFileValue)
Case "formstatetoggle_formxsize"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormXSize = Val(SkinDataFileValue)
Case "formstatetoggle_formysize"
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormYSize = Val(SkinDataFileValue)
Case "formstatetoggle_formstate"
If Len(SkinDataFileValue) > 4 Then SkinDataFileValue = Left$(SkinDataFileValue, 4) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormState = Val(SkinDataFileValue)
Case "x"
If SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber = 32767 Then
SkinDataFile_Allocate = True 'ok
Exit Function 'verify
End If
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber = SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber + 1
ReDim Preserve SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointXArray(1 To SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber) As Long
ReDim Preserve SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointYArray(1 To SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber) As Long
If Not (UCase$(SkinDataFileValue) = "WIDTH") Then
If Len(SkinDataFileValue) > 9 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointXArray(SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber) = Val(SkinDataFileValue)
Else
'NOTE: the user may use 'WIDTH' (control must be registered).
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointXArray(SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber) = 10 'preset (do not use 0 to make debugging easier)
For StructLoop = 1 To SERelationStructNumber
If SERelationStructArray(StructLoop).SEControlName = SkinDataFileStructVar.SEControlInfoStructVar.ControlName Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointXArray(SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber) = SERelationStructArray(StructLoop).SEControlObject.Width / Screen.TwipsPerPixelX
Exit For
End If
Next StructLoop
End If
Case "y"
If SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber = 0 Then Exit Function 'array can be enlarged by an x coordinate only
If Not (UCase$(SkinDataFileValue) = "HEIGHT") Then
If Len(SkinDataFileValue) > 8 Then SkinDataFileValue = Left$(SkinDataFileValue, 8) 'verify to avoid overflow (important)
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointYArray(SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber) = Val(SkinDataFileValue)
Else
'NOTE: the user may use 'HEIGHT' (control must be registered).
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointYArray(SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber) = 10 'preset (do not use 0 to make debugging easier)
For StructLoop = 1 To SERelationStructNumber
If SERelationStructArray(StructLoop).SEControlName = SkinDataFileStructVar.SEControlInfoStructVar.ControlName Then
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointYArray(SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber) = SERelationStructArray(StructLoop).SEControlObject.Height / Screen.TwipsPerPixelY
Exit For
End If
Next StructLoop
End If
End Select
If LCase$(Left$(SkinDataFileCommand, 12)) = "system_color" Then
'allocate a system color
Temp = Val(Right$(SkinDataFileCommand, MIN(Len(SkinDataFileCommand) ‑ 12, 8))) 'use MIN() to avoid Val() overflow
If Not ((Temp < LBound(SESystemStructVar.SystemColorArray())) Or (Temp > UBound(SESystemStructVar.SystemColorArray()))) Then 'verify
SESystemStructVar.SystemColorArray(Temp) = STRINGTOCOLOR(SkinDataFileValue)
End If
End If
If LCase$(Left$(SkinDataFileCommand, 11)) = "system_text" Then
'allocate a system text
Temp = Val(Right$(SkinDataFileCommand, MIN(Len(SkinDataFileCommand) ‑ 11, 8))) 'use MIN() to avoid Val() overflow
If Not ((Temp < LBound(SESystemStructVar.SystemTextArray())) Or (Temp > UBound(SESystemStructVar.SystemTextArray()))) Then 'verify
SESystemStructVar.SystemTextArray(Temp) = SkinDataFileValue
End If
End If
If LCase$(Left$(SkinDataFileCommand, 17)) = "system_framecolor" Then
'allocate a system text
Temp = Val(Right$(SkinDataFileCommand, MIN(Len(SkinDataFileCommand) ‑ 17, 8))) 'use MIN() to avoid Val() overflow
If Not ((Temp < LBound(SESystemStructVar.SystemFrameColorArray())) Or (Temp > UBound(SESystemStructVar.SystemFrameColorArray()))) Then 'verify
SESystemStructVar.SystemFrameColorArray(Temp) = STRINGTOCOLOR(SkinDataFileValue)
End If
End If
SkinDataFile_Allocate = True 'ok
Exit Function
Error:
MsgBox "internal error in SkinDataFile_Allocate() (GFSkinEngine) during processing control '" + SkinDataFileStructVar.SEControlInfoStructVar.ControlName + "' !", vbOKOnly + vbCritical
SkinDataFile_Allocate = False 'error
Exit Function
End Function
Private Sub SkinDataFile_Read_Preset(ByRef SkinDataFileStructVar As SkinDataFileStruct)
'on error resume next 'configure default values carefully so that the user needs to use as few commands as possible
SkinDataFileStructVar.SEControlInfoStructVar.ControlName = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlNoFileDropFlag = False
SkinDataFileStructVar.SEControlInfoStructVar.ControlGridLinesEnabledFlag = False
SkinDataFileStructVar.SEControlInfoStructVar.ControlCaption = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlForeColor = SESystemStructVar.SystemForeColor
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackColor = SESystemStructVar.SystemBackColor
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont = SESystemStructVar.SystemFont
SkinDataFileStructVar.SEControlInfoStructVar.ControlFrameIndex = 1 'preset
SkinDataFileStructVar.SEControlInfoStructVar.ControlUpPicture = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlDownPicture = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlMoveOverPicture = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackPicture = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackPictureEnabledFlag = False
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarPicture = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarSpawnStartPos = 10 'preset
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarSpawnLength = 10 'preset
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarHeight = 10 'preset
SkinDataFileStructVar.SEControlInfoStructVar.ControlMouseIcon = SESystemStructVar.SystemMouseIcon
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber = 0 'reset
ReDim SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointXArray(1 To 1) As Long 'reset
ReDim SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointYArray(1 To 1) As Long 'reset
SkinDataFileStructVar.SEControlInfoStructVar.ControlToolTipText = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteNumber = 1
ReDim SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteArray(1 To 1) As Integer
SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteArray(1) = SkinDataFileStructVar.SEPaletteNumber '‑1 by default
SkinDataFileStructVar.SEControlInfoStructVar.ControlXPos = SE_POS_NOT_DEFINED 'preset (not defined)
SkinDataFileStructVar.SEControlInfoStructVar.ControlYPos = SE_POS_NOT_DEFINED 'preset (not defined)
SkinDataFileStructVar.SEControlInfoStructVar.ControlXSize = SE_SIZE_NOT_DEFINED 'preset (not defined)
SkinDataFileStructVar.SEControlInfoStructVar.ControlYSize = SE_SIZE_NOT_DEFINED 'preset (not defined)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.ResizeEnabledFlag = False
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.ResizeStep = (GetXGrid + GetYGrid) / 2 'preset (default)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.ResizeMouseIcon = SESystemStructVar.SystemMouseIcon
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_XSizeMax = Screen.Width / Screen.TwipsPerPixelX
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_YSizeMax = Screen.Height / Screen.TwipsPerPixelY
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_XSizeMin = 1
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_YSizeMin = 1
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_LeftFixedFlag = False
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_TopFixedFlag = False
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_RightFixedFlag = False
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_BottomFixedFlag = False
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_ParentFormName = ""
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_ParentFormXSize = SE_SIZE_NOT_DEFINED 'preset (not defined)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.Resize_ParentFormYSize = SE_SIZE_NOT_DEFINED 'preset (not defined)
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormXPos = SE_POS_NOT_DEFINED 'you know
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormYPos = SE_POS_NOT_DEFINED
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormXSize = SE_SIZE_NOT_DEFINED
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormYSize = SE_SIZE_NOT_DEFINED
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct.FormStateToggleStructVar.FormState = SE_FORMTOGGLESTATE_NOT_DEFINED
End Sub
Public Sub SkinDataFile_Read_CopyFrom(ByRef SkinDataFileStructVar As SkinDataFileStruct, ByVal SEControlStructIndex As Integer)
'on error resume next 'pay attention that all values that are preset are also transferred
Dim TransferLoop As Integer
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then 'verify
MsgBox "internal error in SkinDataFile_Read_CopyFrom(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
'SkinDataFileStructVar.SEControlInfoStructVar.ControlName = SEControlStructArray(SEControlStructIndex).SEControlName 'nonono!!!
SkinDataFileStructVar.SEControlInfoStructVar.ControlNoFileDropFlag = SEControlStructArray(SEControlStructIndex).SEControl_NoFileFropFlag
SkinDataFileStructVar.SEControlInfoStructVar.ControlGridLinesEnabledFlag = SEControlStructArray(SEControlStructIndex).SEControl_GridLinesEnabledFlag
SkinDataFileStructVar.SEControlInfoStructVar.ControlCaption = SEControlStructArray(SEControlStructIndex).SEControl_Caption
SkinDataFileStructVar.SEControlInfoStructVar.ControlForeColor = SEControlStructArray(SEControlStructIndex).SEControl_ForeColor
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackColor = SEControlStructArray(SEControlStructIndex).SEControl_BackColor
SkinDataFileStructVar.SEControlInfoStructVar.ControlFont = SEControlStructArray(SEControlStructIndex).SEControl_Font
SkinDataFileStructVar.SEControlInfoStructVar.ControlFrameIndex = SEControlStructArray(SEControlStructIndex).SEControl_FrameIndex
SkinDataFileStructVar.SEControlInfoStructVar.ControlUpPicture = SEControlStructArray(SEControlStructIndex).SEControl_UpPicture
SkinDataFileStructVar.SEControlInfoStructVar.ControlDownPicture = SEControlStructArray(SEControlStructIndex).SEControl_DownPicture
SkinDataFileStructVar.SEControlInfoStructVar.ControlMoveOverPicture = SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPicture
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackPicture = SEControlStructArray(SEControlStructIndex).SEControl_BackPicture
SkinDataFileStructVar.SEControlInfoStructVar.ControlBackPictureEnabledFlag = SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarPicture = SEControlStructArray(SEControlStructIndex).SEControl_TitleBarPicture
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarSpawnStartPos = SEControlStructArray(SEControlStructIndex).SEControl_TitleBarSpawnLength
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarSpawnLength = SEControlStructArray(SEControlStructIndex).SEControl_TitleBarSpawnLength
SkinDataFileStructVar.SEControlInfoStructVar.ControlTitleBarHeight = SEControlStructArray(SEControlStructIndex).SEControl_TitleBarHeight
SkinDataFileStructVar.SEControlInfoStructVar.ControlMouseIcon = SEControlStructArray(SEControlStructIndex).SEControl_MouseIcon
SkinDataFileStructVar.SEControlInfoStructVar.ControlPolyRgnPointNumber = SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointNumber
With SkinDataFileStructVar.SEControlInfoStructVar
If .ControlPolyRgnPointNumber = 0 Then
ReDim .ControlPolyRgnPointXArray(1 To 1) As Long 'reset
ReDim .ControlPolyRgnPointYArray(1 To 1) As Long 'reset
Else
ReDim .ControlPolyRgnPointXArray(1 To .ControlPolyRgnPointNumber) As Long 'reset
ReDim .ControlPolyRgnPointYArray(1 To .ControlPolyRgnPointNumber) As Long 'reset
For TransferLoop = 1 To .ControlPolyRgnPointNumber
.ControlPolyRgnPointXArray(TransferLoop) = SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointXArray(TransferLoop)
.ControlPolyRgnPointYArray(TransferLoop) = SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointYArray(TransferLoop)
Next TransferLoop
End If
End With
SkinDataFileStructVar.SEControlInfoStructVar.ControlToolTipText = SEControlStructArray(SEControlStructIndex).SEControl_ToolTipText
If Not (SEControlStructArray(SEControlStructIndex).SEControl_PaletteNumber = 0) Then 'verify
SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteNumber = SEControlStructArray(SEControlStructIndex).SEControl_PaletteNumber
ReDim SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteArray(1 To SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteNumber) As Integer
For TransferLoop = 1 To SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteNumber
SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteArray(TransferLoop) = SEControlStructArray(SEControlStructIndex).SEControl_PaletteArray(TransferLoop)
Next TransferLoop
Else
SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteNumber = 0 'reset
ReDim SkinDataFileStructVar.SEControlInfoStructVar.ControlPaletteArray(1 To 1) As Integer 'reset
End If
SkinDataFileStructVar.SEControlInfoStructVar.ControlXPos = SEControlStructArray(SEControlStructIndex).SEControl_XPos
SkinDataFileStructVar.SEControlInfoStructVar.ControlYPos = SEControlStructArray(SEControlStructIndex).SEControl_YPos
SkinDataFileStructVar.SEControlInfoStructVar.ControlXSize = SEControlStructArray(SEControlStructIndex).SEControl_XSize
SkinDataFileStructVar.SEControlInfoStructVar.ControlYSize = SEControlStructArray(SEControlStructIndex).SEControl_YSize
SkinDataFileStructVar.SEControlInfoStructVar.ControlResizeStruct = SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct
End Sub
Public Sub SkinDataFile_Read_GetPaletteArray(ByVal SkinDataFileValue As String, ByRef PaletteNumber As Integer, ByRef PaletteArray() As Integer)
'on error resume next 'transfers a string in the format #,#,#,# to PaletteArray()
Dim CharLoop As Integer
'reset
PaletteNumber = 0 'reset
ReDim PaletteArray(1 To 1) As Integer 'reset
'preset
SkinDataFileValue = SkinDataFileValue + ","
'begin
ReDo:
For CharLoop = 1 To Len(SkinDataFileValue)
If Mid$(SkinDataFileValue, CharLoop, 1) = "," Then
If Not (PaletteNumber = 32766) Then 'verify
PaletteNumber = PaletteNumber + 1
Else
Exit Sub
End If
ReDim Preserve PaletteArray(1 To PaletteNumber) As Integer
PaletteArray(PaletteNumber) = Val(Trim$(Left$(SkinDataFileValue, MIN(CharLoop ‑ 1, 4)))) 'limit palette number to 9999 to avoid Integer overflow
SkinDataFileValue = Right$(SkinDataFileValue, Len(SkinDataFileValue) ‑ CharLoop)
GoTo ReDo:
End If
Next CharLoop
If PaletteNumber = 0 Then 'verify
PaletteNumber = 1
ReDim PaletteArray(1 To 1) As Integer
PaletteArray(1) = ‑1 'default palette
End If
End Sub
Public Function SkinDataFile_ChangeProperty(ByVal SkinDataFile As String, ByVal ControlName As String, ByVal PropertyName As String, ByVal PropertyValue As String, Optional ByVal DeletePropertyLineOnlyFlag As Boolean = False, Optional ByVal ForcePropertyLineAddFlag As Boolean = False) As Boolean
'on error resume next 'returns True if a property line has been deleted, False if not
Dim SkinDataFileString As String
'
'NOTE: changing a property is split up into several sub functions to allow
'changing several properties along with reading and writing the SkinDataFile
'once only (increases speed).
'
'begin
Call SkinDataFile_ReadString(SkinDataFile, SkinDataFileString)
SkinDataFile_ChangeProperty = _
SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, PropertyName, PropertyValue, DeletePropertyLineOnlyFlag, ForcePropertyLineAddFlag)
Call SkinDataFile_WriteString(SkinDataFile, SkinDataFileString)
End Function
Public Function SkinDataFile_CreateDomain(ByVal SkinDataFile As String, ByVal DomainName As String, ByVal DomainPaletteNumber As Integer) As Boolean
'on error resume next 'returns True for domain was not existing (has been newly created) or False for domain was existing
Dim SkinDataFileString As String
'
'NOTE: adds the domain at very end of SDF if the domain is not existing yet.
'Any kind of target project can call this function if any controls were added and any old
'skin the user could re‑use for the new program version is to be updated.
'
'begin
Call SkinDataFile_ReadString(SkinDataFile, SkinDataFileString)
SkinDataFile_CreateDomain = _
SkinDataFile_CreateDomainSub(SkinDataFileString, DomainName, DomainPaletteNumber)
Call SkinDataFile_WriteString(SkinDataFile, SkinDataFileString)
End Function
Public Sub SkinDataFile_ReadString(ByVal SkinDataFile As String, ByRef SkinDataFileString As String)
'on error resume next 'reads whole SkinDataFile into passed string
Dim SkinDataFileNumber As Integer
'
'NOTE: this sub must support SkinDataFile being any file name,
'also e.g. "C:\Windows\Temp\034890123.tmp".
'
'verify
If (DirSave(SkinDataFile) = "") Or (Right$(SkinDataFile, 1) = "\") Or (SkinDataFile = "") Then
MsgBox "internal error in SkinDataFile_ChangeProperty(): file '" + SkinDataFile + "' not found !", vbOKOnly + vbInformation
SkinDataFileString = "" 'reset (error)
Exit Sub 'error
End If
'preset
SkinDataFileNumber = FreeFile(0)
'begin
If UCase$(SkinDataFile) = UCase$(SkinDataFileCacheStructVar.SkinDataFile) Then
'NOTE: there's no need to read the SkinDataFile again.
SkinDataFileString = SkinDataFileCacheStructVar.SkinDataFileString
Else
Call Skin_DecryptFile(SkinDataFile)
Open SkinDataFile For Binary As #SkinDataFileNumber
SkinDataFileString = String$(LOF(SkinDataFileNumber), Chr$(0))
Get #1, 1, SkinDataFileString
Close #SkinDataFileNumber
Call Skin_EncryptFile(SkinDataFile)
SkinDataFileCacheStructVar.SkinDataFileString = SkinDataFileString
SkinDataFileCacheStructVar.SkinDataFile = SkinDataFile 'important
End If
End Sub
Private Function SkinDataFile_VerifyString(ByRef SkinDataFileString As String) As Boolean
'on error resume next 'returns True if an error was found, then the calling sub/function should rewrite the whole SkinDataFile
Dim SkinDataFileStringByte() As Byte 'use a byte string for checking to increase speed
Dim ErrorExistingFlag As Boolean
Dim Temp As Long
'
'NOTE: this sub verifies Chr$(13) and Chr$(10) appear always
'as a pair (important when changing a property in SkinDataFileString).
'
'verify
If Len(SkinDataFileString) = 0 Then
SkinDataFile_VerifyString = False 'no error
Exit Function
End If
ReDo:
'preset
ReDim SkinDataFileStringByte(1 To Len(SkinDataFileString)) As Byte
Call CopyMemory(SkinDataFileStringByte(1), ByVal SkinDataFileString, Len(SkinDataFileString))
'begin
For Temp = 1 To Len(SkinDataFileString)
Select Case SkinDataFileStringByte(Temp)
Case 10
If Not (Temp = 1) Then 'verify
If Not (SkinDataFileStringByte(Temp ‑ 1) = 13) Then
SkinDataFileString = Left$(SkinDataFileString, Temp ‑ 1) + _
Chr$(13) + Right$(SkinDataFileString, Len(SkinDataFileString) ‑ Temp + 1)
ErrorExistingFlag = True
GoTo ReDo:
End If
Else
SkinDataFileString = Chr$(13) + SkinDataFileString
ErrorExistingFlag = True
GoTo ReDo:
End If
Case 13
If Not (Temp = Len(SkinDataFileString)) Then 'verify
If Not (SkinDataFileStringByte(Temp + 1) = 10) Then
SkinDataFileString = Left$(SkinDataFileString, Temp) + _
Chr$(10) + Right$(SkinDataFileString, Len(SkinDataFileString) ‑ Temp)
ErrorExistingFlag = True
GoTo ReDo:
End If
Else
SkinDataFileString = SkinDataFileString + Chr$(10)
ErrorExistingFlag = True
GoTo ReDo:
End If
End Select
Next Temp
If ErrorExistingFlag = True Then MsgBox "internal error in SkinDataFile_Verify(): Chr$(13) + Chr$(10) did not appear as a pair !", vbOKOnly + vbExclamation 'for debugging
SkinDataFile_VerifyString = ErrorExistingFlag
Exit Function
End Function
Private Function SkinDataFile_VerifySystemLines(ByRef SkinDataFileString As String) As Boolean
'on error resume next 'returns True if an error was found, then the calling sub/function should rewrite the whole SkinDataFile
Dim SkinDataFileStringLength As Long
Dim SkinDataFileStringByte() As Byte 'use a byte string for checking to increase speed
Dim LineStartPos As Long
Dim LineEndPos As Long
Dim ErrorExistingFlag As Boolean
Dim EndSignAddedFlag As Boolean
Dim Temp As Long
Dim TempByteStringLength As Long
Dim TempByteString() As Byte
'
'NOTE: call this function AFTER the line returns have been checked
'(a line must be bordered by Char$(13) AND Chr$(10)).
'Every second, third, etc. appearance of any system_[...] line will be
'removed, [...] represents all chars 'till '='.
'The following SkinDataFileCommands will not be checked:
'‑system_palettenumber
'
'verify
If Not (Right$(SkinDataFileString, 2) = Chr$(13) + Chr$(10)) Then
EndSignAddedFlag = True
SkinDataFileString = SkinDataFileString + Chr$(13) + Chr$(10)
End If
'preset
SkinDataFileStringLength = Len(SkinDataFileString) 'preset once only
ReDim SkinDataFileStringByte(1 To SkinDataFileStringLength) As Byte
Call CopyMemory(SkinDataFileStringByte(1), ByVal SkinDataFileString, SkinDataFileStringLength)
SkinDataFile_VerifySystemLines = False 'preset
ReDo:
'reset
VerifySystemLinesStructNumber = 0 'reset
ReDim VerifySystemLinesStructArray(1 To 1) As VerifySystemLinesStruct 'reset
'begin
LineStartPos = 1
For Temp = 1 To SkinDataFileStringLength
If SkinDataFileStringByte(Temp) = 13 Then
If LineStartPos = 0 Then
LineStartPos = (Temp + 2)
Else
LineEndPos = (Temp + 1)
TempByteStringLength = (LineEndPos ‑ LineStartPos + 1) 'can be 0
If TempByteStringLength = 0 Then GoTo Jump: 'verify
ReDim TempByteString(1 To TempByteStringLength) As Byte
Call CopyMemory(TempByteString(1), SkinDataFileStringByte(LineStartPos), TempByteStringLength)
If SkinDataFile_VerifySystemLines_IsSystemLine(TempByteStringLength, TempByteString()) = True Then
If SkinDataFile_VerifySystemLines_IsLineBuffered(TempByteStringLength, TempByteString()) = True Then
If Not ((LineEndPos + 1) > SkinDataFileStringLength) Then 'verify
If (LineStartPos > SkinDataFileStringLength) Or (LineEndPos + 1 > SkinDataFileStringLength) Then 'verify
MsgBox "internal error in SkinDataFile_VerifySystemLines() !", vbOKOnly + vbExclamation
Else
Call CopyMemory( _
SkinDataFileStringByte(LineStartPos), _
SkinDataFileStringByte(LineEndPos + 1), _
SkinDataFileStringLength ‑ LineEndPos)
End If
End If
SkinDataFileStringLength = SkinDataFileStringLength ‑ TempByteStringLength
ReDim Preserve SkinDataFileStringByte(1 To SkinDataFileStringLength) As Byte
SkinDataFile_VerifySystemLines = True
LineStartPos = Temp + 2 'reset
LineEndPos = 0 'reset
GoTo ReDo:
Else
LineStartPos = Temp + 2 'reset
LineEndPos = 0 'reset
Call SkinDataFile_VerifySystemLines_AddLine(TempByteStringLength, TempByteString())
End If
End If
Jump:
LineStartPos = Temp + 2 'reset
LineEndPos = 0 'reset
Temp = Temp + 1
End If
End If
Next Temp
If EndSignAddedFlag = True Then
EndSignAddedFlag = False 'reset
SkinDataFileStringLength = SkinDataFileStringLength ‑ 1
End If
SkinDataFileString = String$(SkinDataFileStringLength, Chr$(0))
Call CopyMemory(ByVal SkinDataFileString, SkinDataFileStringByte(1), SkinDataFileStringLength)
End Function
Private Function SkinDataFile_VerifySystemLines_IsSystemLine(ByVal ByteStringLength As Long, ByRef ByteString() As Byte) As Boolean
'on error resume next 'returns true if passed line is a system_[...] line that is to be removed, False if not
If Not (ByteStringLength < 7) Then
If (ByteString(1) = 115) Or (ByteString(1) = 83) Then
If (ByteString(2) = 121) Or (ByteString(2) = 89) Then
If (ByteString(3) = 115) Or (ByteString(3) = 83) Then
If (ByteString(4) = 116) Or (ByteString(4) = 84) Then
If (ByteString(5) = 101) Or (ByteString(5) = 69) Then
If (ByteString(6) = 109) Or (ByteString(6) = 77) Then
If (ByteString(7) = 95) Then 'system_
Dim Tempstr$
Tempstr$ = String$(MIN(ByteStringLength, 20), Chr$(0))
Call CopyMemory(ByVal Tempstr$, ByteString(1), MIN(ByteStringLength, 20))
Select Case UCase$(Tempstr$)
Case "SYSTEM_PALETTENUMBER" 'add lines that are not to be removed here
GoTo Error:
Case Else
SkinDataFile_VerifySystemLines_IsSystemLine = True
Exit Function
End Select
Else: GoTo Error: End If
Else: GoTo Error: End If
Else: GoTo Error: End If
Else: GoTo Error: End If
Else: GoTo Error: End If
Else: GoTo Error: End If
Else: GoTo Error: End If
Else: GoTo Error: End If
SkinDataFile_VerifySystemLines_IsSystemLine = True
Exit Function
Error:
SkinDataFile_VerifySystemLines_IsSystemLine = False
Exit Function
End Function
Private Sub SkinDataFile_VerifySystemLines_AddLine(ByVal ByteStringLength As Long, ByRef ByteString() As Byte)
'on error resume next
If Not (VerifySystemLinesStructNumber = 32766) Then 'verify (else do nothing)
VerifySystemLinesStructNumber = VerifySystemLinesStructNumber + 1
ReDim Preserve VerifySystemLinesStructArray(1 To VerifySystemLinesStructNumber) As VerifySystemLinesStruct
VerifySystemLinesStructArray(VerifySystemLinesStructNumber).ByteStringLength = ByteStringLength
ReDim VerifySystemLinesStructArray(VerifySystemLinesStructNumber).ByteString(1 To ByteStringLength)
Call CopyMemory(VerifySystemLinesStructArray(VerifySystemLinesStructNumber).ByteString(1), ByteString(1), ByteStringLength)
End If
End Sub
Private Function SkinDataFile_VerifySystemLines_IsLineBuffered(ByRef ByteStringLength As Long, ByRef ByteString() As Byte) As Boolean
'on error resume next
Dim BufferLoop As Integer
Dim Temp As Long
'begin
For BufferLoop = 1 To VerifySystemLinesStructNumber
If (VerifySystemLinesStructArray(BufferLoop).ByteStringLength = ByteStringLength) Then 'otherwise strings cannot be equal
If (ByteStringLength > 0) Then
If VerifySystemLinesStructArray(BufferLoop).ByteString(1) = ByteString(1) Then
If (ByteStringLength > 1) Then
If VerifySystemLinesStructArray(BufferLoop).ByteString(2) = ByteString(2) Then
If (ByteStringLength > 2) Then
If VerifySystemLinesStructArray(BufferLoop).ByteString(3) = ByteString(3) Then
For Temp = 1 To ByteStringLength
If VerifySystemLinesStructArray(BufferLoop).ByteString(Temp) = ByteString(Temp) Then
If ByteString(Temp) = 61 Then Exit For 'check only 'till '='
Else
GoTo Jump:
End If
Next Temp
SkinDataFile_VerifySystemLines_IsLineBuffered = True
Exit Function
Else
GoTo Jump:
End If
Else
SkinDataFile_VerifySystemLines_IsLineBuffered = True
Exit Function
End If
Else
GoTo Jump:
End If
Else
SkinDataFile_VerifySystemLines_IsLineBuffered = True
Exit Function
End If
Else
GoTo Jump:
End If
Else
SkinDataFile_VerifySystemLines_IsLineBuffered = True
Exit Function
End If
Else
GoTo Jump:
End If
Jump:
Next BufferLoop
SkinDataFile_VerifySystemLines_IsLineBuffered = False
Exit Function
End Function
Private Function SkinDataFile_Verify(ByVal SkinDataFile As String) As Boolean
'on error resume next 'returns True if passed SkinDataFile seems to be valid, False if it contains fatal errors
Dim SkinDataFileString As String
Dim VerifyControlNumber As Integer
'
'NOTE: at least 80 percent of the controls registered by the target project
'must appear in the passed SkinDataFile and reading the SkinDataFile
'must have worked, too.
'
'verify
If (DirSave(SkinDataFile) = "") Or (Right(SkinDataFile, 1) = "\") Or (SkinDataFile = "") Then
SkinDataFile_Verify = False 'file not valid
Exit Function
End If
'begin
Call SkinDataFile_ReadString(SkinDataFile, SkinDataFileString) 'will not use cached string if SkinDataFile changed
If SkinDataFile_ReadSub(SkinDataFileString, True, VerifyControlNumber) = True Then
If (CSng(VerifyControlNumber) / CSng(SERelationStructNumber)) < 0.8! Then
SkinDataFile_Verify = False 'error
Exit Function
Else
SkinDataFile_Verify = True 'ok
Exit Function
End If
Else
SkinDataFile_Verify = False 'error
Exit Function
End If
End Function
Public Sub SkinDataFile_WriteString(ByVal SkinDataFile As String, ByRef SkinDataFileString As String)
'on error resume next 'fills SkinDataFile with passed string
Dim SkinDataFileNumber As Integer
'verify
If (DirSave(SkinDataFile) = "") Or (Right$(SkinDataFile, 1) = "\") Or (SkinDataFile = "") Then
MsgBox "internal error in SkinDataFile_WriteString(): file '" + SkinDataFile + "' not found !", vbOKOnly + vbInformation
Exit Sub 'error
End If
'preset
SkinDataFileNumber = FreeFile(0)
'begin
'Call Skin_DecryptFile(SkinDataFile) 'not necessary
If SESystemStructVar.SystemNoSkinDataFileWriteFlag = False Then
Open SkinDataFile For Output As #SkinDataFileNumber
Print #SkinDataFileNumber, SkinDataFileString;
Close #SkinDataFileNumber
End If
Call Skin_EncryptFile(SkinDataFile)
If UCase$(SkinDataFile) = UCase$(SkinDataFileCacheStructVar.SkinDataFile) Then
'NOTE: also update the 'memory SkinDataFile'.
SkinDataFileCacheStructVar.SkinDataFileString = SkinDataFileString
End If
End Sub
Public Function SkinDataFile_ChangePropertySub(ByRef SkinDataFileString As String, ByVal ControlName As String, ByVal PropertyName As String, ByVal PropertyValue As String, Optional ByVal DeletePropertyLineOnlyFlag As Boolean = False, Optional ByVal ForcePropertyLineAddFlag As Boolean = False) As Boolean
'on error resume next 'returns True if a property line has deleted, False if not
Dim SkinDataFileStringNew As String
Dim ControlDomainStartPos As Long
Dim ControlDomainEndPos As Long
Dim ControlPropertyLineStartPos As Long
Dim ControlPropertyLineEndPos As Long
Dim Temp As Long
'
'HANDS OFF THIS SHIT CODE OR IT WILL NEVER WORK AGAIN!!!
'
'NOTE: call this sub to update e.g. the uppicture of a control.
'This sub will search the SkinDataFile for the existing property line
'(SkinDataFileCommand + "=" + SkinDataFileValue) and replace it with
'the passed one. If the property line does not exist, it will be created
'and placed 'below' existing property lines related to the control name.
'
'NOTE: if the passed control name is nothing (""), the first command value
'related to the passed command name will be changed.
'If the passed control name is not nothing, the command name must
'appear after '[ControlName]', but before next control name to be changed.
'Otherwise the command name and related value will be created automatically.
'
'NOTE: if DeletePropertyLineOnlyFlag is True, this function will
'remove the complete line that includes ProgertyName in the
'control domain ControlName.
'The function returns True if a line has been removed, False if not.
'
'NOTE: if ForcePropertyLineAddFlag is True, a new property line will
'be created right below control name, also if it also exists.
'Do not add a such a property line at end of the control domain as then
'the order poly rgn points are saved would be wrong.
'(ForcePropertyLineAddFlag = True is only used to save poly rgn points).
'
'NOTE: there may not be any space char left of the '=' (e.g. 'enabled =').
'
'NOTE: a property line to change or cut includes bordering
'Chr$(13) + Chr$(10)s, so any ControlPropertyLineStartPos
'points to a Chr$(13) and every end pos points to a Chr$(10).
'
'verify
If Not (Right$(SkinDataFileString, 2) = Chr$(13) + Chr$(10)) Then SkinDataFileString = SkinDataFileString + Chr$(13) + Chr$(10) 'add end sign (important)
If Len(PropertyName) > 128 Then
MsgBox "internal error in SkinDataFile_ChangePropertySub(): property name '" + PropertyName + "' too long !", vbOKOnly + vbExclamation
SkinDataFile_ChangePropertySub = False 'line has not been deleted
Exit Function 'error
End If
If Len(PropertyValue) > 800 Then
'NOTE: the line length in SkinDataFile should never exceed 1024 chars.
MsgBox "warning in SkinDataFile_ChangePropertySub(): property value too long, was limited to 800 chars !", vbOKOnly + vbExclamation
PropertyValue = Left$(PropertyValue, 800)
End If
'begin
Call SkinDataFile_GetControlDomainPos(SkinDataFileString, ControlName, ControlDomainStartPos, ControlDomainEndPos)
Call SkinDataFile_GetControlPropertyLinePos(SkinDataFileString, PropertyName, ControlDomainStartPos, ControlDomainEndPos, _
ControlPropertyLineStartPos, ControlPropertyLineEndPos, DeletePropertyLineOnlyFlag)
'
'NOTE: the cut string starts at Chr$(13) and ends with the last letter of the property value.
'Note that the property line end pos could be smaller than the start pos
'(the inserting algorithm below needs this).
'
If (ForcePropertyLineAddFlag = True) And (DeletePropertyLineOnlyFlag = False) Then
'
'NOTE: even if there is already the property name to create, another one will be created
'AT TOP of the current property string.
'
ControlPropertyLineStartPos = ControlDomainStartPos
ControlPropertyLineEndPos = (ControlDomainStartPos + 1) 'replace existing Chr$(13) + Chr$(10)
Else
If ControlPropertyLineStartPos = 0 Then 'property not existing, e.g. caption= not existing, create it
If DeletePropertyLineOnlyFlag = False Then 'important, no sense to create if to be removed
ControlPropertyLineStartPos = ControlDomainStartPos
ControlPropertyLineEndPos = (ControlDomainStartPos + 1) 'replace existing Chr$(13) + Chr$(10)
End If
End If
End If
'create new string
If Not ((ControlPropertyLineStartPos < 1) Or (ControlPropertyLineEndPos > (Len(SkinDataFileString) + 1))) Then 'verify
'
'NOTE: ControlPropertyLineEndPos could point to (Len(SkinDataFileString) + 1)
'if the end of the SkinDataFile looks like this: [control name]EOF.
'Use MAX() to avoid errors from Right$().
'
If DeletePropertyLineOnlyFlag = True Then
SkinDataFileStringNew = Left$(SkinDataFileString, ControlPropertyLineStartPos ‑ 1) + _
Right$(SkinDataFileString, MAX(Len(SkinDataFileString) ‑ ControlPropertyLineEndPos + 2, 0)) 'do not cut second Chr$(13) + Chr$(10)
SkinDataFileString = SkinDataFileStringNew 'transfer new string
SkinDataFile_ChangePropertySub = True 'line has been deleted
Else
SkinDataFileStringNew = Left$(SkinDataFileString, ControlPropertyLineStartPos ‑ 1) + _
Chr$(13) + Chr$(10) + PropertyName + "=" + PropertyValue + Chr$(13) + Chr$(10) + _
Right$(SkinDataFileString, MAX(Len(SkinDataFileString) ‑ ControlPropertyLineEndPos, 0))
SkinDataFileString = SkinDataFileStringNew 'transfer new string
SkinDataFile_ChangePropertySub = False 'line has not been deleted
End If
Else
'property line not found, do not edit passed string
SkinDataFile_ChangePropertySub = False 'line has not been deleted
End If
End Function
Private Function SkinDataFile_CreateDomainSub(ByRef SkinDataFileString As String, ByVal DomainName As String, ByVal DomainPaletteNumber As Integer) As Boolean
'on error resume next 'returns True if domain has just been created
Dim ControlDomainStartPos As Long
Dim ControlDomainEndPos As Long
'verify
If SkinDataFile_GetControlDomainPos(SkinDataFileString, DomainName, ControlDomainStartPos, ControlDomainEndPos) = True Then
'NOTE: don't check ControlDomainStartPos, will always be >= 1 as 1 is preset as insert position.
SkinDataFile_CreateDomainSub = False
Exit Function
End If
'begin
If Not (Right$(SkinDataFileString, 2) = Chr$(13) + Chr$(10)) Then
SkinDataFileString = SkinDataFileString + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) 'add one empty line
Else
If Not (Right$(SkinDataFileString, 4) = Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)) Then '1 new line existing, also 2?
SkinDataFileString = SkinDataFileString + Chr$(13) + Chr$(10) 'add one empty line
End If
End If
SkinDataFileString = SkinDataFileString + "system_palettenumber=" + CStr(DomainPaletteNumber) + Chr$(13) + Chr$(10)
SkinDataFileString = SkinDataFileString + Chr$(13) + Chr$(10)
SkinDataFileString = SkinDataFileString + "[" + DomainName + "]" + Chr$(13) + Chr$(10)
SkinDataFileString = SkinDataFileString + Chr$(13) + Chr$(10)
SkinDataFile_CreateDomainSub = True
End Function
Private Function SkinDataFile_GetControlDomainPos(ByVal SkinDataFileString As String, ByVal ControlName As String, ByRef ControlDomainStartPos As Long, ByRef ControlDomainEndPos As Long) As Boolean
'on error resume next 'returns True if domain is already existing, False if not (start pos will be >= 1 in any case)
Dim EndPos1 As Long
Dim EndPos2 As Long
Dim Temp As Long
'begin
If (Len(ControlName)) Then
ControlDomainStartPos = InStr(1, SkinDataFileString, "[" + ControlName + "]" + Chr$(13) + Chr$(10), vbBinaryCompare)
Else
ControlDomainStartPos = 0
End If
'
'NOTE: if ControlName is "" then any system_[...] property is to be changed.
'The whole SkinDataFile is to be searched for those system_[...] property lines.
'Also note that there may be '[]' lines that mark the end of any control domain,
'so the InStr() line above would return a non‑zero value if the ControlName is "".
'
If Not (ControlDomainStartPos = 0) Then
ControlDomainStartPos = ControlDomainStartPos + 2 + Len(ControlName)
'Example:
'[Command1]
'caption=Test
'ControlDomainStartPos points to Chr$(13)
EndPos1 = InStr(ControlDomainStartPos, SkinDataFileString, Chr$(13) + Chr$(10) + "[", vbBinaryCompare)
EndPos2 = InStr(ControlDomainStartPos, SkinDataFileString, Chr$(13) + Chr$(10) + "system_", vbTextCompare)
If (EndPos1) And Not (EndPos2) Then _
ControlDomainEndPos = EndPos1 'do not select 0
If Not (EndPos1) And (EndPos2) Then _
ControlDomainEndPos = EndPos2 'do not select 0
If (EndPos1) And (EndPos2) Then _
ControlDomainEndPos = MIN(EndPos1, EndPos2) 'do not select 0
'IMPORTANT: also pay attention for system_[...] as a control domain end sign.
If ControlDomainEndPos = 0 Then
ControlDomainEndPos = Len(SkinDataFileString)
'Example:
'[Command1]
'caption=Test
'EOF
'ControlDomainEndPos points to Chr$(10)
Else
ControlDomainEndPos = (ControlDomainEndPos + 1)
'Example:
'[Command1]
'caption=Test
'[Command2]
'ControlDomainEndPos points to Chr$(10) in front of '['
For Temp = ControlDomainEndPos To 1 Step (‑1)
Select Case Asc(Mid$(SkinDataFileString, Temp, 1))
Case 13, 10
Case Else
ControlDomainEndPos = (Temp + 1) + 1
Exit For 'important
'Example:
'[Command1]
'caption=Test
'
'[Command2]
'ControlDomainEndPos points to Chr$(10) in front of Chr$(13) and Chr$(10) of empty line
End Select
Next Temp
End If
SkinDataFile_GetControlDomainPos = True 'already existing
Else
ControlDomainStartPos = 1
ControlDomainEndPos = Len(SkinDataFileString)
'If e.g. system_forecolor is to be changed
SkinDataFile_GetControlDomainPos = False 'not existing yet
End If
End Function
Private Sub SkinDataFile_GetControlPropertyLinePos(ByVal SkinDataFileString As String, ByVal PropertyName As String, ByVal ControlDomainStartPos As Long, ByVal ControlDomainEndPos As Long, ByRef ControlPropertyLineStartPos As Long, ByRef ControlPropertyLineEndPos As Long, ByVal DeletePropertyLineOnlyFlag As Boolean)
'on error resume next
Dim Temp As Long
'begin
ControlPropertyLineStartPos = InStr(ControlDomainStartPos, SkinDataFileString, Chr$(13) + Chr$(10) + PropertyName + "=", vbTextCompare) 'search for '=' (backpicture <‑> backpictureenabled)
If (ControlPropertyLineStartPos = 0) Or (ControlPropertyLineStartPos > ControlDomainEndPos) Then
'
'NOTE: when the property line does not exist, it is added automatically
'AT BOTTOM of the current property string.
'
If DeletePropertyLineOnlyFlag = False Then
ControlPropertyLineStartPos = InStr(ControlDomainStartPos, SkinDataFileString, Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10), vbBinaryCompare)
If (ControlPropertyLineStartPos = 0) Or (ControlPropertyLineStartPos > ControlDomainEndPos) Then
ControlPropertyLineStartPos = InStr(ControlDomainStartPos, SkinDataFileString, Chr$(13) + Chr$(10) + "[", vbBinaryCompare)
If (ControlPropertyLineStartPos = 0) Or (ControlPropertyLineEndPos > ControlDomainEndPos) Then
ControlPropertyLineStartPos = Len(SkinDataFileString)
If (ControlPropertyLineStartPos = 0) Or (ControlPropertyLineStartPos > ControlDomainEndPos) Then
'
'insert new property line (x) at begin of current control domain:
'[current control]xChr$(13)Chr$(10)
'
ControlPropertyLineStartPos = ControlDomainStartPos
Else
'
'insert new property line (x) at end of file:
'ypos=0xChr$(13)Chr$(10)EOF
'
For Temp = Len(SkinDataFileString) To 1 Step (‑1)
Select Case Asc(Mid$(SkinDataFileString, Temp, 1))
Case 13, 10
Case Else
ControlPropertyLineStartPos = (Temp + 1) 'start at Chr$(13)
Exit For 'important
End Select
Next Temp
End If
Else
'
'insert new property line (x) in front of new control name:
'ypos=0xChr$(13)Chr$(10)[next control]
'
End If
Else
'
'insert new property line (x) at begin of an empty line related to current control,
'empty line mostly is located in front of next control domain:
'ypos=0xChr$(13)Chr$(10)Chr$(13)Chr$(10)[next control]
'
End If
ControlPropertyLineEndPos = (ControlPropertyLineStartPos + 1) 'start pos points to a Chr$(13) and end pos to a Chr$(10)
Else
ControlPropertyLineStartPos = 0 'reset (error, nothing to delete)
ControlPropertyLineEndPos = 0 'reset (error, nothing to delete)
End If
Else
ControlPropertyLineEndPos = InStr((ControlPropertyLineStartPos + 2), SkinDataFileString, Chr$(13) + Chr$(10), vbBinaryCompare)
If ControlPropertyLineEndPos = 0 Then
ControlPropertyLineEndPos = Len(SkinDataFileString)
Else
ControlPropertyLineEndPos = (ControlPropertyLineEndPos + 1)
End If
End If
End Sub
'**********************************END OF SKINDATAFILE**********************************
'*********************************DISABLEDPICTURECACHE**********************************
'NOTE: the user cannot (needn't) set an se command's disabled picture, it is created by the system.
'As the creation of these pictures is rather slow it cannot be done when an se command was
'just disabled, but the disabled pictures are all created by calling DisabledPictureChache_Create().
'The creation must be done every time any changes on one or more se commands have been done,
'e.g. by reloading the SkinDataFile or by changing an se command's special properties.
'Always call DisabledPictureCache_Reset() when the se command disabled pictures are no
'longer needed.
'
'NOTE: as creating all se command disabled pictures at once didn't work now missing or invalid
'disabled pictures are recreated when the related se command control is loaded by SE_LoadControl().
'It is NOT necessary to refresh the DisabledPicturCache because of one changed se command if this
'se command is reloaded.
Public Sub DisabledPictureCache_Create(ByVal SEControlStructNumber As Integer, ByRef SEControlStructArray() As SEControlStruct)
'on error resume next
Dim DisabledPictureCacheDir As String
Dim StructLoop As Integer
'
'NOTE: now let us mess up the user's hard disk with tons of temp files.
'
'verify
Call DisabledPictureCache_Reset(SEControlStructNumber, SEControlStructArray()) 'important (although implemented here to be done separately before calling this sub)
'preset
Call DisabledPictureCache_GetCacheDir(DisabledPictureCacheDir)
'begin
For StructLoop = 1 To SEControlStructNumber
Call DisabledPictureCache_CreateSub(StructLoop, DisabledPictureCacheDir, True)
Next StructLoop
End Sub
Public Sub DisabledPictureCache_GetCacheDir(ByRef DisabledPictureCacheDir As String)
'on error resume next 'initializes passed cache dir
DisabledPictureCacheDir = SESystemStructVar.SystemSkinDirectory
If Not (Right$(DisabledPictureCacheDir, 1) = "\") Then DisabledPictureCacheDir = DisabledPictureCacheDir + "\" 'verify
End Sub
Public Function GetDisabledPictureCacheDir() As String
'on error resume next 'returns a string, no need to declare and pass one
Dim CacheDir As String
Call DisabledPictureCache_GetCacheDir(CacheDir)
GetDisabledPictureCacheDir = CacheDir
End Function
Public Function DisabledPictureCache_CreateSub(ByVal SEControlStructIndex As Integer, ByVal DisabledPictureCacheDir As String, ByVal ForceRecreateFlag As Boolean) As Boolean
On Error Resume Next 'important (if a file cannot be deleted); returns True if a disabled picture is existing for the control whose index has been passed, False if not
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
DisabledPictureCache_CreateSub = False 'error
Exit Function
End If
If Not ((DirSave(SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture) = "") Or (Len(SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture) = 0)) Then 'verify (don't check for '\' to increase speed)
If ForceRecreateFlag = False Then
DisabledPictureCache_CreateSub = True 'ok
Exit Function
Else
Kill SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture 'clean up in here (important)
End If
End If
'preset
'DisabledPictureCache_CreateSub = False 'preset
'begin
SESystemStructVar.SystemTempPicture.DrawMode = vbInvert
If SEControlStructArray(SEControlStructIndex).SEControlType = SECONTROLTYPE_SECOMMAND Then
If (IsFullPath(SEControlStructArray(SEControlStructIndex).SEControl_UpPicture)) Then
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture) 'reset
If SE_FileToPictureBox(SEControlStructArray(SEControlStructIndex).SEControl_UpPicture, SESystemStructVar.SystemTempPicture) = False Then GoTo Jump:
If SESystemStructVar.SystemGFAlphaBlendAvailableFlag = False Then
'
'NOTE: if alpha blending is not available (on a Win95 machine) then adjusting
'the se command's brightness is not possible, invert the command picture
'instead.
'
SESystemStructVar.SystemTempPicture.Line (‑Screen.TwipsPerPixelX, ‑Screen.TwipsPerPixelY)‑(SESystemStructVar.SystemTempPicture.ScaleWidth ‑ Screen.TwipsPerPixelX, SESystemStructVar.SystemTempPicture.ScaleHeight ‑ Screen.TwipsPerPixelY), 0, BF
Else
'
'NOTE: if alpha blending is available then decrease the se command's
'brightness.
'
Call GFAlphaBlendfrm.GFAlphaBlend_AdjustBrightness( _
SESystemStructVar.SystemTempPicture.hDC, _
SESystemStructVar.SystemTempPicture.Width / Screen.TwipsPerPixelX ‑ 4, _
SESystemStructVar.SystemTempPicture.Height / Screen.TwipsPerPixelY ‑ 4, _
0.8!) 'subtract 4 pixels for picture box borders
End If
'NOTE: for some reason the rectangle cannot be drawn from 0,0 on (tested) (???).
SESystemStructVar.SystemTempPicture.Picture = SESystemStructVar.SystemTempPicture.Image
SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture = _
GenerateTempFileName(DisabledPictureCacheDir)
'
'NOTE: the disabled picture files are delete by DisabledPictureCache_Reset
'or by SE_DeleteTempFiles at Skin Engine start up.
'
Call SE_PictureBoxToFile(SESystemStructVar.SystemTempPicture, SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture)
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture) 'reset
DisabledPictureCache_CreateSub = True
Jump:
End If
End If
SESystemStructVar.SystemTempPicture.DrawMode = vbCopyPen 'reset (important)
Exit Function
End Function
Public Sub DisabledPictureCache_Reset(ByVal SEControlStructNumber As Integer, ByRef SEControlStructArray() As SEControlStruct)
On Error Resume Next 'important
Dim StructLoop As Integer
'begin
For StructLoop = 1 To SEControlStructNumber
If (Len(SEControlStructArray(StructLoop).SEControl_DisabledPicture)) Then
ReDo:
If Not ((DirSave(SEControlStructArray(StructLoop).SEControl_DisabledPicture) = "") Or (Right$(SEControlStructArray(StructLoop).SEControl_DisabledPicture, 1) = "\")) Then 'verify
Kill SEControlStructArray(StructLoop).SEControl_DisabledPicture
If Not (DirSave(SEControlStructArray(StructLoop).SEControl_DisabledPicture) = "") Then 'verify
Select Case MsgBox("internal error in DisabledPictureCache_Reset() (GFSkinEngine): deleting file failed: " + SEControlStructArray(StructLoop).SEControl_DisabledPicture + " !", vbRetryCancel)
Case vbCancel
'do nothing (skip file)
Case vbRetry
GoTo ReDo:
End Select
Else
SEControlStructArray(StructLoop).SEControl_DisabledPicture = "" 'reset
End If
End If
End If
Next StructLoop
End Sub
'******************************END OF DISABLEDPICTURECACHE******************************
'************************************SE POP UP MENU*************************************
'NOTE: the following subs/functions are used to update and open the SE op up menu
'and to process clicks into the menu.
'NOTE: the SE pop up menus are provided by the Skin Engine, the target
'project needs only to open it using SE_OpenPopMenu.
'Then the user can configure the Skin Engine, this configuration is done by the engine itself.
'
'Note that there are two important menus:
'‑the form menu: opened by the target project, allows the user to change general SE settings
'‑the control menu: opened by the Skin Engine during UserMove, allows the user to change
' the properties of one single control.
'
'Also the subs to update the two pop up menus include the menu name:
'‑SE_UpdateFormMenu() (instead of SE_UpdatePopUpMenu) and
'‑SE_UpdateControlMenu() (pass control data to allow fitting menu items to control properties).
Public Sub SE_OpenFormMenu(ByVal SourceFormName As String, ByRef SourceFormObject As Object)
'On Error Resume Next 'opens the SkinEngine configuration menu at the current mouse pos
Dim UpdateLoop As Integer
Dim TempBool As Boolean
Dim Temp As Long
'NOTE: access data of SE_FormMenuStructVar when pop up menu click arrives.
SE_FormMenuStructVar.SourceFormName = SourceFormName
Set SE_FormMenuStructVar.SourceFormObject = SourceFormObject
'begin
If (SE_FormMenuStructVar.PopUpMenuClickInProcessingFlag = False) And _
(SE_ControlMenuStructVar.PopUpMenuClickInProcessingFlag = False) And _
(SE_KeyHookStructVar.ShortCutKeyPressInProcessingFlag = False) Then
'
'NOTE: open pop up menu only if not one of its functions is in use at the moment.
'(see also annotation in SE_ProcessPopUpMenu_Click()).
'
Call SE_ForwardCallBackMessageEx(SECBMSG_FORMMENU_OPENING, SourceFormName, "", TempBool, Temp)
If (TempBool = True) And (Temp = SECBMSG_REPLY_CANCEL) Then
Exit Sub
End If
'
'NOTE: open pop up menu only if the target project allows.
'
For UpdateLoop = 1 To 16 'just update and update
Call SE_UpdateFormMenu(UpdateLoop, SourceFormName, SourceFormObject)
Next UpdateLoop
Call SE_OpenPopUpMenu(ProgramGetMousePosX, ProgramGetMousePosY, 1, SourceFormName, SourceFormObject) 'Menu1
Call SE_ForwardCallBackMessage(SECBMSG_FORMMENU_CLOSED, SourceFormName, "") 'program control will stay in line above as long as the menu is visible
End If
Exit Sub
End Sub
Public Sub SE_OpenControlMenu(ByVal SEControlName As String, ByRef SEControlObject As Object, Optional ByVal SEControlStructIndex As Integer = 0)
'on error resume next
Dim TempBool As Boolean
Dim Temp As Long
'preset
If SEControlStructIndex = 0 Then SEControlStructIndex = GetSEControlStructIndex(SEControlName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'NOTE: access data of SE_ControlMenuStructVar when pop up menu click arrives.
SE_ControlMenuStructVar.SEControlName = SEControlName
Set SE_ControlMenuStructVar.SEControlObject = SEControlObject
SE_ControlMenuStructVar.SEControlStructIndex = SEControlStructIndex
SE_ControlMenuStructVar.SEControlType = SEControlStructArray(SEControlStructIndex).SEControlType
'begin
If (SE_ControlMenuStructVar.PopUpMenuClickInProcessingFlag = False) And _
(SE_FormMenuStructVar.PopUpMenuClickInProcessingFlag = False) And _
(SE_KeyHookStructVar.ShortCutKeyPressInProcessingFlag = False) Then
'
'NOTE: open pop up menu only if not one of its functions is in use at the moment.
'(see also annotation in SE_ProcessPopUpMenu_Click()).
'
Call SE_ForwardCallBackMessageEx(SECBMSG_CONTROLMENU_OPENING, SEControlName, "", TempBool, Temp)
If (TempBool = True) And (Temp = SECBMSG_REPLY_CANCEL) Then
Exit Sub
End If
'
'NOTE: open pop up menu only if the target project allows.
'
Call SE_UpdateControlMenu(SEControlName, SEControlObject, SEControlStructIndex)
Call SE_OpenPopUpMenu(ProgramGetMousePosX, ProgramGetMousePosY, 4, "", Nothing) 'Menu11
Call SE_ForwardCallBackMessage(SECBMSG_CONTROLMENU_CLOSED, SEControlName, "") 'program control will stay in line above as long as the menu is visible
End If
Exit Sub
End Sub
Private Sub SE_UpdateControlMenu(ByVal SEControlName As String, ByRef SEControlObject As Object, Optional ByVal SEControlStructIndex As Integer = 0)
'on error resume next 'updates the control pop up menu only
'
'NOTE: this sub enables/disables menu entries, depending on the
'property support of the current control.
'Note that this menu is not available for all control types.
'
'preset
If SEControlStructIndex = 0 Then SEControlStructIndex = GetSEControlStructIndex(SEControlName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'begin
With GFSkinEngine_MENUfrm
.M11(1).Enabled = True 'preset (special fore color)
.M11(2).Enabled = True 'preset (special back color)
.M11(3).Enabled = True 'preset (special font)
.M11(4).Enabled = SECM_HasSpecialProperties(SEControlStructIndex) 'preset (disable special properties)
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND
.M11(1).Enabled = False 'no fore color support
End Select
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND, SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING
.M11(2).Enabled = False 'no back color support
End Select
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE
.M11(3).Enabled = False 'no font support
End Select
'Select Case SEControlStructArray(SEControlStructIndex).SEControlType
'Case ?
' .M11(4).Enabled = False 'disable special properties
'End Select
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND
.M11(6).Enabled = True
.M11(7).Enabled = True
.M11(8).Enabled = True
.M11(9).Enabled = SECM_HasSECommandPictures(SEControlStructIndex) 'disable se command pictures
Case Else
.M11(6).Enabled = False
.M11(7).Enabled = False
.M11(8).Enabled = False
.M11(9).Enabled = False
End Select
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_PICTUREBOX, SECONTROLTYPE_GFLISTVIEW
.M11(11).Enabled = True
If IsPicture(SEControlStructArray(SEControlStructIndex).SEControl_BackPicture, False) = True Then 'creates no error messages
.M11(12).Enabled = True
Else
.M11(12).Enabled = False 'nothing to disable
End If
Case Else
.M11(11).Enabled = False
.M11(12).Enabled = False
End Select
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND, SECONTROLTYPE_CHECKBOX, SECONTROLTYPE_LABEL, SECONTROLTYPE_FRAME, SECONTROLTYPE_OPTIONBUTTON
.M11(14).Enabled = True 'set caption
Case Else
.M11(14).Enabled = False
End Select
.M11(15).Enabled = True 'control size can always be determined
End With
End Sub
Private Sub SE_UpdateFormMenu(ByVal MenuIndex As Integer, ByVal SourceFormName As String, ByRef SourceFormObject As Object)
'On Error Resume Next 'new PopUp Menu system sub; is from now on to be called to update pop up menus
Dim SkinNameListStructNumber As Integer
Dim SkinNameListStructArray() As SkinNameListStruct
Dim StructLoop As Integer
Dim StructIndex As Integer
Dim Temp As Long
'
'NOTE: to avoid system errors some functions are not available when other
'ones are currently in use.
'E.g. if the poly rgn desk or skin info is shown, no form menu entry is available,
'this is necessary because when the poly rgn desk and the skin info is shown
'the control rests in a loop, waiting for 'finished' or 'abort'. This loop cannot
'be left until THE USER finishes or aborts.
'
'begin
Select Case MenuIndex
Case 2 'colors
If SESystemStructVar.ColorSchemeEnabledFlag = True Then
GFSkinEngine_MENUfrm.M2(4).Enabled = False 'enable color scheme
GFSkinEngine_MENUfrm.M2(5).Enabled = True 'disable color scheme
GFSkinEngine_MENUfrm.M2(6).Enabled = True 'set color scheme color
Else
GFSkinEngine_MENUfrm.M2(4).Enabled = True 'enable color scheme
GFSkinEngine_MENUfrm.M2(5).Enabled = False 'disable color scheme
GFSkinEngine_MENUfrm.M2(6).Enabled = False 'set color scheme color
End If
Case 3 'user move
If UserMoveControlStructVar.UserMoveSystemEnabledFlag = True Then
GFSkinEngine_MENUfrm.M3(1).Enabled = False
GFSkinEngine_MENUfrm.M3(2).Enabled = True
GFSkinEngine_MENUfrm.M3(7).Enabled = True 'fit control height to font height
GFSkinEngine_MENUfrm.M3(8).Enabled = True 'move controls in visible area
Else
GFSkinEngine_MENUfrm.M3(1).Enabled = True
GFSkinEngine_MENUfrm.M3(2).Enabled = False
GFSkinEngine_MENUfrm.M3(7).Enabled = False 'fit control height to font height
GFSkinEngine_MENUfrm.M3(8).Enabled = False 'move controls in visible area
End If
If UserMoveStructVar.GridEnabledFlag = True Then
GFSkinEngine_MENUfrm.M3(4).Checked = True
Else
GFSkinEngine_MENUfrm.M3(4).Checked = False
End If
If UserMoveStructVar.ControlInfoEnabledFlag = True Then
GFSkinEngine_MENUfrm.M3(5).Checked = True
Else
GFSkinEngine_MENUfrm.M3(5).Checked = False
End If
Case 4 'poly rgn
'
'NOTE: the following code searches all controls for the poly rgn
'that is assigned to the pop up menu source form.
'If no poly rgn is assigned to the source form the following code
'disables both the poly rgn enable‑ and disable sub menu.
'
'
GFSkinEngine_MENUfrm.M4(1).Enabled = False
GFSkinEngine_MENUfrm.M4(2).Enabled = False 'preset (if loop does not bring any results)
GFSkinEngine_MENUfrm.M4(3).Enabled = False 'preset
'
StructIndex = GetSEControlStructIndexFromControlObject(SourceFormObject, SECONTROLTYPE_SEPOLYRGN, SESystemStructVar.SystemPaletteNumberCurrent)
'
'For StructLoop = 1 To SEControlStructNumber
' If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_SEPOLYRGN Then
' If SEControlStructArray(StructLoop).SEControl Is SourceFormObject Then
If Not (StructIndex = 0) Then 'verify
If SEControlStructArray(StructIndex).SEControl_PolyRgnEnabledFlag = True Then
GFSkinEngine_MENUfrm.M4(1).Enabled = True
GFSkinEngine_MENUfrm.M4(2).Enabled = False
GFSkinEngine_MENUfrm.M4(3).Enabled = True
Else
GFSkinEngine_MENUfrm.M4(1).Enabled = False 'poly rgn cannot be changed if not enabled
GFSkinEngine_MENUfrm.M4(2).Enabled = True
GFSkinEngine_MENUfrm.M4(3).Enabled = False
End If
End If
' End If
' End If
'Next StructLoop
Case 5 'back picture
'
'NOTE: the following code searches all controls for the back picture
'that is assigned to the pop up menu source form.
'If no back picture is assigned to the source form the following code
'disables both the back picture enable‑ and disable sub menu.
'
'
GFSkinEngine_MENUfrm.M5(2).Enabled = False 'preset (if loop does not bring any results)
GFSkinEngine_MENUfrm.M5(3).Enabled = False 'preset
'
StructIndex = GetSEControlStructIndexFromControlObject(SourceFormObject, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
'
' For StructLoop = 1 To SEControlStructNumber
' If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_FORM Then
' If SEControlStructArray(StructLoop).SEControl Is SourceFormObject Then
If Not (StructIndex = 0) Then 'verify
If SEControlStructArray(StructIndex).SEControl_BackPictureEnabledFlag = True Then
GFSkinEngine_MENUfrm.M5(2).Enabled = False
GFSkinEngine_MENUfrm.M5(3).Enabled = True
Else
GFSkinEngine_MENUfrm.M5(2).Enabled = True
GFSkinEngine_MENUfrm.M5(3).Enabled = False
End If
End If
' End If
' End If
' Next StructLoop
Case 7 'skins
With GFSkinEngine_MENUfrm
.M7(7).Enabled = Not (UCase$(SESystemStructVar.SystemSkinNameCurrent) = "BASESKIN") 'the base skin cannot be deleted
.M7(12).Caption = "Current Skin: " + FixMaxLineLength(GetCurrentSkinName, 50)
End With
Case 8
'
'NOTE: Menu8 contains all available skins.
'As the number of skins varies from machine to machine,
'Menu8 has only one sub menu, M8 Index 0 by default.
'Menu8 Index 0 represents the base skin and must not be
'changed or even removed.
'All other sub menus are loaded and unloaded permanently.
'Note that the menu TAG (bless it!) contains the SkinDirectory.
'The skin name that is currently in use is checked.
'
With GFSkinEngine_MENUfrm
For Temp = 1 To (.M8.UBound) 'if .M8 contains 4 sub menu then .M8.UBound is 3
Unload .M8(Temp) 'reset
Next Temp
Call Skin_GetSkinNameList(SkinNameListStructNumber, SkinNameListStructArray()) 'return value ignored
If (UCase$(GetCurrentSkinName)) = "BASESKIN" Then
.M8(0).Checked = True
Else
.M8(0).Checked = False
End If
For Temp = 1 To SkinNameListStructNumber
Load .M8(Temp)
.M8(Temp).Caption = SkinNameListStructArray(Temp).SkinName
.M8(Temp).Tag = SkinNameListStructArray(Temp).SkinDirectory
If UCase$(GetCurrentSkinName) = UCase$(SkinNameListStructArray(Temp).SkinName) Then
.M8(Temp).Checked = True
Else
.M8(Temp).Checked = False
End If
Next Temp
End With
Case 9 'options
With GFSkinEngine_MENUfrm
If SESystemStructVar.SystemSkinRandomSelectFlag = True Then
.M9(1).Checked = True
.M9(2).Enabled = True 'display random skin name
Else
.M9(1).Checked = False
.M9(2).Enabled = False 'display random skin name
End If
If SESystemStructVar.SystemSkinRandomSelectDisplayNameFlag = True Then
.M9(2).Checked = True
Else
.M9(2).Checked = False
End If
If SESystemStructVar.SystemAskForPictureImportFlag = True Then
.M9(3).Checked = True
Else
.M9(3).Checked = False
End If
End With
End Select
End Sub
Public Sub SE_OpenPopUpMenu(ByVal XPos As Long, ByVal YPos As Long, ByVal PopUpMenuIndex As Integer, ByVal SourceFormName As String, ByRef SourceFormObject As Object)
'On Error Resume Next 'this sub is GFSkinEngine specific
Dim MenuHandle As Long
Dim SubMenuHandle As Long
Dim RECTVar As RECT
'preset
'
'NOTE: it was necessary to store extended data for processing
'pop up menu clicks. The structure var used below is GFSkinEngine
'specific.
'
Set SE_FormMenuStructVar.SourceFormObject = SourceFormObject
SE_FormMenuStructVar.SourceFormName = SourceFormName
'begin
RECTVar.Left = 0
RECTVar.Top = 0
RECTVar.Right = Screen.Width / Screen.TwipsPerPixelX
RECTVar.Bottom = Screen.Height / Screen.TwipsPerPixelY
MenuHandle = GetMenu(GFSkinEngine_MENUfrm.hwnd)
SubMenuHandle = GetSubMenu(MenuHandle, (PopUpMenuIndex ‑ 1)) '1 to 0 based
Call TrackPopupMenu(SubMenuHandle, 2, XPos, YPos, 0, GFSkinEngine_MENUfrm.hwnd, RECTVar)
End Sub
Public Sub SE_ReceivePopUpMenu_Click(ByVal MenuIndex As Integer, ByVal SubMenuIndex As Integer)
'On Error Resume Next 'this sub is GFSkinEngine specific
Dim SEControlStructIndex As Integer
Dim SourceMenuDescription As String 'for call back message
Dim SourceControlName As String 'for call back message
'verify
'
'NOTE: some subs/functions called by a pop up menu click
'or short cut key press stay in a loop, allowing the user to open the
'pop up menu again.
'As a 'doubled' pop up menu click can lead to system errors,
'flags are used to determine of a pop up menu click is
'currently processed. If this is the case, this sub must be left
'immediately. Also SE_UpdatePopUpMenu() should disable a
'pop up menu that is currently in use.
'Note that multiple flags are used, one for every pop up menu.
'The flags should belong to the related pop up menu structure.
'
'If one pop up menu click is processed, NO other menu can be opened.
'
'Don't forget to add pop up menu numbers to the two Select Case
'statements at top and bottom of this sub if adding a new
'pop up menu.
'
'Note that every system (e.g. the KeyHook) that calls a
'sub/function that is originally accessible via a pop up menu
'click must also check if a pop up menu sub/function is currently in use.
'
'preset
Call SE_RefreshForms 'remove pop‑up menu trash (important, tested)
'verify
'
'NOTE: some menu clicks must be completely (!) ignored as they
'are no 'real' menu clicks but appear when a sub menu is opened.
If (MenuIndex = 7) And (SubMenuIndex = 9) Then Exit Sub
'
Select Case MenuIndex
Case 1, 2, 3, 4, 5, 6, 7, 9, 12, 13
'NOTE: use SE_FormMenuStructVar.ForcePopUpMenuClickProcessingFlag to force precessing a call of this sub.
'
SourceMenuDescription = "FormMenu"
SourceControlName = SE_FormMenuStructVar.SourceFormName
Call SE_ForwardCallBackMessage(SECBMSG_POPUPMENUCLICK_PROCESSING_START, SourceMenuDescription, SourceControlName)
'
If SE_FormMenuStructVar.PopUpMenuClickInProcessingFlag = True Then _
If SE_FormMenuStructVar.ForcePopUpMenuClickProcessingFlag = False Then GoTo Processing_End: 'verify
If SE_ControlMenuStructVar.PopUpMenuClickInProcessingFlag = True Then GoTo Processing_End: 'verify
If SE_KeyHookStructVar.ShortCutKeyPressInProcessingFlag = True Then GoTo Processing_End: 'verify
SE_FormMenuStructVar.PopUpMenuClickInProcessingFlag = True
Case 8, 10, 11
'
SourceMenuDescription = "ControlMenu"
SourceControlName = SE_ControlMenuStructVar.SEControlName
Call SE_ForwardCallBackMessage(SECBMSG_POPUPMENUCLICK_PROCESSING_START, SourceMenuDescription, SourceControlName)
'
If SE_ControlMenuStructVar.PopUpMenuClickInProcessingFlag = True Then GoTo Processing_End: 'verify
If SE_FormMenuStructVar.PopUpMenuClickInProcessingFlag = True Then _
If SE_FormMenuStructVar.ForcePopUpMenuClickProcessingFlag = False Then GoTo Processing_End: 'verify (check also Force‑flag)
If SE_KeyHookStructVar.ShortCutKeyPressInProcessingFlag = True Then GoTo Processing_End: 'verify
SE_ControlMenuStructVar.PopUpMenuClickInProcessingFlag = True
Case 14 'no special processing
'
SourceMenuDescription = "DebugMenu"
SourceControlName = ""
Call SE_ForwardCallBackMessage(SECBMSG_POPUPMENUCLICK_PROCESSING_START, SourceMenuDescription, SourceControlName)
'
End Select
'begin
Select Case MenuIndex
Case 2
Select Case SubMenuIndex
Case 1 'set system fore color
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_ForeColor_Select
Case 2 'set system back color
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_BackColor_Select
Case 4 'enable color scheme
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_ColorScheme_Enable
Case 5 'disable color scheme
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_ColorScheme_Disable
Case 6 'set color scheme color
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_ColorScheme_SetColor
End Select
Case 3
Select Case SubMenuIndex
Case 1 'enable UserMove
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_UserMove_Enable
Case 2 'disable UserMove
Call SEM_UserMove_Disable
Case 4 'toggle grid
If UserMoveStructVar.GridEnabledFlag = True Then
Call SEM_UserMove_DisableGrid
Call SEToReg 'save changes
Else
Call SEM_UserMove_EnableGrid
Call SEToReg 'save changes
End If
Case 5 'toggle control info
'
'NOTE: as the control info is only displayed during user move
'the user then cannot click this menu item and thus no extra code
'is necessary to en‑ or disable the control info.
'
If UserMoveStructVar.ControlInfoEnabledFlag = True Then
UserMoveStructVar.ControlInfoEnabledFlag = False
Call SEToReg 'save changes
Else
UserMoveStructVar.ControlInfoEnabledFlag = True
Call SEToReg 'save changes
End If
Case 7 'move controls into visible area
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_MoveControlsIntoVisibleArea(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
Case 8 'fit control height to font height
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_ControlHeightToFontHeight
Case 9 'get window size
Call SEM_UserMove_Abort(UserMoveStructVar)
Call SEM_ShowFormSize(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
End Select
Case 4
Select Case SubMenuIndex
Case 1 'change window region
Call SEM_UserMove_Abort(UserMoveStructVar) 'disable current UserMove to avoid e.g. stack overflow
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_PolyRgn_Change(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
Case 2 'enable
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
'NOTE: the user must edit the poly rgn instantly if it is invalid.
SEControlStructIndex = GetSEControlStructIndexFromControlObject(SE_FormMenuStructVar.SourceFormObject, SECONTROLTYPE_SEPOLYRGN, SESystemStructVar.SystemPaletteNumberCurrent)
If Not (SEControlStructIndex = 0) Then 'verify
If SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointNumber < 3 Then 'verify rgn is valid
If MsgBox("The region for the current window has not been set yet, do you want to edit it now ?", vbYesNo + vbQuestion) = vbYes Then
Call SEM_UserMove_Abort(UserMoveStructVar) 'disable current UserMove to avoid e.g. stack overflow
Call SEM_PolyRgn_Change(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
End If
End If
End If
SEControlStructIndex = GetSEControlStructIndexFromControlObject(SE_FormMenuStructVar.SourceFormObject, SECONTROLTYPE_SEPOLYRGN, SESystemStructVar.SystemPaletteNumberCurrent) 'do again (safe)
If Not (SEControlStructIndex = 0) Then 'verify
If Not (SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnPointNumber < 3) Then 'verify rgn is valid
Call SEM_PolyRgn_Enable(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
Else
MsgBox "Poly rgn could not be enabled.", vbOKOnly + vbInformation
End If
End If
Case 3 'disable
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_PolyRgn_Disable(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
End Select
Case 5
Select Case SubMenuIndex
Case 1 'import back picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_BackPicture_Import(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
Case 2 'enable back picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_BackPicture_Enable(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject, SECONTROLTYPE_FORM)
'NOTE: if the current back picture is invalid, the system makes the user select a new one.
SEControlStructIndex = GetSEControlStructIndexFromControlObject(SE_FormMenuStructVar.SourceFormObject, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
If Not (SEControlStructIndex = 0) Then 'verify
If ((DirSave(SEControlStructArray(SEControlStructIndex).SEControl_BackPicture) = "") Or (Right$(SEControlStructArray(SEControlStructIndex).SEControl_BackPicture, 1) = "\") Or (SEControlStructArray(SEControlStructIndex).SEControl_BackPicture = "")) Then 'verify back picture is valid
If MsgBox("The back picture is not a valid picture file, do you want to select one now ?", vbYesNo + vbQuestion) = vbYes Then
Call SEM_BackPicture_Import(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
End If
End If
End If
Case 3 'disable back picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_BackPicture_Disable(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject, SECONTROLTYPE_FORM)
End Select
Case 6
Select Case SubMenuIndex
Case 1 'select system font
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_Font_Select
Case 3 'list used fonts
Call SEM_Font_List
End Select
Case 7
'
'NOTE: always disable the UserMove system if any skin
'related values are changed (or the total error might happen).
'
Select Case SubMenuIndex
Case 1 'change skin
Call SEM_UserMove_Disable
Call SEM_PolyRgn_Abort
Call SEM_Skin_Select
Case 2 'next skin
Call SEM_UserMove_Disable
Call SEM_Skin_Next
Case 3 'previous skin
Call SEM_UserMove_Disable
Call SEM_Skin_Previous
Case 5 'import
Call SEM_UserMove_Disable
Call SEM_Info
Case 6 'copy
Call SEM_UserMove_Disable
Call SEM_PolyRgn_Abort
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_Skin_Copy
Case 7 'delete
Call SEM_UserMove_Disable
Call SEM_PolyRgn_Abort
Call SEM_Skin_Delete
Case 8 'browse
Call SEM_UserMove_Abort(UserMoveStructVar)
Call SEM_PolyRgn_Abort
Call SEM_Browse
Case 12 'current skin
Call SEM_UserMove_Disable
Call SEM_PolyRgn_Abort
Call SEM_Skin_Select 'do any operation
Case 14 'new skin
Call SEM_UserMove_Disable
Call SEM_PolyRgn_Abort
Call SEM_New
Case 15 'export
Call SEM_UserMove_Disable
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_Export
Case 16 'import
Call SEM_UserMove_Disable
Call SEM_Import
End Select
Case 8
If Not ((SubMenuIndex < GFSkinEngine_MENUfrm.M8.LBound) Or (SubMenuIndex > GFSkinEngine_MENUfrm.M8.UBound)) Then 'verify
'NOTE: all sub menus of M8 represent skins that can be loaded
Call SEToReg 'save current skin name
Call Skin_Change(GetSkinNameFromMenuIndex(SubMenuIndex))
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
End If
Case 9
Select Case SubMenuIndex
Case 1 'random skin at start up
If SESystemStructVar.SystemSkinRandomSelectFlag = True Then
SESystemStructVar.SystemSkinRandomSelectFlag = False
Call SEToReg 'save changes
Else
SESystemStructVar.SystemSkinRandomSelectFlag = True
Call SEToReg 'save changes
End If
Case 2 'display random skin name
If SESystemStructVar.SystemSkinRandomSelectDisplayNameFlag = True Then
SESystemStructVar.SystemSkinRandomSelectDisplayNameFlag = False
Call SEToReg 'save changes
Else
SESystemStructVar.SystemSkinRandomSelectDisplayNameFlag = True
Call SEToReg 'save changes
End If
Case 3 'ask for picture import
If SESystemStructVar.SystemAskForPictureImportFlag = True Then
SESystemStructVar.SystemAskForPictureImportFlag = False
Call SEToReg 'save changes
Else
SESystemStructVar.SystemAskForPictureImportFlag = True
Call SEToReg 'save changes
End If
End Select
Case 10
Select Case SubMenuIndex
Case 1 'back picture
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_PolyRgn_BackPicture_Select( _
GFSkinEngine_PolyRgnDeskfrm.Desk_GetPolyRgnFormName, _
GFSkinEngine_PolyRgnDeskfrm.Desk_GetPolyRgnFormObject)
End Select
Case 11
Select Case SubMenuIndex
Case 1 'special fore color
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_SpecialForeColor(SE_ControlMenuStructVar)
Case 2 'special back color
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_SpecialBackColor(SE_ControlMenuStructVar)
Case 3 'special font
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_SpecialFont(SE_ControlMenuStructVar)
Case 4 'disable special properties
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_DisableSpecialProperties(SE_ControlMenuStructVar)
Case 6 'up picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_UpPicture(SE_ControlMenuStructVar)
Case 7 'down picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_DownPicture(SE_ControlMenuStructVar)
Case 8 'move over picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_MoveOverPicture(SE_ControlMenuStructVar)
Case 9 'disable se command picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_DisableSECommandPictures(SE_ControlMenuStructVar)
Case 11 'set back picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_BackPicture(SE_ControlMenuStructVar)
Case 12 'disable back picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_BackPicture_Disable(SE_ControlMenuStructVar)
Case 14 'set caption
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_SetControlCaption(SE_ControlMenuStructVar)
Case 15 'get control size
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SECM_ShowControlSize(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlObject)
Case 17 'properties
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_SEPE(SE_ControlMenuStructVar.SEControlName)
End Select
Case 12
Select Case SubMenuIndex
Case 1 'set title bar picture
Call SEM_UserMove_Abort(UserMoveStructVar)
If Skin_VerifyUserEditPermission = False Then GoTo Leave:
Call SEM_TitleBarPicture_Import(SE_FormMenuStructVar.SourceFormName, SE_FormMenuStructVar.SourceFormObject)
End Select
Case 13
Select Case SubMenuIndex
Case 1 'frame maker
Call FrameMakerfrm.FM_Initialize(SESystemStructVar.RegMainKey, SESystemStructVar.RegRootKey)
Call FrameMakerfrm.FM_Show
End Select
Case 14
Select Case SubMenuIndex
Case 1 'headline 'Skin Engine Debug Menu'
'do nothing
Case 3 'import current skin
Call SEDM_Import
Case 5 'decrypt ContextHelpFile
Call SEDM_ContextHelpFile_Decrypt
Case 6 'encrypt ContextHelpFile
Call SEDM_ContextHelpFile_Encrypt
Case 8 'decrypt any file
Call SEDM_AnyFile_Decrypt
Case 9 'encrypt any file
Call SEDM_AnyFile_Encrypt
End Select
End Select
Leave:
Select Case MenuIndex
Case 1, 2, 3, 4, 5, 6, 7, 9, 12, 13
If SE_FormMenuStructVar.ForcePopUpMenuClickProcessingFlag = False Then _
SE_FormMenuStructVar.PopUpMenuClickInProcessingFlag = False 'reset
'NOTE: do not reset flag if processing the current pop up menu click was forced.
Case 8, 10, 11
SE_ControlMenuStructVar.PopUpMenuClickInProcessingFlag = False 'reset
Case 14
'nothing to reset
End Select
Processing_End:
Call SE_ForwardCallBackMessage(SECBMSG_POPUPMENUCLICK_PROCESSING_END, _
SourceMenuDescription, SourceControlName)
Exit Sub
End Sub
'*********************************END OF SE POP UP MENU*********************************
'*************************************SE FORM MENU**************************************
'NOTE: the following subs/functions are called after a click on a SE (form) pop up menu.
'As the following subs/functions are all related to the SE pop up menu
'and needn't to be called by the target project they are identified by
'the 'SEM_' prefix.
'Note that ControlMenu clicks are processed by the SECM sub system.
'***FORE COLOR***
Public Sub SEM_ForeColor_Select()
'on error resume next
Dim Color As Long
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_OPENED, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Please select system foreground color...", "")
Color = GFCDGetColor(SESystemStructVar.SystemForeColor, 0, NULLARRAYLONG())
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_CLOSED, "", "")
If Not (Color = True) Then 'check for abort
Call SE_RefreshForms 'remove CommonDialog window‑trash
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, "", "system_forecolor", COLORTOSTRING(Color))
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
End If
End Sub
'***END OF FORE COLOR***
'***BACK COLOR***
Public Sub SEM_BackColor_Select()
'On Error Resume Next
Dim Color As Long
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_OPENED, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Please select system background color...", "")
Color = GFCDGetColor(SESystemStructVar.SystemBackColor, 0, NULLARRAYLONG())
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_CLOSED, "", "")
If Not (Color = True) Then 'check for abort
Call SE_RefreshForms 'remove CommonDialog window‑trash
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, "", "system_backcolor", COLORTOSTRING(Color))
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
End If
End Sub
'***END OF BACK COLOR***
'***COLOR SCHEME***
Public Sub SEM_ColorScheme_Enable()
'on error resume next
If SESystemStructVar.ColorSchemeEnabledFlag = False Then 'verify changes must be done
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, "Skin Engine System Settings", "system_colorschemeenabled", BOOLTOSTRING(True))
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
End If
End Sub
Public Sub SEM_ColorScheme_Disable()
'on error resume next
If SESystemStructVar.ColorSchemeEnabledFlag = True Then 'verify changes must be done
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, "Skin Engine System Settings", "system_colorschemeenabled", BOOLTOSTRING(False))
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
End If
End Sub
Public Sub SEM_ColorScheme_SetColor()
'on error resume next
Dim Color As Long
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_OPENED, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Please select color scheme color...", "")
Color = GFCDGetColor(SESystemStructVar.ColorSchemeColor, 0, NULLARRAYLONG())
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_CLOSED, "", "")
If Not (Color = True) Then 'check for abort
Call SE_RefreshForms 'remove CommonDialog window‑trash
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, "Skin Engine System Settings", "system_colorschemecolor", COLORTOSTRING(Color))
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
End If
End Sub
'***BACK PICTURE***
'NOTE: a form can have a back picture, and also a picture box,
'that's why the back picture control type must be passed to the following
'subs/functions.
Public Sub SEM_BackPicture_Enable(ByVal BackPictureControlName As String, ByVal BackPictureControlObject As Object, ByVal BackPictureControlObjectType As Integer)
'On Error Resume Next 'call to enable a form's (only) back picture; do not use BackPictureControlName because of pool system
Dim SEControlStructIndex As Integer
'
'NOTE: the system doesn't need to call this sub if the 'backpictureenabled'
'property in the SkinDataFile is set to 'True'.
'Other controls than a SECONTROLTYPE_FORM do not support the 'backpictureenabled'
'property, to disable their back picture the back picture name must be reset.
'
'preset
SEControlStructIndex = GetSEControlStructIndexFromControlObject(BackPictureControlObject, BackPictureControlObjectType, SESystemStructVar.SystemPaletteNumberCurrent)
If SEControlStructIndex = 0 Then
MsgBox "internal error in SEM_BackPicture_Enable() !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
Call SE_RefreshForms 'remove pop up menu window‑trash
SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag = True
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, _
SEControlStructArray(SEControlStructIndex).SEControlName, "backpictureenabled", BOOLTOSTRING(True), False, False)
Call SE_LoadControl(SEControlStructArray(SEControlStructIndex).SEControlName, True, SEControlStructIndex)
Call SE_RefreshControl(SEControlStructArray(SEControlStructIndex).SEControlName, 0, SEControlStructIndex)
Call SE_ForwardCallBackMessage(SECBMSG_BACKPICTURE_ENABLED, "", BackPictureControlName)
Call SE_ForwardCallBackMessage(SECBMSG_PICTUREBOX_REDRAW, BackPictureControlName, BackPictureControlName)
End Sub
Public Sub SEM_BackPicture_Disable(ByVal BackPictureControlName As String, ByVal BackPictureControlObject As Object, ByVal BackPictureControlObjectType As Integer)
'On Error Resume Next 'call to enable a form's (only) back picture; do not use BackPictureControlName because of pool system
Dim SEControlStructIndex As Integer
'preset
SEControlStructIndex = GetSEControlStructIndexFromControlObject(BackPictureControlObject, BackPictureControlObjectType, SESystemStructVar.SystemPaletteNumberCurrent)
If SEControlStructIndex = 0 Then
MsgBox "internal error in SEM_BackPicture_Disable() !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
Call SE_RefreshForms 'remove pop up menu window‑trash
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, _
SEControlStructArray(SEControlStructIndex).SEControlName, "backpictureenabled", BOOLTOSTRING(False), False, False)
Call SE_UnloadControl(SEControlStructArray(SEControlStructIndex).SEControlName)
SEControlStructArray(SEControlStructIndex).SEControl_BackPictureEnabledFlag = False
Call SE_LoadControl(SEControlStructArray(SEControlStructIndex).SEControlName, True, SEControlStructIndex) 'important for message filtering
Call SE_RefreshControl(SEControlStructArray(SEControlStructIndex).SEControlName, 0, SEControlStructIndex)
Call SE_ForwardCallBackMessage(SECBMSG_BACKPICTURE_DISABLED, "", BackPictureControlName)
Call SE_ForwardCallBackMessage(SECBMSG_PICTUREBOX_REDRAW, BackPictureControlName, BackPictureControlName)
End Sub
Public Sub SEM_BackPicture_Import(ByVal BackPictureFormName As String, ByVal BackPictureFormObject As Object)
'On Error Resume Next
Dim BackPictureNameOld As String
Dim BackPictureNameNew As String
Dim FilterDescriptionArray(1 To 2) As String
Dim FilterStringArray(1 To 2) As String
Dim SEControlStructIndex As Integer
'preset
FilterDescriptionArray(1) = "Picture Files"
FilterStringArray(1) = "*.bmp;*.jpg;*.gif"
FilterDescriptionArray(2) = "All Files"
FilterStringArray(2) = "*.*"
'preset
SEControlStructIndex = GetSEControlStructIndexFromControlObject(BackPictureFormObject, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
If SEControlStructIndex = 0 Then 'verify
MsgBox "internal error in SEM_BackPicture_Import(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
Call SE_ForwardCallBackMessage(SECBMSG_BACKPICTURECHOOSINGBOX_OPENED, "", "")
BackPictureNameOld = SEControlStructArray(SEControlStructIndex).SEControl_BackPicture
BackPictureNameOld = GFCDGetFileName("Select back picture...", 2, FilterDescriptionArray(), FilterStringArray(), 0, BackPictureNameOld)
Call SE_ForwardCallBackMessage(SECBMSG_BACKPICTURECHOOSINGBOX_CLOSED, BackPictureNameOld, "")
If Not (BackPictureNameOld = "") Then 'verify user didn't abort
'transfer picture to current skin directory
If (Not (UCase$(GetDirectoryName(BackPictureNameOld)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("Do you want to copy the image file to the current skin's directory to allow transfering it to other machines (recommended when you are creating a serious skin) ?", vbYesNoCancel + vbQuestion)
Case vbCancel
Exit Sub
Case vbYes
BackPictureNameNew = SESystemStructVar.SystemSkinDirectory + GetFileName(BackPictureNameOld)
If CopyFile(BackPictureNameOld, BackPictureNameNew, 0) = 0 Then
MsgBox "Copying picture failed, check disk space or network connection and try again !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call Skin_EncryptFile(BackPictureNameNew)
End If
Case vbNo
BackPictureNameNew = BackPictureNameOld 'user does not want to transfer picture file
End Select
Else
BackPictureNameNew = BackPictureNameOld 'picture is already in current skin directory
End If
Call SE_RefreshForms 'remove CommonDialog window‑trash
Call SEM_BackPicture_ChangeSub(BackPictureFormName, BackPictureFormObject, SECONTROLTYPE_FORM, BackPictureNameNew)
End If
Exit Sub
End Sub
Public Sub SEM_BackPicture_ChangeSub(ByVal BackPictureControlName As String, ByRef BackPictureControlObject As Object, ByVal BackPictureControlObjectType As Integer, ByVal BackPictureNameNew As String)
'on error resume next 'changes the back picture of a form or a picture box or a GFListView
Dim SEControlStructIndex As Integer
'verify
If IsPicture(BackPictureNameNew) = False Then Exit Sub
'begin
SEControlStructIndex = GetSEControlStructIndexFromControlObject(BackPictureControlObject, BackPictureControlObjectType, SESystemStructVar.SystemPaletteNumberCurrent)
If Not (SEControlStructIndex = 0) Then
If Not ((DirSave(BackPictureNameNew) = "") Or (Right$(BackPictureNameNew, 1) = "\") Or (BackPictureNameNew = "")) Then 'verify
SEControlStructArray(SEControlStructIndex).SEControl_BackPicture = BackPictureNameNew
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SEControlStructArray(SEControlStructIndex).SEControlName, "backpicture", BackPictureNameNew, False, False)
Call SEM_BackPicture_Enable(BackPictureControlName, BackPictureControlObject, BackPictureControlObjectType)
'Call SE_LoadControl(BackPictureControlName, True, SEControlStructIndex) 'done by SEM_BackPicture_Enable
'Call SE_RefreshControl(BackPictureControlName, 0, SEControlStructIndex)'done by SEM_BackPicture_Enable
Call SE_ForwardCallBackMessage(SECBMSG_BACKPICTURE_CHANGED, BackPictureNameNew, BackPictureControlName)
Call SE_ForwardCallBackMessage(SECBMSG_PICTUREBOX_REDRAW, BackPictureControlName, BackPictureControlName)
Else
MsgBox "internal error in SEM_BackPicture_ChangeSub(): file '" + BackPictureNameNew + "' not found !", vbOKOnly + vbCritical
End If
Else
MsgBox "internal error in SEM_BackPicture_ChangeSub() !", vbOKOnly + vbExclamation
End If
End Sub
Public Sub SEM_TitleBarPicture_Import(ByVal TitleBarPictureFormName As String, ByVal TitleBarPictureFormObject As Object)
'On Error Resume Next
Dim TitleBarPictureNameOld As String
Dim TitleBarPictureNameNew As String
Dim FilterDescriptionArray(1 To 2) As String
Dim FilterStringArray(1 To 2) As String
Dim SEControlStructIndex As Integer
'preset
FilterDescriptionArray(1) = "Picture Files"
FilterStringArray(1) = "*.bmp;*.jpg;*.gif"
FilterDescriptionArray(2) = "All Files"
FilterStringArray(2) = "*.*"
'preset
SEControlStructIndex = GetSEControlStructIndexFromControlObject(TitleBarPictureFormObject, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
If SEControlStructIndex = 0 Then 'verify
MsgBox "internal error in SEM_TitleBarPicture_Import(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
Call SE_ForwardCallBackMessage(SECBMSG_TITLEBARPICTURECHOOSINGBOX_OPENED, "", "")
TitleBarPictureNameOld = SEControlStructArray(SEControlStructIndex).SEControl_TitleBarPicture
TitleBarPictureNameOld = GFCDGetFileName("Select title bar picture...", 2, FilterDescriptionArray(), FilterStringArray(), 0, TitleBarPictureNameOld)
Call SE_ForwardCallBackMessage(SECBMSG_TITLEBARPICTURECHOOSINGBOX_CLOSED, TitleBarPictureNameOld, "")
'NOTE: the title bar can be disabled by pressing 'Abort'.
If Not (TitleBarPictureNameOld = "") Then
'transfer picture to current skin directory
If (Not (UCase$(GetDirectoryName(TitleBarPictureNameOld)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("Do you want to copy the image file to the current skin's directory to allow transfering it to other machines ?", vbYesNoCancel + vbQuestion)
Case vbCancel
Exit Sub
Case vbYes
TitleBarPictureNameNew = SESystemStructVar.SystemSkinDirectory + GetFileName(TitleBarPictureNameOld)
If CopyFile(TitleBarPictureNameOld, TitleBarPictureNameNew, 0) = 0 Then
MsgBox "Copying picture failed, check disk space or network connection and try again !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call Skin_EncryptFile(TitleBarPictureNameNew)
End If
Case vbNo
TitleBarPictureNameNew = TitleBarPictureNameOld 'user does not want to transfer picture file
End Select
Else
TitleBarPictureNameNew = TitleBarPictureNameOld 'picture is already in current skin directory
End If
Call SE_RefreshForms 'remove CommonDialog window‑trash
Call SEM_TitleBarPicture_ChangeSub(TitleBarPictureFormName, TitleBarPictureFormObject, TitleBarPictureNameNew)
Else
If MsgBox("Do you want to use no title bar picture ?", vbYesNo + vbQuestion) = vbYes Then
Call SEM_TitleBarPicture_ChangeSub(TitleBarPictureFormName, TitleBarPictureFormObject, TitleBarPictureNameNew)
End If
End If
Exit Sub
End Sub
Public Sub SEM_TitleBarPicture_ChangeSub(ByVal TitleBarPictureFormName As String, ByRef TitleBarPictureFormObject As Object, ByVal TitleBarPictureNameNew As String)
'on error resume next 'TileBarPictureNameNew may be "" to disable the title bar picture
Dim SEControlStructIndex As Integer
Dim TitleBarFormNameControlStructIndex As Integer
'verify
If Not (TitleBarPictureNameNew = "") Then
'NOTE: the title bar picture may be nothing ("") (disabled).
If IsPicture(TitleBarPictureNameNew) = False Then Exit Sub
End If
'begin
SEControlStructIndex = GetSEControlStructIndexFromControlObject(TitleBarPictureFormObject, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
If Not (SEControlStructIndex = 0) Then
If (Not ((DirSave(TitleBarPictureNameNew) = "") Or (Right$(TitleBarPictureNameNew, 1) = "\") Or (TitleBarPictureNameNew = ""))) Or _
(TitleBarPictureNameNew = "") Then 'verify
If Not (TitleBarPictureNameNew = "") Then
'display warning message if title bar picture's y size is greater than half the form size
Call SE_DeletePictureBox(GFSkinEnginefrm.GFSkinEngineTempPicture)
Call SE_FileToPictureBox(TitleBarPictureNameNew, GFSkinEnginefrm.GFSkinEngineTempPicture)
If GFSkinEnginefrm.GFSkinEngineTempPicture.ScaleHeight > (TitleBarPictureFormObject.Height / 2) Then
If MsgBox("The title bar picture is higher than half the form, use it nevertheless ?", vbYesNo + vbQuestion) = vbNo Then
GoTo Jump:
End If
End If
If GFSkinEnginefrm.GFSkinEngineTempPicture.ScaleWidth < _
((SEControlStructArray(SEControlStructIndex).SEControl_TitleBarSpawnStartPos + _
SEControlStructArray(SEControlStructIndex).SEControl_TitleBarSpawnLength ‑ _
1) * Screen.TwipsPerPixelX) Then
If MsgBox("The title bar picture's x size is smaller that the current form's title bar spawn start pos and ‑length." + Chr$(10) + "The title bar cannot be made fit to the form's width." + Chr$(10) + "Continue ?", vbYesNo + vbQuestion) = vbNo Then
MsgBox "Enable the User Move mode and left‑click on any control while pressing 'Ctrl'. Search for the current form and change the 'titlebarspawnstartpos' and 'titlebarspawnstartlength' values.", vbOKOnly + vbInformation
GoTo Jump:
End If
End If
End If
'apply title bar picture
SEControlStructArray(SEControlStructIndex).SEControl_TitleBarPicture = TitleBarPictureNameNew
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SEControlStructArray(SEControlStructIndex).SEControlName, "titlebarpicture", TitleBarPictureNameNew, False, False)
Call SE_LoadControl(TitleBarPictureFormName, True, SEControlStructIndex)
Call SE_RefreshControl(TitleBarPictureFormName, 0, SEControlStructIndex)
'
TitleBarFormNameControlStructIndex = GetSEControlStructIndexFromControlObject( _
TitleBarPictureFormObject, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
If Not (TitleBarPictureNameNew = "") Then 'notification message only if title bar picture enabled
If Not (TitleBarFormNameControlStructIndex = 0) Then 'verify
If (SEControlStructArray(TitleBarFormNameControlStructIndex).SEControl_BackPictureEnabledFlag = False) Or _
(IsPicture(SEControlStructArray(TitleBarFormNameControlStructIndex).SEControl_BackPicture, False) = False) Then
MsgBox "Note: the title bar will not be visible until you enable the back picture.", vbOKOnly + vbInformation
End If
End If
End If
'
Call SE_ForwardCallBackMessage(SECBMSG_TITLEBARPICTURE_CHANGED, TitleBarPictureNameNew, TitleBarPictureFormName)
Jump:
Else
MsgBox "internal error in SEM_TitleBarPicture_ChangeSub(): file '" + TitleBarPictureNameNew + "' not found !", vbOKOnly + vbCritical
End If
Else
MsgBox "internal error in SEM_TitleBarPicture_ChangeSub() !", vbOKOnly + vbExclamation
End If
End Sub
'***END OF BACK PICTURE***
'***FONT***
Public Sub SEM_Font_Select()
'On Error Resume Next
Dim FontName As String
Dim FontSize As Single
Dim FontSizeUnchanged As Boolean
Dim FontBoldFlag As Boolean
Dim FontItalicFlag As Boolean
Dim FontUnderlineFlag As Boolean
Dim FontStrikeThroughFlag As Boolean
Dim SkinDataFileString As String
'
'NOTE: to hell with the Windows ChooseFont API,
'and also the whole LOGFONT and structure shit.
'
'preset
FontName = SESystemStructVar.SystemFont.Name
FontSize = SESystemStructVar.SystemFont.Size
FontSizeUnchanged = SESystemStructVar.SystemFont.Size
FontBoldFlag = SESystemStructVar.SystemFont.Bold
FontItalicFlag = SESystemStructVar.SystemFont.Italic
FontUnderlineFlag = SESystemStructVar.SystemFont.Underline
FontStrikeThroughFlag = SESystemStructVar.SystemFont.StrikeThrough
'begin
Call SE_ForwardCallBackMessage(SECBMSG_FONTCHOOSINGBOX_OPENED, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Please select system font...", "")
If GFSelectFontfrm.GFSelectFont_SelectFont(FontName, FontSize, FontBoldFlag, FontItalicFlag, FontUnderlineFlag, FontStrikeThroughFlag) = True Then
Call SE_RefreshForms 'remove window‑trash
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_FONTCHOOSINGBOX_CLOSED, "", "")
'user selected a font (did not cancel)
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read the string to write it once only to increase speed
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontname", FontName, False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontsize", LTrim$(Str$(FontSize)), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontbold", BOOLTOSTRING(FontBoldFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontitalic", BOOLTOSTRING(FontItalicFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontunderline", BOOLTOSTRING(FontUnderlineFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontstrikethrough", BOOLTOSTRING(FontStrikeThroughFlag), False, False)
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
If Not (FontSize = FontSizeUnchanged) Then
'If MsgBox("You changed the system font size, do you want to fit all controls to the new font size now ?", vbYesNo + vbQuestion) = vbYes Then 'no! (annoying)
' Call SE_RefreshForms 'remove window‑trash
' Call SEM_ControlHeightToFontHeight(True) 'create no MsgBox
'End If
End If
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
Else
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_FONTCHOOSINGBOX_CLOSED, "", "")
End If
End Sub
Private Sub SEM_Font_List()
'on error resume next
Dim SEFontListStructNumber As Integer
Dim SEFontListStructArray() As SEFontListStruct
Dim FontLoop1 As Integer
Dim FontLoop2 As Integer
Dim FontFrequencyTotal As Integer 'how many controls there are with any font set
Dim FontPercentageInt As Integer '1 to 100
Dim FontString As String 'contains message to display
Dim StructLoop As Integer
'
'NOTE: this sub displays one or more MsgBoxes that show up to 12 fonts
'listed by frequency of usage in SEControlStructArray().
'
'preset
For StructLoop = 1 To SEControlStructNumber
Call SEFontListStruct_AddFont(SEFontListStructNumber, SEFontListStructArray(), _
SEControlStructArray(StructLoop).SEControl_Font.Name)
Next StructLoop
Call SEFontListStruct_Sort(SEFontListStructNumber, SEFontListStructArray())
For StructLoop = 1 To SEFontListStructNumber
FontFrequencyTotal = FontFrequencyTotal + SEFontListStructArray(StructLoop).FontFrequency
Next StructLoop
'begin
If Not (SEFontListStructNumber = 0) Then 'verify to avoid division by zero
For FontLoop1 = 1 To ‑Int(‑SEFontListStructNumber / 12)
FontString = "Here you see a list of the fonts the current skin uses," + Chr$(10) + "followed by their frequency (rounded) of usage:" + Chr$(10) + Chr$(10)
For FontLoop2 = FontLoop1 To MIN(FontLoop1 + 11, SEFontListStructNumber)
FontPercentageInt = CInt(CSng(SEFontListStructArray(FontLoop2).FontFrequency) / CSng(FontFrequencyTotal) * 100!)
If FontPercentageInt < 1 Then FontPercentageInt = 1 'verify (0 doesn't look good)
FontString = FontString + SEFontListStructArray(FontLoop2).FontName + ": " + LTrim$(Str$(FontPercentageInt)) + "%" + Chr$(10)
Next FontLoop2
FontString = FontString + Chr$(10) + "Furthermore all non‑pictured buttons use the following font:" + Chr$(10) + Chr$(10)
FontString = FontString + SESystemStructVar.SystemControlFont.Name
If (FontLoop1 + 11) < SEFontListStructNumber Then
If MsgBox(FontString, vbOKCancel + vbInformation) = vbCancel Then Exit For
Else
Call MsgBox(FontString, vbOKOnly + vbInformation)
End If
Next FontLoop1
Else
MsgBox "No font used (?).", vbOKOnly + vbInformation
End If
End Sub
Private Sub SEFontListStruct_AddFont(ByRef SEFontListStructNumber As Integer, ByRef SEFontListStructArray() As SEFontListStruct, ByVal FontName As String)
'on error resume next
Dim StructLoop As Integer
'
'NOTE: if the passed font already appears in list then
'its frequency will be increased by one.
'
'verify
If Len(FontName) = 0 Then Exit Sub 'may happen
'begin
For StructLoop = 1 To SEFontListStructNumber
If UCase$(SEFontListStructArray(StructLoop).FontName) = UCase$(FontName) Then
SEFontListStructArray(StructLoop).FontFrequency = SEFontListStructArray(StructLoop).FontFrequency + 1
Exit Sub
End If
Next StructLoop
If Not (SEFontListStructNumber = 32766) Then 'verify
SEFontListStructNumber = SEFontListStructNumber + 1
Else
Exit Sub 'error
End If
ReDim Preserve SEFontListStructArray(1 To SEFontListStructNumber) As SEFontListStruct
SEFontListStructArray(SEFontListStructNumber).FontName = FontName
SEFontListStructArray(SEFontListStructNumber).FontFrequency = 1 'preset
End Sub
Private Sub SEFontListStruct_Sort(ByVal SEFontListStructNumber As Integer, ByRef SEFontListStructArray() As SEFontListStruct)
'on error resume next 'sorts the whole shit by its frequency
Dim FontFrequencyMax As Integer
Dim Loop1 As Integer
Dim Loop2 As Integer
Dim TempSEFontListStruct As SEFontListStruct
'begin
Do
Loop1 = Loop1 + 1
If Not (Loop1 < SEFontListStructNumber) Then Exit Do 'verify
For Loop2 = Loop1 To SEFontListStructNumber
If SEFontListStructArray(Loop2).FontFrequency > FontFrequencyMax Then _
FontFrequencyMax = SEFontListStructArray(Loop2).FontFrequency
Next Loop2
For Loop2 = Loop1 To SEFontListStructNumber
If SEFontListStructArray(Loop2).FontFrequency = FontFrequencyMax Then
If Not (Loop2 = Loop1) Then 'verify shit must be moved around
TempSEFontListStruct = SEFontListStructArray(Loop2)
SEFontListStructArray(Loop2) = SEFontListStructArray(Loop1)
SEFontListStructArray(Loop1) = TempSEFontListStruct
End If
End If
Next Loop2
Loop
End Sub
'***END OF FONT***
'***USER MOVE***
'
'NOTE: about UserMove:
'The user is allowed to move around (almost) any control type.
'The Skin Engine therefore subclasses every control (as far as possible)
'when it is added during reading the SkinDataFile.
'If the UserMoveSystemEnabledFlag of UserMoveControlStructVar
'is set to True, the system will react to mouse down, move and up
'events by moving around the clicked control, following the mouse pointer.
'As the coordinates returned by GetSEControlXPos() and GetSEControlYPos()
'are not always screen related, a special moving system is used
'(see GFSkinEnginefrm code for further annotations).
'
Public Sub SEM_UserMove_Enable()
'On Error Resume Next
Dim ReturnValue As Long
Dim ReturnValueUsedFlag As Boolean
'begin
If UserMoveControlStructVar.UserMoveSystemEnabledFlag = False Then
Call SE_ForwardCallBackMessageEx(SECBMSG_USERMOVESYSTEM_ENABLING, "", "", ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = False) Or ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Then
UserMoveControlStructVar.UserMoveSystemEnabledFlag = True
Call SE_RefreshForms 'remove pop up window‑trash
Call GFSkinEnginefrm.SEMouseCapture_Remove 'reset
'
'NOTE: as the mouse cursor is to be changed when the UserMove system
'is enabled a WM_MOUSEMOVE message must be sent to the control
'that is currently located under the mouse pointer.
'
Call SetCursorPos(ProgramGetMousePosX, ProgramGetMousePosY)
Call SE_ForwardCallBackMessage(SECBMSG_USERMOVESYSTEM_ENABLED, "", "")
End If
End If
End Sub
Public Sub SEM_UserMove_Disable()
'On Error Resume Next
Dim ReturnValue As Long
Dim ReturnValueUsedFlag As Boolean
'begin
If UserMoveControlStructVar.UserMoveSystemEnabledFlag = True Then
Call SE_ForwardCallBackMessageEx(SECBMSG_USERMOVESYSTEM_DISABLING, "", "", ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = False) Or ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Then
UserMoveControlStructVar.UserMoveSystemEnabledFlag = False
Call SE_RefreshForms 'remove pop up window‑trash
'abort moving of a control (if enabled)
Call SEM_UserMove_Abort(UserMoveStructVar)
'reset mark
Call SEM_Mark_Remove
'reset mouse pointer
Call SEM_UserMove_ResetMousePointer(UserMoveStructVar)
'reset other
Call SE_ForwardCallBackMessage(SECBMSG_USERMOVESYSTEM_DISABLED, "", "")
End If
End If
End Sub
Public Sub SEM_UserMove_Abort(ByRef UserMoveStructVar As UserMoveStruct)
'on error resume next 'passed value is ignored
Call GFSkinEnginefrm.UserMove_Abort_Public
End Sub
Private Sub SEM_MouseCapture_Remove()
'on error resume next
Call GFSkinEnginefrm.SEMouseCapture_Remove
End Sub
Private Sub SEM_FilterMessage_Reset()
'on error resume next
Call GFSkinEnginefrm.SE_FilterMessage_Reset
End Sub
Private Sub SEM_Mark_Remove()
'on error resume next
Call GFSkinEnginefrm.Mark_Remove
End Sub
Public Sub SEM_UserMove_ResetMousePointer(ByRef UserMoveStructVar As UserMoveStruct)
'on error resume next 'call when the mouse leaves the size area of a control
Dim SEControlStructIndex As Integer
'begin
SEControlStructIndex = GetSEControlStructIndex(UserMoveStructVar.MousePointerControlName)
If Not (SEControlStructIndex = 0) Then 'verify
SEControlStructArray(SEControlStructIndex).SEControl.MousePointer = UserMoveStructVar.MousePointerUnchanged 'reset
UserMoveStructVar.MousePointerControlName = "" 'reset
UserMoveStructVar.MousePointerUnchanged = 0 'reset
End If
End Sub
Public Sub SEM_UserMove_EnableGrid()
'On Error Resume Next
UserMoveStructVar.GridEnabledFlag = True
UserMoveStructVar.GridXSize = 5 'fixed
UserMoveStructVar.GridYSize = 5 'fixed
End Sub
Public Sub SEM_UserMove_DisableGrid()
'On Error Resume Next
UserMoveStructVar.GridEnabledFlag = False
End Sub
Private Sub SEM_MoveControlsIntoVisibleArea(ByVal FormName As String, ByRef FormObject As Object)
'on error resume next 'moves all controls of current palette so that they are completely visible
Dim FormWidth As Long 'format: pixels
Dim FormHeight As Long 'format: pixels
Dim ControlLeft As Long
Dim ControlTop As Long
Dim ControlWidth As Long
Dim ControlHeight As Long
Dim ChangesExistingFlag As Boolean
Dim SkinDataFileString As String
Dim SkinDataFileStringChangedFlag As Boolean
Dim FormStructIndex As Integer
Dim StructLoop As Integer
'
'NOTE: controls of the palette ‑1 will never be moved as it is not
'sure to which parent form they belong to.
'
'preset
FormStructIndex = GetSEControlStructIndex(FormName)
If FormStructIndex = 0 Then Exit Sub 'verify
FormWidth = GetSEControlXSize(FormStructIndex)
FormHeight = GetSEControlYSize(FormStructIndex)
'begin
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Moving controls into visible area...", "")
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
For StructLoop = 1 To SEControlStructNumber
If IsControlPaletteEqualEx( _
SEControlStructArray(FormStructIndex).SEControl_PaletteNumber, SEControlStructArray(FormStructIndex).SEControl_PaletteArray(), _
SEControlStructArray(StructLoop).SEControl_PaletteNumber, SEControlStructArray(StructLoop).SEControl_PaletteArray()) = True Then
'
'NOTE: controls that are in the same palette should also be located on the same form.
'If this is not the case the total error may happen
'(external palette window size could be used when moving the controls of the main form).
'It is not important if a control to move is in the current system palette or not but it
'must be in the same palette as the form whose controls are to be moved is.
'
Select Case SEControlStructArray(StructLoop).SEControlType
Case SECONTROLTYPE_SECOMMAND, SECONTROLTYPE_PICTUREBOX, SECONTROLTYPE_TEXTBOX, SECONTROLTYPE_LISTBOX, _
SECONTROLTYPE_CHECKBOX, SECONTROLTYPE_COMBOBOX, SECONTROLTYPE_LABEL, _
SECONTROLTYPE_OPTIONBUTTON, SECONTROLTYPE_GFLISTVIEW, SECONTROLTYPE_GFTREEVIEW
If SEControlStructArray(StructLoop).SEControl.Visible = True Then 'do not move when not necessary
'
ChangesExistingFlag = False 'reset
ControlLeft = GetSEControlXPos(StructLoop)
ControlTop = GetSEControlYPos(StructLoop)
ControlWidth = GetSEControlXSize(StructLoop)
ControlHeight = GetSEControlYSize(StructLoop)
'
'verify control size
If ControlWidth > (Screen.Width / Screen.TwipsPerPixelX) Then
Call SetSEControlXSize(StructLoop, (Screen.Width / Screen.TwipsPerPixelX), GetXGrid)
ChangesExistingFlag = True
End If
If ControlWidth < GetXGrid Then
Call SetSEControlXSize(StructLoop, GetXGrid, GetXGrid)
ChangesExistingFlag = True
End If
If ControlHeight > (Screen.Height / Screen.TwipsPerPixelY) Then
Call SetSEControlYSize(StructLoop, (Screen.Height / Screen.TwipsPerPixelY), GetYGrid)
ChangesExistingFlag = True
End If
If ControlHeight < GetYGrid Then
Call SetSEControlYSize(StructLoop, GetYGrid, GetYGrid)
ChangesExistingFlag = True
End If
ControlWidth = GetSEControlXSize(StructLoop) 'refresh (grid)
ControlHeight = GetSEControlYSize(StructLoop) 'refresh (grid)
'verify control pos
If (ControlLeft + ControlWidth ‑ 1) > FormWidth Then
Call SetSEControlXPos(StructLoop, FormWidth ‑ ControlWidth + 1, GetXGrid)
ChangesExistingFlag = True
End If
If ControlLeft < 0 Then
Call SetSEControlXPos(StructLoop, 0, GetXGrid)
ChangesExistingFlag = True
End If
If (ControlTop + ControlHeight ‑ 1) > FormHeight Then
Call SetSEControlYPos(StructLoop, FormHeight ‑ ControlHeight + 1, GetYGrid)
ChangesExistingFlag = True
End If
If ControlTop < 0 Then
Call SetSEControlYPos(StructLoop, 0, GetYGrid)
ChangesExistingFlag = True
End If
'save control pos (if changed) (or controls will reset its position if user didn't move them further)
If ChangesExistingFlag = True Then
SkinDataFileStringChangedFlag = True
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "xpos", GetSEControlXPos(StructLoop))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "ypos", GetSEControlYPos(StructLoop))
End If
'update parent form size
If ChangesExistingFlag = True Then
If (Len(SEControlStructArray(StructLoop).SEControl_ResizeStruct.Resize_ParentFormName)) Then
SkinDataFileStringChangedFlag = True
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "resize_parentformxsize", GetSEControlXSize(FormStructIndex))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "resize_parentformysize", GetSEControlYSize(FormStructIndex))
End If
End If
'
End If
End Select
End If
Next StructLoop
If SkinDataFileStringChangedFlag = True Then _
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
End Sub
Public Sub SEM_ControlHeightToFontHeight(Optional ByVal NoUserPermissionFlag As Boolean = False) 'may be used by the target project, too
'on error resume next 'also called by SEM_New
Dim ScreenMousePointerUnchanged As Integer
Dim StructLoop As Integer
'verify
If NoUserPermissionFlag = False Then
If MsgBox("The height of all text boxes, option buttons, check boxes and labels will be manipulated so that the control's text is completely visible (the control width stays unchanged). Continue ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
End If
'preset
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'begin
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Setting optimal control height...", "")
For StructLoop = 1 To SEControlStructNumber
Call SEM_ControlHeightToFontHeightSub(StructLoop)
Next StructLoop
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
Screen.MousePointer = ScreenMousePointerUnchanged 'reset
End Sub
Public Sub SEM_ControlHeightToFontHeightSub(ByVal SEControlStructIndex As Integer) 'may be used by the target project, too
'on error resume next 'fits the height of ONE control to the control's font height
'Exit Sub
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_TEXTBOX
'
'NOTE: generally it is a good thing to save any control's size in the SkinDataFile
'as then the control will be resized when the system font's size is decreased
'(Windows enlarges text boxes automatically, but does not shrink them again).
'
SESystemStructVar.SystemTempPicture.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name
SESystemStructVar.SystemTempPicture.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size
SESystemStructVar.SystemTempPicture.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold
SESystemStructVar.SystemTempPicture.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic
SESystemStructVar.SystemTempPicture.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline
SESystemStructVar.SystemTempPicture.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough
'
'NOTE: we must not save the parent form size as this leads for errors for pool controls (we loop through all instances with different positions/sizes here).
Call SetSEControlYSize(SEControlStructIndex, SESystemStructVar.SystemTempPicture.TextHeight(Chr$(32)) / Screen.TwipsPerPixelY, GetYGrid, True, True) 'use grid, round up only, don't change parent form x/y size
Call SaveSEControlSize(SEControlStructIndex, GetSEControlXSize(SEControlStructIndex), GetSEControlYSize(SEControlStructIndex), GetXGrid, GetYGrid, False, True)
'
Case SECONTROLTYPE_CHECKBOX, SECONTROLTYPE_LABEL, SECONTROLTYPE_OPTIONBUTTON
'
'NOTE: GFSkinEnginefrm.GFSkinEngineWordWrapLabel has the AutoSize and WordWrap
'properties set to True.
'The label will be automatically sized in y direction to display its whole caption text.
'The current control's y size is set to the new label height.
'
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Font.Name = SEControlStructArray(SEControlStructIndex).SEControl_Font.Name
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Font.Size = SEControlStructArray(SEControlStructIndex).SEControl_Font.Size
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Font.Bold = SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Font.Italic = SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Font.Underline = SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Font.StrikeThrough = SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Caption = "" 'reset
'
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_CHECKBOX, SECONTROLTYPE_OPTIONBUTTON
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Width = (GetSEControlXSize(SEControlStructIndex) ‑ 10) * Screen.TwipsPerPixelX 'subtract some pixels for 'included box'
Case Else
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Width = (GetSEControlXSize(SEControlStructIndex) ‑ 0) * Screen.TwipsPerPixelX
End Select
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Caption = _
SEControlStructArray(SEControlStructIndex).SEControl.Caption 'caption could be set at design‑time
GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Refresh
'
'NOTE: we must not save the parent form size as this leads for errors for pool controls (we loop through all instances with different positions/sizes here).
Call SetSEControlYSize(SEControlStructIndex, GFSkinEnginefrm.GFSkinEngineWordWrapLabel.Height / Screen.TwipsPerPixelY, GetYGrid, True, True) 'use grid, round up only, don't change parent form x/y size
Call SaveSEControlSize(SEControlStructIndex, GetSEControlXSize(SEControlStructIndex), GetSEControlYSize(SEControlStructIndex), GetXGrid, GetYGrid, False, True)
'
End Select
End Sub
Private Sub SEM_ShowFormSize(ByVal FormName As String, ByRef FormObject As Object)
'on error resume next
Dim SEControlStructIndex As Integer
Dim Tempstr$
'preset
SEControlStructIndex = GetSEControlStructIndex(FormName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'begin
Tempstr$ = "The total window size is " + LTrim$(Str$(GetSEControlXSize(SEControlStructIndex))) + "x" + LTrim$(Str$(GetSEControlYSize(SEControlStructIndex))) + " pixels. " + _
"As the title bar is " + LTrim$(Str$(SEControlStructArray(SEControlStructIndex).SEControl_TitleBarHeight)) + " pixels high the back picture's visible area has a size of " + _
LTrim$(Str$(GetSEControlXSize(SEControlStructIndex))) + "x" + LTrim$(Str$(GetSEControlYSize(SEControlStructIndex) ‑ SEControlStructArray(SEControlStructIndex).SEControl_TitleBarHeight)) + " pixels." + _
Chr$(10) + "(use this information when creating a custom back picture)"
MsgBox Tempstr$, vbOKOnly + vbInformation
End Sub
'***END OF USER MOVE***
'***SKIN (SE POP UP MENU)***
Public Sub SEM_Skin_Select()
'On Error Resume Next
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'begin
Call SE_ForwardCallBackMessageEx(SECBMSG_BEFORE_SKIN_SELECT, "", "", ReturnValueUsedFlag, ReturnValue)
If ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Or (ReturnValueUsedFlag = False) Then
Call SE_UpdateFormMenu(8, "", Nothing) 'Menu8 (will not use SourceFormName or ‑Object)
Call SE_OpenPopUpMenu(ProgramGetMousePosX, ProgramGetMousePosY, 2, "", Nothing) 'Menu8 (will not use SourceFormName or ‑Object)
End If
End Sub
Public Sub SEM_Skin_Next()
'on error resume next
Dim SkinNameListStructNumber As Integer
Dim SkinNameListStructArray() As SkinNameListStruct
Dim SkinNameListIndexCurrent As Integer
Dim SkinNameListIndexNew As Integer
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim ScreenMousePointerUnchanged As Integer
Dim SkinLoop As Integer
Dim Tempstr$
'verify
Call SE_ForwardCallBackMessageEx(SECBMSG_BEFORE_SKIN_NEXT, "", "", ReturnValueUsedFlag, ReturnValue)
If ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Or (ReturnValueUsedFlag = False) Then
'select next skin as target project allows it
Else
Exit Sub
End If
'preset
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'begin
Call Skin_GetSkinNameList(SkinNameListStructNumber, SkinNameListStructArray())
Select Case SkinNameListStructNumber
Case 0
MsgBox "You do only have the base skin installed. To get more skins you can download new ones, create your own skin and export it (see pop up menu) or import a skin of a friend.", vbOKOnly + vbExclamation
Case 1
If SESystemStructVar.SystemSkinNameCurrent = SkinNameListStructArray(1).SkinName Then
If MsgBox("You do only have one custom skin installed, do you want to enjoy the great base skin ?", vbYesNo + vbQuestion) = vbYes Then
Call Skin_Change("")
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
End If
Else
If MsgBox("You only have one custom skin installed ('" + SkinNameListStructArray(1).SkinName + "'), do you want to use this one now ?", vbYesNo + vbQuestion) = vbYes Then
Call Skin_Change(SkinNameListStructArray(1).SkinName)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
Call SE_ForwardCallBackMessage(SECBMSG_DISPLAY_SKIN_NAME, GetCurrentSkinName, "")
End If
End If
Case Else
Tempstr$ = GetCurrentSkinName
For SkinLoop = 1 To SkinNameListStructNumber
If UCase$(SkinNameListStructArray(SkinLoop).SkinName) = UCase$(Tempstr$) Then
SkinNameListIndexCurrent = SkinLoop
End If
Next SkinLoop
SkinNameListIndexNew = SkinNameListIndexCurrent 'preset
NextSkin:
SkinNameListIndexNew = SkinNameListIndexNew + 1 'plus one
If SkinNameListIndexNew < 1 Then SkinNameListIndexNew = SkinNameListStructNumber 'circle
If SkinNameListIndexNew > SkinNameListStructNumber Then SkinNameListIndexNew = 1 'circle
Select Case MsgBox("The next skin is '" + SkinNameListStructArray(SkinNameListIndexNew).SkinName + "'. Do you want to use this one ?", vbYesNoCancel + vbQuestion)
Case vbCancel
GoTo Leave:
Case vbYes
If Not (SkinNameListIndexNew = SkinNameListIndexCurrent) Then 'verify
Call Skin_Change(SkinNameListStructArray(SkinNameListIndexNew).SkinName)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
Call SE_ForwardCallBackMessage(SECBMSG_DISPLAY_SKIN_NAME, GetCurrentSkinName, "")
End If
Case vbNo
If SkinNameListIndexNew = SkinNameListIndexCurrent Then 'check if 'circle was closed'
MsgBox "You really don't want to use any skin, starting from beginning again !", vbOKOnly + vbInformation
End If
GoTo NextSkin:
End Select
End Select
Leave:
Screen.MousePointer = ScreenMousePointerUnchanged 'reset
Exit Sub
End Sub
Public Sub SEM_Skin_Previous()
'on error resume next
Dim SkinNameListStructNumber As Integer
Dim SkinNameListStructArray() As SkinNameListStruct
Dim SkinNameListIndexCurrent As Integer
Dim SkinNameListIndexNew As Integer
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim ScreenMousePointerUnchanged As Integer
Dim SkinLoop As Integer
Dim Tempstr$
'verify
Call SE_ForwardCallBackMessageEx(SECBMSG_BEFORE_SKIN_PREVIOUS, "", "", ReturnValueUsedFlag, ReturnValue)
If ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Or (ReturnValueUsedFlag = False) Then
'select next skin as target project allows it
Else
Exit Sub
End If
'preset
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'begin
Call Skin_GetSkinNameList(SkinNameListStructNumber, SkinNameListStructArray())
Select Case SkinNameListStructNumber
Case 0
MsgBox "You do only have the base skin installed. To get more skins you can download new ones, create your own skin and export it (see pop up menu) or import a skin of a friend.", vbOKOnly + vbExclamation
Case 1
If SESystemStructVar.SystemSkinNameCurrent = SkinNameListStructArray(1).SkinName Then
If MsgBox("You do only have one custom skin installed, do you want to enjoy the great base skin ?", vbYesNo + vbQuestion) = vbYes Then
Call Skin_Change("")
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
End If
Else
If MsgBox("You only have one custom skin installed ('" + SkinNameListStructArray(1).SkinName + "'), do you want to use this one now ?", vbYesNo + vbQuestion) = vbYes Then
Call Skin_Change(SkinNameListStructArray(1).SkinName)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
Call SE_ForwardCallBackMessage(SECBMSG_DISPLAY_SKIN_NAME, GetCurrentSkinName, "")
End If
End If
Case Else
Tempstr$ = GetCurrentSkinName
For SkinLoop = 1 To SkinNameListStructNumber
If UCase$(SkinNameListStructArray(SkinLoop).SkinName) = UCase$(Tempstr$) Then
SkinNameListIndexCurrent = SkinLoop
End If
Next SkinLoop
SkinNameListIndexNew = SkinNameListIndexCurrent 'preset
PreviousSkin:
SkinNameListIndexNew = SkinNameListIndexNew ‑ 1 'minus 1
If SkinNameListIndexNew < 1 Then SkinNameListIndexNew = SkinNameListStructNumber 'circle
If SkinNameListIndexNew > SkinNameListStructNumber Then SkinNameListIndexNew = 1 'circle
Select Case MsgBox("The previous skin is '" + SkinNameListStructArray(SkinNameListIndexNew).SkinName + "'. Do you want to use this one ?", vbYesNoCancel + vbQuestion)
Case vbCancel
GoTo Leave:
Case vbYes
If Not (SkinNameListIndexNew = SkinNameListIndexCurrent) Then 'verify
Call Skin_Change(SkinNameListStructArray(SkinNameListIndexNew).SkinName)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
Call SE_ForwardCallBackMessage(SECBMSG_DISPLAY_SKIN_NAME, GetCurrentSkinName, "")
End If
Case vbNo
If SkinNameListIndexNew = SkinNameListIndexCurrent Then 'check if 'circle was closed'
MsgBox "You really don't want to use any skin, starting from beginning again !", vbOKOnly + vbInformation
End If
GoTo PreviousSkin:
End Select
End Select
Leave:
Screen.MousePointer = ScreenMousePointerUnchanged 'reset
Exit Sub
End Sub
Public Sub SEM_Skin_Copy()
On Error Resume Next 'important (if a file cannot be deleted)
Dim SkinNameDefault As String
Dim SkinNameNew As String
Dim SkinSourceDirectory As String
Dim SkinTargetDirectory As String
Dim SkinFileNumber As Integer
Dim SkinFileArray() As String
Dim ExportSkinDataFile As String
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim ScreenMousePointerUnchanged As Integer
Dim FileLoop As Integer
Dim NumerateLoop As Integer
'verify
Call SE_ForwardCallBackMessageEx(SECBMSG_BEFORE_SKIN_COPY, "", "", ReturnValueUsedFlag, ReturnValue)
If ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Or (ReturnValueUsedFlag = False) Then
'copy skin as target project allows it
Else
Exit Sub
End If
'begin
SkinNameDefault = GetSkinNameFromSkinDataFile(SE_GetSkinDataFile)
If SkinNameDefault = "" Then Exit Sub 'error
'number skin name
If Not (DirSave(SESystemStructVar.SystemSkinBaseDirectory + SkinNameDefault, vbDirectory) = "") Then
For NumerateLoop = 2 To 32766 'if not settable user must enter name
If DirSave(SESystemStructVar.SystemSkinBaseDirectory + SkinNameDefault + " (" + LTrim$(Str$(NumerateLoop)) + ")", vbDirectory) = "" Then
SkinNameDefault = SkinNameDefault + " (" + LTrim$(Str$(NumerateLoop)) + ")"
Exit For 'ok
End If
Next NumerateLoop
End If
ReDo1:
SkinNameNew = GFMsgBoxmod.GFInputBox("Please enter the new skin's name:", "Copy skin", SkinNameDefault)
If SkinNameNew = "" Then 'verify
'Select Case MsgBox("Sorry, this skin name is invalid, please try again !", vbOKCancel + vbExclamation)
'Case vbOK
' GoTo Redo:
'Case vbCancel
Exit Sub 'user canceled
'End Select
End If
If Skin_VerifySkinName(SkinNameNew) = False Then GoTo ReDo1: 'verify
'
SkinSourceDirectory = SESystemStructVar.SystemSkinDirectory
If Not (Right$(SkinSourceDirectory, 1) = "\") Then SkinSourceDirectory = SkinSourceDirectory + "\" 'verify
SkinTargetDirectory = SESystemStructVar.SystemSkinBaseDirectory + SkinNameNew
If Not (Right$(SkinTargetDirectory, 1) = "\") Then SkinTargetDirectory = SkinTargetDirectory + "\" 'verify
If Not (DirSave(SkinTargetDirectory, vbDirectory) = "") Then
Select Case MsgBox("Sorry, this skin name is already in use, please enter an other one !", vbOKCancel + vbInformation)
Case vbOK
GoTo ReDo1:
Case vbCancel
Exit Sub
End Select
End If
If GFCreateDirectory(SkinTargetDirectory) = False Then
MsgBox "Error: skin directory '" + SkinTargetDirectory + "' could not be created !", vbOKOnly + vbCritical
Exit Sub 'error
End If
With GFSkinEnginefrm
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
Call SE_RefreshForms 'remove form‑trash
Call SEM_Export_GetSkinFileArray(SkinFileNumber, SkinFileArray())
'
For FileLoop = 1 To SkinFileNumber
ReDo2:
If CopyFile(SkinFileArray(FileLoop), SkinTargetDirectory + GetFileName(SkinFileArray(FileLoop)), 0) = 0 Then
Select Case MsgBox("Copying file '" + SkinFileArray(FileLoop) + "' into '" + SkinTargetDirectory + GetFileName(SkinFileArray(FileLoop)) + "' failed, please check disk space or network connection !", vbRetryCancel + vbExclamation)
Case vbRetry
GoTo ReDo2:
Case vbCancel
'ignore current file
End Select
End If
Next FileLoop
'
'NOTE: we copied all files the current skin uses to the new skin directory.
'Note that unused files are not copied, the source directory of files
'that were copied needn't to be the directory of the copied skin.
'Now we must manipulate the SkinDataFile of the copy to use files
'in the copy's directory, not the files of the current skin.
'Therefore we use SEM_Export_CreateExportSkinDataFile().
'The current SkinDataFile is manipulated and copied to the copy's SDF.
'All file directories in the copy's SDF will be removed so that
'the system will use the files in the current (copy's) directory.
'
If SEM_Export_CreateExportSkinDataFile(ExportSkinDataFile) = True Then 'verify
If CopyFile(ExportSkinDataFile, SkinTargetDirectory + "Skin.dat", 0) = 0 Then 'verify
MsgBox "internal error in SEM_Skin_Copy: copying ExportSkinDataFile failed !", vbOKOnly + vbExclamation 'should not happen
If Not ((DirSave(ExportSkinDataFile) = "") Or (Right$(ExportSkinDataFile, 1) = "\") Or (ExportSkinDataFile = "")) Then Kill ExportSkinDataFile
Else
'the SkinDataFile with removed file directories was successfully copied to the copy's SDF
If Not ((DirSave(ExportSkinDataFile) = "") Or (Right$(ExportSkinDataFile, 1) = "\") Or (ExportSkinDataFile = "")) Then Kill ExportSkinDataFile
End If
Else 'should not happen
MsgBox "internal error in SEM_Skin_Copy: creating export SDF failed !", vbOKOnly + vbExclamation
End If
'
Screen.MousePointer = ScreenMousePointerUnchanged
End With
If MsgBox("Do you want to use the new skin now ?" + Chr$(10) + "(press 'No' if you just created a back up copy, press 'Yes' if you copied the current skin to create a new skin)", vbYesNo + vbQuestion) = vbYes Then
Call SEToReg 'save current skin name
Call Skin_Change(SkinNameNew)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
End If
Exit Sub
End Sub
Public Sub SEM_Skin_Delete()
On Error Resume Next 'important (if a file cannot be deleted)
Dim SkinName As String
Dim SkinOldDirectory As String
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim FileName As String 'directory and name of file to erase
Dim FileLoop As Integer
'verify
Call SE_ForwardCallBackMessageEx(SECBMSG_BEFORE_SKIN_DELETE, "", "", ReturnValueUsedFlag, ReturnValue)
If ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Or (ReturnValueUsedFlag = False) Then
'delete skin as target project allows it
Else
Exit Sub
End If
If MsgBox("Are you sure you want to remove the skin '" + SESystemStructVar.SystemSkinNameCurrent + "' from the hd ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
If UCase$(GetSkinNameFromSkinDataFile(SE_GetSkinDataFile)) = "BASESKIN" Then
MsgBox "You cannot delete the base skin !", vbOKOnly + vbCritical
Exit Sub
End If
'begin
With GFSkinEnginefrm
Call SE_RefreshForms 'remove form‑trash
.GFSkinEngineFile.Path = SESystemStructVar.SystemSkinDirectory
.GFSkinEngineFile.Pattern = "*.*"
.GFSkinEngineFile.Refresh
For FileLoop = 1 To .GFSkinEngineFile.ListCount
FileName = SESystemStructVar.SystemSkinDirectory + .GFSkinEngineFile.List(FileLoop ‑ 1)
If Not ((DirSave(FileName) = "") Or (Right$(FileName, 1) = "\") Or (FileName = "")) Then 'verify
Kill FileName
End If
Next FileLoop
.GFSkinEngineFile.Refresh
If .GFSkinEngineFile.ListCount = 0 Then
RmDir SESystemStructVar.SystemSkinDirectory
Else
'do nothing
End If
SkinOldDirectory = SESystemStructVar.SystemSkinDirectory
End With
Call SEToReg 'save current skin name
Call Skin_Change("")
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
If DirSave(SkinOldDirectory, vbDirectory) = "" Then
MsgBox "Skin has been deleted.", vbOKOnly + vbInformation
Else
MsgBox "Skin could not be deleted completely !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
Private Sub SEM_Browse()
On Error Resume Next 'important
Dim Tempdbl#
'begin
Tempdbl# = Shell("Explorer.exe" + " " + SESystemStructVar.SystemSkinDirectory, vbNormalFocus)
If Tempdbl# = 0# Then 'verify
MsgBox "Error starting Explorer.exe !", vbOKOnly + vbExclamation
End If
End Sub
Public Sub SEM_Info()
'on error resume next 'uses ST system to display info about the current skin (if available)
Dim SkinTransferFile As String
'
'NOTE: this sub can only be used to display an info about the current skin
'that was already unpacked from a SkinPacketFile.
'
'begin
SkinTransferFile = SESystemStructVar.SystemSkinDirectory + "SkinTransferFile.dat"
Call GFSkinEngine_SkinTransferfrm.ST_ShowInfo(SkinTransferFile)
End Sub
Public Sub SEM_New()
'on error resume next
Dim SkinNameUnchanged As String 'if user aborts creation of new skin
Dim SkinNameDefault As String 'Windows owner, or 'The great one' if owner shorter than 4 chars
Dim SkinNameNew As String
Dim SkinSourceDirectory As String
Dim SkinTargetDirectory As String
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'
'NOTE: call this sub to allow the user to create his own Skin.
'This sub does the following:
'‑request the desired name for the new Skin
'‑copy the default skin to the new skin
'‑set default colors, font, disable all pictures and poly rgns.
'‑send a message to target project, which can optionally display help text
'
'verify
Call SE_ForwardCallBackMessageEx(SECBMSG_BEFORE_SKIN_NEW, "", "", ReturnValueUsedFlag, ReturnValue)
If ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Or (ReturnValueUsedFlag = False) Then
'begin new skin as target project allows it
Else
Exit Sub
End If
'preset
SkinNameUnchanged = GetCurrentSkinName
'begin
If SEM_New_GetSkinNameDefault(SkinNameDefault) = False Then GoTo Error:
If SEM_New_GetSkinNameNew(SkinNameDefault, SkinNameNew, SkinSourceDirectory, SkinTargetDirectory) = False Then GoTo Error:
Call SE_RefreshForms 'important (tested)
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Skin Engine is preparing your new skin, please wait...", "")
If SEM_New_ReadSkinDataFileNew(SkinNameNew) = False Then GoTo Error:
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Skin Engine is preparing your new skin, please wait...", "") 'when reading SkinDataFile the current skin name was displayed, display this message here again
If SEM_New_DisableSpecialProperties = False Then GoTo Error:
If SEM_New_DisableNonSECommandPictures() = False Then GoTo Error:
If SEM_New_DisableSECommandPictures() = False Then GoTo Error:
If SEM_New_DisableSEPolyRgns() = False Then GoTo Error:
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If SEM_New_SetBaseProperties() = False Then GoTo Error:
If SEM_New_SetSkinEngineSystemSettings(SESystemStructVarUnchanged) = False Then GoTo Error:
If SEM_New_SetSkinEngineSettings() = False Then GoTo Error:
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
Call SEM_ControlHeightToFontHeight(True) 'create no MsgBox
Call SE_ForwardCallBackMessage(SECBMSG_SEM_NEW_FINISHED, "", "")
'
MsgBox "The basic settings of your new skin have succesfully been set." + Chr$(10) + _
"Note that when you have finished your surely great skin then you can export it and send it to a friend.", vbOKOnly + vbInformation
'
Exit Sub
Error:
If Not (SkinNameUnchanged = "") Then 'verify
Call Skin_Change(SkinNameUnchanged)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
End If
Call SEM_New_DeleteSkin(SkinSourceDirectory, SkinTargetDirectory)
'
MsgBox "Creation of new skin aborted.", vbOKOnly + vbInformation
'
Exit Sub
End Sub
Private Sub SEM_New_DeleteSkin(ByVal SkinSourceDirectory As String, ByVal SkinTargetDirectory As String)
On Error Resume Next 'important (if a file cannot be deleted)
Dim ResetLoop As Integer
Dim Tempstr$
'
'NOTE: this sub deletes all files in the new skin's directory and
'finally removes the directory if all files could be deleted.
'
If Not (DirSave(SkinTargetDirectory, vbDirectory) = "") Then 'verify
GFSkinEnginefrm.GFSkinEngineFile.Path = SkinTargetDirectory
GFSkinEnginefrm.GFSkinEngineFile.Pattern = "*.*"
GFSkinEnginefrm.GFSkinEngineFile.Refresh
Tempstr$ = GFSkinEnginefrm.GFSkinEngineFile.Path
If Not (Right$(Tempstr$, 1) = "\") Then Tempstr$ = Tempstr$ + "\" 'verify (important)
If UCase$(Tempstr$) = UCase$(SkinTargetDirectory) Then 'verify
For ResetLoop = 1 To GFSkinEnginefrm.GFSkinEngineFile.ListCount
ReDo:
Kill SkinTargetDirectory + GFSkinEnginefrm.GFSkinEngineFile.List(ResetLoop ‑ 1)
If Not (DirSave(SkinTargetDirectory + GFSkinEnginefrm.GFSkinEngineFile.List(ResetLoop ‑ 1)) = "") Then 'verify
Select Case MsgBox("Error deleting file '" + SkinTargetDirectory + GFSkinEnginefrm.GFSkinEngineFile.List(ResetLoop ‑ 1) + "' !", vbOKOnly + vbRetryCancel)
Case vbCancel
'do nothing
Case vbRetry
GoTo ReDo:
End Select
End If
Next ResetLoop
GFSkinEnginefrm.GFSkinEngineFile.Refresh
If GFSkinEnginefrm.GFSkinEngineFile.ListCount = 0 Then 'verify
RmDir SkinTargetDirectory
End If
End If
End If
End Sub
Private Function SEM_New_GetSkinNameDefault(ByRef SkinNameDefault As String) As Boolean
'on error resume next
Dim NumerateLoop As Integer
'begin
SkinNameDefault = Rmod.RegGetKeyValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\", "RegisteredOwner")
If Not (Len(SkinNameDefault) < 4) Then 'verify
If Len(SkinNameDefault) > 35 Then SkinNameDefault = Left$(SkinNameDefault, 32) + "..." 'SkinName length is limited by the system
SkinNameDefault = SkinNameDefault + "'s great skin"
Else
SkinNameDefault = "The great one"
End If
'numerate skin name
If Not (DirSave(SESystemStructVar.SystemSkinBaseDirectory + SkinNameDefault, vbDirectory) = "") Then
For NumerateLoop = 2 To 32766 'if not settable user must enter name
If DirSave(SESystemStructVar.SystemSkinBaseDirectory + SkinNameDefault + " (" + LTrim$(Str$(NumerateLoop)) + ")", vbDirectory) = "" Then
SkinNameDefault = SkinNameDefault + " (" + LTrim$(Str$(NumerateLoop)) + ")"
Exit For 'ok
End If
Next NumerateLoop
End If
SEM_New_GetSkinNameDefault = True 'ok
Exit Function
End Function
Private Function SEM_New_GetSkinNameNew(ByVal SkinNameDefault As String, ByRef SkinNameNew As String, ByRef SkinSourceDirectory As String, ByRef SkinTargetDirectory As String) As Boolean
'on error resume next 'returns True for success or False if user canceled
ReDo:
SkinNameNew = GFMsgBoxmod.GFInputBox("Please enter your skin's name:", "Create your own skin", SkinNameDefault)
If SkinNameNew = "" Then 'verify
SEM_New_GetSkinNameNew = False 'user canceled
Exit Function
End If
If Skin_VerifySkinName(SkinNameNew) = False Then GoTo ReDo: 'verify
'
SkinSourceDirectory = SESystemStructVar.SystemSkinBaseDirectory + "BASESKIN\" 'always copy SkinDataFile from base skin
If Not (Right$(SkinSourceDirectory, 1) = "\") Then SkinSourceDirectory = SkinSourceDirectory + "\" 'verify
SkinTargetDirectory = SESystemStructVar.SystemSkinBaseDirectory + SkinNameNew
If Not (Right$(SkinTargetDirectory, 1) = "\") Then SkinTargetDirectory = SkinTargetDirectory + "\" 'verify
'
If Not (DirSave(SkinTargetDirectory, vbDirectory) = "") Then
Select Case MsgBox("Sorry, this skin name is already in use, please enter an other one !", vbOKCancel + vbInformation)
Case vbOK
GoTo ReDo:
Case vbCancel
SEM_New_GetSkinNameNew = False 'user canceled
Exit Function
End Select
End If
'
If GFCreateDirectory(SkinTargetDirectory) = False Then
MsgBox "Error: skin directory '" + SkinTargetDirectory + "' could not be created !", vbOKOnly + vbCritical
GoTo Error: 'error
End If
'
'NOTE: The SkinDataFile of the new skin is created out of the SkinDataFile of the
'current skin. Note that ONLY the SkinDataFile is copied from the default skin,
'pictures and any other additional files will not be copied and used.
'
If CopyFile(SkinSourceDirectory + "Skin.dat", SkinTargetDirectory + "Skin.dat", 0) = 0 Then
MsgBox "Copying SkinDataFile failed, please check disk space or network connection !", vbOKOnly + vbExclamation
GoTo Error: 'error
End If
SEM_New_GetSkinNameNew = True 'ok
Exit Function
Error:
SEM_New_GetSkinNameNew = False 'error
Exit Function
End Function
Private Function SEM_New_ReadSkinDataFileNew(ByVal SkinNameNew As String) As Boolean
'on error resume next 'returns True for success or False for error
'
'NOTE: this sub changes the current SkinDataFile so that all changes
'will be done to the SkinDataFile of the new skin.
'If the creation of a new skin is aborted then the original SkinDataFile must
'be reselected.
'
'begin
Call Skin_Change(SkinNameNew) 'appearance is not updated, but changes will be done to new skin
Call SEToReg 'save current skin name
If UCase$(GetSkinNameFromSkinDataFile(SE_GetSkinDataFile)) = UCase$(SkinNameNew) Then 'verify
Call SE_SubClass_Disable(SEControlStructNumber, SEControlStructArray())
Call SkinDataFile_Read(SE_GetSkinDataFile)
Call SE_SubClass_Enable(SEControlStructNumber, SEControlStructArray())
SEM_New_ReadSkinDataFileNew = True 'ok
Exit Function
Else 'should not happen
MsgBox "internal error in SEM_New_ReadSkinDataFileNew() (GFSkinEngine): SkinDataFile change failed !", vbOKOnly + vbExclamation
SEM_New_ReadSkinDataFileNew = False 'error
Exit Function
End If
Exit Function
End Function
Private Function SEM_New_SetBaseProperties() As Boolean
'on error resume next 'returns True for success or False if user canceled
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim FontName As String
Dim FontSize As Single
Dim FontBoldFlag As Boolean
Dim FontItalicFlag As Boolean
Dim FontUnderlineFlag As Boolean
Dim FontStrikeThroughFlag As Boolean
Dim Color As Long
Dim SkinDataFile As String
Dim SkinDataFileString As String
'preset
SkinDataFile = SE_GetSkinDataFile
FontName = SESystemStructVar.SystemFont.Name
FontSize = SESystemStructVar.SystemFont.Size
FontBoldFlag = SESystemStructVar.SystemFont.Bold
FontItalicFlag = SESystemStructVar.SystemFont.Italic
FontUnderlineFlag = SESystemStructVar.SystemFont.Underline
FontStrikeThroughFlag = SESystemStructVar.SystemFont.StrikeThrough
'begin
'
MsgBox "Once your new skin is created you have the opportunity to:" + Chr$(10) + _
"‑change the background picture" + Chr$(10) + _
"‑change the titlebar picture" + Chr$(10) + _
"‑edit the window region (i.e. you can create round windows)" + Chr$(10) + _
"‑move buttons, boxes, etc. around, just how you like it best" + Chr$(10) + _
"But first of all you will be shown a color choosing dialog, please select your preferred foreground color...", vbOKOnly + vbInformation
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Please choose the text foreground color for your new skin...", "")
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_OPENED, "", "")
Color = GFCDGetColor(SESystemStructVar.SystemForeColor, 0, NULLARRAYLONG())
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_CLOSED, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If Color = True Then
GoTo Error: 'user canceled
End If
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_SYSTEM_FORECOLOR_CHANGE, LTrim$(Str$(Color)), "", ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, "", "system_forecolor", COLORTOSTRING(Color))
End If
'
MsgBox "WELL DONE !" + Chr$(10) + Chr$(10) + "Please select now your desired background color...", vbOKOnly + vbInformation
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Please choose the text background color for your new skin...", "")
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_OPENED, "", "")
Color = GFCDGetColor(SESystemStructVar.SystemForeColor, 0, NULLARRAYLONG())
Call SE_ForwardCallBackMessage(SECBMSG_COLORCHOOSINGBOX_CLOSED, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If Color = True Then
GoTo Error: 'user canceled
End If
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_SYSTEM_BACKCOLOR_CHANGE, LTrim$(Str$(Color)), "", ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, "", "system_backcolor", COLORTOSTRING(Color))
End If
'
MsgBox "Finally select the default font for your skin...", vbOKOnly + vbInformation
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Please choose the text font for your new skin...", "")
Call SE_ForwardCallBackMessage(SECBMSG_FONTCHOOSINGBOX_OPENED, "", "")
If GFSelectFontfrm.GFSelectFont_SelectFont(FontName, FontSize, FontBoldFlag, FontItalicFlag, FontUnderlineFlag, FontStrikeThroughFlag) = True Then
'user selected a font (did not cancel)
Call SE_RefreshForms 'remove window‑trash (important)
Call SE_ForwardCallBackMessage(SECBMSG_FONTCHOOSINGBOX_CLOSED, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_SYSTEM_FONT_CHANGE, FontName, LTrim$(Str$(FontSize)), ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SkinDataFile_ReadString(SkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontname", FontName, False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontsize", LTrim$(Str$(FontSize)), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontbold", BOOLTOSTRING(FontBoldFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontitalic", BOOLTOSTRING(FontItalicFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontunderline", BOOLTOSTRING(FontUnderlineFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_fontstrikethrough", BOOLTOSTRING(FontStrikeThroughFlag), False, False)
Call SkinDataFile_WriteString(SkinDataFile, SkinDataFileString)
End If
Else
Call SE_ForwardCallBackMessage(SECBMSG_FONTCHOOSINGBOX_CLOSED, "", "")
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
GoTo Error: 'user canceled
End If
SEM_New_SetBaseProperties = True 'ok
Exit Function
Error:
SEM_New_SetBaseProperties = False 'error
Exit Function
End Function
Private Function SEM_New_DisableSpecialProperties() As Boolean
'on error resume next 'always returns True
Dim SkinDataFile As String
Dim SkinDataFileString As String
Dim ControlName As String
Dim StructLoop As Integer
'preset
SkinDataFile = SE_GetSkinDataFile
'begin
Call SkinDataFile_ReadString(SkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
For StructLoop = 1 To SEControlStructNumber
If SECM_HasSpecialProperties(StructLoop) = True Then
'
'NOTE: if doing changes here then also update SECM_DisableSpecialProperties.
'
ControlName = SEControlStructArray(StructLoop).SEControlName
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "forecolor", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "backcolor", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontname", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontsize", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontbold", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontitalic", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontunderline", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontstrikethrough", "", True, False)
'display changes
SEControlStructArray(StructLoop).SEControl_ForeColor = SESystemStructVar.SystemForeColor
SEControlStructArray(StructLoop).SEControl_BackColor = SESystemStructVar.SystemBackColor
SEControlStructArray(StructLoop).SEControl_Font.Name = SESystemStructVar.SystemFont.Name
SEControlStructArray(StructLoop).SEControl_Font.Size = SESystemStructVar.SystemFont.Size
SEControlStructArray(StructLoop).SEControl_Font.Bold = SESystemStructVar.SystemFont.Bold
SEControlStructArray(StructLoop).SEControl_Font.Italic = SESystemStructVar.SystemFont.Italic
SEControlStructArray(StructLoop).SEControl_Font.Underline = SESystemStructVar.SystemFont.Underline
SEControlStructArray(StructLoop).SEControl_Font.StrikeThrough = SESystemStructVar.SystemFont.StrikeThrough
End If
Next StructLoop
Call SkinDataFile_WriteString(SkinDataFile, SkinDataFileString)
SEM_New_DisableSpecialProperties = True 'ok
Exit Function
End Function
Private Function SEM_New_DisableNonSECommandPictures() As Boolean
'on error resume next 'always returns True
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim ScreenMousePointerUnchanged As String
Dim SkinDataFileString As String
Dim StructLoop As Integer
'preset
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'begin
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
For StructLoop = 1 To SEControlStructNumber
If Not (Len(SEControlStructArray(StructLoop).SEControl_TitleBarPicture) = 0) Then
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_TITLEBARPICTURE_RESET, SEControlStructArray(StructLoop).SEControlName, SEControlStructArray(StructLoop).SEControl_TitleBarPicture, ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "titlebarpicture", "", False, False)
End If
End If
If Not (Len(SEControlStructArray(StructLoop).SEControl_BackPicture) = 0) Then 'do not check enabled flag
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_BACKPICTURE_RESET, SEControlStructArray(StructLoop).SEControlName, SEControlStructArray(StructLoop).SEControl_BackPictureEnabledFlag, ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "backpictureenabled", BOOLTOSTRING(False), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "backpicture", "", False, False)
End If
End If
Next StructLoop
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
Screen.MousePointer = ScreenMousePointerUnchanged
SEM_New_DisableNonSECommandPictures = True 'ok
Exit Function
End Function
Private Function SEM_New_DisableSECommandPictures() As Boolean
'on error resume next 'always returns True
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim ScreenMousePointerUnchanged As String
Dim SkinDataFileString As String
Dim StructLoop As Integer
'preset
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'begin
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
For StructLoop = 1 To SEControlStructNumber
If Not (Len(SEControlStructArray(StructLoop).SEControl_UpPicture) = 0) Then
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_UPPICTURE_RESET, SEControlStructArray(StructLoop).SEControlName, SEControlStructArray(StructLoop).SEControl_UpPicture, ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "uppicture", "", False, False)
End If
End If
If Not (Len(SEControlStructArray(StructLoop).SEControl_DownPicture) = 0) Then
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_DOWNPICTURE_RESET, SEControlStructArray(StructLoop).SEControlName, SEControlStructArray(StructLoop).SEControl_DownPicture, ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "downpicture", "", False, False)
End If
End If
If Not (Len(SEControlStructArray(StructLoop).SEControl_MoveOverPicture) = 0) Then
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_MOVEOVERPICTURE_RESET, SEControlStructArray(StructLoop).SEControlName, SEControlStructArray(StructLoop).SEControl_MoveOverPicture, ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "moveoverpicture", "", False, False)
End If
End If
Next StructLoop
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
Screen.MousePointer = ScreenMousePointerUnchanged
SEM_New_DisableSECommandPictures = True 'ok
Exit Function
End Function
Private Function SEM_New_DisableSEPolyRgns() As Boolean
'on error resume next 'always returns True
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim ScreenMousePointerUnchanged As String
Dim SkinDataFileString As String
Dim StructLoop As Integer
Dim Temp As Long
'preset
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'begin
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControlType = SECONTROLTYPE_SEPOLYRGN Then
Call SE_ForwardCallBackMessageEx(SECBMSG_SEM_NEW_POLYRGN_RESET, SEControlStructArray(StructLoop).SEControlName, "", ReturnValueUsedFlag, ReturnValue)
If Not ((ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL)) Then
'erase all poly rgn points
Temp = 0 'reset
Do While SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(StructLoop).SEControlName, "x", "", True, False) = True 'delete 'x=' line
Temp = Temp + 1
If Temp > 32767& Then Exit Do 'avoid endless loop
Loop
Temp = 0 'reset
Do While SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(StructLoop).SEControlName, "y", "", True, False) = True 'delete 'y=' line
Temp = Temp + 1
If Temp > 32767& Then Exit Do 'avoid endless loop
Loop
'set enabled property to false
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SEControlStructArray(StructLoop).SEControlName, "enabled", BOOLTOSTRING(False), False, False)
End If
End If
Next StructLoop
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
Screen.MousePointer = ScreenMousePointerUnchanged
SEM_New_DisableSEPolyRgns = True 'ok
Exit Function
End Function
Private Function SEM_New_SetSkinEngineSystemSettings(ByRef SESystemStructVarUnchanged As SESystemStruct) As Boolean
'on error resume next 'always returns True
Dim SkinDataFile As String
Dim SkinDataFileString As String
'
'NOTE: this sub sets some of the settings belonging to the
'pseudo object 'Skin Engine system settings' to a default value.
'
'preset
SkinDataFile = SE_GetSkinDataFile
'begin
Call SkinDataFile_ReadString(SkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlfontname", "Ms Sans Serif", False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlfontsize", "8", False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlfontbold", BOOLTOSTRING(False), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlfontitalic", BOOLTOSTRING(False), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlfontunderline", BOOLTOSTRING(False), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlfontstrikethrough", BOOLTOSTRING(False), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlcolor", COLORTOSTRING(SESystemStructVarUnchanged.SystemControlColorStruct.ControlColor))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controltextcolor", COLORTOSTRING(SESystemStructVarUnchanged.SystemControlColorStruct.ControlTextColor))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_lockedtextcolor", COLORTOSTRING(SESystemStructVarUnchanged.SystemControlColorStruct.LockedTextColor))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlmarkingcolor", COLORTOSTRING(SESystemStructVarUnchanged.SystemControlColorStruct.ControlMarkingColor))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_controlshadowcolor", COLORTOSTRING(SESystemStructVarUnchanged.SystemControlColorStruct.ControlShadowColor))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_lightshadowcolor", COLORTOSTRING(SESystemStructVarUnchanged.SystemControlColorStruct.LightShadowColor))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_darkshadowcolor", COLORTOSTRING(SESystemStructVarUnchanged.SystemControlColorStruct.DarkShadowColor))
Call SkinDataFile_ChangePropertySub(SkinDataFileString, "", "system_usetransparency", BOOLTOSTRING(SESystemStructVarUnchanged.SystemUseTransparencyFlag))
Call SkinDataFile_WriteString(SkinDataFile, SkinDataFileString)
SEM_New_SetSkinEngineSystemSettings = True 'ok
Exit Function
End Function
Private Function SEM_New_SetSkinEngineSettings() As Boolean
'on error resume next 'always returns True
'
'NOTE: this sub sets Skin Engine settings the user can change via
'the FormMenu (these settings are saved in the registry, not in the SkinDataFile).
'
UserMoveStructVar.GridEnabledFlag = True
SESystemStructVar.SystemAskForPictureImportFlag = False
SESystemStructVar.SystemSkinRandomSelectFlag = False
Call SEToReg 'save changes
SEM_New_SetSkinEngineSettings = True 'ok
Exit Function
End Function
'
'NOTE: about skin exporting/importing:
'Skin 'trading' works over the Skin Packet File, a CompressionPacketFile
'that contains the whole content of a skin directory.
'
Public Sub SEM_Export()
'on error resume next
Const DebugFile As String = "G:\Test.txt" 'debugging code retained as very helpful
Dim CompressionPackFile As String 'file containing all skin data
Dim ExportSkinDataFile As String 'SkinDataFile of skin to export, file links in it have a special format
Dim SEFontFile As String
Dim SkinName As String
Dim ImportPassword As String
Dim ImportPasswordHintText As String
Dim UserEditPassword As String
Dim UserEditPasswordHintText As String
Dim SkinTransferFile As String
Dim FileEx As String
Dim FontNameNumber As Integer
Dim FontNameArray() As String
Dim FontFileArray() As String
Dim SkinFileNumber As Integer 'files used by the current skin
Dim SkinFileArray() As String 'files used by the current skin
Dim StringNumber As Integer 'strings that will be put into CompressionPacketFile
Dim StringArray(1 To 3) As String 'strings that will be put into CompressionPacketFile
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim ScreenMousePointerUnchanged As Integer
Dim FileLoop As Integer
'verify
Call SE_ForwardCallBackMessageEx(SECBMSG_BEFORE_SKIN_EXPORT, "", "", ReturnValueUsedFlag, ReturnValue)
If ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Or (ReturnValueUsedFlag = False) Then
'ok
Else
Exit Sub
End If
'preset
ScreenMousePointerUnchanged = ‑1 'preset (not defined)
'reset
SEM_ExportFileArray_Reset
'begin
MsgBox "Congratulations for finishing your own skin !!" + Chr$(10) + Chr$(10) + "All the data of your skin will be saved in one single file that your friend can import. You will now be asked to select that file, use the default or enter a new file name.", vbOKOnly + vbInformation
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Skin Engine is preparing your skin for exporting, please wait...", "")
If SEM_Export_CreateExportSkinDataFile(ExportSkinDataFile) = False Then GoTo Error:
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If SEM_Export_GetCompressionPackFileName(CompressionPackFile) = False Then GoTo Abort:
Call SE_DeleteTempFiles(GetDirectoryName(CompressionPackFile)) 'GFCompressionmod code sometimes creates a real temp file mess
If SEM_Export_GetSEFontFile(SEFontFile, FontNameNumber, FontNameArray(), FontFileArray()) = False Then GoTo Error:
SkinName = GetFileName(GetFileMainName(CompressionPackFile))
If SEM_Export_GetSkinTransferFile(SkinName, ImportPassword, ImportPasswordHintText, UserEditPassword, UserEditPasswordHintText, SkinTransferFile, FileEx) = False Then GoTo Abort:
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Collecting files to pack...", "")
If SEM_Export_GetSkinFileArray(SkinFileNumber, SkinFileArray()) = False Then GoTo Error:
'
'
'NOTE: in the following lines of code the files that are packed are determined.
'The following 'special' files are packed:
'‑SEFontFile: contains relation font name <‑> font file name
'‑FileEx: set by user
'‑ExportSkinDataFile: copy of current SkinDataFile, directory of external files removed
'‑SkinTransferFile: information about current skin, entered by user
'All packed files are unpacked to the final skin directory (set by user via skin name).
'
'Open DebugFile For Output As #1: Close #1 'DEBUG
For FileLoop = 1 To SkinFileNumber
'Open DebugFile For Append As #1: Print #1, SkinFileArray(FileLoop): Close #1 'DEBUG
Call SEM_ExportFileArray_AddFile(SkinFileArray(FileLoop))
Next FileLoop
For FileLoop = 1 To FontNameNumber
'Open DebugFile For Append As #1: Print #1, FontFileArray(FileLoop): Close #1 'DEBUG
Call SEM_ExportFileArray_AddFile(FontFileArray(FileLoop))
Next FileLoop
'Open DebugFile For Append As #1: Print #1, SEFontFile: Close #1 'DEBUG
Call SEM_ExportFileArray_AddFile(SEFontFile)
'Open DebugFile For Append As #1: Print #1, FileEx: Close #1 'DEBUG
Call SEM_ExportFileArray_AddFile(FileEx)
'Open DebugFile For Append As #1: Print #1, ExportSkinDataFile: Close #1 'DEBUG
Call SEM_ExportFileArray_AddFile(ExportSkinDataFile)
'Open DebugFile For Append As #1: Print #1, SkinTransferFile: Close #1 'DEBUG
Call SEM_ExportFileArray_AddFile(SkinTransferFile)
'
StringNumber = 3
StringArray(1) = SkinName
StringArray(2) = ImportPassword 'may be ""
StringArray(3) = ImportPasswordHintText 'may be ""
'
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
Call SE_RefreshForms 'looks better
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Your skin is compressed and packed, please wait...", "")
'
If Not (UserEditPassword = "") Then
Call Skin_Encrypt(SESystemStructVar.SystemSkinDirectory, SE_CryptString(UserEditPassword), UserEditPasswordHintText) 'UserEditPassword was returned by ST system in encrypted form
'NOTE: ExportSkinDataFile is located in %wintempdir%, encrypt it 'manually'
'as it will later become the SkinDataFile of the imported skin.
Call SE_EncryptFile(ExportSkinDataFile, SE_CryptString(UserEditPassword), UserEditPasswordHintText)
End If
If GFCompression_CompressionPack_Create(CompressionPackFile, SEM_ExportFileNumber, SEM_ExportFileArray(), "rle huffman", StringNumber, StringArray()) = False Then
If Not (UserEditPassword = "") Then
Call Skin_Decrypt(SESystemStructVar.SystemSkinDirectory, SE_CryptString(UserEditPassword)) 'the skin must only be encrypted in the SkinPacketFile
End If
GoTo Error:
Else
If Not (UserEditPassword = "") Then
Call Skin_Decrypt(SESystemStructVar.SystemSkinDirectory, SE_CryptString(UserEditPassword)) 'the skin must only be encrypted in the SkinPacketFile
End If
End If
'
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If Not (ScreenMousePointerUnchanged = ‑1) Then Screen.MousePointer = ScreenMousePointerUnchanged 'reset
Call SEM_Export_DeleteTempFiles(ExportSkinDataFile, SkinTransferFile, SEFontFile)
'
MsgBox "The exporting was successful !!" + Chr$(10) + Chr$(10) + "You can now send '" + CompressionPackFile + "' to a friend, all he must do is choosing 'Import' and selecting this file.", vbOKOnly + vbInformation
Exit Sub
Abort:
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If Not (ScreenMousePointerUnchanged = ‑1) Then Screen.MousePointer = ScreenMousePointerUnchanged 'reset
Call SEM_Export_DeleteTempFiles(ExportSkinDataFile, SkinTransferFile, SEFontFile)
MsgBox "Skin export aborted.", vbOKOnly + vbInformation
Exit Sub
Error:
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If Not (ScreenMousePointerUnchanged = ‑1) Then Screen.MousePointer = ScreenMousePointerUnchanged 'reset
Call SEM_Export_DeleteTempFiles(ExportSkinDataFile, SkinTransferFile, SEFontFile)
MsgBox "Error exporting skin." + Chr$(13) + Chr$(10) + "Check disk space of program‑ and Windows drive (" + GetRootDir(App.Path) + ", " + GetRootDir(GFShellRegistration_GetWinDir) + ")." + Chr$(13) + Chr$(10) + "Verify no files are locked as currently used by any other application.", vbOKOnly + vbExclamation
Exit Sub
End Sub
Private Function SEM_Export_GetCompressionPackFileName(ByRef CompressionPackFile As String) As Boolean
'on error resume next 'returns True if a valid CompressionPackFile name was set, False if not
Dim FilterDescriptionArray(1 To 1) As String
Dim FilterStringArray(1 To 1) As String
'preset
FilterDescriptionArray(1) = "Skin Packets"
FilterStringArray(1) = "*.spf"
'begin
'
'NOTE: by default the SkinPacketFile is located in the root dir of the application
'drive and is named like the current skin, except the current skin is the base skin,
'then the file name is 'MyBaseSkin'. The user can freely change the
'CompressionPackFile name as long as the new name is a valid path and not
'existing yet.
'
'create default CompressionPackFile name
If Not (UCase$(SESystemStructVar.SystemSkinNameCurrent) = "BASESKIN") Then
CompressionPackFile = GetRootDir(App.Path) + SESystemStructVar.SystemSkinNameCurrent
Else
CompressionPackFile = GetRootDir(App.Path) + "MyBaseSkin"
End If
'request CompressionPackFile name from user
ReDo:
CompressionPackFile = GFCDSetFileName("Save Skin Packet", 1, FilterDescriptionArray(), FilterStringArray(), 1, CompressionPackFile)
Call SE_RefreshForms 'remove window‑trash
If Not (CompressionPackFile = "") Then 'verify user did not abort
If Not (LCase$(Right$(CompressionPackFile, 4)) = ".spf") Then CompressionPackFile = CompressionPackFile + ".spf"
If UCase$(GetFileName(GetFileMainName(CompressionPackFile))) = "BASESKIN" Then
MsgBox "Sorry, the file name 'BASESKIN' must not be used, try again !", vbOKOnly + vbExclamation
GoTo ReDo:
End If
If Not (DirSave(CompressionPackFile) = "") Then
If MsgBox("The file '" + CompressionPackFile + "' already exists. Overwrite ?", vbYesNo + vbQuestion) = vbNo Then GoTo ReDo:
End If
SEM_Export_GetCompressionPackFileName = True 'ok
Exit Function
Else
CompressionPackFile = "" 'reset (error)
SEM_Export_GetCompressionPackFileName = False 'reset
Exit Function
End If
End Function
Private Function SEM_Export_CreateExportSkinDataFile(ByRef ExportSkinDataFile As String) As Boolean
On Error GoTo Error: 'important (if a file cannot be deleted); returns True if an ExportSkinDataFile has been created, False if not
Dim ExportSkinDataFileString As String
Dim LocalSkinDataFile As String
Dim WinTempDir As String
Dim StructLoop As Integer
'
'NOTE: this sub creates a temporary SkinDataFile in %wintempdir%
'which content is equal to that of the current SkinDataFile
'except that all directory names where removed from all file paths.
'
'preset
LocalSkinDataFile = SE_GetSkinDataFile
WinTempDir = GFShellRegistration_GetWinTempDir
'verify
If (DirSave(LocalSkinDataFile) = "") Or (Right$(LocalSkinDataFile, 1) = "\") Or (Len(LocalSkinDataFile) = 0) Then GoTo Error:
If DirSave(WinTempDir, vbDirectory) = "" Then GoTo Error:
If Not (Right(WinTempDir, 1) = "\") Then WinTempDir = WinTempDir + "\"
'begin
ExportSkinDataFile = WinTempDir + GetFileName(LocalSkinDataFile)
If Not ((DirSave(ExportSkinDataFile) = "") Or (Right$(ExportSkinDataFile, 1) = "\") Or (Len(ExportSkinDataFile) = 0)) Then _
Kill ExportSkinDataFile
If CopyFile(LocalSkinDataFile, ExportSkinDataFile, 0) = 0 Then GoTo Error:
'
Call SE_DecryptFile(ExportSkinDataFile, SESystemStructVar.SystemSkinUserEditPassword)
Call SkinDataFile_ReadString(ExportSkinDataFile, ExportSkinDataFileString)
'
For StructLoop = 1 To SEControlStructNumber
If (IsFullPath(SEControlStructArray(StructLoop).SEControl_BackPicture)) Then _
Call SkinDataFile_ChangePropertySub( _
ExportSkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"backpicture", GetFileName(SEControlStructArray(StructLoop).SEControl_BackPicture))
If (IsFullPath(SEControlStructArray(StructLoop).SEControl_DownPicture)) Then _
Call SkinDataFile_ChangePropertySub( _
ExportSkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"downpicture", GetFileName(SEControlStructArray(StructLoop).SEControl_DownPicture))
If (IsFullPath(SEControlStructArray(StructLoop).SEControl_MoveOverPicture)) Then _
Call SkinDataFile_ChangePropertySub( _
ExportSkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"moveoverpicture", GetFileName(SEControlStructArray(StructLoop).SEControl_MoveOverPicture))
If (IsFullPath(SEControlStructArray(StructLoop).SEControl_TitleBarPicture)) Then _
Call SkinDataFile_ChangePropertySub( _
ExportSkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"titlebarpicture", GetFileName(SEControlStructArray(StructLoop).SEControl_TitleBarPicture))
If (IsFullPath(SEControlStructArray(StructLoop).SEControl_UpPicture)) Then _
Call SkinDataFile_ChangePropertySub( _
ExportSkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"uppicture", GetFileName(SEControlStructArray(StructLoop).SEControl_UpPicture))
If (IsFullPath(SEControlStructArray(StructLoop).SEControl_MouseIcon)) Then
If Not (UCase$(SEControlStructArray(StructLoop).SEControl_MouseIcon) = UCase$(SESystemStructVar.SystemMouseIcon)) Then 'verify (important)
Call SkinDataFile_ChangePropertySub( _
ExportSkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"mouseicon", GetFileName(SEControlStructArray(StructLoop).SEControl_MouseIcon))
End If
End If
If (IsFullPath(SEControlStructArray(StructLoop).SEControl_ResizeStruct.ResizeMouseIcon)) Then _
Call SkinDataFile_ChangePropertySub( _
ExportSkinDataFileString, SEControlStructArray(StructLoop).SEControlName, _
"resize_mouseicon", GetFileName(SEControlStructArray(StructLoop).SEControl_ResizeStruct.ResizeMouseIcon))
'
'NOTE: there's no system resize mouse icon, thus we don't have to verify
'if the resize control mouse icon is equal to the system resize mouse icon
'(compare to code to format normal mouseicon).
'
Next StructLoop
'
If (IsFullPath(SESystemStructVar.SystemMouseIcon)) Then _
Call SkinDataFile_ChangePropertySub( _
ExportSkinDataFileString, "", _
"system_mouseicon", GetFileName(SESystemStructVar.SystemMouseIcon))
'
Call SkinDataFile_WriteString(ExportSkinDataFile, ExportSkinDataFileString)
'
SEM_Export_CreateExportSkinDataFile = True 'ok
Exit Function
Error:
ExportSkinDataFile = "" 'reset
SEM_Export_CreateExportSkinDataFile = False 'error
Exit Function
End Function
Private Function SEM_Export_GetSEFontFile(ByRef SEFontFile As String, ByRef FontNameNumber As Integer, ByRef FontNameArray() As String, ByRef FontFileArray() As String) As Boolean
'on error resume next 'returns True if SEFontFile is valid, False if not
If SEFont_GetFontFileList(FontNameNumber, FontNameArray(), FontFileArray()) = False Then GoTo Error:
SEFontFile = SEFontFile_Write(FontNameNumber, FontNameArray(), FontFileArray())
If (DirSave(SEFontFile) = "") Or (Right$(SEFontFile, 1) = "\") Or (SEFontFile = "") Then GoTo Error:
SEM_Export_GetSEFontFile = True 'ok
Exit Function
Error:
SEM_Export_GetSEFontFile = False 'error
Exit Function
End Function
Private Function SEM_Export_GetSkinTransferFile(ByRef SkinName As String, ByRef ImportPassword As String, ByRef ImportPasswordHintText As String, ByRef UserEditPassword As String, ByRef UserEditPasswordHintText As String, ByRef SkinTransferFile As String, ByRef FileEx As String) As Boolean
'on error resume next 'returns True if passed values have been initialized correctly, False if not
'
'NOTE: the user can enter skin and author specific data that will be exported
'in the SkinTransferFile within the SkinPacketFile. Also the user can
'include an additional file in the SkinPacketFile. See SkinTransferfrm for
'further information.
'
If GFSkinEngine_SkinTransferfrm.ST_RequestExportData(SkinName, ImportPassword, ImportPasswordHintText, UserEditPassword, UserEditPasswordHintText, SkinTransferFile, FileEx) = False Then
SEM_Export_GetSkinTransferFile = False 'error
Exit Function
Else
Call SE_RefreshForms 'remove window trash
SEM_Export_GetSkinTransferFile = True 'ok
Exit Function
End If
End Function
Private Function SEM_Export_GetSkinFileArray(ByRef SkinFileNumber As Integer, ByRef SkinFileArray() As String) As Boolean
'on error resume next 'returns True if passed array has been initialized correctly, False if not
Dim SkinFile As String
Dim StructLoop As Integer
Dim TestLoop As Integer
'
'NOTE: the source names of all files USED by the current skin are added to the
'passed array. If a file in the current skin's directory is not mentioned in the
'current SkinDataFile then its name will not be added to the array.
'
For StructLoop = 1 To SEControlStructNumber
SkinFile = SEControlStructArray(StructLoop).SEControl_BackPicture
If (IsFileExisting(SkinFile)) Then GoSub AddSkinFile:
SkinFile = SEControlStructArray(StructLoop).SEControl_DownPicture
If (IsFileExisting(SkinFile)) Then GoSub AddSkinFile:
SkinFile = SEControlStructArray(StructLoop).SEControl_MoveOverPicture
If (IsFileExisting(SkinFile)) Then GoSub AddSkinFile:
SkinFile = SEControlStructArray(StructLoop).SEControl_TitleBarPicture
If (IsFileExisting(SkinFile)) Then GoSub AddSkinFile:
SkinFile = SEControlStructArray(StructLoop).SEControl_UpPicture
If (IsFileExisting(SkinFile)) Then GoSub AddSkinFile:
SkinFile = SEControlStructArray(StructLoop).SEControl_MouseIcon
If (IsFileExisting(SkinFile)) Then GoSub AddSkinFile:
SkinFile = SEControlStructArray(StructLoop).SEControl_ResizeStruct.ResizeMouseIcon
If (IsFileExisting(SkinFile)) Then GoSub AddSkinFile:
Next StructLoop
SkinFile = SESystemStructVar.SystemMouseIcon
If (IsFileExisting(SkinFile)) Then GoSub AddSkinFile:
SEM_Export_GetSkinFileArray = True 'ok
Exit Function
Error: 'there can really be no error!
SEM_Export_GetSkinFileArray = False 'error
Exit Function
AddSkinFile:
For TestLoop = 1 To SkinFileNumber 'don't add a file twice to the array
If UCase$(SkinFileArray(TestLoop)) = UCase$(SkinFile) Then
Return
End If
Next TestLoop
If Not (SkinFileNumber = 32766) Then 'verify (should not happen)
SkinFileNumber = SkinFileNumber + 1
ReDim Preserve SkinFileArray(1 To SkinFileNumber) As String
SkinFileArray(SkinFileNumber) = SkinFile
End If
Return
End Function
Private Sub SEM_Export_DeleteTempFiles(ByVal ExportSkinDataFile As String, ByVal SkinTransferFile As String, ByVal SEFontFile As String)
On Error Resume Next 'important; deletes passed files (if existing)
If Not ((DirSave(ExportSkinDataFile) = "") Or (Right$(ExportSkinDataFile, 1) = "\") Or (Len(ExportSkinDataFile) = 0)) Then Kill ExportSkinDataFile
'If Not ((DirSave(SkinTransferFile) = "") Or (Right$(SkinTransferFile, 1) = "\") Or (Len(SkinTransferFile) = 0)) Then Kill SkinTransferFile 'we reatin this file to allow displaying information about the current skin
If Not ((DirSave(SEFontFile) = "") Or (Right$(SEFontFile, 1) = "\") Or (Len(SEFontFile) = 0)) Then Kill SEFontFile
End Sub
Private Function SEM_ExportFileArray_Reset()
'on error resume next
SEM_ExportFileNumber = 0 'reset
ReDim Preserve SEM_ExportFileArray(1 To 1) As String 'reset
End Function
Private Sub SEM_ExportFileArray_AddFile(ByVal File As String)
'on error resume next 'add a file to export
Dim StructLoop As Integer
'
'NOTE: as many different files must be packed into the SkinPacketFile,
'this sub was added to receive the files to pack.
'Access SEM_ExportFileArray() when creating the SkinPacketFile.
'A file will never be added twice.
'
'NOTE: not all files will be packet. Temp files and non‑existing files
'will be excluded by this sub.
'
'verify
For StructLoop = 1 To SEM_ExportFileNumber
If UCase$(File) = UCase$(SEM_ExportFileArray(StructLoop)) Then
Exit Sub 'file was already added
End If
Next StructLoop
'begin
If Not ((DirSave(File) = "") Or (Right$(File, 1) = "\") Or (File = "") Or _
(UCase$(GetFileNameSuffix(File)) = "TMP")) Then 'verify
If Not (SEM_ExportFileNumber = 32766) Then 'verify
SEM_ExportFileNumber = SEM_ExportFileNumber + 1
Else
Exit Sub 'error
End If
ReDim Preserve SEM_ExportFileArray(1 To SEM_ExportFileNumber) As String
SEM_ExportFileArray(SEM_ExportFileNumber) = File
End If
End Sub
Public Sub SEM_Import(Optional ByVal CompressionPackFile As String = "")
'on error resume next
Dim OutputDirectory As String
Dim StringNumber As Integer 'strings that are located in ComrpessionPacketFile
Dim StringArray() As String 'strings that are located in ComrpessionPacketFile
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
Dim ScreenMousePointerUnchanged As Integer
'verify
Call SE_ForwardCallBackMessageEx(SECBMSG_BEFORE_SKIN_IMPORT, "", "", ReturnValueUsedFlag, ReturnValue)
If ((ReturnValueUsedFlag = True) And (Not (ReturnValue = SECBMSG_REPLY_CANCEL))) Or (ReturnValueUsedFlag = False) Then
'ok
Else
Exit Sub
End If
'preset
ScreenMousePointerUnchanged = ‑1 'preset (not defined)
'begin
If CompressionPackFile = "" Then
If SEM_Import_GetCompressionPackFile(CompressionPackFile) = False Then GoTo Abort:
Else
If (DirSave(CompressionPackFile) = "") Or (Right$(CompressionPackFile, 1) = "\") Or (Len(CompressionPackFile) = 0) Then
MsgBox "Error importing SkinPacketFile: file '" + CompressionPackFile + "' not found !", vbOKOnly + vbExclamation
GoTo Error:
End If
End If
If GFCompression_CompressionPack_GetStringArray(CompressionPackFile, StringNumber, StringArray()) = False Then GoTo Error:
If StringArray(1) = "" Then GoTo Error: 'skin name
If SEM_Import_VerifyImportPermission(StringNumber, StringArray()) = False Then GoTo Abort:
If SEM_Import_GetOutputDirectory(OutputDirectory, StringNumber, StringArray()) = False Then GoTo Abort:
'
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
Call SE_RefreshForms 'looks better
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_SHOW, "Unpacking and decompressing skin, please wait...", "")
'
If GFCreateDirectory(OutputDirectory) = False Then GoTo Error:
If GFCompression_CompressionPack_Unpack(CompressionPackFile, OutputDirectory) = False Then GoTo Error:
Call SEM_Import_InstallFonts(OutputDirectory + "Font.dat")
'
Screen.MousePointer = ScreenMousePointerUnchanged
'
If Skin_Change(StringArray(1)) = True Then 'name of new skin
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
Call SEM_Import_FileExSaveEx(OutputDirectory)
Else 'display palette (of base skin) in any case
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
GoTo Error:
End If
'
MsgBox "Skin imported successfully.", vbOKOnly + vbInformation
'
If MsgBox("Do you want to read information about the imported skin ?", vbYesNo + vbQuestion) = vbYes Then
Call SE_RefreshForms 'remove MsgBox‑trash
Call SEM_Info
End If
'
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If Not (ScreenMousePointerUnchanged = ‑1) Then Screen.MousePointer = ScreenMousePointerUnchanged 'reset
Exit Sub
Abort:
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If Not (ScreenMousePointerUnchanged = ‑1) Then Screen.MousePointer = ScreenMousePointerUnchanged 'reset
MsgBox "Importing skin aborted.", vbOKOnly + vbInformation
Exit Sub
Error:
Call SE_ForwardCallBackMessage(SECBMSG_MESSAGE_HIDE, "", "")
If Not (ScreenMousePointerUnchanged = ‑1) Then Screen.MousePointer = ScreenMousePointerUnchanged 'reset
MsgBox "Error importing skin." + Chr$(13) + Chr$(10) + "Check disk space of program‑ and Windows drive (" + GetRootDir(App.Path) + ", " + GetRootDir(GFShellRegistration_GetWinDir) + ")." + Chr$(13) + Chr$(10) + "Verify no files are locked as currently used by any other application.", vbOKOnly + vbExclamation
Exit Sub
End Sub
Private Function SEM_Import_GetCompressionPackFile(ByRef CompressionPackFile As String) As Boolean
'on error resume next 'returns True for success or False for error or if user aborted
Dim FilterDescriptionArray(1 To 2) As String
Dim FilterStringArray(1 To 2) As String
'preset
FilterDescriptionArray(1) = "Skin Packets"
FilterDescriptionArray(2) = "All Files"
FilterStringArray(1) = "*.spf"
FilterStringArray(2) = "*.*"
'begin
ReDo:
CompressionPackFile = GFCDGetFileName("Select Skin Packet File", 1, FilterDescriptionArray(), FilterStringArray(), 1, GetRootDir(App.Path))
Call SE_RefreshForms 'remove window‑trash
If Not (CompressionPackFile = "") Then
If Not ((DirSave(CompressionPackFile) = "") Or (Right$(CompressionPackFile, 1) = "\")) Then 'verify
SEM_Import_GetCompressionPackFile = True 'ok
Exit Function
Else
Select Case MsgBox("File '" + CompressionPackFile + "' not found !", vbRetryCancel)
Case vbCancel
SEM_Import_GetCompressionPackFile = False 'error
Exit Function
Case vbRetry
GoTo ReDo:
End Select
End If
Else
SEM_Import_GetCompressionPackFile = False 'error
Exit Function
End If
End Function
Private Function SEM_Import_VerifyImportPermission(ByVal StringNumber As Integer, ByRef StringArray() As String) As Boolean
'on error resume next 'returns True for success or False for error
Dim ImportPassword As String
Dim TempBool As Boolean
Dim Tempstr$
'begin
If Not (StringArray(2) = "") Then
'NOTE: the author of the skin to import made use of the ImportPassword.
Tempstr$ = "STOP!" + Chr$(10) + "The author of this skin ('" + StringArray(1) + "') implemented a password !" + Chr$(10)
If Not (StringArray(3) = "") Then
'NOTE: the author of the skin to import made use of the ImportPasswordHintText.
Tempstr$ = Tempstr$ + "You are given the following hint: " + Chr$(10) + Chr$(10) + StringArray(3) + Chr$(10) + Chr$(10)
End If
Tempstr$ = Tempstr$ + "You will now be asked to enter the password to import the skin. If you don't know the password then you must abort importing the skin (I'm sorry, but these are the rules)."
If MsgBox(Tempstr$, vbOKCancel + vbInformation) = vbCancel Then
GoTo Error:
End If
ReDo:
ImportPassword = GFMsgBoxmod.GFInputBox("Please enter the Import Password:", "Password !", "", False, TempBool)
If TempBool = True Then GoTo Error:
If Not (ImportPassword = SE_CryptString(StringArray(2))) Then
If MsgBox("This is the wrong password, but you can try again !", vbOKCancel + vbExclamation) = vbCancel Then
GoTo Error:
Else
GoTo ReDo:
End If
End If
End If
SEM_Import_VerifyImportPermission = True 'ok
Exit Function
Error:
SEM_Import_VerifyImportPermission = False 'error
Exit Function
End Function
Private Function SEM_Import_GetOutputDirectory(ByRef OutputDirectory As String, ByVal StringNumber As Integer, ByRef StringArray() As String) As Boolean
On Error Resume Next 'important (if a file cannot be deleted); returns True for success or False for error
Dim SkinNameDefault As String
Dim NumerateLoop As Integer
Dim FileLoop As Integer
Dim Temp As Long
Dim Tempstr$
'begin
ReDo1:
'
OutputDirectory = SESystemStructVar.SystemSkinBaseDirectory + StringArray(1)
If Not (Right$(OutputDirectory, 1) = "\") Then OutputDirectory = OutputDirectory + "\" 'verify (important)
'
If Not (DirSave(OutputDirectory, vbDirectory) = "") Then
'NOTE: error: current skin name leads to the creation of a skin that already exists.
If MsgBox("Sorry, there is already a skin named '" + StringArray(1) + "' on your computer, do you want to overwrite it ?", vbYesNo + vbQuestion) = vbNo Then
'do not overwrite existing skin, numerate already existing skin name
ReDo2:
SkinNameDefault = StringArray(1)
If Not (DirSave(SESystemStructVar.SystemSkinBaseDirectory + SkinNameDefault, vbDirectory) = "") Then
For NumerateLoop = 2 To 32766 'if not setable user must enter name
If DirSave(SESystemStructVar.SystemSkinBaseDirectory + SkinNameDefault + " (" + LTrim$(Str$(NumerateLoop)) + ")", vbDirectory) = "" Then
SkinNameDefault = SkinNameDefault + " (" + LTrim$(Str$(NumerateLoop)) + ")"
Exit For 'ok
End If
Next NumerateLoop
End If
StringArray(1) = GFMsgBoxmod.GFInputBox("Please enter new skin name:", "", SkinNameDefault)
If Not (StringArray(1) = "") Then
'entered skin name is not nothing, verify
If Skin_VerifySkinName(StringArray(1)) = False Then 'verify
GoTo ReDo2:
Else
GoTo ReDo1:
End If
Else
'entered skin name is nothing, user wants to abort
GoTo Error:
End If
Else
'overwrite existing skin
If MsgBox("The existing skin '" + StringArray(1) + "' will be deleted, continue ?", vbYesNo + vbQuestion) = vbYes Then
'user permitted to delete the existing skin
'
If UCase$(SESystemStructVar.SystemSkinNameCurrent) = UCase$(StringArray(1)) Then
'NOTE: the skin that is to be deleted must currently not be in use.
Call Skin_Change("") 'select the base skin, the system does not allow that the user can ex‑ and import a skin named 'baseskin'
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
End If
'
OutputDirectory = SESystemStructVar.SystemSkinBaseDirectory + StringArray(1)
If Not (Right$(OutputDirectory, 1) = "\") Then OutputDirectory = OutputDirectory + "\" 'verify (important)
'
GFSkinEnginefrm.GFSkinEngineFile.Path = SESystemStructVar.SystemSkinBaseDirectory + StringArray(1)
GFSkinEnginefrm.GFSkinEngineFile.Pattern = "*.*"
GFSkinEnginefrm.GFSkinEngineFile.Refresh
Tempstr$ = GFSkinEnginefrm.GFSkinEngineFile.Path
If Not (Right$(Tempstr$, 1) = "\") Then Tempstr$ = Tempstr$ + "\"
If UCase$(Tempstr$) = UCase$(OutputDirectory) Then 'veirfy
For FileLoop = 1 To GFSkinEnginefrm.GFSkinEngineFile.ListCount
Kill OutputDirectory + GFSkinEnginefrm.GFSkinEngineFile.List(FileLoop ‑ 1)
If Not (DirSave(OutputDirectory + GFSkinEnginefrm.GFSkinEngineFile.List(FileLoop ‑ 1))) = "" Then 'verify
MsgBox "Error deleting file '" + OutputDirectory + GFSkinEnginefrm.GFSkinEngineFile.List(FileLoop ‑ 1) + "' !", vbOKOnly + vbExclamation
End If
Next FileLoop
End If
Else
'user canceled deleting existing skin
GoTo ReDo1:
End If
End If
End If
If UCase$(StringArray(1)) = "BASESKIN" Then
'entered skin name is reserved
MsgBox "You cannot overwrite the BaseSkin !", vbOKOnly + vbCritical
GoTo ReDo1:
End If
'
OutputDirectory = SESystemStructVar.SystemSkinBaseDirectory + StringArray(1)
If Not (Right$(OutputDirectory, 1) = "\") Then OutputDirectory = OutputDirectory + "\" 'verify (important)
'
SEM_Import_GetOutputDirectory = True 'ok
Exit Function
Error:
OutputDirectory = "" 'reset (error)
SEM_Import_GetOutputDirectory = False 'error
Exit Function
End Function
Private Sub SEM_Import_FileExSaveEx(ByVal OutputDirectory As String)
'on error resume next 'asks the user if FileEx is to be copied to a special directory; OutputDirectory is current skin's directory
Dim ProgramPath As String
Dim SkinTransferFile As String
Dim FileExInputName As String
Dim FileExOutputName As String
Dim SkinTransferStructVar As SkinTransferStruct 'use 'own' var to avoid conflicts with currently displayed data
Dim Temp As Long
'preset
ProgramPath = App.Path
If Not (Right$(App.Path, 1) = "\") Then ProgramPath = ProgramPath + "\"
SkinTransferFile = OutputDirectory + "SkinTransferFile.dat"
If (DirSave(SkinTransferFile) = "") Or (Right$(SkinTransferFile, 1) = "\") Or (Len(SkinTransferFile) = 0) Then GoTo Jump:
If SkinTransferFile_Read(SkinTransferFile, SkinTransferStructVar) = False Then GoTo Jump:
If Len(SkinTransferStructVar.FileEx) = 0 Then GoTo Jump:
If SkinTransferStructVar.FileExSaveExFlag = False Then GoTo Jump:
'begin
If MsgBox("The creator of the skin included the additional file '" + GetFileName(SkinTransferStructVar.FileEx) + "' and the comment of the author is:" + Chr$(10) + Chr$(10) + _
FixMaxLineLength(ReLineBreak(SkinTransferStructVar.Comment), 512) + Chr$(10) + Chr$(10) + "Do you want to create a copy of this file in a special directory ?", vbYesNo + vbQuestion) = vbYes Then
Call SE_RefreshForms 'remove MsgBox‑trash (important, tested)
ReDo:
FileExInputName = OutputDirectory + GetFileName(SkinTransferStructVar.FileEx) 'FileEx is the full path of the ORIGINAL file
FileExOutputName = GFCDSetFileName("Copy included file to...", 0, NULLARRAYSTRING(), NULLARRAYSTRING(), 0, ProgramPath + GetFileName(SkinTransferStructVar.FileEx))
If Not (FileExOutputName = "") Then
If Not (DirSave(FileExOutputName) = "") Then
If MsgBox("File already exists. Overwrite ?", vbYesNo + vbQuestion) = vbNo Then _
GoTo ReDo:
End If
Call SE_RefreshForms 'remove MsgBox‑trash (important, tested)
If CopyFile(FileExInputName, FileExOutputName, 0) = 0 Then
If MsgBox("Copying file failed, check disk space or network connection !", vbRetryCancel + vbExclamation) = vbRetry Then
GoTo ReDo:
Else
MsgBox "You can view the Info of the imported skin and press 'Save As...' to retry copying the included file.", vbOKOnly + vbInformation
End If
End If
End If
Else
MsgBox "Note: you can manually copy the file from the current skin's directory" + Chr$(10) + "('" + OutputDirectory + "')" + Chr$(10) + "at any time if you like to.", vbOKOnly + vbInformation
End If
Jump:
End Sub
Private Function SEM_Import_InstallFonts(ByVal SEFontFile As String) As Boolean
On Error Resume Next 'important (if a file cannot be deleted); returns True if successfull, False if not
Dim FontNameNumber As Integer
Dim FontNameArray() As String
Dim FontFileArray() As String
Dim FileLoop As Integer
'
'NOTE: this sub is called when all files of the SkinPacketFile have been unpacked.
'between the unpacked files there should be 'Font.dat' and related TTF files.
'The TTF files are to be copied to the user's Windows‑Fonts directory and
'must be registered, 'Font.dat' can be deleted as it is not needed anymore.
'
'preset
If (DirSave(SEFontFile) = "") Then 'verify
MsgBox "internal error in SEM_Import_InstallFonts: SEFontFile '" + SEFontFile + "' not found, skin specific fonts may not be available !", vbOKOnly + vbExclamation
SEM_Import_InstallFonts = False 'error
Exit Function 'error
End If
'begin
If SEFontFile_Read(SEFontFile, FontNameNumber, FontNameArray(), FontFileArray()) = False Then 'verify
MsgBox "internal error in SEM_Import_InstallFonts: SEFontFile '" + SEFontFile + "' could not be read !", vbOKOnly + vbExclamation
SEM_Import_InstallFonts = False 'error
Exit Function
End If
For FileLoop = 1 To FontNameNumber
'
'NOTE: the directory included in the font file names is the font directory
'of the exporting machine. This directory name must be exchanged with
'the current skin's directory (target directory of the skin to import).
'
'NOTE: GFFont_InstallFont() will copy the font files to the current machine's
'font directory. The original font files in the current skin's directory
'are deleted to avoid that they become data trash if the skin is exported
'another time as then the font files would be encrypted but not decrypted
'anymore.
'
FontFileArray(FileLoop) = GetDirectoryName(SEFontFile) + GetFileName(FontFileArray(FileLoop))
If GFFont_IsFontInstalled(FontNameArray(FileLoop)) = False Then
If GFFont_InstallFont(FontNameArray(FileLoop), FontFileArray(FileLoop)) = True Then
If Not ((DirSave(FontFileArray(FileLoop)) = "") Or (Right$(FontFileArray(FileLoop), 1) = "\") Or (FontFileArray(FileLoop) = "")) Then 'verify
Kill FontFileArray(FileLoop)
End If
Else
MsgBox "internal error in SEM_Import_InstallFonts: installing font '" + FontNameArray(FileLoop) + "' failed, font will not be available for current skin !", vbOKOnly + vbExclamation
'continue although error
End If
Else
If Not ((DirSave(FontFileArray(FileLoop)) = "") Or (Right$(FontFileArray(FileLoop), 1) = "\") Or (FontFileArray(FileLoop) = "")) Then 'verify
Kill FontFileArray(FileLoop)
End If
End If
Next FileLoop
SEM_Import_InstallFonts = True 'ok
Exit Function
End Function
'***END OF SKIN (SE POP UP MENU)***
'***REGION***
Public Sub SEM_PolyRgn_Enable(ByVal PolyRgnFormName As String, ByRef PolyRgnFormObject As Object)
'On Error Resume Next
Dim SEControlStructIndex As Integer
Dim StructLoop As Integer
'preset
SEControlStructIndex = 0
'search for poly rgn that belongs to passed form object
'
SEControlStructIndex = GetSEControlStructIndexFromControlObject(PolyRgnFormObject, SECONTROLTYPE_SEPOLYRGN, SESystemStructVar.SystemPaletteNumberCurrent)
'
'begin
If Not (SEControlStructIndex = 0) Then
If SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnEnabledFlag = False Then
Call SE_RefreshForms 'remove pop up window‑trash
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"enabled", BOOLTOSTRING(True), _
False, False) 'save changes
SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnEnabledFlag = True
Call SE_LoadControl(SEControlStructArray(SEControlStructIndex).SEControlName, True)
Call SE_RefreshControl(SEControlStructArray(SEControlStructIndex).SEControlName, 0)
End If
End If
End Sub
Public Sub SEM_PolyRgn_Disable(ByVal PolyRgnFormName As String, ByRef PolyRgnFormObject As Object)
'On Error Resume Next 'pass size information in format pixels
Dim SEControlStructIndex As Integer
Dim StructLoop As Integer
'begin
SEControlStructIndex = 0
'search for poly rgn that belongs to passed form object
'
SEControlStructIndex = GetSEControlStructIndexFromControlObject(PolyRgnFormObject, SECONTROLTYPE_SEPOLYRGN, SESystemStructVar.SystemPaletteNumberCurrent)
'
'begin
If Not (SEControlStructIndex = 0) Then
If SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnEnabledFlag = True Then
Call SE_RefreshForms 'remove pop up window‑trash
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"enabled", BOOLTOSTRING(False), _
False, False) 'save changes
Call SE_UnloadControl(SEControlStructArray(SEControlStructIndex).SEControlName)
SEControlStructArray(SEControlStructIndex).SEControl_PolyRgnEnabledFlag = False 'reset
Call SE_LoadControl(SEControlStructArray(SEControlStructIndex).SEControlName, True) 'important for message filtering
Call SE_RefreshControl(SEControlStructArray(SEControlStructIndex).SEControlName, 0)
End If
End If
End Sub
Private Sub SEM_PolyRgn_Abort()
'on error resume next 'call to close poly rgn desk window
Call GFSkinEngine_PolyRgnDeskfrm.PolyRgnDesk_Abort
End Sub
Private Sub SEM_PolyRgn_Change(ByVal PolyRgnFormName As String, ByRef PolyRgnFormObject As Object)
'On Error Resume Next
Dim PolyRgnStructIndex As Integer 'index in SEControlStructArray()
Dim PolyRgnFormStructIndex As Integer
Dim PolyRgnFormLeftUnchanged As Single
Dim DeskWidth As Long 'width of drawing window
Dim DeskHeight As Long 'height of drawing window
Dim BackPictureUnchangedName As String 'name of current form back picture
Dim PointNumber As Integer 'result
Dim PointXArray() As Long
Dim PointYArray() As Long
Dim SkinDataFileString As String
Dim ScreenMousePointerUnchanged As Integer
Dim TransferLoop As Integer
Dim StructLoop As Integer
Dim Temp As Long
'
'NOTE: remember: there can be several poly rgns.
'Every poly rgn has a name, and the related control is the form
'whose WindowRgn is to be manipulated.
'
'preset
'
PolyRgnStructIndex = GetSEControlStructIndexFromControlObject(PolyRgnFormObject, SECONTROLTYPE_SEPOLYRGN, SESystemStructVar.SystemPaletteNumberCurrent)
PolyRgnFormStructIndex = GetSEControlStructIndexFromControlObject(PolyRgnFormObject, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
'
If Not ((PolyRgnStructIndex = 0) Or (PolyRgnFormStructIndex = 0)) Then 'verify
If Not (SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointNumber = 0) Then 'verify
'transfer points to allow displaying current poly rgn
PointNumber = SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointNumber
ReDim Preserve PointXArray(1 To PointNumber) As Long
ReDim Preserve PointYArray(1 To PointNumber) As Long
For TransferLoop = 1 To PointNumber
PointXArray(TransferLoop) = SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointXArray(TransferLoop)
PointYArray(TransferLoop) = SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointYArray(TransferLoop)
Next TransferLoop
End If
End If
'
'begin
If Not ((PolyRgnStructIndex = 0) Or (PolyRgnFormStructIndex = 0)) Then 'verify
'
DeskWidth = (SEControlStructArray(PolyRgnStructIndex).SEControl.Width / Screen.TwipsPerPixelX) + 35
DeskHeight = (SEControlStructArray(PolyRgnStructIndex).SEControl.Height / Screen.TwipsPerPixelY) + 35
BackPictureUnchangedName = SEControlStructArray(PolyRgnFormStructIndex).SEControl_BackPicture
'
PolyRgnFormLeftUnchanged = PolyRgnFormObject.Left 'we must move on‑top‑windows out of the visible area (as we cannot determine which windows are on top so also non‑on‑top‑windows)
Call GFSkinEngine_PolyRgnDeskfrm.PolyRgnDesk_Initialize( _
DeskWidth, DeskHeight, (GetXGrid + GetYGrid) / 2&, RGB(0, 0, 0), RGB(100, 255, 50), RGB(255, 100, 50), SESystemStructVar.SystemForeColor, RGB(255, 255, 255), _
PolyRgnFormName, PolyRgnFormObject)
Call SEM_PolyRgn_BackPicture_Transfer(PolyRgnFormName, PolyRgnFormObject)
PolyRgnFormObject.Left = Screen.Width
'
If GFSkinEngine_PolyRgnDeskfrm.PolyRgnDesk_Draw(PointNumber, PointXArray(), PointYArray(), _
SEControlStructArray(PolyRgnStructIndex).SEControl.Width / Screen.TwipsPerPixelX, _
SEControlStructArray(PolyRgnStructIndex).SEControl.Height / Screen.TwipsPerPixelY, _
PolyRgnFormName, PolyRgnFormObject) = True Then
PolyRgnFormObject.Left = PolyRgnFormLeftUnchanged 'reset
Call SE_RefreshForms 'remove window‑trash
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'save changes
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
Temp = 0 'reset
Do While SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(PolyRgnStructIndex).SEControlName, "x", "", True, False) = True 'delete 'x=' line
Temp = Temp + 1
If Temp > 32767& Then Exit Do 'avoid endless loop
Loop
Temp = 0 'reset
Do While SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(PolyRgnStructIndex).SEControlName, "y", "", True, False) = True 'delete 'y=' line
Temp = Temp + 1
If Temp > 32767& Then Exit Do 'avoid endless loop
Loop
For StructLoop = PointNumber To 1 Step (‑1)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(PolyRgnStructIndex).SEControlName, "y", LTrim$(Str$(PointYArray(StructLoop))), False, True)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(PolyRgnStructIndex).SEControlName, "x", LTrim$(Str$(PointXArray(StructLoop))), False, True)
Next StructLoop
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
'transfer changes to SEControlStructArray() to avoid reloading SkinDataFile
Call SE_UnloadControl(SEControlStructArray(PolyRgnStructIndex).SEControlName)
SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointNumber = PointNumber
ReDim SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointXArray(1 To PointNumber) As Long
ReDim SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointYArray(1 To PointNumber) As Long
For StructLoop = PointNumber To 1 Step (‑1)
SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointXArray(StructLoop) = PointXArray(StructLoop)
SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnPointYArray(StructLoop) = PointYArray(StructLoop)
Next StructLoop
'display changes
'
'NOTE: the user can only change a poly rgn if it is currently enabled. No! (see below)
'SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnEnabledFlag = True
'
'NOTE: do NOT enable the poly rgn here, this cannot be done just by setting
'the flag, we would have to call SEM_PolyRgn_Enable() to write the SDFString, etc.
'If just setting the flag then SEM_PolyRgn_Enable() does nothing because it thinks
'the poly rgn would have been already enabled.
'Also the name of this sub ([...]_Change()) does not 'tell' that the poly rgn would be
'enabled, the calling procedure must en/disable the poly rgn.
'
Call SE_LoadControl(SEControlStructArray(PolyRgnStructIndex).SEControlName, True)
Call SE_RefreshControl(SEControlStructArray(PolyRgnStructIndex).SEControlName, 0)
Screen.MousePointer = ScreenMousePointerUnchanged 'reset
Else
PolyRgnFormObject.Left = PolyRgnFormLeftUnchanged 'reset
If Not (SEControlStructArray(PolyRgnFormStructIndex).SEControl_BackPicture = BackPictureUnchangedName) Then
'restore original back picture
Call SEM_BackPicture_ChangeSub(PolyRgnFormName, PolyRgnFormObject, SECONTROLTYPE_FORM, BackPictureUnchangedName)
End If
End If
Else
MsgBox "There is no poly rgn that could be changed.", vbOKOnly + vbInformation
End If
End Sub
Public Sub SEM_PolyRgn_BackPicture_Transfer(ByVal PolyRgnFormName As String, ByRef PolyRgnFormObject As Object)
On Error Resume Next 'important (if a file cannot be deleted); displays the 'display picture' of the form whose poly rgn is changed in the poly rgn desk
Dim ScreenActiveFormUnchanged As Form
Dim VisibleScreenAreaLeft As Long
Dim VisibleScreenAreaTop As Long
Dim VisibleScreenAreaWidth As Long
Dim VisibleScreenAreaHeight As Long
Dim VisibleScreenAreaRight As Long
Dim VisibleScreenAreaBottom As Long
Dim DeskPictureName As String
Dim FormEnabledUnchanged As Boolean
Dim FormVisibleUnchanged As Boolean
Dim FormWindowStateUnchanged As Integer
Dim PolyRgnStructIndex As Integer
Dim PolyRgnEnabledFlagUnchanged As Boolean
'
'NOTE: this sub will transfer the image of the form whose poly rgn is to be changed
'first to the system temp picture, and then to a temporary file.
'Note that not only the back picture is saved, but the appearance of the
'window, just like the user can see it at the moment.
'
'begin
PolyRgnStructIndex = GetSEControlStructIndexFromControlObject(PolyRgnFormObject, SECONTROLTYPE_SEPOLYRGN, SESystemStructVar.SystemPaletteNumberCurrent)
If Not (PolyRgnStructIndex = 0) Then 'verify
'prepare back picture file to create
DeskPictureName = GenerateTempFileName(WinTempDir)
Call SE_FileFromPictureBox(SESystemStructVar.SystemTempPicture) 'reset
SESystemStructVar.SystemTempPicture.AutoRedraw = True 'important
SESystemStructVar.SystemTempPicture.Width = SEControlStructArray(PolyRgnStructIndex).SEControl.Width + (4 * Screen.TwipsPerPixelX) '4 pixels for picture box frame
SESystemStructVar.SystemTempPicture.Height = SEControlStructArray(PolyRgnStructIndex).SEControl.Height + (4 * Screen.TwipsPerPixelY) '4 pixels for picture box frame
'verify the form related to the poly rgn to edit is visible
Set ScreenActiveFormUnchanged = Screen.ActiveForm
FormEnabledUnchanged = PolyRgnFormObject.Enabled
FormVisibleUnchanged = PolyRgnFormObject.Visible
FormWindowStateUnchanged = PolyRgnFormObject.WindowState
PolyRgnFormObject.Enabled = True
PolyRgnFormObject.Visible = True
PolyRgnFormObject.WindowState = vbNormal
PolyRgnFormObject.SetFocus
'Call GFSetWindowOnTop(PolyRgnFormObject)
'use GFTaskBarInfo code
Call GFTaskBarInfo_GetWindowPosSize(VisibleScreenAreaLeft, VisibleScreenAreaTop, VisibleScreenAreaWidth, VisibleScreenAreaHeight)
'calculate bottom and right
VisibleScreenAreaRight = VisibleScreenAreaLeft + VisibleScreenAreaWidth 'xpos + xsize
VisibleScreenAreaBottom = VisibleScreenAreaTop + VisibleScreenAreaHeight 'ypos + ysize
'move form whose poly rgn is to be changed so that it is completely visible
If (PolyRgnFormObject.Left + PolyRgnFormObject.Width) > VisibleScreenAreaWidth Then
PolyRgnFormObject.Left = VisibleScreenAreaWidth ‑ PolyRgnFormObject.Width
End If
If PolyRgnFormObject.Left < VisibleScreenAreaLeft Then PolyRgnFormObject.Left = VisibleScreenAreaLeft
If (PolyRgnFormObject.Top + PolyRgnFormObject.Height) > VisibleScreenAreaHeight Then
PolyRgnFormObject.Top = VisibleScreenAreaHeight ‑ PolyRgnFormObject.Height
End If
If PolyRgnFormObject.Top < VisibleScreenAreaTop Then PolyRgnFormObject.Top = VisibleScreenAreaTop
'
'NOTE: if the form does not fit in the visible area of the desktop then it will not completely visible on the poly rgn desk.
'
'temporarily disable poly rgn to get a complete picture of the form
PolyRgnEnabledFlagUnchanged = SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnEnabledFlag
If SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnEnabledFlag = True Then
SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnEnabledFlag = False
Call SE_RefreshControl(SEControlStructArray(PolyRgnStructIndex).SEControlName, 0, PolyRgnStructIndex)
End If
'transfer the form image to a picture box
Call SE_RefreshForms 'important
Call BitBlt(SESystemStructVar.SystemTempPicture.hDC, 0, 0, _
SESystemStructVar.SystemTempPicture.Width / Screen.TwipsPerPixelX, _
SESystemStructVar.SystemTempPicture.Height / Screen.TwipsPerPixelY, _
GetWindowDC(SEControlStructArray(PolyRgnStructIndex).SEControl.hwnd), _
0, 0, vbSrcCopy)
'enable poly rgn if it was temporarily disabled
If PolyRgnEnabledFlagUnchanged = True Then
'enable poly rgn again if it was enabled before
SEControlStructArray(PolyRgnStructIndex).SEControl_PolyRgnEnabledFlag = True
Call SE_LoadControl(SEControlStructArray(PolyRgnStructIndex).SEControlName, True, PolyRgnStructIndex)
Call SE_RefreshControl(SEControlStructArray(PolyRgnStructIndex).SEControlName, 0, PolyRgnStructIndex)
End If
'hide the form related to the poly rgn to edit is necessary
PolyRgnFormObject.WindowState = FormWindowStateUnchanged
PolyRgnFormObject.Enabled = FormEnabledUnchanged
PolyRgnFormObject.Visible = FormVisibleUnchanged
If (ScreenActiveFormUnchanged.Enabled = True) And (ScreenActiveFormUnchanged.Visible = True) And (Not (ScreenActiveFormUnchanged.WindowState = vbMinimized)) Then 'verify
ScreenActiveFormUnchanged.SetFocus
ScreenActiveFormUnchanged.Refresh
End If
'transfer the picture box image to the form back picture file
SESystemStructVar.SystemTempPicture.Refresh 'important
Call SE_PictureBoxToFile(SESystemStructVar.SystemTempPicture, DeskPictureName)
Call GFSkinEngine_PolyRgnDeskfrm.Desk_SetBackPicture(DeskPictureName)
If Not ((DirSave(DeskPictureName) = "") Or (Right$(DeskPictureName, 1) = "\") Or (DeskPictureName = "")) Then Kill DeskPictureName 'make sure temp file is deleted
End If
End Sub
Private Sub SEM_PolyRgn_BackPicture_Select(ByVal PolyRgnFormName As String, ByRef PolyRgnFormObject As Object)
'on error resume next
Call SEM_BackPicture_Import(PolyRgnFormName, PolyRgnFormObject)
Call SEM_PolyRgn_BackPicture_Transfer(PolyRgnFormName, PolyRgnFormObject)
End Sub
Public Sub SEM_SEPE(ByVal ControlName As String)
'on error resume next 'call to open the Property Edit window
'verify
'
'NOTE: under special circumstances it may happen that this sub is called
'recursively, what leaded to an VB error (a form must not be shown in modal
'state if already opened).
'The error described above was created by MP3 Renamer 2, when
'LWCfrm is opened and in UserMove mode the user right‑clicks on any
'label while pressing 'Ctrl'.
'
If GFSkinEngine_PropertyEditfrm.Visible = True Then Exit Sub 'verify
'begin
Call SE_RefreshForms 'remove window‑trash (of pop‑up menu)
Call SE_ForwardCallBackMessage(SECBMSG_PROPERTYEDITFRM_OPENED, "", "")
SESystemStructVar.SystemNoSkinDataFileWriteFlag = True 'don't overwrite 'new' SDF
Call GFSkinEngine_PropertyEditfrm.SEPE_ControlNameList_LoadProperties(ControlName)
Call GFSkinEngine_PropertyEditfrm.Show(vbModal, Nothing)
Call GFSkinEnginefrm.SE_FilterMessage_Reset
Call SE_ForwardCallBackMessage(SECBMSG_PROPERTYEDITFRM_CLOSED, "", "")
If GFSkinEngine_PropertyEditfrm.DisplayPaletteFlag = True Then
GFSkinEngine_PropertyEditfrm.DisplayPaletteFlag = False 'reset
'
'NOTE: the PropertyEdit form cannot reload the palette as it is
'opened in vbModal state and thus all se commands would be displayed
'as disabled when reloading.
'
Call SE_RefreshForms 'remove window‑trash
SESystemStructVar.SystemNoSkinDataFileWriteFlag = False 'reset
SkinDataFileCacheStructVar.SkinDataFile = "" 'important, force reading file from disk
SkinDataFileCacheStructVar.SkinDataFileString = "" 'important, for debugging (if the total error happens then it's this line here)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
Else
SESystemStructVar.SystemNoSkinDataFileWriteFlag = False 'reset
End If
Exit Sub
End Sub
'**********************************END OF SE FORM MENU**********************************
'************************************SE CONTROL MENU************************************
'NOTE: SECM stands for SkinEngine ControlMenu.
'The following code allows the user to apply special properties to a control
'(special properties mean properties that differ from the 'system_' default proeprties).
'
Private Sub SECM_SpecialForeColor(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim ForeColor As Long
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
'begin
ForeColor = GFCDGetColor(SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_ForeColor, 0, NULLARRAYLONG())
If ForeColor = True Then Exit Sub 'user canceled
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_ForeColor = ForeColor
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SE_ControlMenuStructVar.SEControlName, _
"forecolor", COLORTOSTRING(ForeColor), False, False)
Call SEM_Mark_Remove 'avoid restoring false fore color
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, 0, SE_ControlMenuStructVar.SEControlStructIndex) 'dsiplay changes
Call SE_ForwardCallBackMessage(SECBMSG_PICTUREBOX_REDRAW, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlName, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlName)
Exit Sub
End Sub
Private Sub SECM_SpecialBackColor(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim BackColor As Long
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
Dim ForeColor As Long
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
'begin
BackColor = GFCDGetColor(SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_BackColor, 0, NULLARRAYLONG())
If BackColor = True Then Exit Sub 'user canceled
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_BackColor = BackColor
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SE_ControlMenuStructVar.SEControlName, _
"backcolor", COLORTOSTRING(BackColor), False, False)
Call SEM_Mark_Remove 'avoid restoring false back color
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, 0, SE_ControlMenuStructVar.SEControlStructIndex) 'dsiplay changes
Call SE_ForwardCallBackMessage(SECBMSG_PICTUREBOX_REDRAW, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlName, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlName)
Exit Sub
End Sub
Private Sub SECM_SpecialFont(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim FontName As String
Dim FontSize As Single
Dim FontBoldFlag As Boolean
Dim FontItalicFlag As Boolean
Dim FontUnderlineFlag As Boolean
Dim FontStrikeThroughFlag As Boolean
Dim SkinDataFileString As String
Dim ControlName As String
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
'preset
FontName = SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Name
FontSize = SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Size
FontBoldFlag = SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Bold
FontItalicFlag = SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Italic
FontUnderlineFlag = SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Underline
FontStrikeThroughFlag = SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.StrikeThrough
'begin
If GFSelectFontfrm.GFSelectFont_SelectFont(FontName, FontSize, FontBoldFlag, FontItalicFlag, FontUnderlineFlag, FontStrikeThroughFlag) = True Then
Call SE_RefreshForms 'remove window‑trash
'user selected a font (did not cancel)
ControlName = SE_ControlMenuStructVar.SEControlName
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontname", FontName, False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontsize", LTrim$(Str$(FontSize)), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontbold", BOOLTOSTRING(FontBoldFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontitalic", BOOLTOSTRING(FontItalicFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontunderline", BOOLTOSTRING(FontUnderlineFlag), False, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontstrikethrough", BOOLTOSTRING(FontStrikeThroughFlag), False, False)
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
'display changes
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Name = FontName
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Size = FontSize
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Bold = FontBoldFlag
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Italic = FontItalicFlag
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Underline = FontUnderlineFlag
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.StrikeThrough = FontStrikeThroughFlag
Select Case SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND
'NOTE: an SECommand must be recreated to display the new font.
Call SE_UnloadControl(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlStructIndex)
Call SE_LoadControl(SE_ControlMenuStructVar.SEControlName, True, SE_ControlMenuStructVar.SEControlStructIndex)
End Select
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, 0, SE_ControlMenuStructVar.SEControlStructIndex) 'display changes
Call SE_RefreshControlPos(SE_ControlMenuStructVar.SEControlStructIndex) 'refresh pos because always refreshed together with size
Call SE_RefreshControlSize(SE_ControlMenuStructVar.SEControlStructIndex) 'refresh size to avoid that a list box shrinks
Call SE_ForwardCallBackMessage(SECBMSG_PICTUREBOX_REDRAW, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlName, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlName)
End If
End Sub
Private Sub SECM_DisableSpecialProperties(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim SkinDataFileString As String
Dim ControlName As String
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
'begin
If MsgBox("Are you sure you want to reset the current control's fore‑ and back color and font to the system default ?", vbYesNo + vbQuestion) = vbYes Then
ControlName = SE_ControlMenuStructVar.SEControlName
'
'NOTE: if doing changes here then also update SEM_New_DisableSpecialProperties.
'
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "forecolor", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "backcolor", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontname", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontsize", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontbold", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontitalic", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontunderline", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, ControlName, "fontstrikethrough", "", True, False)
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
'display changes
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_ForeColor = SESystemStructVar.SystemForeColor
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_BackColor = SESystemStructVar.SystemBackColor
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Name = SESystemStructVar.SystemFont.Name
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Size = SESystemStructVar.SystemFont.Size
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Bold = SESystemStructVar.SystemFont.Bold
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Italic = SESystemStructVar.SystemFont.Italic
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.Underline = SESystemStructVar.SystemFont.Underline
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Font.StrikeThrough = SESystemStructVar.SystemFont.StrikeThrough
Call SEM_Mark_Remove 'important as back color is changed
Select Case SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND
'NOTE: an SECommand must be recreated to display the restored default font.
Call SE_UnloadControl(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlStructIndex)
Call SE_LoadControl(SE_ControlMenuStructVar.SEControlName, True, SE_ControlMenuStructVar.SEControlStructIndex)
End Select
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, 0, SE_ControlMenuStructVar.SEControlStructIndex) 'display changes
Call SE_RefreshControlPos(SE_ControlMenuStructVar.SEControlStructIndex) 'refresh pos because always refreshed together with size
Call SE_RefreshControlSize(SE_ControlMenuStructVar.SEControlStructIndex) 'refresh size to avoid that a list box shrinks when its font is changed
Call SE_ForwardCallBackMessage(SECBMSG_PICTUREBOX_REDRAW, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlName, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlName)
End If
End Sub
Private Sub SECM_UpPicture(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim UpPictureName As String
Dim UpPictureNameNew As String 'for transfering to skin directory
Dim FilterDescriptionArray(1 To 2) As String
Dim FilterStringArray(1 To 2) As String
Dim SEControlStructIndex As Integer
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
'preset
FilterDescriptionArray(1) = "Picture Files"
FilterStringArray(1) = "*.bmp;*.jpg;*.gif"
FilterDescriptionArray(2) = "All Files"
FilterStringArray(2) = "*.*"
'begin
UpPictureName = GFCDGetFileName("Select control up picture", 2, FilterDescriptionArray(), FilterStringArray(), 1, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_UpPicture)
If UpPictureName = "" Then Exit Sub 'verify
If (DirSave(UpPictureName) = "") Or (Right$(UpPictureName, 1) = "\") Then 'verify
MsgBox "Error: file '" + UpPictureName + "' not found, changing control up picture failed !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
If IsPicture(UpPictureName) = False Then Exit Sub 'verify
'transfer picture to current skin directory
If (Not (UCase$(GetDirectoryName(UpPictureName)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("Do you want to copy the image file to the current skin's directory to allow transfering it to other machines ?", vbYesNoCancel + vbQuestion)
Case vbCancel
Exit Sub
Case vbYes
UpPictureNameNew = SESystemStructVar.SystemSkinDirectory + GetFileName(UpPictureName)
If CopyFile(UpPictureName, UpPictureNameNew, 0) = 0 Then
MsgBox "Copying picture failed, check disk space or network connection and try again !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call Skin_EncryptFile(UpPictureNameNew)
End If
Case vbNo
UpPictureNameNew = UpPictureName 'user does not want to transfer picture file
End Select
Else
UpPictureNameNew = UpPictureName 'picture is already in current skin directory
End If
'update system
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SE_ControlMenuStructVar.SEControlName, "uppicture", UpPictureNameNew, False, False)
Call SE_UnloadControl(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlStructIndex)
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_UpPicture = UpPictureNameNew
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_DisabledPicture = "" 'reset (system will recreate picture automatically)
Call SE_LoadControl(SE_ControlMenuStructVar.SEControlName, True, SE_ControlMenuStructVar.SEControlStructIndex)
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, SECONTROLSTATE_NORMAL, SE_ControlMenuStructVar.SEControlStructIndex)
'NOTE: we now fit the size of the se command to the size of the picture it displays.
Call SaveSEControlSize(SE_ControlMenuStructVar.SEControlStructIndex, _
GetSEControlXSize(SE_ControlMenuStructVar.SEControlStructIndex), GetSEControlYSize(SE_ControlMenuStructVar.SEControlStructIndex), 0, 0)
'
Exit Sub
End Sub
Private Sub SECM_DownPicture(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim DownPictureName As String
Dim DownPictureNameNew As String 'for transferring to skin directory
Dim FilterDescriptionArray(1 To 2) As String
Dim FilterStringArray(1 To 2) As String
Dim SEControlStructIndex As Integer
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
'preset
FilterDescriptionArray(1) = "Picture Files"
FilterStringArray(1) = "*.bmp;*.jpg;*.gif"
FilterDescriptionArray(2) = "All Files"
FilterStringArray(2) = "*.*"
'begin
DownPictureName = GFCDGetFileName("Select control down picture", 2, FilterDescriptionArray(), FilterStringArray(), 1, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_DownPicture)
If DownPictureName = "" Then Exit Sub 'verify
If (DirSave(DownPictureName) = "") Or (Right$(DownPictureName, 1) = "\") Then 'verify
MsgBox "Error: file '" + DownPictureName + "' not found, changing control down picture failed !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
If IsPicture(DownPictureName) = False Then Exit Sub 'verify
'transfer picture to current skin directory
If (Not (UCase$(GetDirectoryName(DownPictureName)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("Do you want to copy the image file to the current skin's directory to allow transfering it to other machines ?", vbYesNoCancel + vbQuestion)
Case vbCancel
Exit Sub
Case vbYes
DownPictureNameNew = SESystemStructVar.SystemSkinDirectory + GetFileName(DownPictureName)
If CopyFile(DownPictureName, DownPictureNameNew, 0) = 0 Then
MsgBox "Copying picture failed, check disk space or network connection and try again !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call Skin_EncryptFile(DownPictureNameNew)
End If
Case vbNo
DownPictureNameNew = DownPictureName 'user does not want to transfer picture file
End Select
Else
DownPictureNameNew = DownPictureName 'picture is already in current skin directory
End If
'update system
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SE_ControlMenuStructVar.SEControlName, "downpicture", DownPictureNameNew, False, False)
Call SE_UnloadControl(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlStructIndex)
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_DownPicture = DownPictureNameNew
Call SE_LoadControl(SE_ControlMenuStructVar.SEControlName, True, SE_ControlMenuStructVar.SEControlStructIndex)
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, SECONTROLSTATE_NORMAL, SE_ControlMenuStructVar.SEControlStructIndex)
'NOTE: we now fit the size of the se command to the size of the picture it displays.
Call SaveSEControlSize(SE_ControlMenuStructVar.SEControlStructIndex, _
GetSEControlXSize(SE_ControlMenuStructVar.SEControlStructIndex), GetSEControlYSize(SE_ControlMenuStructVar.SEControlStructIndex), 0, 0)
Exit Sub
End Sub
Private Sub SECM_MoveOverPicture(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim MoveOverPictureName As String
Dim MoveOverPictureNameNew As String 'for transfering to skin directory
Dim FilterDescriptionArray(1 To 2) As String
Dim FilterStringArray(1 To 2) As String
Dim SEControlStructIndex As Integer
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
'preset
FilterDescriptionArray(1) = "Picture Files"
FilterStringArray(1) = "*.bmp;*.jpg;*.gif"
FilterDescriptionArray(2) = "All Files"
FilterStringArray(2) = "*.*"
'begin
MoveOverPictureName = GFCDGetFileName("Select control move over picture", 2, FilterDescriptionArray(), FilterStringArray(), 1, SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_MoveOverPicture)
If MoveOverPictureName = "" Then Exit Sub 'verify
If (DirSave(MoveOverPictureName) = "") Or (Right$(MoveOverPictureName, 1) = "\") Then 'verify
MsgBox "Error: file '" + MoveOverPictureName + "' not found, changing control move over picture failed !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
If IsPicture(MoveOverPictureName) = False Then Exit Sub 'verify
'transfer picture to current skin directory
If (Not (UCase$(GetDirectoryName(MoveOverPictureName)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("Do you want to copy the image file to the current skin's directory to allow transfering it to other machines ?", vbYesNoCancel + vbQuestion)
Case vbCancel
Exit Sub
Case vbYes
MoveOverPictureNameNew = SESystemStructVar.SystemSkinDirectory + GetFileName(MoveOverPictureName)
If CopyFile(MoveOverPictureName, MoveOverPictureNameNew, 0) = 0 Then
MsgBox "Copying picture failed, check disk space or network connection and try again !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call Skin_EncryptFile(MoveOverPictureNameNew)
End If
Case vbNo
MoveOverPictureNameNew = MoveOverPictureName 'user does not want to transfer picture file
End Select
Else
MoveOverPictureNameNew = MoveOverPictureName 'picture is already in current skin directory
End If
'update system
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SE_ControlMenuStructVar.SEControlName, "moveoverpicture", MoveOverPictureNameNew, False, False)
Call SE_UnloadControl(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlStructIndex)
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_MoveOverPicture = MoveOverPictureNameNew
Call SE_LoadControl(SE_ControlMenuStructVar.SEControlName, True, SE_ControlMenuStructVar.SEControlStructIndex)
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, SECONTROLSTATE_NORMAL, SE_ControlMenuStructVar.SEControlStructIndex)
'NOTE: we now fit the size of the se command to the size of the picture it displays.
Call SaveSEControlSize(SE_ControlMenuStructVar.SEControlStructIndex, _
GetSEControlXSize(SE_ControlMenuStructVar.SEControlStructIndex), GetSEControlYSize(SE_ControlMenuStructVar.SEControlStructIndex), 0, 0)
Exit Sub
End Sub
Private Sub SECM_DisableSECommandPictures(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim SkinDataFileString As String
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub 'verify
'begin
If MsgBox("Are you sure you want to disable the current command's pictures to the default (Windows‑styled) ?", vbYesNo + vbQuestion) = vbYes Then
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SE_ControlMenuStructVar.SEControlName, "uppicture", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SE_ControlMenuStructVar.SEControlName, "downpicture", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SE_ControlMenuStructVar.SEControlName, "moveoverpicture", "", True, False)
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
Call SE_UnloadControl(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlStructIndex)
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_UpPicture = "" 'reset
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_DownPicture = "" 'reset
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_MoveOverPicture = "" 'reset
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_DisabledPicture = "" 'reset (system will recreate picture automatically)
'
'NOTE: when reloading the se command the system will realize that there are
'no picture files anymore and will thus create default pictures.
'
Call SE_LoadControl(SE_ControlMenuStructVar.SEControlName, True, SE_ControlMenuStructVar.SEControlStructIndex)
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, 0, SE_ControlMenuStructVar.SEControlStructIndex) 'display changes
End If
End Sub
Private Sub SECM_BackPicture(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim BackPictureNameOld As String
Dim BackPictureNameNew As String
Dim FilterDescriptionArray(1 To 2) As String
Dim FilterStringArray(1 To 2) As String
Dim SEControlStructIndex As Integer
'preset
FilterDescriptionArray(1) = "Picture Files"
FilterStringArray(1) = "*.bmp;*.jpg;*.gif"
FilterDescriptionArray(2) = "All Files"
FilterStringArray(2) = "*.*"
'preset
SEControlStructIndex = GetSEControlStructIndexFromControlObject(SE_ControlMenuStructVar.SEControlObject, SE_ControlMenuStructVar.SEControlType, SESystemStructVar.SystemPaletteNumberCurrent)
If SEControlStructIndex = 0 Then 'verify
MsgBox "internal error in SEM_BackPicture_Import(): passed value invalid !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
BackPictureNameOld = SEControlStructArray(SEControlStructIndex).SEControl_BackPicture
BackPictureNameOld = GFCDGetFileName("Select back picture...", 2, FilterDescriptionArray(), FilterStringArray(), 0, BackPictureNameOld)
If Not (BackPictureNameOld = "") Then 'verify user didn't abort
'transfer picture to current skin directory
If (Not (UCase$(GetDirectoryName(BackPictureNameOld)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
If MsgBox("Do you want to copy the image file to the current skin's directory to allow transfering it to other machines ?", vbYesNo + vbQuestion) = vbYes Then
BackPictureNameNew = SESystemStructVar.SystemSkinDirectory + GetFileName(BackPictureNameOld)
If CopyFile(BackPictureNameOld, BackPictureNameNew, 0) = 0 Then
MsgBox "Copying picture failed, check disk space or network connection and try again !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call Skin_EncryptFile(BackPictureNameNew)
End If
Else
BackPictureNameNew = BackPictureNameOld 'user does not want to transfer picture file
End If
Else
BackPictureNameNew = BackPictureNameOld 'picture is already in current skin directory
End If
Call SE_RefreshForms 'remove CommonDialog window‑trash
Call SEM_BackPicture_ChangeSub(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlObject, _
SE_ControlMenuStructVar.SEControlType, BackPictureNameNew)
'NOTE: setting a special back picture is possible for any picture box and any GFListView.
End If
End Sub
Private Sub SECM_BackPicture_Disable(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next 'disables the back picture of a picture box
Dim SEControlStructIndex As Integer
'preset
SEControlStructIndex = GetSEControlStructIndexFromControlObject(SE_ControlMenuStructVar.SEControlObject, SE_ControlMenuStructVar.SEControlType, SESystemStructVar.SystemPaletteNumberCurrent)
If SEControlStructIndex = 0 Then
MsgBox "internal error in SEMC_BackPicture_Disable() !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
Call SE_RefreshForms 'remove pop up menu window‑trash
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, _
SEControlStructArray(SEControlStructIndex).SEControlName, "backpicture", "", False, False)
Call SE_UnloadControl(SEControlStructArray(SEControlStructIndex).SEControlName)
SEControlStructArray(SEControlStructIndex).SEControl_BackPicture = "" 'reset
Call SE_LoadControl(SEControlStructArray(SEControlStructIndex).SEControlName, True)
Call SE_RefreshControl(SEControlStructArray(SEControlStructIndex).SEControlName, 0)
Call SE_ForwardCallBackMessage(SECBMSG_BACKPICTURE_DISABLED, "", SEControlStructArray(SEControlStructIndex).SEControlName)
Call SE_ForwardCallBackMessage(SECBMSG_PICTUREBOX_REDRAW, SEControlStructArray(SEControlStructIndex).SEControlName, SEControlStructArray(SEControlStructIndex).SEControlName)
End Sub
Private Function SECM_HasSpecialProperties(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'returns True if control has at least one special property set, False if not
'
'NOTE: this function must work fast as it is used to save time by
'saving SkinDataile_ChangeProperty() calls.
'
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
SECM_HasSpecialProperties = False 'error
Exit Function
End If
'begin
SECM_HasSpecialProperties = _
SECM_HasSpecialForeColor(SEControlStructIndex) Or _
SECM_HasSpecialBackColor(SEControlStructIndex) Or _
SECM_HasSpecialFont(SEControlStructIndex)
Exit Function
End Function
Private Function SECM_HasSpecialForeColor(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'returns True if control has a fore color that differs from the system fore color
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
SECM_HasSpecialForeColor = False 'error
Exit Function
End If
'begin
SECM_HasSpecialForeColor = _
Not (SEControlStructArray(SEControlStructIndex).SEControl_ForeColor = SESystemStructVar.SystemForeColor)
Exit Function
End Function
Private Function SECM_HasSpecialBackColor(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'returns True if control has a back color that differs from the system back color
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
SECM_HasSpecialBackColor = False 'error
Exit Function
End If
'begin
SECM_HasSpecialBackColor = _
Not (SEControlStructArray(SEControlStructIndex).SEControl_BackColor = SESystemStructVar.SystemBackColor)
Exit Function
End Function
Private Function SECM_HasSpecialFont(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'returns True if control has a font setting that differs from the system font
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
SECM_HasSpecialFont = False 'error
Exit Function
End If
'begin
SECM_HasSpecialFont = _
Not ( _
(SEControlStructArray(SEControlStructIndex).SEControl_Font.Name = SESystemStructVar.SystemFont.Name) And _
(SEControlStructArray(SEControlStructIndex).SEControl_Font.Size = SESystemStructVar.SystemFont.Size) And _
(SEControlStructArray(SEControlStructIndex).SEControl_Font.Bold = SESystemStructVar.SystemFont.Bold) And _
(SEControlStructArray(SEControlStructIndex).SEControl_Font.Italic = SESystemStructVar.SystemFont.Italic) And _
(SEControlStructArray(SEControlStructIndex).SEControl_Font.Underline = SESystemStructVar.SystemFont.Underline) And _
(SEControlStructArray(SEControlStructIndex).SEControl_Font.StrikeThrough = SESystemStructVar.SystemFont.StrikeThrough))
Exit Function
End Function
Private Function SECM_HasSECommandPictures(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'returns True if control has an up‑, moveover‑ and/or down picture, False if not
'
'NOTE: this function must work fast as it is used to save time by
'saving SkinDataile_ChangeProperty() calls.
'
'verify
If (SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber) Then
SECM_HasSECommandPictures = False 'error
Exit Function
End If
'begin
SECM_HasSECommandPictures = _
(Len(SEControlStructArray(SEControlStructIndex).SEControl_UpPicture)) Or _
(Len(SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPicture)) Or _
(Len(SEControlStructArray(SEControlStructIndex).SEControl_DownPicture))
Exit Function
End Function
Private Sub SECM_SetControlCaption(ByRef SE_ControlMenuStructVar As SE_ControlMenuStruct)
'on error resume next
Dim ControlCaptionCurrent As String
Dim ControlCaptionNew As String
'verify
If (SE_ControlMenuStructVar.SEControlStructIndex < 1) Or (SE_ControlMenuStructVar.SEControlStructIndex > SEControlStructNumber) Then Exit Sub
'begin
ControlCaptionCurrent = SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl.Caption 'do not use structure caption at first, as it may be "" also control caption was set a design time
If Len(ControlCaptionCurrent) = 0 Then ControlCaptionCurrent = SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Caption 'use structure caption is control caption is nothing (e.g. for an se command)
ControlCaptionNew = GFMsgBoxmod.GFInputBox("Enter new control caption:", "SE", ControlCaptionCurrent)
If ControlCaptionNew = "" Then
If MsgBox("Do you want to set the control caption to nothing (press 'No' when wanting to abort) ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub 'user canceled
End If
End If
Select Case SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControlType
Case SECONTROLTYPE_SECOMMAND
Call SE_UnloadControl(SE_ControlMenuStructVar.SEControlName, SE_ControlMenuStructVar.SEControlStructIndex)
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SE_ControlMenuStructVar.SEControlName, "caption", ControlCaptionNew, False, False)
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Caption = ControlCaptionNew
Call SE_LoadControl(SE_ControlMenuStructVar.SEControlName, True, SE_ControlMenuStructVar.SEControlStructIndex)
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, 0, SE_ControlMenuStructVar.SEControlStructIndex)
Case Else
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SE_ControlMenuStructVar.SEControlName, "caption", ControlCaptionNew, False, False)
SEControlStructArray(SE_ControlMenuStructVar.SEControlStructIndex).SEControl_Caption = ControlCaptionNew
Call SE_RefreshControl(SE_ControlMenuStructVar.SEControlName, 0, SE_ControlMenuStructVar.SEControlStructIndex)
End Select
Exit Sub
End Sub
Private Sub SECM_ShowControlSize(ByVal ControlName As String, ByRef ControlObject As Object)
'on error resume next
Dim SEControlStructIndex As Integer
'preset
SEControlStructIndex = GetSEControlStructIndex(ControlName)
If SEControlStructIndex = 0 Then Exit Sub 'verify
'begin
MsgBox "The control size is:" + Chr$(10) + "width: " + LTrim$(Str$(GetSEControlXSize(SEControlStructIndex))) + " pixels," _
+ Chr$(10) + "height: " + LTrim$(Str$(GetSEControlYSize(SEControlStructIndex))) + " pixels.", vbOKOnly + vbInformation
Exit Sub
End Sub
'********************************END OF SE CONTROL MENU*********************************
'********************************SKIN ENGINE DEBUG MENU*********************************
'NOTE: the Skin Engine Debug Menu is opened by pressing Ctrl‑Shift‑d
'(key presses are processed by GFSkinEnginefrm.GFKeyHookProc()).
'The SEDM provides functions that are to be used only by the developers of
'the Skin Engine or its target project.
Private Sub SEDM_Import()
'on error resume next
Dim ExportSkinDataFile As String
Dim SkinFileNumber As Integer
Dim SkinFileArray() As String
Dim SkinFileLoop As Integer
Dim ScreenMousePointerUnchanged As Integer
Dim Tempstr$
'
'NOTE: this sub copies all files used by the current skin into the current skin's directory.
'Furthermore all file references in the current skin's SkinDataFile are changed
'so that they do not contain directory names.
'
'IMPORTANT: all skins that are to be installed on the user's machine using
'the Installer must have been imported by this procedure.
'
'verify
If MsgBox("All files used by the current skin will be copied into the current skin's directory. " + _
"Furthermore all directory names will be removed from file references in the current skin's SkinDataFile. " + _
"Continue ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub 'user canceled
End If
'preset
ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbHourglass
'begin
If SEM_Export_CreateExportSkinDataFile(ExportSkinDataFile) = False Then GoTo Error:
If SEM_Export_GetSkinFileArray(SkinFileNumber, SkinFileArray()) = False Then GoTo Error:
For SkinFileLoop = 1 To SkinFileNumber
Tempstr$ = SESystemStructVar.SystemSkinDirectory + GetFileName(SkinFileArray(SkinFileLoop))
If Not (UCase$(SkinFileArray(SkinFileLoop)) = UCase$(Tempstr$)) Then
If SEDM_Import_CopyFile(SkinFileArray(SkinFileLoop), Tempstr$) = False Then GoTo Error:
End If
Next SkinFileLoop
If SEDM_Import_CopyFile(ExportSkinDataFile, SE_GetSkinDataFile) = True Then
Call SEDM_Import_DeleteFile(ExportSkinDataFile)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True) 'display changes
Else
Call SEDM_Import_DeleteFile(ExportSkinDataFile)
GoTo Error:
End If
Screen.MousePointer = ScreenMousePointerUnchanged 'reset
MsgBox "The current skin has been imported.", vbOKOnly + vbInformation
Exit Sub
Error:
Screen.MousePointer = ScreenMousePointerUnchanged 'reset
MsgBox "Error importing current skin !", vbOKOnly + vbExclamation
Exit Sub
End Sub
Private Function SEDM_Import_CopyFile(ByVal CopySourceName As String, ByVal CopyTargetName As String) As Boolean
'On Error Resume Next 'returns True if file has been copied, False if not
ReDo:
If CopyFile(CopySourceName, CopyTargetName, 0&) = 0& Then
Select Case MsgBox("Error copying file '" + CopySourceName + "' into '" + CopyTargetName + "' failed !", vbAbortRetryIgnore + vbExclamation)
Case vbAbort
SEDM_Import_CopyFile = False 'error
Exit Function
Case vbRetry
GoTo ReDo:
Case vbIgnore
SEDM_Import_CopyFile = True 'ok
Exit Function
End Select
Else
SEDM_Import_CopyFile = True 'ok
Exit Function
End If
Exit Function
End Function
Private Function SEDM_Import_DeleteFile(ByVal DeleteName As String) As Boolean
On Error GoTo Error: 'important; returns True if file has been deleted, False if not
Kill DeleteName
SEDM_Import_DeleteFile = True 'ok
Exit Function
Error:
SEDM_Import_DeleteFile = False 'error
Exit Function
End Function
Private Sub SEDM_ContextHelpFile_Decrypt()
'on error resume next
'verify
If Len(SESystemStructVar.ContextHelpFile) = 0 Then
MsgBox "Error: the target project did not pass ContextHelpFile to SE_Initialize() !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
If (Dir$(SESystemStructVar.ContextHelpFile) = "") Or (Right$(SESystemStructVar.ContextHelpFile, 1) = "\") Then
MsgBox "Error: ContextHelpFile (" + SESystemStructVar.ContextHelpFile + ") was passed to SE_Initialize(), but the file was not found !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
If SE_DecryptFile(SESystemStructVar.ContextHelpFile, SE_CONTEXTHELPFILE_PASSWORD) = True Then
MsgBox "The ContextHelpFile (" + SESystemStructVar.ContextHelpFile + ") is now unencrypted.", vbOKOnly + vbInformation
Else
MsgBox "Error decrypting ContextHelpFile (" + SESystemStructVar.ContextHelpFile + ") !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
Private Sub SEDM_ContextHelpFile_Encrypt()
'on error resume next
'verify
If Len(SESystemStructVar.ContextHelpFile) = 0 Then
MsgBox "Error: the target project did not pass ContextHelpFile to SE_Initialize() !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
If (Dir$(SESystemStructVar.ContextHelpFile) = "") Or (Right$(SESystemStructVar.ContextHelpFile, 1) = "\") Then
MsgBox "Error: ContextHelpFile (" + SESystemStructVar.ContextHelpFile + ") was passed to SE_Initialize(), but the file was not found !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
'begin
If SE_EncryptFile(SESystemStructVar.ContextHelpFile, SE_CONTEXTHELPFILE_PASSWORD, "") = True Then
MsgBox "The ContextHelpFile (" + SESystemStructVar.ContextHelpFile + ") is now encrypted.", vbOKOnly + vbInformation
Else
MsgBox "Error encrypting ContextHelpFile (" + SESystemStructVar.ContextHelpFile + ") !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
Private Sub SEDM_AnyFile_Decrypt()
'on error resume next
Dim DecryptionName As String
Dim DecryptionPassword As String
'verify
If SE_DebugMenuStructVar.DecryptionNameDefault = "" Then SE_DebugMenuStructVar.DecryptionNameDefault = SESystemStructVar.SystemSkinDirectory
'begin
DecryptionName = GFCDGetFileName("Select file to decrypt...", 0, NULLARRAYSTRING(), NULLARRAYSTRING(), 0, SE_DebugMenuStructVar.DecryptionNameDefault)
If Len(DecryptionName) = 0 Then Exit Sub 'user canceled
SE_DebugMenuStructVar.DecryptionNameDefault = DecryptionName
DecryptionPassword = InputBox("Enter password for decryption file:", "Decrypt any file", SE_DebugMenuStructVar.DecryptionPasswordDefault)
If Len(DecryptionPassword) = 0 Then Exit Sub 'user canceled
SE_DebugMenuStructVar.DecryptionPasswordDefault = DecryptionPassword
If SE_DecryptFile(DecryptionName, DecryptionPassword) = True Then
MsgBox "File has been decrypted.", vbOKOnly + vbInformation
Else
MsgBox "Error decryption file !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
Private Sub SEDM_AnyFile_Encrypt()
'on error resume next
Dim EncryptionName As String
Dim EncryptionPassword As String
'verify
If SE_DebugMenuStructVar.EncryptionNameDefault = "" Then SE_DebugMenuStructVar.EncryptionNameDefault = SESystemStructVar.SystemSkinDirectory
'begin
EncryptionName = GFCDGetFileName("Select file to encrypt...", 0, NULLARRAYSTRING(), NULLARRAYSTRING(), 0, SE_DebugMenuStructVar.EncryptionNameDefault)
If Len(EncryptionName) = 0 Then Exit Sub 'user canceled
SE_DebugMenuStructVar.EncryptionNameDefault = EncryptionName
EncryptionPassword = InputBox("Enter password for encryption file:", "encrypt any file", SE_DebugMenuStructVar.EncryptionPasswordDefault)
If Len(EncryptionPassword) = 0 Then Exit Sub 'user canceled
SE_DebugMenuStructVar.EncryptionPasswordDefault = EncryptionPassword
If SE_EncryptFile(EncryptionName, EncryptionPassword, "") = True Then
MsgBox "File has been encrypted.", vbOKOnly + vbInformation
Else
MsgBox "Error encryption file !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
'*****************************END OF SKIN ENGINE DEBUG MENU*****************************
'*************************************CONTEXT HELP**************************************
Public Sub SE_ContextHelp_Enable()
'on error resume next
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'begin
If ContextHelpStructVar.ContextHelpEnabledFlag = False Then
'check if target project allows enabling context help
Call SE_ForwardCallBackMessageEx(SECBMSG_CONTEXTHELP_ENABLED, "", "", ReturnValueUsedFlag, ReturnValue)
If ReturnValueUsedFlag = True Then
If ReturnValue = SECBMSG_REPLY_CANCEL Then Exit Sub
End If
'enable context help
ContextHelpStructVar.ContextHelpEnabledFlag = True
ContextHelpStructVar.ScreenMousePointerUnchanged = Screen.MousePointer
Screen.MousePointer = vbArrowQuestion
End If
Exit Sub
End Sub
Public Sub SE_ContextHelp_ReceiveControlName(ByVal ControlName As String)
'on error resume next 'call when the user wants to get help about a control
Call SE_ForwardCallBackMessage(SECBMSG_CONTEXTHELP_REQUESTED, ControlName, "‑1") 'propose that context help window position is mouse pointer position
End Sub
Public Sub SE_ContextHelp_Abort()
'on error resume next
Call SE_ContextHelp_Disable
End Sub
Public Sub SE_ContextHelp_Disable()
'on error resume next
If ContextHelpStructVar.ContextHelpEnabledFlag = True Then
ContextHelpStructVar.ContextHelpEnabledFlag = False 'reset
Screen.MousePointer = ContextHelpStructVar.ScreenMousePointerUnchanged 'reset
End If
End Sub
'**********************************END OF CONTEXT HELP**********************************
'*******************************GFSKINENGINEFRM INTERFACE*******************************
'NOTE: the following function should be called by the GFSkinEnginefrm only
'as a reaction to a WM_DROPFILES message.
Public Function SE_ControlNameToControlType(ByVal ControlName As String) As Integer
'On Error Resume Next 'returns 0 for error
Dim ControlNameLength As Long
Dim StructLoop As Integer
'preset
ControlNameLength = Len(ControlName)
'begin
For StructLoop = 1 To SEControlStructNumber
If SEControlStructArray(StructLoop).SEControlNameLength = ControlNameLength Then
If SEControlStructArray(StructLoop).SEControlName = ControlName Then
SE_ControlNameToControlType = SEControlStructArray(StructLoop).SEControlType
Exit Function
End If
End If
Next StructLoop
SE_ControlNameToControlType = 0 'reset (error)
Exit Function
End Function
Public Sub SE_SetLastProcessedMessage(ByVal SEControlName As String, ByVal LastProcessedMessage As Long)
'On Error Resume Next
Dim SEControlStructIndex As Integer
'begin
SEControlStructIndex = GetSEControlStructIndex(SEControlName)
If Not (SEControlStructIndex = 0) Then 'verify
SEControlStructArray(SEControlStructIndex).SEControl_LastProcessedMessage = LastProcessedMessage
End If
End Sub
Public Function SE_GetLastProcessedMessage(ByVal SEControlName As String) As Long
'On Error Resume Next
Dim SEControlStructIndex As Integer
'preset
SE_GetLastProcessedMessage = 0 'preset (error)
'begin
SEControlStructIndex = GetSEControlStructIndex(SEControlName)
If Not (SEControlStructIndex = 0) Then 'verify
SE_GetLastProcessedMessage = SEControlStructArray(SEControlStructIndex).SEControl_LastProcessedMessage
End If
End Function
'***REACTION TO WM_DROPDOWN MESSAGE***
Public Sub SE_ReceiveSkinPacketFile(ByVal FormName As String, ByRef FormObject As Object, ByVal DropName As String)
'on error resume next
'
'NOTE: this sub is called if the user dragged a file on any registered form,
'and the file has the suffix 'spf'.
'
If MsgBox("Do you want to import the skin in the dropped file '" + DropName + "' ?", vbYesNo + vbQuestion) = vbYes Then
Call SEM_Import(DropName) 'DropName verified there
End If
End Sub
Public Sub SE_ReceiveSkinDataFile(ByVal FormName As String, ByRef FormObject As Object, ByVal DropName As String)
'on error resume next
Dim SkinDirectory As String
Dim SkinName As String
'
'NOTE: this sub is called if the user dragged a file on any registered form,
'and the file is named 'skin.dat'.
'
'If MsgBox("Do you want to change the current skin ?", vbYesNo + vbQuestion) = vbYes Then
SkinDirectory = GetDirectoryName(DropName)
If Not (InStr(1, SkinDirectory, SESystemStructVar.SystemSkinBaseDirectory, vbTextCompare) = 1) Then GoTo Error: 'verify
SkinName = GetSkinNameFromSkinDirectory(SkinDirectory)
If SkinName = "" Then GoTo Error: 'verify
Call Skin_Change(SkinName)
Call SE_DisplayPalette(SESystemStructVar.SystemPaletteNumberCurrent, SESystemStructVar.SystemPaletteNumberCurrent, True, True)
'End If
Exit Sub
Error:
MsgBox "Sorry, the skin related to the dropped file is invalid !", vbOKOnly + vbExclamation
Exit Sub
End Sub
Public Sub SE_ReceiveFormPictureName(ByVal FormName As String, ByRef FormObject As Object, ByVal FormPictureName As String)
'On Error Resume Next
Dim FormPictureNameNew As String
Dim SEControlStructIndex As Integer
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'
'NOTE: when the user drags a picture file on a form, he/she is asked
'if the Skin Engine should copy the picture file to the current skin's
'directory, or if the Skin Engine should access the file from its original
'place to save disk space.
'
'verify
If Skin_VerifyUserEditPermission = False Then Exit Sub 'user cannot drop file if user edit password missing
'begin
If Not ((DirSave(FormPictureName) = "") Or (Right$(FormPictureName, 1) = "\") Or (FormPictureName = "")) Then 'verify
If IsPicture(FormPictureName) = False Then Exit Sub 'verify
'
Call SE_ForwardCallBackMessageEx(SECBMSG_PICTURE_DROPPED, FormName, FormPictureName, ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL) Then
Exit Sub
End If
'
SEControlStructIndex = GetSEControlStructIndex(FormName)
If Not (SEControlStructIndex = 0) Then 'verify
If (Not (UCase$(GetDirectoryName(FormPictureName)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("You are about to change the back ground picture, do you want to copy the image file '" + FormPictureName + "' into the current skin's directory to allow transferring it to other machines (requires additional disk space) ?", vbYesNoCancel + vbQuestion)
Case vbCancel
'do nothing
Case vbNo
Call SEM_BackPicture_ChangeSub(FormName, FormObject, SECONTROLTYPE_FORM, FormPictureName) 'access image file from original place
Case vbYes
FormPictureNameNew = GetExtendedFileName(SESystemStructVar.SystemSkinDirectory + GetFileName(GetFileMainName(FormPictureName)), "." + GetFileNameSuffix(FormPictureName), "#")
If CopyFile(FormPictureName, FormPictureNameNew, 0) = 0 Then
MsgBox "Copying file failed, please check disk space or network connection !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call SEM_BackPicture_ChangeSub(FormName, FormObject, SECONTROLTYPE_FORM, FormPictureNameNew) 'access image file in skin directory
End If
End Select
Else
Call SEM_BackPicture_ChangeSub(FormName, FormObject, SECONTROLTYPE_FORM, FormPictureName) 'access image file from original place
End If
Else
MsgBox "internal error in SE_ReceiveFormPictureName() (GFSkinEngine): form control '" + FormName + "' not found !", vbOKOnly + vbExclamation
End If
Else
MsgBox FormPictureName + " is not a valid picture file, changing back picture failed !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
Public Sub SE_ReceivePictureBoxPictureName(ByVal PictureBoxName As String, ByRef PictureBoxObject As Object, ByVal PictureBoxPictureName As String)
'On Error Resume Next
Dim PictureBoxPictureNameNew As String
Dim SEControlStructIndex As Integer
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'
'NOTE: when the user drags a picture file on a PictureBox, he/she is asked
'if the Skin Engine should copy the picture file to the current skin's
'directory, or if the Skin Engine should access the file from its original
'place to save disk space.
'
'verify
If Skin_VerifyUserEditPermission = False Then Exit Sub 'user cannot drop file if user edit password missing
'begin
If Not ((DirSave(PictureBoxPictureName) = "") Or (Right$(PictureBoxPictureName, 1) = "\") Or (PictureBoxPictureName = "")) Then 'verify
If IsPicture(PictureBoxPictureName) = False Then Exit Sub 'verify
'
Call SE_ForwardCallBackMessageEx(SECBMSG_PICTURE_DROPPED, PictureBoxName, PictureBoxPictureName, ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL) Then
Exit Sub
End If
'
SEControlStructIndex = GetSEControlStructIndex(PictureBoxName)
If Not (SEControlStructIndex = 0) Then 'verify
If (Not (UCase$(GetDirectoryName(PictureBoxPictureName)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("You are about to change the back ground picture, do you want to copy the image file '" + PictureBoxPictureName + "' into the current skin's directory to allow transferring it to other machines (requires additional disk space) ?", vbYesNoCancel + vbQuestion)
Case vbCancel
'do nothing
Case vbNo
Call SEM_BackPicture_ChangeSub(PictureBoxName, PictureBoxObject, SECONTROLTYPE_PICTUREBOX, PictureBoxPictureName) 'access image file from original place
Case vbYes
PictureBoxPictureNameNew = GetExtendedFileName(SESystemStructVar.SystemSkinDirectory + GetFileName(GetFileMainName(PictureBoxPictureName)), "." + GetFileNameSuffix(PictureBoxPictureName), "#")
If CopyFile(PictureBoxPictureName, PictureBoxPictureNameNew, 0) = 0 Then
MsgBox "Copying file failed, please check disk space or network connection", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call SEM_BackPicture_ChangeSub(PictureBoxName, PictureBoxObject, SECONTROLTYPE_PICTUREBOX, PictureBoxPictureNameNew) 'access image file in skin directory
End If
End Select
Else
Call SEM_BackPicture_ChangeSub(PictureBoxName, PictureBoxObject, SECONTROLTYPE_PICTUREBOX, PictureBoxPictureName) 'access image file from original place
End If
Else
MsgBox "internal error in SE_ReceivePictureBoxPictureName() (GFSkinEngine): PictureBox control '" + PictureBoxName + "' not found !", vbOKOnly + vbExclamation
End If
Else
MsgBox PictureBoxPictureName + " is not a valid picture file, changing back picture failed !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
Public Sub SE_ReceiveGFListViewPictureName(ByVal GFListViewName As String, ByRef GFListViewObject As Object, ByVal GFListViewPictureName As String)
'On Error Resume Next
Dim GFListViewPictureNameNew As String
Dim SEControlStructIndex As Integer
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'
'NOTE: when the user drags a picture file on a GFListView, he/she is asked
'if the Skin Engine should copy the picture file to the current skin's
'directory, or if the Skin Engine should access the file from its original
'place to save disk space.
'
'verify
If Skin_VerifyUserEditPermission = False Then Exit Sub 'user cannot drop file if user edit password missing
'begin
If Not ((DirSave(GFListViewPictureName) = "") Or (Right$(GFListViewPictureName, 1) = "\") Or (GFListViewPictureName = "")) Then 'verify
If IsPicture(GFListViewPictureName) = False Then Exit Sub 'verify
'
Call SE_ForwardCallBackMessageEx(SECBMSG_PICTURE_DROPPED, GFListViewName, GFListViewPictureName, ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL) Then
Exit Sub
End If
'
SEControlStructIndex = GetSEControlStructIndex(GFListViewName)
If Not (SEControlStructIndex = 0) Then 'verify
If (Not (UCase$(GetDirectoryName(GFListViewPictureName)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("You are about to change the back ground picture, do you want to copy the image file '" + GFListViewPictureName + "' into the current skin's directory to allow transferring it to other machines (requires additional disk space) ?", vbYesNoCancel + vbQuestion)
Case vbCancel
'do nothing
Case vbNo
Call SEM_BackPicture_ChangeSub(GFListViewName, GFListViewObject, SECONTROLTYPE_GFLISTVIEW, GFListViewPictureName) 'access image file from original place
Case vbYes
GFListViewPictureNameNew = GetExtendedFileName(SESystemStructVar.SystemSkinDirectory + GetFileName(GetFileMainName(GFListViewPictureName)), "." + GetFileNameSuffix(GFListViewPictureName), "#")
If CopyFile(GFListViewPictureName, GFListViewPictureNameNew, 0) = 0 Then
MsgBox "Copying file failed, please check disk space or network connection", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call SEM_BackPicture_ChangeSub(GFListViewName, GFListViewObject, SECONTROLTYPE_GFLISTVIEW, GFListViewPictureNameNew) 'access image file in skin directory
End If
End Select
Else
Call SEM_BackPicture_ChangeSub(GFListViewName, GFListViewObject, SECONTROLTYPE_GFLISTVIEW, GFListViewPictureName) 'access image file from original place
End If
Else
MsgBox "internal error in SE_ReceiveGFListViewPictureName() (GFSkinEngine): GFListView control '" + GFListViewName + "' not found !", vbOKOnly + vbExclamation
End If
Else
MsgBox GFListViewPictureName + " is not a valid picture file, changing back picture failed !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
Public Sub SE_ReceiveFormTitleBarPictureName(ByVal FormName As String, ByRef FormObject As Object, ByVal FormTitleBarPictureName As String)
'On Error Resume Next
Dim FormTitleBarPictureNameNew As String
Dim SEControlStructIndex As Integer
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'
'NOTE: when the user drags a picture file on a form, he/she is asked
'if the Skin Engine should copy the picture file to the current skin's
'directory, or if the Skin Engine should access the file from its original
'place to save disk space.
'
'verify
If Skin_VerifyUserEditPermission = False Then Exit Sub 'user cannot drop file if user edit password missing
'begin
If Not ((DirSave(FormTitleBarPictureName) = "") Or (Right$(FormTitleBarPictureName, 1) = "\") Or (FormTitleBarPictureName = "")) Then 'verify
If IsPicture(FormTitleBarPictureName) = False Then Exit Sub 'verify
'
Call SE_ForwardCallBackMessageEx(SECBMSG_PICTURE_DROPPED, FormName, FormTitleBarPictureName, ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL) Then
Exit Sub
End If
'
SEControlStructIndex = GetSEControlStructIndex(FormName)
If Not (SEControlStructIndex = 0) Then 'verify
If (Not (UCase$(GetDirectoryName(FormTitleBarPictureName)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("You are about to change the title bar picture, do you want to copy the image file '" + FormTitleBarPictureName + "' into the current skin's directory to allow transferring it to other machines (requires additional disk space) ?", vbYesNoCancel + vbQuestion)
Case vbCancel
'do nothing
Case vbNo
Call SEM_TitleBarPicture_ChangeSub(FormName, FormObject, FormTitleBarPictureName) 'access image file from original place
Case vbYes
FormTitleBarPictureNameNew = GetExtendedFileName(SESystemStructVar.SystemSkinDirectory + GetFileName(GetFileMainName(FormTitleBarPictureName)), "." + GetFileNameSuffix(FormTitleBarPictureName), "#")
If CopyFile(FormTitleBarPictureName, FormTitleBarPictureNameNew, 0) = 0 Then
MsgBox "Copying file failed, please check disk space or network connection !", vbOKOnly + vbExclamation
Exit Sub 'error
Else
Call SEM_TitleBarPicture_ChangeSub(FormName, FormObject, FormTitleBarPictureNameNew) 'access image file in skin directory
End If
End Select
Else
Call SEM_TitleBarPicture_ChangeSub(FormName, FormObject, FormTitleBarPictureName) 'access image file from original place
End If
Else
MsgBox "internal error in SE_ReceiveFormTitleBarPictureName() (GFSkinEngine): form control '" + FormName + "' not found !", vbOKOnly + vbExclamation
End If
Else
MsgBox FormTitleBarPictureName + " is not a valid picture file, changing title bar picture failed !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
Public Sub SE_ReceiveSECommandPictureName(ByVal SECommandName As String, ByRef SECommandObject As Object, ByVal SECommandPictureName As String)
'On Error Resume Next 'call to change a command's picture
Dim SECommandPictureNameNew As String
Dim SEControlStructIndex As Integer
Dim SkinDataFileString As String
Dim ScreenActiveFormUnchanged As Form
Dim PictureUsage As Integer
Dim ReturnValueUsedFlag As Boolean
Dim ReturnValue As Long
'
'NOTE: the user will be asked if the passed picture is to be used as
'up‑, down‑ or move over picture.
'
'verify
If Skin_VerifyUserEditPermission = False Then Exit Sub 'user cannot drop file if user edit password missing
'begin
If Not ((DirSave(SECommandPictureName) = "") Or (Right$(SECommandPictureName, 1) = "\") Or (SECommandPictureName = "")) Then
If IsPicture(SECommandPictureName) = False Then Exit Sub 'verify
'
Call SE_ForwardCallBackMessageEx(SECBMSG_PICTURE_DROPPED, SECommandName, SECommandPictureName, ReturnValueUsedFlag, ReturnValue)
If (ReturnValueUsedFlag = True) And (ReturnValue = SECBMSG_REPLY_CANCEL) Then
Exit Sub
End If
'
SEControlStructIndex = GetSEControlStructIndex(SECommandName)
If SEControlStructIndex = 0 Then 'verify
MsgBox "internal error in SE_ReceiveSECommandPictureName() (GFSkinEngine): se command control '" + SECommandName + "' not found !", vbOKOnly + vbExclamation
Exit Sub
End If
Set ScreenActiveFormUnchanged = Screen.ActiveForm
PictureUsage = GFSkinEnginefrm.SE_RequestPictureUsage
If Not (ScreenActiveFormUnchanged Is Nothing) Then 'verify
If (ScreenActiveFormUnchanged.Enabled = True) And (ScreenActiveFormUnchanged.Visible = True) And (ScreenActiveFormUnchanged.WindowState = vbNormal) Then 'verify
ScreenActiveFormUnchanged.SetFocus 'important (tested)
End If
End If
Select Case PictureUsage
Case SE_ERROR
'do nothing (error)
Case SE_DISABLEPICTURES
Call SE_UnloadControl(SECommandName)
SEControlStructArray(SEControlStructIndex).SEControl_UpPicture = "" 'reset
SEControlStructArray(SEControlStructIndex).SEControl_DownPicture = "" 'reset
SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPicture = "" 'reset
SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture = "" 'reset (system will recreate picture automatically)
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString) 'we read and write the string once only to increase speed
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SECommandName, "uppicture", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SECommandName, "downpicture", "", True, False)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, SECommandName, "moveoverpicture", "", True, False)
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
Call SE_LoadControl(SECommandName, True)
Call SE_RefreshControl(SECommandName, SECONTROLSTATE_NORMAL) 'display changes
Case Else
'define se command picture name
If (Not (UCase$(GetDirectoryName(SECommandPictureName)) = UCase$(SESystemStructVar.SystemSkinDirectory))) And _
(SESystemStructVar.SystemAskForPictureImportFlag = True) Then
Select Case MsgBox("Do you want to copy the selected image file into the current skin's directory to allow transfering it to other machines (requires additional disk space) ?", vbYesNoCancel + vbInformation)
Case vbYes
SECommandPictureNameNew = GetExtendedFileName(SESystemStructVar.SystemSkinDirectory + GetFileName(GetFileMainName(SECommandPictureName)), "." + GetFileNameSuffix(SECommandPictureName), "#")
If CopyFile(SECommandPictureName, SECommandPictureNameNew, 0) = 0 Then
MsgBox "Copying file failed, please check disk space or network connection !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
Case vbNo
SECommandPictureNameNew = SECommandPictureName
Case vbCancel
Exit Sub 'user canceled
End Select
Else
SECommandPictureNameNew = SECommandPictureName
End If
'resize se command to display new picture
' Select Case MsgBox("Do you want to retain the current command size (press 'No' to fit command to image) ?", vbYesNoCancel + vbQuestion)
' Case vbYes
' 'do nothing (retain command size)
' Case vbNo
Call SE_DeletePictureBox(SESystemStructVar.SystemTempPicture) 'reset
SESystemStructVar.SystemTempPicture.AutoSize = True
On Error GoTo 0
On Error Resume Next 'important (if picture tot load is invalid)
SESystemStructVar.SystemTempPicture.Picture = LoadPicture(SECommandPictureNameNew)
SESystemStructVar.SystemTempPicture.Refresh
On Error GoTo 0
'On Error Resume Next
If Not (SESystemStructVar.SystemTempPicture.Picture Is Nothing) Then 'verify picture could be loaded
Call SaveSEControlSize(SE_ControlMenuStructVar.SEControlStructIndex, _
(SESystemStructVar.SystemTempPicture.Width / Screen.TwipsPerPixelX) ‑ 4, _
(SESystemStructVar.SystemTempPicture.Height / Screen.TwipsPerPixelY) ‑ 4, _
1, 1) '4 pixels for borders; don't use SEControlStructIndex or the button will be wrong positionated when changing the current palette (tested, no idea why)
Else
'do nothing
End If
'NOTE: SaveSEControlSize() must also resize the control the size is saved of.
SESystemStructVar.SystemTempPicture.AutoSize = False 'reset (to default)
' Case vbCancel
' Exit Sub 'user canceled
' End Select
'refresh se command
If (PictureUsage = SE_UPPICTURE) Then
Call SE_UnloadControl(SECommandName)
SEControlStructArray(SEControlStructIndex).SEControl_UpPicture = SECommandPictureNameNew
SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture = "" 'reset (system will recreate picture)
Call SE_LoadControl(SECommandName, True)
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SECommandName, "uppicture", SECommandPictureNameNew) 'save changes
Call SE_RefreshControl(SECommandName, SECONTROLSTATE_NORMAL) 'display changes
'NOTE: we now fit the size of the se command to the size of the picture it displays.
Call SaveSEControlSize(SE_ControlMenuStructVar.SEControlStructIndex, _
GetSEControlXSize(SE_ControlMenuStructVar.SEControlStructIndex), GetSEControlYSize(SE_ControlMenuStructVar.SEControlStructIndex), 0, 0)
End If
If (PictureUsage = SE_DOWNPICTURE) Then
Call SE_UnloadControl(SECommandName)
SEControlStructArray(SEControlStructIndex).SEControl_DownPicture = SECommandPictureNameNew
'SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture = "" 'reset (system will recreate picture) 'not necessary
Call SE_LoadControl(SECommandName, True)
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SECommandName, "downpicture", SECommandPictureNameNew) 'save changes
Call SE_RefreshControl(SECommandName, SECONTROLSTATE_NORMAL) 'display changes
'NOTE: we now fit the size of the se command to the size of the picture it displays.
Call SaveSEControlSize(SE_ControlMenuStructVar.SEControlStructIndex, _
GetSEControlXSize(SE_ControlMenuStructVar.SEControlStructIndex), GetSEControlYSize(SE_ControlMenuStructVar.SEControlStructIndex), 0, 0)
End If
If (PictureUsage = SE_MOVEOVERPICTURE) Then
Call SE_UnloadControl(SECommandName)
SEControlStructArray(SEControlStructIndex).SEControl_MoveOverPicture = SECommandPictureNameNew
'SEControlStructArray(SEControlStructIndex).SEControl_DisabledPicture = "" 'reset (system will recreate picture) 'not necessary
Call SE_LoadControl(SECommandName, True)
Call SkinDataFile_ChangeProperty(SE_GetSkinDataFile, SECommandName, "moveoverpicture", SECommandPictureNameNew) 'save changes
Call SE_RefreshControl(SECommandName, SECONTROLSTATE_NORMAL) 'display changes
'NOTE: we now fit the size of the se command to the size of the picture it displays.
Call SaveSEControlSize(SE_ControlMenuStructVar.SEControlStructIndex, _
GetSEControlXSize(SE_ControlMenuStructVar.SEControlStructIndex), GetSEControlYSize(SE_ControlMenuStructVar.SEControlStructIndex), 0, 0)
End If
End Select
Else
MsgBox SECommandPictureName + " is not a valid picture file, changing command skin failed !", vbOKOnly + vbExclamation
End If
Exit Sub
End Sub
'***************************END OF GFSKINENGINEFRM INTERFACE****************************
'*****************************************GRID******************************************
Public Function GetXGrid() As Long
'On Error Resume Next 'returns x grid (1 if grid is disabled)
'
'NOTE: the grid is used when saving a control's position and size.
'
If UserMoveStructVar.GridEnabledFlag = True Then
GetXGrid = UserMoveStructVar.GridXSize
Else
GetXGrid = 1
End If
End Function
Public Function GetYGrid() As Long
'on error resume next 'returns y grid (1 if grid is disabled)
If UserMoveStructVar.GridEnabledFlag = True Then
GetYGrid = UserMoveStructVar.GridYSize
Else
GetYGrid = 1
End If
End Function
'**************************************END OF GRID**************************************
'*******************************SE CONTROL POSING/SIZING********************************
Public Function GetSEControlXPos(ByVal SEControlStructIndex As Integer) As Long
'On Error Resume Next 'returns control screen x pos in pixels or SE_POS_NOT_DEFINED for error
'
'NOTE: the returned coordinates needn't to be screen related
'(e.g. if an option button has a frame as parent window).
'The sub/function that uses this function must be able to
'handle non‑screen coordinates, too.
'
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
GetSEControlXPos = SE_POS_NOT_DEFINED 'x pos cannot be determined
Case Else
GetSEControlXPos = SEControlStructArray(SEControlStructIndex).SEControl.Left / Screen.TwipsPerPixelX
End Select
Else
GetSEControlXPos = SE_POS_NOT_DEFINED 'error
End If
End Function
Public Function GetSEControlYPos(ByVal SEControlStructIndex As Integer) As Long
'On Error Resume Next 'returns control screen y pos in pixels or SE_POS_NOT_DEFINED for error
'
'NOTE: the returned coordinates needn't to be screen related
'(e.g. if an option button has a frame as parent window).
'The sub/function that uses this function must be able to
'handle non‑screen coordinates, too.
'
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
GetSEControlYPos = SE_POS_NOT_DEFINED 'y pos cannot be determined
Case Else
GetSEControlYPos = SEControlStructArray(SEControlStructIndex).SEControl.Top / Screen.TwipsPerPixelY
End Select
Else
GetSEControlYPos = SE_POS_NOT_DEFINED 'error
End If
End Function
Public Function GetSEControlXSize(ByVal SEControlStructIndex As Long) As Long
'On Error Resume Next 'returns control width in pixels or SE_SIZE_NOT_DEFINED for error
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
GetSEControlXSize = SE_SIZE_NOT_DEFINED 'y pos cannot be determined
Case Else
' If Not (SEControlStructArray(SEControlStructIndex).SEControl_XSize = SE_SIZE_NOT_DEFINED) Then 'verify
' '
' 'NOTE: the target control could be a pool object.
' 'Return the size related to the right 'instance' of the pool object
' '(return size of structure, not current size). No! (leads to errors, tested)
' '
' GetSEControlXSize = SEControlStructArray(SEControlStructIndex).SEControl_XSize
' Else
GetSEControlXSize = SEControlStructArray(SEControlStructIndex).SEControl.Width / Screen.TwipsPerPixelX
' End If
End Select
Else
GetSEControlXSize = SE_SIZE_NOT_DEFINED 'error
End If
End Function
Public Function GetSEControlYSize(ByVal SEControlStructIndex As Long) As Long
'On Error Resume Next 'returns control height in pixels or SE_SIZE_NOT_DEFINED for error
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
GetSEControlYSize = SE_SIZE_NOT_DEFINED 'y pos cannot be determined
Case Else
' If Not (SEControlStructArray(SEControlStructIndex).SEControl_YSize = SE_SIZE_NOT_DEFINED) Then 'verify
' '
' 'NOTE: the target control could be a pool object.
' 'Return the size related to the right 'instance' of the pool object
' '(return size of structure, not current size). No! (leads to errors, tested)
' '
' GetSEControlYSize = SEControlStructArray(SEControlStructIndex).SEControl_YSize
' Else
GetSEControlYSize = SEControlStructArray(SEControlStructIndex).SEControl.Height / Screen.TwipsPerPixelY
' End If
End Select
Else
GetSEControlYSize = SE_SIZE_NOT_DEFINED 'error
End If
End Function
Public Sub SetSEControlXPos(ByVal SEControlStructIndex As Integer, ByVal ControlXPosNew As Long, Optional ByVal GridXSize As Long = 0, Optional ByVal ParentFormSizeNotChangedFlag As Boolean = False)
'On Error Resume Next 'format: pixels
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
'apply grid
If Not (GridXSize = 0) Then
If (ControlXPosNew Mod GridXSize) > (GridXSize / 2) Then
ControlXPosNew = ControlXPosNew + (GridXSize ‑ (ControlXPosNew Mod GridXSize))
Else
ControlXPosNew = ControlXPosNew ‑ (ControlXPosNew Mod GridXSize)
End If
End If
'move control
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
'do nothing (position cannot be changed)
Case Else
SEControlStructArray(SEControlStructIndex).SEControl_XPos = ControlXPosNew
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Left = ControlXPosNew * Screen.TwipsPerPixelX) Then 'verify to increase speed (less WM_PAINT messages)
SEControlStructArray(SEControlStructIndex).SEControl.Left = ControlXPosNew * Screen.TwipsPerPixelX
End If
If ParentFormSizeNotChangedFlag = False Then 'set to True if saving size/position of a pool control (different sizes/positions) that is currently not loaded
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)) Then
'NOTE: it is important to also update the parent form height in memory.
Dim ParentFormStructIndex As Integer
ParentFormStructIndex = GetPoolControlStructIndex(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)
If (ParentFormStructIndex) Then 'verify
If IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteNumber, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteArray()) = True Then 'important (all positions and sizes must have been set correctly)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = GetSEControlXSize(ParentFormStructIndex)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = GetSEControlYSize(ParentFormStructIndex)
Else
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = SEControlStructArray(ParentFormStructIndex).SEControl_XSize
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = SEControlStructArray(ParentFormStructIndex).SEControl_YSize
End If
End If
End If
End If
End Select
End If
End Sub
Public Sub SetSEControlYPos(ByVal SEControlStructIndex As Integer, ByVal ControlYPosNew As Long, Optional ByVal GridYSize As Long = 0, Optional ByVal ParentFormSizeNotChangedFlag As Boolean = False)
'On Error Resume Next 'format: pixels
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
'apply grid
If Not (GridYSize = 0) Then
If (ControlYPosNew Mod GridYSize) > (GridYSize / 2) Then
ControlYPosNew = ControlYPosNew + (GridYSize ‑ (ControlYPosNew Mod GridYSize))
Else
ControlYPosNew = ControlYPosNew ‑ (ControlYPosNew Mod GridYSize)
End If
End If
'move control
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
'do nothing (position cannot be changed)
Case Else
SEControlStructArray(SEControlStructIndex).SEControl_YPos = ControlYPosNew
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Top = ControlYPosNew * Screen.TwipsPerPixelY) Then 'verify to increase speed (less WM_PAINT messages)
SEControlStructArray(SEControlStructIndex).SEControl.Top = ControlYPosNew * Screen.TwipsPerPixelY
End If
If ParentFormSizeNotChangedFlag = False Then 'set to True if saving size/position of a pool control (different sizes/positions) that is currently not loaded
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)) Then
'NOTE: it is important to also update the parent form height in memory.
Dim ParentFormStructIndex As Integer
ParentFormStructIndex = GetPoolControlStructIndex(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)
If (ParentFormStructIndex) Then 'verify
If IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteNumber, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteArray()) = True Then 'important (all positions and sizes must have been set correctly)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = GetSEControlXSize(ParentFormStructIndex)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = GetSEControlYSize(ParentFormStructIndex)
Else
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = SEControlStructArray(ParentFormStructIndex).SEControl_XSize
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = SEControlStructArray(ParentFormStructIndex).SEControl_YSize
End If
End If
End If
End If
End Select
End If
End Sub
Public Sub SetSEControlXSize(ByVal SEControlStructIndex As Integer, ByVal ControlXSizeNew As Long, Optional ByVal GridXSize As Long = 0, Optional ByVal GridRoundUpOnlyFlag As Boolean = False, Optional ByVal ParentFormSizeNotChangedFlag As Boolean = False)
'On Error Resume Next 'format: pixels
'verify
If ControlXSizeNew < 0 Then ControlXSizeNew = 0
If ControlXSizeNew > (Screen.Width / Screen.TwipsPerPixelX) Then ControlXSizeNew = (Screen.Width / Screen.TwipsPerPixelX)
'preset
If Not (GridXSize = 0) Then
If ((ControlXSizeNew Mod GridXSize) > (GridXSize / 2)) Or (GridRoundUpOnlyFlag = True) Then
ControlXSizeNew = ControlXSizeNew + (GridXSize ‑ (ControlXSizeNew Mod GridXSize))
Else
ControlXSizeNew = ControlXSizeNew ‑ (ControlXSizeNew Mod GridXSize)
End If
End If
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
'do nothing (size cannot be changed)
Case Else
SEControlStructArray(SEControlStructIndex).SEControl_XSize = ControlXSizeNew
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Width = ControlXSizeNew * Screen.TwipsPerPixelX) Then 'verify to increase speed (less WM_PAINT messages)
SEControlStructArray(SEControlStructIndex).SEControl.Width = ControlXSizeNew * Screen.TwipsPerPixelX
End If
If ParentFormSizeNotChangedFlag = False Then 'set to True if saving size/position of a pool control (different sizes/positions) that is currently not loaded
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)) Then
'NOTE: it is important to also update the parent form width in memory.
Dim ParentFormStructIndex As Integer
ParentFormStructIndex = GetPoolControlStructIndex(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)
If (ParentFormStructIndex) Then 'verify
If IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteNumber, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteArray()) = True Then 'important (all positions and sizes must have been set correctly)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = GetSEControlXSize(ParentFormStructIndex)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = GetSEControlYSize(ParentFormStructIndex)
Else
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = SEControlStructArray(ParentFormStructIndex).SEControl_XSize
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = SEControlStructArray(ParentFormStructIndex).SEControl_YSize
End If
End If
End If
End If
End Select
End If
End Sub
Public Sub SetSEControlYSize(ByVal SEControlStructIndex As Integer, ByVal ControlYSizeNew As Long, Optional ByVal GridYSize As Long = 0, Optional ByVal GridRoundUpOnlyFlag As Boolean = False, Optional ByVal ParentFormSizeNotChangedFlag As Boolean = False)
'On Error Resume Next 'format: pixels
'verify
If ControlYSizeNew < 0 Then ControlYSizeNew = 0
If ControlYSizeNew > (Screen.Height / Screen.TwipsPerPixelY) Then ControlYSizeNew = (Screen.Height / Screen.TwipsPerPixelY)
'preset
If Not (GridYSize = 0) Then
If ((ControlYSizeNew Mod GridYSize) > (GridYSize / 2)) Or (GridRoundUpOnlyFlag = True) Then
ControlYSizeNew = ControlYSizeNew + (GridYSize ‑ (ControlYSizeNew Mod GridYSize))
Else
ControlYSizeNew = ControlYSizeNew ‑ (ControlYSizeNew Mod GridYSize)
End If
End If
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_COMBOBOX, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_LINE, SECONTROLTYPE_PSEUDOCONTROL
'do nothing (size cannot be changed)
Case Else
SEControlStructArray(SEControlStructIndex).SEControl_YSize = ControlYSizeNew
If Not (SEControlStructArray(SEControlStructIndex).SEControl.Height = ControlYSizeNew * Screen.TwipsPerPixelY) Then 'verify to increase speed (less WM_PAINT messages)
SEControlStructArray(SEControlStructIndex).SEControl.Height = ControlYSizeNew * Screen.TwipsPerPixelY
End If
If ParentFormSizeNotChangedFlag = False Then 'set to True if saving size/position of a pool control (different sizes/positions) that is currently not loaded
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)) Then
'NOTE: it is important to also update the parent form height in memory.
Dim ParentFormStructIndex As Integer
ParentFormStructIndex = GetPoolControlStructIndex(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)
If (ParentFormStructIndex) Then 'verify
If IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteNumber, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteArray()) = True Then 'important (all positions and sizes must have been set correctly)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = GetSEControlXSize(ParentFormStructIndex)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = GetSEControlYSize(ParentFormStructIndex)
Else
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = SEControlStructArray(ParentFormStructIndex).SEControl_XSize
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = SEControlStructArray(ParentFormStructIndex).SEControl_YSize
End If
End If
End If
End If
End Select
End If
End Sub
Public Sub SaveSEControlPos(ByVal SEControlStructIndex As Integer, ByVal ControlXPos As Long, ByVal ControlYPos As Long, ByVal GridXSize As Long, ByVal GridYSize As Long, Optional ByVal ForcePropertyLineAddFlag As Boolean = False, Optional ByVal ParentFormSizeNotChangedFlag As Boolean = False)
'On Error Resume Next 'format (all parameters): pixels; save a control's position in SkinDataFile; if Grid[X/Y]Size is not 0 the control will be fit to a invisible grid
Dim ParentFormStructIndex As Integer
Dim SkinDataFileString As String
'
'NOTE: the property names 'x' (poly rgn) and 'xpos' (other controls)
'may never be the same (note if changing internal property names).
'
'preset
If Not (GridXSize = 0) Then
If (ControlXPos Mod GridXSize) > (GridXSize / 2) Then
ControlXPos = ControlXPos + (GridXSize ‑ (ControlXPos Mod GridXSize))
Else
ControlXPos = ControlXPos ‑ (ControlXPos Mod GridXSize)
End If
End If
If Not (GridYSize = 0) Then
If (ControlYPos Mod GridYSize) > (GridYSize / 2) Then
ControlYPos = ControlYPos + (GridYSize ‑ (ControlYPos Mod GridYSize))
Else
ControlYPos = ControlYPos ‑ (ControlYPos Mod GridYSize)
End If
End If
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
'save x/y pos
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
'do nothing (control cannot be posed; avoid error when loading SkinDataFile)
Case Else
'
'NOTE: as writing the SkinDataFileString needs some time we
'read the string matnually and save it once only.
'
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"xpos", LTrim$(Str$(ControlXPos)), False, ForcePropertyLineAddFlag)
Call SetSEControlXPos(SEControlStructIndex, ControlXPos, _
ParentFormSizeNotChangedFlag:=ParentFormSizeNotChangedFlag) 'move because of grid; forward flag value to avoid that controls are misplaced under special circumstances (for what reason ever)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"ypos", LTrim$(Str$(ControlYPos)), False, ForcePropertyLineAddFlag)
Call SetSEControlYPos(SEControlStructIndex, ControlYPos, _
ParentFormSizeNotChangedFlag:=ParentFormSizeNotChangedFlag) 'move because of grid; forward flag value to avoid that controls are misplaced under special circumstances (for what reason ever)
If ParentFormSizeNotChangedFlag = False Then 'set to True if saving size/position of a pool control (different sizes/positions) that is currently not loaded
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)) Then
'
'NOTE: the current control is to be moved when the parent form is resized.
'Save the current parent form's size to know where the controls must be located
'when the parent form is resized.
'
ParentFormStructIndex = GetPoolControlStructIndex(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)
'NOTE: we want the current pool instance (if any) of the parent form.
'If (ParentFormStructIndex) Then ParentFormStructIndex = GetSEControlStructIndexFromControlObject(SEControlStructArray(ParentFormStructIndex).SEControl, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
If (ParentFormStructIndex) Then 'verify
If IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteNumber, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteArray()) = True Then 'important (all positions and sizes must have been set correctly)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = GetSEControlXSize(ParentFormStructIndex)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = GetSEControlYSize(ParentFormStructIndex)
Else
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = SEControlStructArray(ParentFormStructIndex).SEControl_XSize
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = SEControlStructArray(ParentFormStructIndex).SEControl_YSize
End If
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"resize_parentformxsize", LTrim$(Str$(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize)), False, False) 'do not force adding line in any case
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"resize_parentformysize", LTrim$(Str$(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize)), False, False) 'do not force adding line in any case
End If
End If
End If
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
End Select
End If
End Sub
Public Sub SaveSEControlSize(ByVal SEControlStructIndex As Integer, ByVal ControlXSize As Long, ByVal ControlYSize As Long, ByVal GridXSize As Long, ByVal GridYSize As Long, Optional ByVal ForcePropertyLineAddFlag As Boolean = False, Optional ByVal ParentFormSizeNotChangedFlag As Boolean = False)
'On Error Resume Next 'format (all parameters): pixels; save a control's size in SkinDataFile; if Grid[X/Y]Size is not 0 the control will be fit to a invisible grid
Dim ParentFormStructIndex As Integer
Dim SkinDataFileString As String
'
'NOTE: as some controls (e.g. list box) cannot have any size (height),
'the control size is first set, and then the current control size is saved.
'
'verify
If ControlXSize < 0 Then ControlXSize = 0
If ControlXSize > (Screen.Width / Screen.TwipsPerPixelX) Then ControlXSize = (Screen.Width / Screen.TwipsPerPixelX)
If ControlYSize < 0 Then ControlYSize = 0
If ControlYSize > (Screen.Height / Screen.TwipsPerPixelY) Then ControlYSize = (Screen.Height / Screen.TwipsPerPixelY)
'preset
If Not (GridXSize = 0) Then
If (ControlXSize Mod GridXSize) > (GridXSize / 2) Then
ControlXSize = ControlXSize + (GridXSize ‑ (ControlXSize Mod GridXSize))
Else
ControlXSize = ControlXSize ‑ (ControlXSize Mod GridXSize)
End If
End If
If Not (GridYSize = 0) Then
If (ControlYSize Mod GridYSize) > (GridYSize / 2) Then
ControlYSize = ControlYSize + (GridYSize ‑ (ControlYSize Mod GridYSize))
Else
ControlYSize = ControlYSize ‑ (ControlYSize Mod GridYSize)
End If
End If
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
If SEControlStructArray(SEControlStructIndex).SEControlType = SECONTROLTYPE_SECOMMAND Then
'NOTE: unload se command picture to force a recreation with new size.
Call SE_UnloadControl(SEControlStructArray(SEControlStructIndex).SEControlName)
End If
'save x size
Select Case SEControlStructArray(SEControlStructIndex).SEControlType
Case SECONTROLTYPE_LINE, SECONTROLTYPE_GFTABSTRING, SECONTROLTYPE_PSEUDOCONTROL
'do nothing (control cannot be resized; avoid error when loading SkinDataFile)
Case Else
'
'NOTE: as writing the SkinDataFileString needs some time we
'read the string manually and save it once only.
'
Call SkinDataFile_ReadString(SE_GetSkinDataFile, SkinDataFileString)
Call SetSEControlXSize(SEControlStructIndex, ControlXSize, _
ParentFormSizeNotChangedFlag:=ParentFormSizeNotChangedFlag) 'size because of grid; forward flag value to avoid that controls are misplaced under special circumstances (for what reason ever)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"xsize", LTrim$(Str$(GetSEControlXSize(SEControlStructIndex))), False, ForcePropertyLineAddFlag)
Call SetSEControlYSize(SEControlStructIndex, ControlYSize, _
ParentFormSizeNotChangedFlag:=ParentFormSizeNotChangedFlag) 'size because of grid; forward flag value to avoid that controls are misplaced under special circumstances (for what reason ever)
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"ysize", LTrim$(Str$(GetSEControlYSize(SEControlStructIndex))), False, ForcePropertyLineAddFlag)
If ParentFormSizeNotChangedFlag = False Then 'set to True if saving size/position of a pool control (different sizes/positions) that is currently not loaded
If (Len(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)) Then
'
'NOTE: the current control is to be moved when the parent form is resized.
'Save the current parent form's size to know where the controls must be located
'when the parent form is resized.
'
ParentFormStructIndex = GetPoolControlStructIndex(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormName)
'NOTE: we want the current pool instance (if any) of the parent form. 'no!
'If (ParentFormStructIndex) Then ParentFormStructIndex = GetSEControlStructIndexFromControlObject(SEControlStructArray(ParentFormStructIndex).SEControl, SECONTROLTYPE_FORM, SESystemStructVar.SystemPaletteNumberCurrent)
If (ParentFormStructIndex) Then 'verify
If IsControlPaletteEqual(SESystemStructVar.SystemPaletteNumberCurrent, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteNumber, SEControlStructArray(ParentFormStructIndex).SEControl_PaletteArray()) = True Then 'important (all positions and sizes must have been set correctly)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = GetSEControlXSize(ParentFormStructIndex)
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = GetSEControlYSize(ParentFormStructIndex)
Else
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize = SEControlStructArray(ParentFormStructIndex).SEControl_XSize
SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize = SEControlStructArray(ParentFormStructIndex).SEControl_YSize
End If
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"resize_parentformxsize", LTrim$(Str$(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormXSize)), False, False) 'do not force adding line in any case
Call SkinDataFile_ChangePropertySub(SkinDataFileString, _
SEControlStructArray(SEControlStructIndex).SEControlName, _
"resize_parentformysize", LTrim$(Str$(SEControlStructArray(SEControlStructIndex).SEControl_ResizeStruct.Resize_ParentFormYSize)), False, False) 'do not force adding line in any case
End If
End If
End If
Call SkinDataFile_WriteString(SE_GetSkinDataFile, SkinDataFileString)
End Select
End If
End Sub
'****************************END OF SE CONTROL POSING/SIZING****************************
'************************************FRAMEBRUSHCACHE************************************
'NOTE: to draw a frame around an SE control FrameRect() is used, which needs a handle
'to a brush. The FrameBrushCache creates/deletes these brushes.
'Any value of SESystemStructVar.SystemFrameBrushHandleArray() can be passed to
'FrameRect() after FrameBrushCache_Create() has been called.
Private Sub FrameBrushCache_Create(ByRef SESystemStructVar As SESystemStruct)
'on error resume next
Dim BrushLoop As Integer
Dim BrightnessLoop As Integer
'
'NOTE: for every frame color a brush is created, never minding if the frame color
'is in use or not. As there are only 16 * 24 frame colors no memory problems should occur.
'NOTE: the first color index specifies the frame color (the user can use several frame
'colors) and the second index specifies the frame color brightness (1 to 24).
'
'reset
Call FrameBrushCache_Reset(SESystemStructVar)
'begin
For BrushLoop = LBound(SESystemStructVar.SystemFrameBrushHandleArray(), 1) To UBound(SESystemStructVar.SystemFrameBrushHandleArray(), 1) 'do not use structure values (temporarily not preset)
For BrightnessLoop = 1 To 24
SESystemStructVar.SystemFrameBrushHandleArray(BrushLoop, BrightnessLoop) = _
CreateSolidBrush( _
GFColor_ChangeBrightness( _
SESystemStructVar.SystemFrameColorArray(BrushLoop), _
(13 ‑ BrightnessLoop) * 6))
Next BrightnessLoop
SESystemStructVar.SystemFrameBrushHandleArray(BrushLoop, 0) = _
CreateSolidBrush(0&) 'brush brightness 0 is always 0
Next BrushLoop
End Sub
Private Sub FrameBrushCache_Reset(ByRef SESystemStructVar As SESystemStruct)
'on error resume next
Dim BrushLoop As Integer
Dim BrightnessLoop As Integer
'begin
For BrushLoop = LBound(SESystemStructVar.SystemFrameBrushHandleArray(), 1) To UBound(SESystemStructVar.SystemFrameBrushHandleArray(), 1) 'do not use structure values (temporarily not preset)
For BrightnessLoop = 0 To 24
If (SESystemStructVar.SystemFrameBrushHandleArray(BrushLoop, BrightnessLoop)) Then
Call DeleteObject(SESystemStructVar.SystemFrameBrushHandleArray(BrushLoop, BrightnessLoop))
SESystemStructVar.SystemFrameBrushHandleArray(BrushLoop, BrightnessLoop) = 0 'reset
End If
Next BrightnessLoop
Next BrushLoop
End Sub
'********************************END OF FRAMEBRUSHCACHE*********************************
'*************************************SKIN TRANSFER*************************************
Public Function SkinTransferFile_Write(ByVal SkinTransferFile As String, ByRef SkinTransferStructVar As SkinTransferStruct) As Boolean
On Error GoTo Error: 'returns True for success, False for error
Dim STFNumber As Integer
'preset
STFNumber = FreeFile(0)
'begin
Open SkinTransferFile For Output As #STFNumber
Print #STFNumber, "SkinTransferFile";
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.SkinName));
Print #STFNumber, SkinTransferStructVar.SkinName;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.Author));
Print #STFNumber, SkinTransferStructVar.Author;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.Dedicated));
Print #STFNumber, SkinTransferStructVar.Dedicated;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.Date));
Print #STFNumber, SkinTransferStructVar.Date;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.CurrentLocation));
Print #STFNumber, SkinTransferStructVar.CurrentLocation;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.Motto));
Print #STFNumber, SkinTransferStructVar.Motto;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.Comment));
Print #STFNumber, SkinTransferStructVar.Comment;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.ImportPassword));
Print #STFNumber, SkinTransferStructVar.ImportPassword; 'already encrypted
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.ImportPasswordHintText));
Print #STFNumber, SkinTransferStructVar.ImportPasswordHintText;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.EditPassword));
Print #STFNumber, SkinTransferStructVar.EditPassword; 'already encrypted
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.EditPasswordHintText));
Print #STFNumber, SkinTransferStructVar.EditPasswordHintText;
Print #STFNumber, GetLongString(Len(SkinTransferStructVar.FileEx));
Print #STFNumber, SkinTransferStructVar.FileEx;
Print #STFNumber, GetLongString(CLng(SkinTransferStructVar.FileExSaveExFlag));
Close #STFNumber
SkinTransferFile_Write = True 'ok
Exit Function
Error:
Close #STFNumber 'make sure file is closed
MsgBox "internal error in SkinTransferFile_Write() !", vbOKOnly + vbExclamation
SkinTransferFile_Write = False 'error
Exit Function
End Function
Public Function SkinTransferFile_Read(ByVal SkinTransferFile As String, ByRef SkinTransferStructVar As SkinTransferStruct) As Boolean
'on error resume next 'returns True for success, False for error
Dim STFNumber As Integer
Dim STFString As String
Dim STFStringLength As Long
'verify
If (DirSave(SkinTransferFile) = "") Or (Right$(SkinTransferFile, 1) = "\") Or (SkinTransferFile = "") Then 'verify
MsgBox "internal error in SkinTransferFile_Read(): file '" + SkinTransferFile + "' not found !", vbOKOnly + vbExclamation
GoTo Error:
End If
'preset
STFNumber = FreeFile(0)
'begin
Open SkinTransferFile For Binary As #STFNumber
STFString = String$(Len("SkinTransferFile"), Chr$(0))
Get #STFNumber, 1, STFString
If Not (STFString = "SkinTransferFile") Then
MsgBox "internal error in SkinTransferFile_Read(): file '" + SkinTransferFile + "' has an invalid format !", vbOKOnly + vbExclamation
GoTo Error:
End If
GoSub ReadString:
SkinTransferStructVar.SkinName = STFString
GoSub ReadString:
SkinTransferStructVar.Author = STFString
GoSub ReadString:
SkinTransferStructVar.Dedicated = STFString
GoSub ReadString:
SkinTransferStructVar.Date = STFString
GoSub ReadString:
SkinTransferStructVar.CurrentLocation = STFString
GoSub ReadString:
SkinTransferStructVar.Motto = STFString
GoSub ReadString:
SkinTransferStructVar.Comment = STFString
GoSub ReadString:
SkinTransferStructVar.ImportPassword = STFString 'already encrypted
GoSub ReadString:
SkinTransferStructVar.ImportPasswordHintText = STFString
GoSub ReadString:
SkinTransferStructVar.EditPassword = STFString 'already encrypted
GoSub ReadString:
SkinTransferStructVar.EditPasswordHintText = STFString
GoSub ReadString:
SkinTransferStructVar.FileEx = STFString
STFString = String$(4, Chr$(0))
Get #STFNumber, , STFString
SkinTransferStructVar.FileExSaveExFlag = CBool(GetStringLong(STFString))
Close #STFNumber
SkinTransferFile_Read = True 'ok
Exit Function
Error:
Close #STFNumber 'make sure file is closed
SkinTransferFile_Read = False 'error
Exit Function
ReadString:
STFString = String$(4, Chr$(0))
Get #STFNumber, , STFString
STFStringLength = GetStringLong(STFString)
STFString = String$(STFStringLength, Chr$(0))
Get #STFNumber, , STFString
Return
End Function
'*********************************END OF SKIN TRANSFER**********************************
'**************************************UPDATECHECK**************************************
'NOTE: the UpdateCheck system provides functions to check if a control must
'really be refreshed or if no property has been changed since last refreshing.
'The functionality of the UpdateCheck functions has been verified successfully.
'For 20 controls the speed increase is around 10%.
Private Sub UpdateCheck_Save(ByVal SEControlStructIndex As Integer, ByVal SEControlStructNumber As Integer, ByRef SEControlStructArray() As SEControlStruct)
'on error resume next
'DEBUG
Exit Sub 'see [...]_WasChanged()
'
If Not (UpdateCheckStructNumber = SEControlStructNumber) Then
'allocate memory for the SEControlStructArray() copy
UpdateCheckStructNumber = SEControlStructNumber
If Not (UpdateCheckStructNumber = 0) Then 'verify
ReDim UpdateCheckStructArray(1 To UpdateCheckStructNumber) As SEControlStruct
Else
ReDim UpdateCheckStructArray(1 To 1) As SEControlStruct 'reset
End If
End If
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > UpdateCheckStructNumber)) Then 'verify
'NOTE: do not use '=' as strings will be copied and UpdatCheckStructArray() contains other reference numbers.
Call CopyMemory(ByVal VarPtr(UpdateCheckStructArray(SEControlStructIndex).SEControlName), ByVal VarPtr(SEControlStructArray(SEControlStructIndex).SEControlName), Len(SEControlStructArray(SEControlStructIndex)))
End If
End Sub
Private Function UpdateCheck_WasChanged(ByVal SEControlStructIndex As Integer) As Boolean
'on error resume next 'returns True if ANY control property has been changed since last call of UpdateCheck_Save
Dim ByteString1() As Byte
Dim ByteString2() As Byte
Dim Temp As Long
'DEBUG
UpdateCheck_WasChanged = True '***TEMP***
Exit Function
'NOTE: when using CopyMemory() mysterious errors occur when
'reloading the SkinDataFile and changing the back picture of a form (?).
'begin
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > UpdateCheckStructNumber)) Then 'verify
If Not ((SEControlStructIndex < 1) Or (SEControlStructIndex > SEControlStructNumber)) Then 'verify
ReDim ByteString1(1 To Len(SEControlStructArray(SEControlStructIndex))) As Byte
ReDim ByteString2(1 To Len(SEControlStructArray(SEControlStructIndex))) As Byte
'NOTE: it seems like one must use 'ByVal VarPtr()' on public vars or mysterious errors will happen.
Call CopyMemory(ByteString1(1), ByVal VarPtr(SEControlStructArray(SEControlStructIndex).SEControlName), Len(SEControlStructArray(SEControlStructIndex)))
Call CopyMemory(ByteString2(1), ByVal VarPtr(UpdateCheckStructArray(SEControlStructIndex).SEControlName), Len(UpdateCheckStructArray(SEControlStructIndex)))
For Temp = 1 To Len(SEControlStructArray(SEControlStructIndex))
If Not (ByteString1(Temp) = ByteString2(Temp)) Then
UpdateCheck_WasChanged = True
Exit Function
End If
Next Temp
UpdateCheck_WasChanged = False
Else
UpdateCheck_WasChanged = True 'if UpdateCheckStructArray() has not been initialized yet
End If
Else
UpdateCheck_WasChanged = True 'if UpdateCheckStructArray() has not been initialized yet
End If
Exit Function
End Function
'**********************************END OF UPDATECHECK***********************************
'****************************************SEFONT*****************************************
'NOTE: the functions of the SEFont sub system verify a font can be transferred
'from one machine to an other (important when exporting a skin).
Private Function SEFont_GetFontFileList(ByRef FontNameNumber As Integer, ByRef FontNameArray() As String, ByRef FontFileArray() As String) As Boolean
'on error resume next 'initializes the passed array with the full name of the font files and font names itself related to the fonts used in the current skin; returns True for success or False for error
Dim StructLoop As Integer
Dim TestLoop As Integer
Dim FontFileName As String
Dim FontDirectory As String
Dim FontFile As String
'reset
FontNameNumber = 0 'reset
ReDim FontNameArray(1 To 1) As String 'reset
ReDim FontFileArray(1 To 1) As String 'reset
'preset
FontDirectory = GFGetSpecialFolderLocation(CSIDL_FONTS)
If DirSave(FontDirectory, vbDirectory) = "" Then FontDirectory = GFShellRegistration_GetWinDir + "FONTS\"
If DirSave(FontDirectory, vbDirectory) = "" Then GoTo Error:
If Not (Right$(FontDirectory, 1) = "\") Then FontDirectory = FontDirectory + "\" 'verify
'begin
For StructLoop = 1 To SEControlStructNumber
If (Len(SEControlStructArray(StructLoop).SEControl_Font.Name)) Then 'verify
For TestLoop = 1 To FontNameNumber
If UCase$(FontNameArray(TestLoop)) = UCase$(SEControlStructArray(StructLoop).SEControl_Font.Name) Then
GoTo Jump:
End If
Next TestLoop
FontFileName = GFFont_FontNameToFontFileName(SEControlStructArray(StructLoop).SEControl_Font.Name)
'
'NOTE: somehow I couldn't manage to get the name of non‑TrueType
'fonts, if [...].SEControl_Font.Name is e.g. 'Terminal' then FontFileName
'will be "". We just don't add this font and hope the receiver has
'the font installed, if not the Skin Engine will automatically use 'Arial'.
'
If FontFileName = "" Then GoTo Jump: 'GoTo Error: 'verify
FontFile = FontDirectory + FontFileName
If DirSave(FontFile) = "" Then GoTo Jump: 'GoTo Error: 'verify
FontNameNumber = FontNameNumber + 1
ReDim Preserve FontNameArray(1 To FontNameNumber) As String
ReDim Preserve FontFileArray(1 To FontNameNumber) As String
FontNameArray(FontNameNumber) = SEControlStructArray(StructLoop).SEControl_Font.Name
FontFileArray(FontNameNumber) = FontFile
Jump:
End If
Next StructLoop
SEFont_GetFontFileList = True 'ok
Exit Function
Error:
SEFont_GetFontFileList = False 'error
Exit Function
End Function
'***SEFONTFILE***
'
'NOTE: the SEFontFile is included within the SkinPacketFile.
'The SEFontFile contains a list of the font names and related font files
'used by the transferred skin.
'The file is necessary to know under which font name a font file must
'be installed on the target machine where the skin is imported.
'
'The SEFontFile is named 'Font.dat' and is located in the current skin's
'directory when the skin is packed. After 'Font.dat' has been packed
'it is deleted from the exporting machine's hd. The importing machine
'also deletes 'Font.dat' after all fonts of the skin to import have been
'registered.
'
Private Function SEFontFile_Write(ByVal FontNameNumber As Integer, ByRef FontNameArray() As String, ByRef FontFileArray() As String) As String
On Error GoTo Error: 'if disk full or whatever; returns a temp file name (full path) if successful, or nothing ("") if any error occurred
Dim TempFile As String
Dim TempFileNumber As String
Dim FontNameLoop As Integer
'
'NOTE: the calling sub/function must delete the returned temp file
'after processing its data.
'
'preset
TempFile = GFShellRegistration_GetWinTempDir + "Font.dat" 'let's continue wasting space there
'
'NOTE: the file name of the FontFile must be the final name,
'do not use GenerateTempFileName().
'
'begin
TempFileNumber = FreeFile(0)
Open TempFile For Output As TempFileNumber
For FontNameLoop = 1 To FontNameNumber
Print #TempFileNumber, GetLongString(Len(FontNameArray(FontNameLoop)));
Print #TempFileNumber, FontNameArray(FontNameLoop);
Print #TempFileNumber, GetLongString(Len(FontFileArray(FontNameLoop)));
Print #TempFileNumber, FontFileArray(FontNameLoop);
Next FontNameLoop
Close #TempFileNumber
SEFontFile_Write = TempFile 'ok
Exit Function
Error:
Close #TempFileNumber 'make sure file is closed
SEFontFile_Write = "" 'error
Exit Function
End Function
Private Function SEFontFile_Read(ByVal SEFontFile As String, ByRef FontNameNumber As Integer, ByRef FontNameArray() As String, ByRef FontFileArray() As String) As Boolean
'on error resume next 'returns true for success, False for error
Dim SEFontFileNumber As Integer
Dim SEFontFileStringLength As Long
Dim SEFontFileString As String
Dim FontName As String
Dim FontFile As String
'reset
FontNameNumber = 0 'reset
ReDim FontNameArray(1 To 1) As String 'reset
ReDim FontFileArray(1 To 1) As String 'reset
'verify
If (DirSave(SEFontFile) = "") Or (Right$(SEFontFile, 1) = "\") Or (SEFontFile = "") Then 'verify
SEFontFile_Read = False 'error
Exit Function
End If
'begin
SEFontFileNumber = FreeFile(0)
Open SEFontFile For Binary As #SEFontFileNumber
Do While Not (EOF(SEFontFileNumber) Or (Seek(SEFontFileNumber) = LOF(SEFontFileNumber)))
SEFontFileString = String$(4, Chr$(0)) 'read font name length
Get #SEFontFileNumber, , SEFontFileString
SEFontFileStringLength = GetStringLong(SEFontFileString)
SEFontFileString = String$(SEFontFileStringLength, Chr$(0))
Get #SEFontFileNumber, , SEFontFileString 'read font name
FontName = SEFontFileString
SEFontFileString = String$(4, Chr$(0)) 'read font file length
Get #SEFontFileNumber, , SEFontFileString
SEFontFileStringLength = GetStringLong(SEFontFileString)
SEFontFileString = String$(SEFontFileStringLength, Chr$(0))
Get #SEFontFileNumber, , SEFontFileString 'read file name
FontFile = SEFontFileString
If Not ((Len(FontName) = 0) Or (Len(FontFile) = 0)) Then 'verify
If FontNameNumber = 32766 Then Exit Do 'verify
FontNameNumber = FontNameNumber + 1
ReDim Preserve FontNameArray(1 To FontNameNumber) As String
ReDim Preserve FontFileArray(1 To FontNameNumber) As String
FontNameArray(FontNameNumber) = FontName
FontFileArray(FontNameNumber) = FontFile
End If
Loop
Close #SEFontFileNumber
SEFontFile_Read = True 'ok
Exit Function
End Function
'***END OF SEFONTFILE***
'*************************************END OF SEFONT*************************************
'**********************************SKIN ADMINISTRATION**********************************
'NOTE: the following subs/functions are part of the skin sub system.
'
'NOTE: about skin selection:
'There is the SystemSkinBaseDirectory, which represents the directory
'that contains skin sub directories (one sub directory per skin).
'
'By default there must be the following skin directory:
'SystemSkinBaseDirectory + "BaseSkin\" (8.3 format).
'
'After initializing the target project should instantly call Skin_Change(d$),
'where d$ is the new sub dir name (equal to skin name).
'If it doesn't the base skin will be used.
'If there is no base skin anymore, an error message will appear and
'skinning will fail.
'The target projects should use SkinDataFile_Load(SE_GetSkinDataFile)
'to load the selected skin.
'
'NOTE: it is possible to delay the 'skinning' of controls until they become
'visible (decreases loading time) by assigning a palette number to
'them (0 by default).
'To create palettes, insert 'system_palettenumber=x' into the
'SkinDataFile, all controls following this line will be updated once the
'first time SE_RefreshAll(x) is called.
'SECommands have an extended handling, their pictures are removed
'from the OS memory if their related palette has lost the focus,
'and are reloaded if the related palette is loaded.
'A control that is assigned to the default palette (‑1) will not be unloaded.
Public Function Skin_Change(ByVal SkinNameOrNothing As String) As Boolean
'On Error Resume Next 'sets the new skin directory name (does not update system), if passed file name is nothing ("") the base skin will be used
Dim SkinDirectoryNew As String
Dim ErrorFlag As Boolean
'
'NOTE: function returns True if passed skin was enabled, False if not.
'If "" was passed to enable the base skin then this function will return
'False too, as the name of the enabled skin does not match the passed
'name.
'
'NOTE: it is from importance that "" can be passed as then using this
'sub for initialization purposes is possible.
'NOTE: always call this sun to change the current skin name.
'The system should call SEToReg after using this sub.
'
'preset
'
'NOTE: it is important that the UserMove system is completely disabled
'when changing the skin to make sure the password protection cannot be
'fooled.
'
Call SEM_UserMove_Disable
'begin
ReDo:
ErrorFlag = False 'reset
If Not (SkinNameOrNothing = "") Then
SkinDirectoryNew = SESystemStructVar.SystemSkinBaseDirectory + SkinNameOrNothing
If Not (Right$(SkinDirectoryNew, 1) = "\") Then SkinDirectoryNew = SkinDirectoryNew + "\" 'verify
If DirSave(SkinDirectoryNew + "Skin.dat") = "" Then ErrorFlag = True
SESystemStructVar.SystemSkinEncryptedFlag = SE_IsFileEncrypted(SkinDirectoryNew + "skin.dat")
SESystemStructVar.SystemSkinUserEditPassword = SE_GetFileEncryptionPassword(SkinDirectoryNew + "skin.dat")
SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag = False 'reset
SESystemStructVar.SystemSkinUserEditPasswordHintText = SE_GetFileEncryptionPasswordHintText(SkinDirectoryNew + "skin.dat")
If ErrorFlag = False Then _
If SkinDataFile_Verify(SkinDirectoryNew + "Skin.dat") = False Then ErrorFlag = True
If ErrorFlag = False Then 'verify
SESystemStructVar.SystemSkinDirectory = SkinDirectoryNew
SESystemStructVar.SystemSkinNameCurrent = GetCurrentSkinName
SESystemStructVar.SystemSkinEncryptedFlag = Skin_IsSkinEncrypted
SESystemStructVar.SystemSkinUserEditPassword = Skin_GetUserEditPassword
SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag = False 'reset
SESystemStructVar.SystemSkinUserEditPasswordHintText = Skin_GetUserEditPasswordHintText
Call SEToReg 'save changes
Call SE_DeleteTempFiles(SESystemStructVar.SystemSkinDirectory)
Call SE_ForwardCallBackMessage(SECBMSG_DISPLAY_SKIN_NAME, SESystemStructVar.SystemSkinNameCurrent, "")
Skin_Change = True 'ok
Else
MsgBox "Error: the skin directory '" + SkinDirectoryNew + "' was not found or its content is invalid, the default skin will be used !", vbOKOnly + vbExclamation
SkinNameOrNothing = "" 'reset (error, use default skin)
SESystemStructVar.SystemSkinDirectory = "" 'error
SESystemStructVar.SystemSkinNameCurrent = "ERROR" 'error (use 'ERROR')
SESystemStructVar.SystemSkinEncryptedFlag = False 'error
SESystemStructVar.SystemSkinUserEditPassword = "" 'error
SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag = False 'reset
SESystemStructVar.SystemSkinUserEditPasswordHintText = "" 'reset
GoTo ReDo:
End If
Else
SkinDirectoryNew = SESystemStructVar.SystemSkinBaseDirectory + "BASESKIN\"
If Not (Right$(SkinDirectoryNew, 1) = "\") Then SkinDirectoryNew = SkinDirectoryNew + "\" 'verify
If DirSave(SkinDirectoryNew + "Skin.dat") = "" Then ErrorFlag = True
SESystemStructVar.SystemSkinEncryptedFlag = SE_IsFileEncrypted(SkinDirectoryNew + "skin.dat")
SESystemStructVar.SystemSkinUserEditPassword = SE_GetFileEncryptionPassword(SkinDirectoryNew + "skin.dat")
SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag = False 'reset
SESystemStructVar.SystemSkinUserEditPasswordHintText = SE_GetFileEncryptionPasswordHintText(SkinDirectoryNew + "skin.dat")
If ErrorFlag = False Then _
If SkinDataFile_Verify(SkinDirectoryNew + "Skin.dat") = False Then ErrorFlag = True
If ErrorFlag = False Then 'verify
SESystemStructVar.SystemSkinDirectory = SkinDirectoryNew 'ok
SESystemStructVar.SystemSkinNameCurrent = GetCurrentSkinName
SESystemStructVar.SystemSkinEncryptedFlag = Skin_IsSkinEncrypted
SESystemStructVar.SystemSkinUserEditPassword = Skin_GetUserEditPassword
SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag = False 'reset
SESystemStructVar.SystemSkinUserEditPasswordHintText = Skin_GetUserEditPasswordHintText
Call SEToReg 'save changes
Call SE_DeleteTempFiles(SESystemStructVar.SystemSkinDirectory)
Call SE_ForwardCallBackMessage(SECBMSG_DISPLAY_SKIN_NAME, SESystemStructVar.SystemSkinNameCurrent, "")
Skin_Change = False 'error
Else
MsgBox "Error: the default skin was not found or is invalid !" + Chr$(10) + "Skins are not available, please reinstall this propgram !", vbOKOnly + vbCritical
SESystemStructVar.SystemSkinDirectory = "" 'error
SESystemStructVar.SystemSkinNameCurrent = "ERROR" 'error (use 'ERROR')
SESystemStructVar.SystemSkinEncryptedFlag = False 'error
SESystemStructVar.SystemSkinUserEditPassword = "" 'error
SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag = False 'reset
SESystemStructVar.SystemSkinUserEditPasswordHintText = "" 'reset
'NOTE: the target project should unload itself if the following message arrives.
Call SE_ForwardCallBackMessage(SECBMSG_SKIN_ENGINE_NOT_AVAILABLE, "", "")
Skin_Change = False 'error
End If
End If
End Function
'***SKIN HELP FUNCTIONS***
'NOTE: the following function return a skin name gotten out of
'different 'kinds' of input data.
Public Function GetSkinNameFromSkinDataFile(ByVal SkinDataFile As String) As String
'On Error Resume Next
Dim SkinDataFileDirectory As String
'
'NOTE: the SkinDataFile (name) has the following format:
'SESystemStructVar.SystemSkinBaseDirectory + SkinName + "\" + "skin.dat"
'
'preset
GetSkinNameFromSkinDataFile = "" 'preset (error)
'verify
If SkinDataFile = "" Then Exit Function 'error
'begin
SkinDataFileDirectory = GetDirectoryName(SkinDataFile)
GetSkinNameFromSkinDataFile = _
GetFileName(Left$(SkinDataFileDirectory, Len(SkinDataFileDirectory) ‑ 1))
End Function
Public Function GetSkinNameFromSkinDirectory(ByVal SkinDirectory As String) As String
'On Error Resume Next 'returns skin name or nothing ("") for error
Dim SkinBaseDirectory As String
'preset
If Right$(SkinDirectory, 1) = "\" Then SkinDirectory = Left$(SkinDirectory, Len(SkinDirectory) ‑ 1) 'remove backslash to allow using GetFileName()
'verify
SkinBaseDirectory = GetDirectoryName(SkinDirectory)
If Not (UCase(SkinBaseDirectory) = UCase$(SESystemStructVar.SystemSkinBaseDirectory)) Then
GetSkinNameFromSkinDirectory = "" 'error
Exit Function
End If
'begin
GetSkinNameFromSkinDirectory = GetFileName(SkinDirectory)
End Function
Private Function GetSkinNameFromMenuIndex(ByVal M8MenuIndex As Integer) As String
'On Error Resume Next 'returns skin name or nothing ("") for error
'
'NOTE: do not use the M8().Caption property as skin name, as the
'base skin caption differs from the base skin name.
'
If Not ((M8MenuIndex < GFSkinEngine_MENUfrm.M8.LBound) Or (M8MenuIndex > GFSkinEngine_MENUfrm.M8.UBound)) Then 'verify
'NOTE: the full skin directory name is converted into the skin name.
GetSkinNameFromMenuIndex = GetSkinNameFromSkinDirectory(GFSkinEngine_MENUfrm.M8(M8MenuIndex).Tag)
Else
GetSkinNameFromMenuIndex = "" 'reset (error)
End If
End Function
Public Function GetCurrentSkinName() As String
'On Error Resume Next
'
'NOTE: this sub may merely use the value of
'SESystemStructVar.SystemSkinDirectory to determine the current skin name.
'
GetCurrentSkinName = GetSkinNameFromSkinDataFile(SE_GetSkinDataFile)
End Function
Private Function GetRandomSkinName() As String
'On Error Resume Next
Dim SkinNameListStructNumber As Integer
Dim SkinNameListStructArray() As SkinNameListStruct
'
'NOTE: this sub returns either the default skin name, or,
'if there are custom skins existing, a randomly selected custom skin name.
'Note that Skin_GetSkinNameList() will exclude the default skin name from
'the returned skin names.
'
'preset
Call Skin_GetSkinNameList(SkinNameListStructNumber, SkinNameListStructArray())
'begin
Randomize Timer
If Not (SkinNameListStructNumber = 0) Then 'verify
GetRandomSkinName = SkinNameListStructArray(Int((SkinNameListStructNumber ‑ 1 + 1) * Rnd(1) + 1)).SkinName 'return random skin name (default skin not included)
Else
GetRandomSkinName = "" 'return default skin name
End If
End Function
Private Sub Skin_GetSkinNameList(ByRef SkinNameListStructNumber As Integer, ByRef SkinNameListStructArray() As SkinNameListStruct)
'On Error Resume Next 'searches available skin directories and sets the related skin name
Dim DirCurrent As String
Dim DirLoop As Integer
Dim Tempstr$
'
'NOTE: the base skin's directory
'(SESystemStructVar.SystemSkinBaseDirectory + "BASESKIN\")
'will be excluded from skin name list
'(this function returns 0 results if only the base skin is installed).
'
'reset
SkinNameListStructNumber = 0
ReDim SkinNameListStructArray(1 To 1) As SkinNameListStruct
'begin
With GFSkinEnginefrm
.GFSkinEngineDir.Path = SESystemStructVar.SystemSkinBaseDirectory
.GFSkinEngineDir.Refresh
'loop through sub directories and check if they are valid skin directories
For DirLoop = 1 To .GFSkinEngineDir.ListCount
'
DirCurrent = .GFSkinEngineDir.List(DirLoop ‑ 1)
If Not (Right$(DirCurrent, 1) = "\") Then DirCurrent = DirCurrent + "\" 'verify
'
If DirSave(DirCurrent + "Skin.dat") = "" Then GoTo Jump: 'verify directory is really a skin directory
Tempstr$ = DirCurrent
If Right$(Tempstr$, 1) = "\" Then Tempstr$ = Left$(Tempstr$, Len(Tempstr$) ‑ 1)
'NOTE: Tempstr$ has now the following format (example): F:\MP3 Renamer\Skins\BaseSkin.
If UCase(GetFileName(Tempstr$)) = "BASESKIN" Then GoTo Jump: 'do not add base skin to list
If Not (UCase$(GetDirectoryName(Tempstr$)) = UCase$(SESystemStructVar.SystemSkinBaseDirectory)) Then
GoTo Jump:
End If
'NOTE: the current directory is a valid skin directory, add it to return list.
SkinNameListStructNumber = SkinNameListStructNumber + 1 'DirListNumber is from type Integer, too
ReDim Preserve SkinNameListStructArray(1 To SkinNameListStructNumber) As SkinNameListStruct
SkinNameListStructArray(SkinNameListStructNumber).SkinName = GetFileName(Tempstr$)
SkinNameListStructArray(SkinNameListStructNumber).SkinDirectory = DirCurrent
Jump:
Next DirLoop
End With
End Sub
'***END OF SKIN HELP FUNCTIONS***
'***SKIN ENCRYPTION***
'NOTE: when the user exported a skin and entered an Edit Password then
'the exported string is encrypted before being exported.
'The system handles a skin (all the files that belong to the skin) as encrypted
'if the SkinDataFile is encrypted. The system uses SE_IsFileEncrypted()
'to determine if the SkinDataFile is encrypted.
'You always can access
'SESystemStructVar.SystemSkinEncryptedFlag
'SESystemStructVar.SystemSkinUserEditPassword
'SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag,
'these variables are updated when the skin is changed using Skin_Change().
'The system should call Skin_DecryptFile() before accessing any of the
'skin's image files, and it should call Skin_EncryptFile() after file accessing
'is finished. The system will decide if a skin file must be en/decrypted or if
'no cryption is used on its own.
'All following functions refer to the current skin.
'
'NOTE: to verify EVERY file of the current skin is encrypted or decrypted
'correctly the system does not check the value of
'SESystemStructVar.SystemSkinEncryptedFlag, but just calls the cryption sub
'functions (they will check if a file's encrypted or not).
'Sub functions that receive a skin file name will decrypt this file automatically,
'for all other functions Skin_DecryptFile() must be called automatically.
'To know where Skin_DecryptFile() must be inserted one must think about
'how many different file 'types' there are in the skin directory:
'‑SkinDataFile: Skin_DecryptFile()/Skin_EncryptFile() must be used when reading
' SDF/changing properties
'‑picture files: Skin_DecryptFile() must be used when accessing picture files via
' the graphics functions, Skin_EncryptFile() must be also used when importing a file
'‑cursor files: de/encryption done in graphics function
'‑FileEx, SkinTransferFile: not encrypted in any case
'
'Generally only functions at lowest level should use the Skin cryption functions.
'
'NOTE: Skin_VerifyUserEditPermission() should be used where user input
'is processed, e.g. in SE_ReceivePopUpMenu_Click or in the key hook
'callback sub.
'Use Skin_VerifyUserEditPermission() after aborting the UserMove ,
'not before to verify the UserMove system really is not enabled.
'
'NOTE: besides editing a skin the user is also not allowed to
'‑copy the skin.
'
'NOTE: 'SkinTransferFile.dat' is NEVER encrypted as this is not necessary
'and would require extra ST code to handle SkinTransferFile encryption.
'IMPORTANT: a skin can ONLY be encrypted when it is exported (see SEM_Export).
'
Private Function Skin_IsSkinEncrypted() As Boolean
'on error resume next 'returns True if the current skin is encrypted, False if not
Skin_IsSkinEncrypted = SE_IsFileEncrypted(SESystemStructVar.SystemSkinDirectory + "skin.dat")
End Function
Private Function Skin_VerifySkinName(ByVal SkinName As String) As Boolean
'on error resume next 'returns True if skin name is valid, False if not (then an error message is created)
Dim Temp As Long
'begin
If Len(SkinName) > 50 Then
MsgBox "Error: skin name is too long (max. 50 chars) !", vbOKOnly + vbExclamation
Skin_VerifySkinName = False 'error
Exit Function
End If
For Temp = 1 To Len(SkinName)
Select Case Mid$(SkinName, Temp, 1)
Case "<", ">", "|", "/", "\", ":", "?", "*", """"
MsgBox "Error: a skin name must not contain the following chars:" + Chr$(10) + "< > | / \ : "" * ? ", vbOKOnly + vbExclamation
Skin_VerifySkinName = False 'error
Exit Function
End Select
Next Temp
Skin_VerifySkinName = True 'ok
Exit Function
End Function
Private Function Skin_GetUserEditPassword() As String
'on error resume next
Skin_GetUserEditPassword = SE_GetFileEncryptionPassword(SESystemStructVar.SystemSkinDirectory + "skin.dat")
End Function
Private Function Skin_GetUserEditPasswordHintText() As String
'on error resume next
Skin_GetUserEditPasswordHintText = SE_GetFileEncryptionPasswordHintText(SESystemStructVar.SystemSkinDirectory + "skin.dat")
End Function
Public Sub Skin_Preload()
'on error resume next
Dim RandomSkinName As String
'
'NOTE: the target project should call this sub after (!) all controls
'have been registered. If it doesn't call this sub
'(e.g. when wanting to load a special skin) then the target project
'must use Skin_Change() before calling SE_DisplayPalette().
'
'begin
Call SEFromReg
Call SEToReg
If SESystemStructVar.SystemSkinRandomSelectFlag = True Then
RandomSkinName = GetRandomSkinName
Call Skin_Change(RandomSkinName)
If SESystemStructVar.SystemSkinRandomSelectDisplayNameFlag = True Then
If Not (UCase$(SESystemStructVar.SystemSkinNameCurrent) = "BASESKIN") Then 'verify there was a skin to randomly select
If MsgBox("Enjoy the randomly selected skin:" + Chr$(10) + Chr$(10) + RandomSkinName + Chr$(10) + Chr$(10) + "(press abort to avoid displaying this message again)", vbOKCancel + vbInformation) = vbCancel Then
SESystemStructVar.SystemSkinRandomSelectDisplayNameFlag = False 'reset
Call SEToReg 'save changes
End If
End If
End If
Else
Call Skin_Change(SESystemStructVar.SystemSkinNameCurrent) 'read out of registry
End If
End Sub
Public Function Skin_VerifyUserEditPermission() As Boolean
'on error resume next 'returns True if the user is allowed to change the current skin, False if not
'
'NOTE: always call this function before allowing the user to do any changes
'on the current skin. If this function returns False, the calling sub/function
'must be left immediately.
'
If SESystemStructVar.SystemSkinEncryptedFlag = True Then
If SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag = False Then
If GFMsgBoxmod.GFInputBox("Please enter password to edit the current skin, hint:" + Chr$(13) + Chr$(10) + SESystemStructVar.SystemSkinUserEditPasswordHintText, "Password", "") = SESystemStructVar.SystemSkinUserEditPassword Then
'
'NOTE: once the user entered the edit password the current
'skin is decrypted and stays decrypted.
'This is important as an unencrypted skin could have stayed
'encrypted when the program crashed during exporting.
'
Call SE_RefreshForms 'remove form‑trash (tested)
Call Skin_Decrypt(SESystemStructVar.SystemSkinDirectory, SESystemStructVar.SystemSkinUserEditPassword)
SESystemStructVar.SystemSkinEncryptedFlag = False
SESystemStructVar.SystemSkinUserEditPasswordEnteredFlag = True
Skin_VerifyUserEditPermission = True
Else
MsgBox "Sorry, the author of the current skin does not want that his/her skin is changed !", vbOKOnly + vbExclamation 'it's not SE's fault! IS NOT!
Skin_VerifyUserEditPermission = False
End If
Else
Skin_VerifyUserEditPermission = True
End If
Else
Skin_VerifyUserEditPermission = True
End If
End Function
Private Sub Skin_Encrypt(ByVal SkinDirectory As String, ByVal UserEditPasswordNew As String, ByVal UserEditPasswordHintTextNew As String)
'on error resume next 'encrypts all files of the current skin
Dim FileLoop As Integer
'NOTE: pass passwords in UNCRYPTED form.
'begin
With GFSkinEnginefrm
.GFSkinEngineFile.Path = SkinDirectory
.GFSkinEngineFile.Pattern = "*.*"
.GFSkinEngineFile.Refresh
'
'NOTE: the SkinDataFile is used by SE to determine if a skin
'is encrypted, thus encrypt it as first file to signalize that SE
'should use decryption when reading the current skin, even if
'the program crashes in the loop below.
'
Call SE_EncryptFile(SkinDirectory + "skin.dat", UserEditPasswordNew, UserEditPasswordHintTextNew)
For FileLoop = 1 To .GFSkinEngineFile.ListCount
Select Case UCase$(.GFSkinEngineFile.List(FileLoop ‑ 1))
Case "SKINTRANSFERFILE.DAT", "FONT.DAT"
'NOTE: the SkinTransferFile is never encrypted (passwords saved in encrypted form could become visible).
Case Else
If Not (LCase(.GFSkinEngineFile.List(FileLoop ‑ 1)) = "skin.dat") Then
Call SE_EncryptFile(SkinDirectory + .GFSkinEngineFile.List(FileLoop ‑ 1), UserEditPasswordNew, UserEditPasswordHintTextNew)
End If
End Select
Next FileLoop
End With
End Sub
Private Sub Skin_Decrypt(ByVal SkinDirectory As String, ByVal UserEditPassword As String)
'on error resume next 'decrypts all files of the current skin
Dim FileLoop As Integer
'begin
With GFSkinEnginefrm
.GFSkinEngineFile.Path = SkinDirectory
.GFSkinEngineFile.Pattern = "*.*"
.GFSkinEngineFile.Refresh
For FileLoop = 1 To .GFSkinEngineFile.ListCount
If Not (LCase$(.GFSkinEngineFile.List(FileLoop ‑ 1)) = "skin.dat") Then
Call SE_DecryptFile(SkinDirectory + .GFSkinEngineFile.List(FileLoop ‑ 1), UserEditPassword)
End If
Next FileLoop
'
'NOTE: decrypt the SkinDataFile as last file as its content is used to determine
'if a skin is encrypted or not. If SE crashes during decrypting a skin,
'the skin will still be seen as encrypted until it was decrypted a second time
'(SE will still decrypt all files before reading their content).
'
Call SE_DecryptFile(SkinDirectory + "skin.dat", UserEditPassword)
End With
End Sub
Public Function Skin_EncryptFile(ByVal SkinFile As String)
'on error resume next
If SESystemStructVar.SystemSkinEncryptedFlag = True Then 'verify encryption is enabled
Call SE_EncryptFile(SkinFile, SESystemStructVar.SystemSkinUserEditPassword, SESystemStructVar.SystemSkinUserEditPasswordHintText)
End If
End Function
Public Function Skin_DecryptFile(ByVal SkinFile As String)
'on error resume next
If SESystemStructVar.SystemSkinEncryptedFlag = True Then 'verify encryption is enabled
'NOTE: without checking encryption flag the skinning will become slow for uncrypted skins.
Call SE_DecryptFile(SkinFile, SESystemStructVar.SystemSkinUserEditPassword)
End If
End Function
'******************************END OF SKIN ADMINISTRATION*******************************
'**************************************SE CRYPTION**************************************
Public Function SE_CryptString(ByVal CryptionString As String) As String
'on error resume next 'use e.g. for passwords in SkinTransferFile
Dim Temp As Long
'begin
For Temp = 1 To Len(CryptionString)
Mid$(CryptionString, Temp, 1) = Chr$(Asc(Mid$(CryptionString, Temp, 1)) Xor (64& + (Temp Mod 8&) ‑ (Len(CryptionString) Mod 10&)))
Next Temp
SE_CryptString = CryptionString
End Function
Private Sub SE_CryptByteString(ByVal ByteStringLength As Long, ByRef ByteString() As Byte, ByVal CryptionStep As Long)
'on error resume next 'use to crypt a file's content
Dim Temp As Long
'
'NOTE: this function should be use to crypt an image file's content.
'The larger the file is the greater CryptionStep should be to increase speed.
'
For Temp = 1 To ByteStringLength Step CryptionStep
ByteString(Temp) = ByteString(Temp) Xor 64& 'must be fast, not good
Next Temp
End Sub
'NOTE: about SE file cryption:
'The SE file cryption is used to encrypt a skin directory's content if the creator
'of the skin uses an Edit Password. The file cryption functions must not be good,
'but fast as a lot of files may be encrypted/decrypted during the skin usage.
'The encryption is good enough when the encrypted image cannot be displayed
'anymore by a graphics program.
'
'A file that was encrypted using SE_EncryptFile() has the following format:
'SE FILE CRYPTION v1.0xxxxpppppppyyyyhhhhhhhh[...]
'SE FILE CRYPTION: sign that file is encrypted
' v1.0: five chars reserved for version information
'xxxx: length of password (p)
'p: chars of encrypted password, has been encrypted using SE_CryptString()
'yyyy: length of password hint text (h)
'h: chars of encrypted password hint text, has been encrypted using SE_CryptString()
'[...]: encrypted file data
'The whole string until the encrypted file data is called HeaderString.
Public Function SE_IsFileEncrypted(ByVal FileName As String) As Boolean
'on error resume next 'returns True if passed file (full path) was encrypted using SE_EncryptFile(), False if not
Dim FileNameNumber As Integer
Dim FileNameString As String
'verify
If (DirSave(FileName) = "") Or (Right$(FileName, 1) = "\") Or (FileName = "") Then 'verify
SE_IsFileEncrypted = False 'error
Exit Function
End If
'check if file is already encrypted
FileNameNumber = FreeFile(0)
Open FileName For Binary As #FileNameNumber
FileNameString = String$(16, Chr$(0))
Get #FileNameNumber, 1, FileNameString
Close #FileNameNumber
If FileNameString = "SE FILE CRYPTION" Then
SE_IsFileEncrypted = True 'file is encrypted
Exit Function
Else
SE_IsFileEncrypted = False 'file is not encrypted
Exit Function
End If
End Function
Private Function SE_GetFileEncryptionPassword(ByVal FileName As String) As String
'on error resume next 'returns the password required to decrypt a file (password is saved in every encrypted file), or "" if there is no password (password may also be "")
Dim FileNameNumber As Integer
Dim FileNameString As String
Dim DecryptionPassword As String
Dim DecryptionPasswordLength As Long
'verify
If (DirSave(FileName) = "") Or (Right$(FileName, 1) = "\") Or (FileName = "") Then 'verify
SE_GetFileEncryptionPassword = "" 'reset (error)
Exit Function
End If
'check if file is already encrypted
FileNameNumber = FreeFile(0)
Open FileName For Binary As #FileNameNumber
FileNameString = String$(16, Chr$(0))
Get #FileNameNumber, 1, FileNameString
If FileNameString = "SE FILE CRYPTION" Then
DecryptionPassword = String$(4, Chr$(0)) 'temporary use of DecryptionPassword for storing password length information
Get #FileNameNumber, 22, DecryptionPassword
DecryptionPasswordLength = GetStringLong(DecryptionPassword)
DecryptionPassword = String$(DecryptionPasswordLength, Chr$(0))
Get #FileNameNumber, , DecryptionPassword
Close #FileNameNumber 'make sure file is closed
SE_GetFileEncryptionPassword = SE_CryptString(DecryptionPassword)
Exit Function
Else
Close #FileNameNumber 'make sure file is closed
SE_GetFileEncryptionPassword = "" 'reset (file is not encrypted)
Exit Function
End If
Close #FileNameNumber
End Function
Private Function SE_GetFileEncryptionPasswordHintText(ByVal FileName As String) As String
'on error resume next 'returns the password hint text stored in file (may be "")
Dim FileNameNumber As Integer
Dim FileNameString As String
Dim DecryptionPassword As String
Dim DecryptionPasswordLength As Long
Dim DecryptionPasswordHintText As String
Dim DecryptionPasswordHintTextLength As Long
'verify
If (DirSave(FileName) = "") Or (Right$(FileName, 1) = "\") Or (FileName = "") Then 'verify
SE_GetFileEncryptionPasswordHintText = "" 'reset (error)
Exit Function
End If
'check if file is already encrypted
FileNameNumber = FreeFile(0)
Open FileName For Binary As #FileNameNumber
FileNameString = String$(16, Chr$(0))
Get #FileNameNumber, 1, FileNameString
If FileNameString = "SE FILE CRYPTION" Then
DecryptionPassword = String$(4, Chr$(0)) 'temporary use of DecryptionPassword for storing password length information
Get #FileNameNumber, 22, DecryptionPassword
DecryptionPasswordLength = GetStringLong(DecryptionPassword)
DecryptionPassword = String$(DecryptionPasswordLength, Chr$(0))
Get #FileNameNumber, , DecryptionPassword
DecryptionPasswordHintText = String$(4, Chr$(0)) 'temporary use of DecryptionPasswordHintText for storing PasswordHintText length information
Get #FileNameNumber, , DecryptionPasswordHintText
DecryptionPasswordHintTextLength = GetStringLong(DecryptionPasswordHintText)
DecryptionPasswordHintText = String$(DecryptionPasswordHintTextLength, Chr$(0))
Get #FileNameNumber, , DecryptionPasswordHintText
Close #FileNameNumber 'make sure file is closed
SE_GetFileEncryptionPasswordHintText = SE_CryptString(DecryptionPasswordHintText)
Exit Function
Else
Close #FileNameNumber 'make sure file is closed
SE_GetFileEncryptionPasswordHintText = "" 'reset (file is not encrypted)
Exit Function
End If
Close #FileNameNumber
End Function
Public Function SE_EncryptFile(ByVal EncryptionName As String, ByVal EncryptionPassword As String, ByVal EncryptionPasswordHintText As String) As Boolean
'on error resume next 'returns True if file has been encrypted, False if not
Dim EncryptionNameNumber As Integer
Dim EncryptionNameString As String
Dim HeaderString As String
Dim HeaderStringLength As Long
Dim BlockEndPos As Long 'file is read backwards
Dim BlockLength As Long
Dim BlockString As String
Dim BlockStringByte() As Byte
Dim CryptionStep As Long 'how many chars are not encrypted (1: encrypt all chars)
Dim Tempstr$
'verify
If (DirSave(EncryptionName) = "") Or (Right$(EncryptionName, 1) = "\") Or (EncryptionName = "") Then 'verify
SE_EncryptFile = False 'error
Exit Function
End If
'check if file is already encrypted
EncryptionNameNumber = FreeFile(0)
Open EncryptionName For Binary As #EncryptionNameNumber
EncryptionNameString = String$(16, Chr$(0))
Get #EncryptionNameNumber, 1, EncryptionNameString
Close #EncryptionNameNumber
If EncryptionNameString = "SE FILE CRYPTION" Then
SE_EncryptFile = True 'file is already encrypted
Exit Function
Else
Debug.Print "ENCRYPTING: " + EncryptionName 'DEBUG
End If
'enlarge file
HeaderString = "SE FILE CRYPTION v1.0" + GetLongString(Len(EncryptionPassword)) + SE_CryptString(EncryptionPassword) + GetLongString(Len(EncryptionPasswordHintText)) + SE_CryptString(EncryptionPasswordHintText)
HeaderStringLength = Len(HeaderString)
Open EncryptionName For Append As #EncryptionNameNumber
Print #EncryptionNameNumber, HeaderString; 'write any garbage with the length of the HeaderString at the end to enlarge file (I think this is faster than using GFEnlargeFile())
Close #EncryptionNameNumber
'encrypt file in blocks, starting at end of file as its content must be moved 'backwards' by the length of HeaderString
Open EncryptionName For Binary As #EncryptionNameNumber
Select Case LOF(EncryptionNameNumber)
Case Is < 4096
CryptionStep = 1
Case Is < 10240
CryptionStep = 2
Case Is < 64000
CryptionStep = 3
Case Else
CryptionStep = 4
End Select
BlockEndPos = LOF(EncryptionNameNumber) ‑ HeaderStringLength
Do
BlockLength = 512000 'preset
If (BlockEndPos ‑ BlockLength + 1) < 1 Then 'verify
BlockLength = BlockEndPos
End If
If BlockLength = 0 Then Exit Do
BlockString = String$(BlockLength, Chr$(0))
ReDim BlockStringByte(1 To BlockLength) As Byte
Get #EncryptionNameNumber, (BlockEndPos ‑ BlockLength + 1), BlockString
Call CopyMemory(BlockStringByte(1), ByVal BlockString, BlockLength)
Call SE_CryptByteString(BlockLength, BlockStringByte(), CryptionStep)
Call CopyMemory(ByVal BlockString, BlockStringByte(1), BlockLength) 'length of BlockString has not changed
Put #EncryptionNameNumber, (BlockEndPos ‑ BlockLength + 1 + HeaderStringLength), BlockString 'put data HeaderStringLength bytes behind orginal position to create space for header string at file beginning
BlockEndPos = BlockEndPos ‑ BlockLength
Loop
Put #EncryptionNameNumber, 1, HeaderString
Close #EncryptionNameNumber
SE_EncryptFile = True 'ok
Exit Function
End Function
Public Function SE_DecryptFile(ByVal DecryptionName As String, ByVal DecryptionPassword As String) As Boolean
'on error resume next 'returns True for success or False for error (e.g. if password is wrong)
Dim DecryptionNameNumber As Integer
Dim DecryptionNameString As String
Dim DecryptionNameLength As Long
Dim DecryptionPasswordLength As Long
Dim DecryptionPasswordHintTextLength As Long
Dim HeaderStringLength As Long
Dim BlockStartPos As Long 'file is read forwards
Dim BlockLength As Long
Dim BlockString As String
Dim BlockStringByte() As Byte
Dim CryptionStep As Long 'how many chars are not encrypted (1: encrypt all chars)
Dim Tempstr$
'verify
If (DirSave(DecryptionName) = "") Or (Right$(DecryptionName, 1) = "\") Or (DecryptionName = "") Then 'verify
SE_DecryptFile = False 'error
Exit Function
End If
'check if file has really been encrypted
DecryptionNameNumber = FreeFile(0)
Open DecryptionName For Binary As #DecryptionNameNumber
DecryptionNameString = String$(16, Chr$(0))
Get #DecryptionNameNumber, 1, DecryptionNameString
Close #DecryptionNameNumber
If Not (DecryptionNameString = "SE FILE CRYPTION") Then
SE_DecryptFile = True 'file is not encrypted
Exit Function
Else
Debug.Print "DECRYPTING: " + DecryptionName 'DEBUG
End If
'check password and decrypt file
Open DecryptionName For Binary As #DecryptionNameNumber
Tempstr$ = String$(4, Chr$(0))
Get #DecryptionNameNumber, 22, Tempstr$
DecryptionPasswordLength = GetStringLong(Tempstr$)
Tempstr$ = String$(DecryptionPasswordLength, Chr$(0))
Get #DecryptionNameNumber, , Tempstr$
If Not (SE_CryptString(DecryptionPassword) = Tempstr$) Then
Close #DecryptionNameNumber 'make sure file is closed
SE_DecryptFile = False 'error (wrong password)
Exit Function
End If
Tempstr$ = String$(4, Chr$(0))
Get #DecryptionNameNumber, , Tempstr$
DecryptionPasswordHintTextLength = GetStringLong(Tempstr$)
Tempstr$ = String$(DecryptionPasswordHintTextLength, Chr$(0))
Get #DecryptionNameNumber, , Tempstr$
HeaderStringLength = 21 + 4 + DecryptionPasswordLength + 4 + DecryptionPasswordHintTextLength
Select Case LOF(DecryptionNameNumber) ‑ HeaderStringLength
Case Is < 4096
CryptionStep = 1
Case Is < 10240
CryptionStep = 2
Case Is < 64000
CryptionStep = 3
Case Else
CryptionStep = 4
End Select
BlockStartPos = HeaderStringLength + 1
Do
If (BlockStartPos = HeaderStringLength + 1) Then
'
'NOTE: the first block is read. When encrypting we looped backwards,
'so the first block is the one that was was encrypted at the end and thus
'needn't be exactly 512000 bytes long.
'When we loop forwards here the first block in the file must be as large
'as the last block that was encrypted, otherwise errors occur.
'
BlockLength = ((LOF(DecryptionNameNumber) ‑ HeaderStringLength) Mod 512000)
Else
BlockLength = 512000 'preset
End If
If (BlockStartPos + BlockLength ‑ 1) > LOF(DecryptionNameNumber) Then 'verify
BlockLength = LOF(DecryptionNameNumber) ‑ BlockStartPos + 1
End If
If BlockLength = 0 Then Exit Do
BlockString = String$(BlockLength, Chr$(0))
ReDim BlockStringByte(1 To BlockLength) As Byte
Get #DecryptionNameNumber, BlockStartPos, BlockString
Call CopyMemory(BlockStringByte(1), ByVal BlockString, BlockLength)
Call SE_CryptByteString(BlockLength, BlockStringByte(), CryptionStep)
Call CopyMemory(ByVal BlockString, BlockStringByte(1), BlockLength) 'length of BlockString has not changed
Put #DecryptionNameNumber, BlockStartPos ‑ HeaderStringLength, BlockString 'overwrite header string
BlockStartPos = BlockStartPos + BlockLength
Loop
DecryptionNameLength = LOF(DecryptionNameNumber)
Close #DecryptionNameNumber
Call GFShrinkFile(DecryptionName, DecryptionNameLength ‑ HeaderStringLength)
SE_DecryptFile = True 'ok
Exit Function
End Function
'**********************************END OF SE CRYPTION***********************************
'***********************************GENERAL FUNCTIONS***********************************
'NOTE: some of the general function were changed because 'Me' is not a form
'but a module that cannot hold controls and has no hWnd.
Private Function GFSetWindowStyle(ByVal WindowHandle As Long, ByVal Style As Long, ByVal StyleEnabledFlag As Boolean)
'On Error Resume Next 'use to enable or disable a window style
Dim WindowStyleMaskOld As Long
'
WindowStyleMaskOld = GetWindowLong(WindowHandle, GWL_STYLE)
'
If StyleEnabledFlag = True Then
GFSetWindowStyle = SetWindowLong(WindowHandle, GWL_STYLE, WindowStyleMaskOld Or Style)
Else
GFSetWindowStyle = SetWindowLong(WindowHandle, GWL_STYLE, WindowStyleMaskOld Xor Style)
End If
End Function
'***COMMONDIALOG FUNCTIONS***
Private Function GFSelectDirectory(ByVal RootDirectory As String, ByVal InfoText As String) As String
'On Error Resume Next 'v1.0 ‑ does not support a root directory
Dim BROWSEINFOVar As BROWSEINFO
Dim Temp As Long
Dim Tempstr$
'preset
'BROWSEINFOVar.pidlRoot = RootDirectory 'does not work
BROWSEINFOVar.hOwner = 0 'do not use an owner form (module ?)
BROWSEINFOVar.pszDisplayName = String$(MAX_PATH, Chr$(0)) 'display name (i.e. 'Windows' for C:\Windows\)
BROWSEINFOVar.lpszTitle = InfoText
BROWSEINFOVar.ulFlags = BIF_RETURNONLYFSDIRS 'file system directories only
BROWSEINFOVar.lpfn = 0 'address of event call‑back function
BROWSEINFOVar.lParam = 0 'parameter that would be passed to event call‑back function
'begin
Temp = SHBrowseForFolder(BROWSEINFOVar)
'return selected folder
'BROWSEINFOVar.pszDisplayName 'display name of selected folder
'BROWSEINFOVar.iImage 'image of selected item in system image list
If Not (Temp = 0) Then 'verify
Tempstr$ = String$(MAX_PATH, Chr$(0))
Call SHGetPathFromIDList(ByVal Temp, ByVal Tempstr$)
If Not (InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) = 0) Then 'verify
GFSelectDirectory = Left$(Tempstr$, InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) ‑ 1) 'ok
Else
GFSelectDirectory = "" 'error
End If
Else
GFSelectDirectory = "" 'error
End If
End Function
Public Function GFCDGetFileName(ByVal Title As String, ByRef FilterNumber As Integer, ByRef FilterDescriptionArray() As String, ByRef FilterStringArray() As String, ByVal DefaultFilterIndex As Integer, ByVal DefaultPath As String) As String
'On Error Resume Next 'must be placed into a form (uses hWnd); FilterNumber may be 0 (then pass NULLARRAYSTRING()), DefaultPath should contain path and file name
Dim OPENFILENAMEVar As OPENFILENAME
Dim DefaultFileName As String
Dim DefaultDirectoryName As String
Dim Temp As Long
'
'NOTE: the FilerDescriptionArray() and the FilterStringArray() data
'must have the following format (example; description/string):
'
'Bitmap/*.bmp;*.jpg;*.gif
'
'If FilterNumber is 0, the preset filter 'All Files/*.*' is used.
'If the user pressed 'Cancel' the function returns nothing ("").
'
'initialize structure
OPENFILENAMEVar.lStructSize = Len(OPENFILENAMEVar)
OPENFILENAMEVar.hWndOwner = 0 'do not use form (module ?!) handle
OPENFILENAMEVar.hInstance = App.hInstance
If Not (FilterNumber = 0) Then
'
'NOTE: the filter string contains string pairs (filter description/string),
'the string end is marked by two null chars.
'
For Temp = 1 To FilterNumber
OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + _
FilterDescriptionArray(Temp) + Chr$(0) + FilterStringArray(Temp) + Chr$(0)
Next Temp
OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + Chr$(0) 'two null chars at filter string end
Else
OPENFILENAMEVar.lpstrFilter = "All Files" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
End If
OPENFILENAMEVar.nFilterIndex = DefaultFilterIndex
If Not (GetFileName(DefaultPath) = "") Then
DefaultFileName = GetFileName(DefaultPath)
OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
Mid$(OPENFILENAMEVar.lpstrFile, 1, Len(DefaultFileName)) = Left$(DefaultFileName, 260)
Else
OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
End If
OPENFILENAMEVar.lpstrTitle = Title + Chr$(0)
DefaultDirectoryName = Left$(DefaultPath, Len(DefaultPath) ‑ Len(DefaultFileName))
OPENFILENAMEVar.lpstrInitialDir = DefaultDirectoryName + Chr$(0)
OPENFILENAMEVar.nMaxFileTitle = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFileTitle = String$(260 + 1, Chr$(0)) 'receives selected file name (without directory)
OPENFILENAMEVar.Flags = OFN_HIDEREADONLY
'end of initializing structure
If Not (GetOpenFileName(OPENFILENAMEVar) = 0) Then
If Not (InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) = 0) Then 'verify
GFCDGetFileName = Left$(OPENFILENAMEVar.lpstrFile, InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) ‑ 1)
Else
GFCDGetFileName = OPENFILENAMEVar.lpstrFile
End If
Else
GFCDGetFileName = "" 'reset (error)
End If
End Function
Public Function GFCDSetFileName(ByVal Title As String, ByRef FilterNumber As Integer, ByRef FilterDescriptionArray() As String, ByRef FilterStringArray() As String, ByVal DefaultFilterIndex As Integer, ByVal DefaultPath As String) As String
'on error resume next 'must be placed into a form (uses hWnd); FilterNumber may be 0 (then pass NULLARRAYSTRING()), DefaultPath should contain path and file name
Dim OPENFILENAMEVar As OPENFILENAME
Dim DefaultFileName As String
Dim DefaultDirectoryName As String
Dim Temp As Long
'
'NOTE: the FilerDescriptionArray() and the FilterStringArray() data
'must have the following format (example; description/string):
'
'Bitmap/*.bmp;*.jpg;*.gif
'
'If FilterNumber is 0, the preset filter 'All Files/*.*' is used.
'If the user pressed 'Cancel' the function returns nothing ("").
'
'initialize structure
OPENFILENAMEVar.lStructSize = Len(OPENFILENAMEVar)
OPENFILENAMEVar.hWndOwner = 0 'do not use form (module ?!) handle
OPENFILENAMEVar.hInstance = App.hInstance
If Not (FilterNumber = 0) Then
'
'NOTE: the filter string contains string pairs (filter description/string),
'the string end is marked by two null chars.
'
For Temp = 1 To FilterNumber
OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + _
FilterDescriptionArray(Temp) + Chr$(0) + FilterStringArray(Temp) + Chr$(0)
Next Temp
OPENFILENAMEVar.lpstrFilter = OPENFILENAMEVar.lpstrFilter + Chr$(0) 'two null chars at filter string end
Else
OPENFILENAMEVar.lpstrFilter = "All Files" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
End If
OPENFILENAMEVar.nFilterIndex = DefaultFilterIndex
If Not (GetFileName(DefaultPath) = "") Then
DefaultFileName = GetFileName(DefaultPath)
OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
Mid$(OPENFILENAMEVar.lpstrFile, 1, Len(DefaultFileName)) = Left$(DefaultFileName, 260)
Else
OPENFILENAMEVar.nMaxFile = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFile = String$(260 + 1, Chr$(0))
End If
OPENFILENAMEVar.lpstrTitle = Title + Chr$(0)
DefaultDirectoryName = Left$(DefaultPath, Len(DefaultPath) ‑ Len(DefaultFileName))
OPENFILENAMEVar.lpstrInitialDir = DefaultDirectoryName + Chr$(0)
OPENFILENAMEVar.nMaxFileTitle = 260 + 1 'MAX_PATH
OPENFILENAMEVar.lpstrFileTitle = String$(260 + 1, Chr$(0)) 'receives selected file name (without directory)
OPENFILENAMEVar.Flags = OFN_HIDEREADONLY
'end of initializing structure
If Not (GetSaveFileName(OPENFILENAMEVar) = 0) Then
If Not (InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) = 0) Then 'verify
GFCDSetFileName = Left$(OPENFILENAMEVar.lpstrFile, InStr(1, OPENFILENAMEVar.lpstrFile, Chr$(0), vbBinaryCompare) ‑ 1)
Else
GFCDSetFileName = OPENFILENAMEVar.lpstrFile
End If
Else
GFCDSetFileName = "" 'reset (error)
End If
End Function
Public Function GFCDGetColor(ByVal DefaultColor As Long, ByVal UserColorNumberPassed As Integer, ByRef UserColorArrayPassed() As Long) As Long 'also used by GFSkinEngine_PolyRgnfrm
'On Error Resume Next 'v1.0 (no user color support); returns True if user aborted (always check if return value is True)
Dim CHOOSECOLORSTRUCTVar As CHOOSECOLORSTRUCT
Dim UserColorArray(1 To 16) As Long
Dim UserColorLoop As Integer
'
'NOTE: the ChooseColor function requires to be able to
'access an array of exactly 16 COLORREF (Long) variables, otherwise
'the program will crash.
'The passed array must not contain 16 values, this function
'will transfer the user color values of the passed user color array.
'
'preset
For UserColorLoop = 1 To UserColorNumberPassed
If UserColorLoop > 16 Then Exit For
UserColorArray(UserColorLoop) = UserColorArrayPassed(UserColorLoop)
Next UserColorLoop
'initialize structure
CHOOSECOLORSTRUCTVar.lStructSize = Len(CHOOSECOLORSTRUCTVar)
CHOOSECOLORSTRUCTVar.hWndOwner = 0 'do not use an owner window (module?)
CHOOSECOLORSTRUCTVar.hInstance = App.hInstance
CHOOSECOLORSTRUCTVar.rgbResult = DefaultColor
CHOOSECOLORSTRUCTVar.Flags = CC_RGBINIT
CHOOSECOLORSTRUCTVar.lpCustColors = VarPtr(UserColorArray(1))
CHOOSECOLORSTRUCTVar.lCustData = 0
CHOOSECOLORSTRUCTVar.lpfnHook = 0
CHOOSECOLORSTRUCTVar.lpTemplateName = Chr$(0)
'end of initializing structure
'begin
If Not (ChooseColor(CHOOSECOLORSTRUCTVar) = 0) Then 'verify
GFCDGetColor = CHOOSECOLORSTRUCTVar.rgbResult 'ok
Else
GFCDGetColor = True 'error
End If
End Function
'***END OF COMMONDIALOG FUNCTIONS***
Private Function GFGetLineArray(ByVal InputString As String, ByVal LineWidthMax As Long, ByVal LineBorderChar As String, ByRef LineArray() As String, ByRef LineNumber As Integer, ByRef LineWidthPicture As PictureBox) As Boolean
'on error resume next 'breaks lines like a Command button (string is only broken at border chars), a word may not be completely visible; InputString must not contain Chr$(13) or Chr$(10)
Dim LineBorderCharPos As Long 'position of last line border char
Dim Temp As Long
'
'NOTE: this function may contains bugs.
'
'reset
LineNumber = 0 'reset
ReDim LineArray(1 To 1) As String 'reset
'preset
InputString = InputString + LineBorderChar 'add end sign (will be cut automatically)
'begin
Do
Temp = Temp + 1
If Mid$(InputString, Temp, 1) = LineBorderChar Then 'check for border char
If (LineWidthPicture.TextWidth(Left$(InputString, Temp)) > LineWidthMax) Then
If Not (LineNumber = 32766) Then
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
If LineBorderCharPos = 0 Then 'happens if a word is too large for one line
LineArray(LineNumber) = Left$(InputString, Temp ‑ 1)
InputString = Right$(InputString, Len(InputString) ‑ Temp)
Else
LineArray(LineNumber) = Left$(InputString, LineBorderCharPos ‑ 1)
InputString = Right$(InputString, Len(InputString) ‑ LineBorderCharPos)
End If
Temp = 0 'reset
End If
If Len(InputString) = 0 Then
Exit Do 'finished
Else
If Temp = Len(InputString) Then
If Not (LineNumber = 32766) Then
LineNumber = LineNumber + 1
Else
GoTo Error:
End If
ReDim Preserve LineArray(1 To LineNumber) As String
LineArray(LineNumber) = Left$(InputString, Len(InputString) ‑ 1) 'cut end sign
Exit Do 'finished
End If
End If
LineBorderCharPos = Temp
End If
Loop
GFGetLineArray = True 'ok
Exit Function
Error:
GFGetLineArray = False 'error
Exit Function
End Function
'***GFCreateDirectory***
Private Function GFCreateDirectory(ByVal DirectoryName As String) As Boolean
On Error GoTo Error: 'important; creates up to 100 sub directories in current directory or given parent directory
Dim Temp As Long
Dim SECURITY_ATTRIBUTESVar As SECURITY_ATTRIBUTES
'
'NOTE: MkDir and CreateDirectory() can create one sub directory only,
'this function is able to create up to 100 ones with one call, i.e. even if only
'c:\ exists, the value of DirectoryName can be c:\sub1\sub2\sub3\.
'
'verify
If DirectoryName = "" Then 'verify first
GoTo Error:
End If
If Not (Dir$(DirectoryName, vbDirectory) = "") Then
GoTo Success:
End If
If (GFCreateDirectorySubCallNumber < 100) Then
GFCreateDirectorySubCallNumber = GFCreateDirectorySubCallNumber + 1
Else
GoTo Error:
End If
'begin
ReDo:
'NOTE: remove last backslash so that GetDirectoryName() will cut last directory name.
If Right$(DirectoryName, 1) = "\" Then DirectoryName = Left$(DirectoryName, Len(DirectoryName) ‑ 1)
If Not (Dir$(GFCreateDirectory_GetDirectoryName(DirectoryName), vbDirectory) = "") Then
'one sub directory to create left
If Not (CreateDirectory(DirectoryName, SECURITY_ATTRIBUTESVar) = 0) Then
GFCreateDirectory = True 'ok
GoTo Success: '(*1)
Else
GoTo Error: '(*2)
End If
Else
'several sub directories to create left
GFCreateDirectory = GFCreateDirectory(GFCreateDirectory_GetDirectoryName(DirectoryName))
'NOTE: if arrived here (over (*1) or (*2) of last call), the first sub directory has been created.
If GFCreateDirectory = True Then
GoTo ReDo:
Else
GoTo Error:
End If
End If
GFCreateDirectorySubCallNumber = 0 'reset
Exit Function
Success:
GFCreateDirectory = True 'ok
GFCreateDirectorySubCallNumber = 0 'reset
Exit Function
Error: 'if passed directory name is i.e. '>>>', Dir$() will create an error
GFCreateDirectory = False 'error
GFCreateDirectorySubCallNumber = 0 'reset
'NOTE: if function returns False there cannot be any more subcalls, so
'GFCreateDirectorySubCallNumber can be reset to zero.
Exit Function
End Function
Private Function GFCreateDirectory_GetDirectoryName(ByVal GetDirectoryNameName As String) As String
'On Error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
Dim Temp As Long
GFCreateDirectory_GetDirectoryName = "" 'reset
For Temp = Len(GetDirectoryNameName) To 1 Step (‑1)
If Mid$(GetDirectoryNameName, Temp, 1) = "\" Then
GFCreateDirectory_GetDirectoryName = Left$(GetDirectoryNameName, Temp)
Exit For
End If
Next Temp
End Function
'***END OF GFCreateDirectory***
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
'***FILE SYSTEM FUNCTIONS***
Private Function GetExtendedFileName(ByVal FileMainName As String, ByVal FileNameExtension As String, FileMainNameSuffix As String) As String 'general function (may be used in any project)
On Error GoTo Error: 'important; v1.1
GetExtendedFileName = "" 'reset
'
'NOTE: example: passing ("C:\VisualBasic", ".EXE", "#") will return the following
'strings (depending on number of files already created using this function):
'
'"C:\VisualBasic.EXE"
'"C:\VisualBasic#2.EXE"
'[...]
'"C:\VisualBasic#256.EXE"
'""
'
If Not (FileMainName + FileNameExtension = "") Then
If (Dir$(FileMainName + FileNameExtension) = "") And (Dir$(FileMainName + FileMainNameSuffix + LTrim$(Str$(1)) + FileNameExtension) = "") Then
GetExtendedFileName = FileMainName + FileNameExtension
Exit Function
End If
Dim Temp As Long
For Temp = 2 To 256
If Dir$(FileMainName + FileMainNameSuffix + LTrim$(Str$(Temp)) + FileNameExtension) = "" Then
GetExtendedFileName = FileMainName + FileMainNameSuffix + LTrim$(Str$(Temp)) + FileNameExtension
Exit Function
End If
Next Temp
End If
Exit Function
Error:
GetExtendedFileName = "" 'reset (error)
Exit Function
End Function
Private Function GenerateTempFileName(ByVal TempFilePath As String) As String
'On Error Resume Next 'returns name of a non‑existing file in TempFilePath, file name has following format: ########.tmp
Dim GenerateTempFileTemp As Integer
If (Not (Right$(TempFilePath, 1) = "\")) And (Not (TempFilePath = "")) Then
TempFilePath = TempFilePath + "\"
End If
Do
GenerateTempFileName = TempFilePath + Format$((Rnd(1) * 1E+08!), "00000000") + ".tmp"
GenerateTempFileTemp = GenerateTempFileTemp + 1 'just to make sure
Loop Until (Dir$(GenerateTempFileName) = "") Or (GenerateTempFileTemp = 32767)
End Function
Private Function GetFileName(ByVal GetFileNameName As String) As String 'also used by Hmod.KeyHook_Open()
'On Error Resume Next 'returns chars after last backslash or nothing
Dim GetFileNameLoop As Integer
GetFileName = "" 'reset
For GetFileNameLoop = Len(GetFileNameName) To 1 Step (‑1)
If Mid$(GetFileNameName, GetFileNameLoop, 1) = "\" Then
GetFileName = Right$(GetFileNameName, Len(GetFileNameName) ‑ GetFileNameLoop)
Exit For
End If
Next GetFileNameLoop
End Function
Private Function GetFileMainName(ByVal File As String) As String
'On Error Resume Next 'returns chars before last "." or File
Dim GetFileMainNameLoop As Long
GetFileMainName = File 'preset
For GetFileMainNameLoop = Len(File) To 1 Step (‑1)
If Mid$(File, GetFileMainNameLoop, 1) = "." Then
GetFileMainName = Left$(File, GetFileMainNameLoop ‑ 1)
Exit For
End If
Next GetFileMainNameLoop
End Function
Private Function GetFileNameSuffix(ByVal File As String) As String
'On Error Resume Next 'returns chars after last "." or nothing
Dim GetFileNameSuffixLoop As Long
GetFileNameSuffix = "" 'reset
For GetFileNameSuffixLoop = Len(File) To 1 Step (‑1)
If Mid$(File, GetFileNameSuffixLoop, 1) = "." Then
GetFileNameSuffix = Right$(File, Len(File) ‑ GetFileNameSuffixLoop)
Exit For
End If
Next GetFileNameSuffixLoop
End Function
Private Function IsFullPath(ByVal File As String) As Boolean
'on error resume next 'something new since MP3 Renamer 2, returns True if File is a full path, False if not
'
'NOTE: to be a full path File must contain one directory‑ and one file name.
'
If (InStr(1, File, "\", vbBinaryCompare)) Then 'check first to increase speed
If GetDirectoryName(File) = "" Then GoTo Error:
If GetFileName(File) = "" Then GoTo Error:
IsFullPath = True 'ok
Exit Function
Else
GoTo Error:
End If
Exit Function
Error:
IsFullPath = False 'error
Exit Function
End Function
Private Function IsFileExisting(ByVal File As String) As Boolean 'GFSkinEngine specific
'on error resume next 'returns True if passed File (full path) is existing, False if not
'
'NOTE: this function was implemented for compatibility with IsFullPath()
'only, still use the 'conventional' checking method (see below).
'
If (Len(File)) Then 'check first to increase speed
IsFileExisting = Not ((DirSave(File) = "") Or (Right$(File, 1) = "\")) 'Len() = 0 already checked
Exit Function
Else
IsFileExisting = False 'error
Exit Function
End If
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 GetRootDir(ByVal GetRootDirPath As String) As String
'On Error Resume Next 'returns root dir of passed path, even if located on a network machine
Dim GetRootDirLoop As Integer
'verify
GetRootDirPath = Left$(GetRootDirPath, 32767)
'begin
If Not (Left$(GetRootDirPath, 2) = "\\") Then
GetRootDir = Left$(GetRootDirPath, 3) 'i.e. c:\
Else
GetRootDir = Chr$(0) 'preset (error)
GetRootDirPath = GetRootDirPath + "\" 'add end sign (testing is not required, increase speed)
For GetRootDirLoop = 3 To Len(GetRootDirPath)
If Mid$(GetRootDirPath, GetRootDirLoop, 1) = "\" Then
Select Case GetRootDir
Case Chr$(0)
GetRootDir = ""
Case ""
GetRootDir = Left$(GetRootDirPath, GetRootDirLoop) 'i.e. \\SERVER\C\
Exit For
End Select
End If
Next GetRootDirLoop
If GetRootDir = Chr$(0) Then GetRootDir = "" 'reset (error)
End If
End Function
'***END OF FILE SYSTEM FUNCTIONS***
'***CONVERSION FUNCTIONS***
Private Function STRINGTOBOOL(ByVal StringString As String) As Boolean
'On Error Resume Next
If UCase$(StringString) = "TRUE" Then
STRINGTOBOOL = True
Else
STRINGTOBOOL = False
End If
End Function
Private Function BOOLTOSTRING(ByVal BooleanFlag As Boolean) As String
'On Error Resume Next
If BooleanFlag = True Then
BOOLTOSTRING = "True"
Else
BOOLTOSTRING = "False"
End If
End Function
'***END OF CONVERSION FUNCTIONS***
Private Sub GFTilePicture(ByRef TileSourcePicture As PictureBox, ByRef TileTargetPicture As PictureBox)
'On Error Resume Next 'source and target picture must not be equal
Dim TileSourcePictureScaleModeUnchanged As Integer
Dim TileTargetPictureScaleModeUnchanged As Integer
Dim TileXSizeCurrent As Long
Dim TileYSizeCurrent As Long
Dim TileXSizeTotal As Long
Dim TileYSizeTotal As Long
'preset
TileSourcePictureScaleModeUnchanged = TileSourcePicture.ScaleMode
TileSourcePicture.ScaleMode = vbPixels 'important
TileTargetPictureScaleModeUnchanged = TileTargetPicture.ScaleMode
TileTargetPicture.ScaleMode = vbPixels 'important
'verify
If (TileSourcePicture.ScaleWidth = 0) Or (TileSourcePicture.ScaleHeight = 0) Then 'verify
Exit Sub
End If
'begin
Do
TileYSizeCurrent = TileSourcePicture.ScaleHeight
If (TileYSizeTotal + TileYSizeCurrent) > TileTargetPicture.ScaleHeight Then
TileYSizeCurrent = TileTargetPicture.ScaleHeight ‑ TileYSizeTotal
End If
TileXSizeTotal = 0 'reset
Do
TileXSizeCurrent = TileSourcePicture.ScaleWidth
If (TileXSizeTotal + TileXSizeCurrent) > TileTargetPicture.ScaleWidth Then
TileXSizeCurrent = TileTargetPicture.ScaleWidth ‑ TileXSizeTotal
End If
Call BitBlt(TileTargetPicture.hDC, TileXSizeTotal, TileYSizeTotal, TileXSizeCurrent, TileYSizeCurrent, TileSourcePicture.hDC, 0, 0, vbSrcCopy)
TileXSizeTotal = TileXSizeTotal + TileXSizeCurrent
If Not (TileXSizeTotal < TileTargetPicture.ScaleWidth) Then Exit Do
Loop
TileYSizeTotal = TileYSizeTotal + TileYSizeCurrent
If Not (TileYSizeTotal < TileTargetPicture.ScaleHeight) Then Exit Do
Loop
'reset
TileSourcePicture.ScaleMode = TileSourcePictureScaleModeUnchanged
TileTargetPicture.ScaleMode = TileTargetPictureScaleModeUnchanged
End Sub
Private Function FixMaxLineLength(ByVal Line As String, ByVal Length As Integer) As String
'On Error Resume Next
If Length < 3 Then Length = 3 'otherwise error
If Len(Line) > Length Then
FixMaxLineLength = String$(3, ".") + Right$(Line, Length ‑ 3)
Else
FixMaxLineLength = Line
End If
End Function
Private Function LineBreak(ByVal Line As String) As String
'On Error Resume Next 'GFSkinEngine specific function, replaces '|' by Chr$(13) + Chr$(10) and returns the result
Dim LineNew As String
Dim Temp As Long
'verify
If InStr(1, Line, "|", vbBinaryCompare) = 0 Then 'increase speed (function must be fast (if e.g. numeric values are permanently saved using SE_SetSystemText()))
LineBreak = Line
Exit Function
End If
'preset
Line = Line + "|" 'add end sign
'begin
For Temp = 1 To Len(Line)
If Mid$(Line, Temp, 1) = "|" Then
LineNew = LineNew + Left$(Line, Temp ‑ 1) + Chr$(13) + Chr$(10)
Line = Right$(Line, Len(Line) ‑ Temp)
End If
Next Temp
LineBreak = Left$(LineNew, Len(LineNew) ‑ 2) 'remove end sign
End Function
Public Function ReLineBreak(ByVal Line As String) As String
'on error resume next 'GFSkinEngine specific function; replaces any Chr$(13) or/and Chr$(10) by a space char
Dim Temp As Long
'
'NOTE: use this function to make sure a string
'(e.g. STComment) can be displayed in one line (MsgBox prompt).
'Make this function as fast as possible for numeric values (tested).
'
'verify
If InStr(1, Line, Chr$(13) + Chr$(10), vbBinaryCompare) = 0 Then 'increase speed
If InStr(1, Line, Chr$(10) + Chr$(13), vbBinaryCompare) = 0 Then 'increase speed
ReLineBreak = Line
Exit Function
End If
End If
'begin
ReDo:
For Temp = 1 To (Len(Line) ‑ 1)
Select Case Mid$(Line, Temp, 2)
Case Chr$(13) + Chr$(10)
Line = Left$(Line, Temp ‑ 1) + Chr$(32) + Right$(Line, Len(Line) ‑ (Temp + 1))
GoTo ReDo:
End Select
Next Temp
For Temp = 1 To Len(Line)
Select Case Mid$(Line, Temp, 1)
Case Chr$(10), Chr$(13)
Mid$(Line, Temp, 1) = Chr$(32)
End Select
Next Temp
ReLineBreak = Trim$(Line)
End Function
Private Function MIN(ByVal Value1 As Long, ByVal Value2 As Long) As Long
'on error resume next
If Value1 > Value2 Then
MIN = Value2
Else
MIN = Value1
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 = Value2
Else
MAX = Value1
End If
End Function
Private Function ISFONTAVAILABLE(ByVal FontName As String) As Boolean 'small help function
'On Error Resume Next 'returns True if font is installed on local machine, False if not
Dim FontLoop As Integer
For FontLoop = 1 To Screen.FontCount
If UCase$(Screen.Fonts(FontLoop)) = UCase$(FontName) Then
ISFONTAVAILABLE = True
Exit Function
End If
Next FontLoop
ISFONTAVAILABLE = False
Exit Function
End Function
Private Function IsPicture(ByVal PictureName As String, Optional ByVal CreateErrorMessage As Boolean = True) As Boolean
On Error GoTo Error: 'important; SE specific, tries to load passed picture into the system temp picture
'
'NOTE: this function creates an error message and returns False if the passed
'file is not a valid picture file, otherwise it returns True.
'The calling sub should be left immediately if this function returns False.
'
If (Dir$(PictureName) = "") Or (Right$(PictureName, 1) = "\") Or (PictureName = "") Then GoTo Error:
Call Skin_DecryptFile(PictureName)
SESystemStructVar.SystemTempPicture.Picture = LoadPicture(PictureName)
Call Skin_EncryptFile(PictureName)
IsPicture = True 'ok
Exit Function
Error:
If CreateErrorMessage = True Then
MsgBox "Error: '" + PictureName + "' is not a valid picture file (supported: *.bmp, *.jpg, *.ico) !", vbOKOnly + vbExclamation
End If
IsPicture = False 'error
Exit Function
End Function
Public Function GFCursor_Load(ByVal CursorName As String) As StdPicture
On Error GoTo Error: 'important (if cursor to load is invalid); always use to load a cursor or picture file, function will return a reference to an already loaded cursor/picture if possible
Dim CursorLoop As Integer
Dim TempStdPicture As New StdPicture
'preset
For CursorLoop = 1 To CursorNumber
If UCase$(CursorNameArray(CursorLoop)) = UCase$(CursorName) Then
Set GFCursor_Load = CursorPictureArray(CursorLoop)
Exit Function
End If
Next CursorLoop
'begin
If Not ((Dir$(CursorName) = "") Or (Right$(CursorName, 1) = "\") Or (CursorName = "")) Then 'verify
If Not (CursorNumber = 32767) Then 'verify
CursorNumber = CursorNumber + 1
Else
MsgBox "internal error in GFCursor_Load() (GFSkinEngine): overflow !", vbOKOnly + vbExclamation
Exit Function
End If
Set TempStdPicture = LoadPicture(CursorName)
ReDim Preserve CursorNameArray(1 To CursorNumber) As String
ReDim Preserve CursorPictureArray(1 To CursorNumber) As New StdPicture
CursorNameArray(CursorLoop) = CursorName
Set CursorPictureArray(CursorLoop) = TempStdPicture
Set GFCursor_Load = CursorPictureArray(CursorLoop) 'ok
Else
MsgBox "internal error in GFCursor_Load(): file '" + CursorName + "' not found !", vbOKOnly + vbExclamation
Set GFCursor_Load = Nothing 'error
Exit Function
End If
Exit Function
Error:
MsgBox "internal error in GFCursor_Load(): file '" + CursorName + "' invalid !", vbOKOnly + vbExclamation
Set GFCursor_Load = Nothing 'error
Exit Function
End Function
Public Sub GFCursor_Reset()
'on error resume next 'call to free up memory
Dim CursorLoop As Integer
'begin
For CursorLoop = 1 To CursorNumber
Call DeleteObject(CursorPictureArray(CursorLoop).Handle) 'make sure loaded images are removed from memory
Next CursorLoop
Erase CursorNameArray()
Erase CursorPictureArray() 'free up class‑array memory
CursorNumber = 0 'reset
ReDim CursorNameArray(1 To 1) As String 'reset
ReDim CursorPictureArray(1 To 1) As New StdPicture 'reset
End Sub
Private Function GFDCToStdPicture(ByVal DC As Long, ByVal Width As Long, ByVal Height As Long) As StdPicture
'on error resume next 'returns a StdPicture structure that 'contains' an image from a memory DC; format: pixels
Dim BitmapHandle As Long
Dim BitmapHandleOld As Long
Dim PaletteHandle As Long
Dim PaletteHandleOld As Long
Dim ScreenRasterCaps As Long
Dim ScreenHasPalette As Long
Dim ScreenPaletteSize As Long
Dim LOGPALETTEVar As LOGPALETTE
Dim PicBmpVar As PicBmp
Dim lPictureVar As IPicture
Dim GUIDVar As GUID
Dim TempDC As Long
Dim Temp As Long
'
'NOTE: use this function to transfer images between memory DCs
'and VB picture boxes or forms.
'The whole code is a manipulation of a Microsoft example named:
'Q161299 ‑ HOWTO Capture and Print the Screen, a Form, or Any Window.
'
'preset
GUIDVar.Data1 = &H20400
GUIDVar.Data4(0) = &HC0
GUIDVar.Data4(7) = &H46
'begin
'create a temporary memory DC
TempDC = CreateCompatibleDC(0)
'create a bitmap and place it in the memory DC
BitmapHandle = CreateCompatibleBitmap(DC, Width, Height)
BitmapHandleOld = SelectObject(TempDC, BitmapHandle)
'get screen properties
ScreenRasterCaps = GetDeviceCaps(DC, RASTERCAPS)
ScreenHasPalette = ScreenRasterCaps And RC_PALETTE
ScreenPaletteSize = GetDeviceCaps(DC, SIZEPALETTE)
'if the screen has a palette then make a copy and realize it (tested, ok)
If (ScreenHasPalette) And (ScreenPaletteSize = 256) Then
'create a copy of the system palette
LOGPALETTEVar.palVersion = &H300
LOGPALETTEVar.palNumEntries = 256
Temp = GetSystemPaletteEntries(DC, 0, 256, LOGPALETTEVar.palPalEntry(0))
PaletteHandle = CreatePalette(LOGPALETTEVar)
'select the new palette into the memory DC and realize it
PaletteHandleOld = SelectPalette(TempDC, PaletteHandle, 0)
Temp = RealizePalette(TempDC)
End If
'copy the image into the memory DC
Call BitBlt(TempDC, 0, 0, Width, Height, DC, 0, 0, vbSrcCopy)
'remove the new copy of the image
BitmapHandle = SelectObject(TempDC, BitmapHandleOld)
'if the screen has a palette then get back the palette that was selected previously
If (ScreenHasPalette) And (ScreenPaletteSize = 256) Then
PaletteHandle = SelectPalette(TempDC, PaletteHandleOld, 0)
Call DeleteObject(PaletteHandle)
Call DeleteObject(PaletteHandleOld)
Call DeleteDC(TempDC)
Else
Call DeleteDC(TempDC)
End If
'
PicBmpVar.Size = Len(PicBmpVar)
PicBmpVar.Type = vbPicTypeBitmap
PicBmpVar.hBmp = BitmapHandle
PicBmpVar.hPal = PaletteHandle
'
Call OleCreatePictureIndirect(PicBmpVar, GUIDVar, 1, lPictureVar) '1 for system deletes picture when no longer needed
'
Set GFDCToStdPicture = lPictureVar
End Function
Private Function GFShrinkFile(ByVal ShrinkName As String, ByVal ShrinkNameSizeNew As Long) As Boolean
'on error resume next 'shrinks a file; function returns True if file was shrunk, False if not
Dim ShrinkNameHandle As Long
Dim OFSTRUCTVar As OFSTRUCT
Dim ShrinkFileTemp As Long
'verify
If ((Dir$(ShrinkName) = "") Or (Right$(ShrinkName, 1) = "\") Or (ShrinkName = "")) Then 'verify
GFShrinkFile = False 'error
Exit Function
End If
Select Case ShrinkNameSizeNew
Case Is < 0
GoTo Error:
Case Is > FileLen(ShrinkName)
ShrinkNameSizeNew = FileLen(ShrinkName)
End Select
'begin
ShrinkNameHandle = OpenFile(ShrinkName, OFSTRUCTVar, OF_READWRITE)
If ShrinkNameHandle = 0 Then GoTo Error: 'verify
ShrinkFileTemp = SetFilePointer(ShrinkNameHandle, ShrinkNameSizeNew, 0, FILE_BEGIN)
'If ShrinkFileTemp = 0 Then GoTo Error: 'functions returns something nobody understands
ShrinkFileTemp = SetEndOfFile(ShrinkNameHandle)
If ShrinkFileTemp = 0 Then GoTo Error: 'verify
ShrinkFileTemp = CloseHandle(ShrinkNameHandle)
If ShrinkFileTemp = 0 Then GoTo Error: 'verify
GFShrinkFile = True 'ok
Exit Function
Error:
Call CloseHandle(ShrinkNameHandle) 'make sure file is closed
GFShrinkFile = False 'error
Exit Function
End Function
'NOTE: we have a problem:
'if we use Dir$() on a cdrom drive with no cd inserted then Dir$() will raise
'and error. We must replace all those Dir$() functions in the code which
'verify the existence of a file selected by the user.
'
'We used the VB replace function to replace ALL 'Dir('s by 'Dir(',
'except in the General Functions section.
'
'Traditional lines like:
'If (Dir$(F) = "") or (Right$(F, 1) = "\") or (Len(F) = 0) Then
'look now like this:
'If (Dir$(F) = "") or (Right$(F, 1) = "\") or (Len(F) = 0) Then.
Private Function DirSave(ByRef PathName As String, Optional ByVal Attributes As Integer = vbNormal) As String
On Error GoTo Error: 'important
'
'NOTE: Dir$() raises an error if PathName represents a cdrom drive
'and the cd is not inserted (damn VB!). Use this function rather than Dir$().
'
DirSave = Dir$(PathName, Attributes) 'ok
Exit Function
Error:
DirSave = "" 'error
Exit Function
End Function
Private Function GetLongString(ByVal LongValue As Long) As String
'on error resume next 'get the 4 bytes of a Long value
GetLongString = String$(4, Chr$(0))
Call CopyMemory(ByVal GetLongString, LongValue, 4)
End Function
Private Function GetStringLong(ByVal StringString As String) As Long
'on error resume next
Call CopyMemory(GetStringLong, ByVal StringString, 4)
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
'***END OF MODULE***
[END OF FILE]