Die Community zu .NET und Classic VB.
Menü

Quellcode von FcAddOn

 von 

Quellcode  

 Option Explicit

 'Konstante für "GetVersionEx"
 Const VER_PLATFORM_OTHER = 0
 Const VER_PLATFORM_WIN95 = 1
 Const VER_PLATFORM_WIN98 = 2
 Const VER_PLATFORM_WINNT = 3
 Const VER_PLATFORM_WIN2K = 4

 'Konstante für Registry-Pfad
 Const KEYNAME = ".Default\Software\Microsoft\Windows\" & _
   "CurrentVersion\Applets\FreeCell"

 'Typ für FreeCell-Daten
 Private Type FREECELLINFO
  WonGames As Long
  LostGames As Long
  WonSMax As Long
  LostSMax As Long
  Streak As Long
  SType As Long
 End Type

 'Typ für "GetVersionEx"
 Private Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
 End Type

 'Typ für "CreateProcess"
 Private Type STARTUPINFO
  cb As Long
  lpReserved As String
  lpDesktop As String
  lpTitle As String
  dwX As Long
  dwY As Long
  dwXSize As Long
  dwYSize As Long
  dwXCountChars As Long
  dwYCountChars As Long
  dwFillAttribute As Long
  dwFlags As Long
  wShowWindow As Integer
  cbReserved2 As Integer
  lpReserved2 As Byte
  hStdInput As Long
  hStdOutput As Long
  hStdError As Long
 End Type

 'Typ für "CreateProcess"
 Private Type PROCESS_INFORMATION
  hProcess As Long
  hThread As Long
  dwProcessID As Long
  dwThreadId As Long
 End Type

 Private Declare Function GetVersionEx Lib "KERNEL32" _
  Alias "GetVersionExA" _
  (lpVersionInformation As OSVERSIONINFO) As Long

 Private Declare Function GetSystemMenu Lib "user32" _
  (ByVal hwnd As Long, _
  ByVal bRevert As Long) As Long

 Private Declare Function RemoveMenu Lib "user32" _
  (ByVal hMenu As Long, _
  ByVal nPosition As Long, _
  ByVal wFlags As Long) As Long

 Private Declare Function EnableMenuItem Lib "user32" _
  (ByVal hMenu As Long, _
  ByVal wIDEnableItem As Long, _
  ByVal wEnable As Long) As Long

 Private Declare Function CreateProcess Lib "KERNEL32" _
  Alias "CreateProcessA" _
  (ByVal lpApplicationName As Long, _
  ByVal lpCommandLine As String, _
  ByVal lpProcessAttributes As Long, _
  ByVal lpThreadAttributes As Long, _
  ByVal bInheritHandles As Long, _
  ByVal dwCreationFlags As Long, _
  ByVal lpEnvironment As Long, _
  ByVal lpCurrentDirectory As Long, _
  lpStartupInfo As STARTUPINFO, _
  lpProcessInformation As PROCESS_INFORMATION) As Long

 Private Declare Function WaitForSingleObject Lib "KERNEL32" _
  (ByVal hHandle As Long, _
  ByVal dwMilliSeconds As Long) As Long

 Private Declare Function GetWindowsDirectory Lib "KERNEL32" _
  Alias "GetWindowsDirectoryA" _
  (ByVal lpBuffer As String, _
  ByVal nSize As Long) As Long

 Private Declare Function GetCurrentProcessId Lib "KERNEL32" () _
  As Long

 Private Declare Sub Sleep Lib "KERNEL32" _
  (ByVal dwMilliSeconds As Long)

 Dim IniPath As String
 Dim Registry As New cRegistry
'--------------------------------------------------------------------------------

 Private Sub Form_Initialize()

  Dim bError As Boolean
  Dim SourceIsReg As Boolean
  Dim Success As Boolean

  Dim FCHandle As Long
  Dim ProcessID As Long

  'Registry-Klasse initialisieren
  Registry.ClassKey = HKEY_USERS
  Registry.SectionKey = KEYNAME
  'Datenquelle ist Registry
  SourceIsReg = True

  Select Case Betriebssystem
    Case VER_PLATFORM_WINNT
      'Datenquelle ist INI-Datei
      SourceIsReg = False
      'Pfad zur Ini-Datei
      IniPath = WinDir & "\entpack.ini"
      'Registry-Einträge vorhanden?
      If Not Registry.KeyExists Then
        Registry.CreateKey
        Registry.ValueType = REG_DWORD
        Registry.ValueKey = "wins"
        Registry.Value = &H0
        Registry.ValueKey = "losses"
        Registry.Value = &H0
      End If
    Case VER_PLATFORM_OTHER
      MsgBox "Keine Windows-Plattform vorgefunden." & vbCr & _
        "FCAddOn wird deswegen abgebrochen.", _
        vbCritical + vbOKOnly, App.Title & " - Abbruch"
      End
    Case Else
      'Tu nix
  End Select

  'FreeCell starten
  bError = ShellGetHandle("Freecell.exe", FCHandle)
  If bError Then
    'Fehlermeldung und Abbruch
    MsgBox "FreeCell kann nicht ausgeführt werden." & vbCr & _
      "FCAddOn wird deswegen abgebrochen.", _
      vbCritical + vbOKOnly, App.Title & " - Abbruch"
    End
  Else
    'Form anzeigen
    Me.Show
    '"X" in der Form ausschalten
    DisableClose Me
    'Prozeß-ID bestimmen
    ProcessID = GetCurrentProcessId
    'PGM vorm Taskmanager verstecken
    App.TaskVisible = False
    App.Title = vbNullString
    'Hauptroutine
    Call GetDataLoop(SourceIsReg, FCHandle)
  End If
  Set Registry = Nothing
  'Programm beenden
  End

 End Sub
 '--------------------------------------------------------------------------------

 Private Sub GetDataLoop(SourceIsReg As Boolean, FCHandle As Long)

  Dim GameIsWon As Boolean
  Dim GameIsLost As Boolean

  Dim i As Integer

  Dim tmpHandle As Long
  Dim WindowHandle As Long

  Dim Size As RECT
  Dim NewData As FREECELLINFO
  Dim NowData As FREECELLINFO
  Dim OldData As FREECELLINFO

  Dim Windows() As String

  'Einzulesende Werte initialisieren
  OldData.WonGames = 0
  OldData.LostGames = 0
  OldData.WonSMax = 0
  OldData.LostSMax = 0
  OldData.Streak = 0
  OldData.SType = 0
  NowData = OldData

  'Je nach Source andere Routine aufrufen
  If SourceIsReg Then
    Call GetRegData(OldData)
  Else
    Call GetIniData(OldData)
  End If
  'Neue Daten initialisieren
  NewData = OldData
  Call DisplayData(OldData, NowData)
  'Ist Programm noch aktiv?
  Do While Wait(FCHandle)
    'War letztes Spiel gewonnen oder verloren?
    GameIsWon = (NewData.SType = 1) And _
      (NewData.WonGames > OldData.WonGames)
    GameIsLost = (NewData.SType = 0) And _
      (NewData.LostGames > OldData.LostGames)
    'Bei gewonnenem Spiel Daten ändern
    If GameIsWon Then
      OldData = NewData
      NowData.WonGames = NowData.WonGames + 1
      If Betriebssystem = VER_PLATFORM_WINNT Then
        If NewData.Streak > NewData.WonSMax Then
          OldData.WonSMax = NewData.Streak
          NewData.WonSMax = NewData.Streak
          Registry.ValueKey = "wins"
          Registry.Value = NewData.Streak
        End If
      End If
    End If
    'Bei verlorenem Spiel Daten ändern
    If GameIsLost Then
      OldData = NewData
      NowData.LostGames = NowData.LostGames + 1
      If Betriebssystem = VER_PLATFORM_WINNT Then
        If NewData.Streak > NewData.LostSMax Then
          OldData.LostSMax = NewData.Streak
          NewData.LostSMax = NewData.Streak
          Registry.ValueKey = "losses"
          Registry.Value = NewData.Streak
        End If
      End If
    End If
    'In beiden Fällen Änderungen anzeigen
    If GameIsWon Or GameIsLost Then
      Call DisplayData(NewData, NowData)
    End If
    'Daten erneut auslesen
    If SourceIsReg Then
      Call GetRegData(NewData)
    Else
      Call GetIniData(NewData)
    End If
    Sleep (250)
    'FreeCell-Fenster finden
    Call GetAllParentWindows(Windows, Me, "FreeCell")
    WindowHandle = FindWindow(vbNullString, Windows(0))
    tmpHandle = GetWindowRect(WindowHandle, Size)
    'FCAddOn-Fenster-Position anpassen
    Main.Top = Size.Top * Screen.TwipsPerPixelX
    Main.Left = Size.Right * Screen.TwipsPerPixelY
    DoEvents
  Loop

 '--------------------------------------------------------------------------------
 End Sub

 Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

  '"Alt-F4"-Tastenkombination unterdrücken
  If (Shift = vbAltMask) Then
    Select Case KeyCode
      Case vbKeyF4
        KeyCode = 0
    End Select
  End If

 End Sub
 '--------------------------------------------------------------------------------

 Private Sub DisableClose(Window As Form)

  Dim hwndF As Long
  Dim hwndM As Long

  hwndF = Window.hwnd
  hwndM = GetSystemMenu(hwnd, 0)

  'Das "X"-Symbol ausschalten
  RemoveMenu hwndM, &HF060, &H200&
  EnableMenuItem hwndM, &HF060, 1

 End Sub
 '--------------------------------------------------------------------------------

 Private Sub EnableClose(Window As Form)

  Dim hwndF As Long
  Dim hwndM As Long

  hwndF = Window.hwnd
  hwndM = GetSystemMenu(hwnd, 1)

  'Das "X"-Symbol einschalten
  EnableMenuItem hwndM, &HF060, 0

 End Sub
 '--------------------------------------------------------------------------------

 Private Function ShellGetHandle(ByVal sDateiname As String, _
  lHandle As Long) As Boolean

  Dim udtProcessInfo As PROCESS_INFORMATION
  Dim udtStartupInfo As STARTUPINFO
  Dim lSuccess As Long

  'Programm "sDateiname" starten
  udtStartupInfo.cb = Len(udtStartupInfo)
  lSuccess = CreateProcess(0&, sDateiname, 0&, 0&, 1&, &H20, _
    0&, 0&, udtStartupInfo, udtProcessInfo)
  'Bei Erfolg Schalter setzen und Prozess-Handle merken
  If lSuccess = 1 Then
    lHandle = udtProcessInfo.hProcess
    ShellGetHandle = False
  Else
    ShellGetHandle = True
  End If

 End Function
 '--------------------------------------------------------------------------------

 Private Function Wait(ByVal lHandle As Long) As Boolean

  'Ein bestimmtes Programm beobachten, ob es aktiv ist
  If WaitForSingleObject(lHandle, 0) <> 0 Then
    Wait = True
  Else
    Wait = False
  End If

 End Function
 '--------------------------------------------------------------------------------

 Private Function Betriebssystem() As Byte

  Dim OS As OSVERSIONINFO

  OS.dwOSVersionInfoSize = Len(OS)
  GetVersionEx OS
  With OS
    Select Case .dwPlatformId
      Case 1  'Windows 95 oder Windows 98
        If (.dwMajorVersion = 4) And (.dwMinorVersion = 0) Then
          Betriebssystem = VER_PLATFORM_WIN95
          Exit Function
        End If
        If ((.dwMajorVersion = 4) And (.dwMinorVersion > 0)) Or _
          (.dwMajorVersion > 4) Then
          Betriebssystem = VER_PLATFORM_WIN98
          Exit Function
        End If
      Case 2  'Windows NT 4 oder Windows 2000
        If (.dwMajorVersion = 4) Then
          Betriebssystem = VER_PLATFORM_WINNT
          Exit Function
        End If
        If (.dwMajorVersion = 5) Then
          Betriebssystem = VER_PLATFORM_WIN2K
          Exit Function
        End If
      Case Else  'andere Plattformen
          Betriebssystem = VER_PLATFORM_OTHER
    End Select
  End With

 End Function
 '--------------------------------------------------------------------------------

 Private Function WinDir() As String

  Dim StrLen As Long
  Dim sDirBuf As String * 255

  'Bestimmt das Windows-Systemverzeichnis
  StrLen = GetWindowsDirectory(sDirBuf, 255)
  WinDir = Left$(sDirBuf, StrLen)

 End Function
 '--------------------------------------------------------------------------------

 Private Sub GetRegData(RegData As FREECELLINFO)

  'Alle Werte aus der Registry auslesen
  Registry.ValueKey = "won"
  RegData.WonGames = Registry.Value
  Registry.ValueKey = "lost"
  RegData.LostGames = Registry.Value
  Registry.ValueKey = "stype"
  RegData.SType = Registry.Value
  Registry.ValueKey = "streak"
  RegData.Streak = Registry.Value
  Registry.ValueKey = "wins"
  RegData.WonSMax = Registry.Value
  Registry.ValueKey = "losses"
  RegData.LostSMax = Registry.Value

 '--------------------------------------------------------------------------------
 End Sub

 Private Sub GetIniData(IniData As FREECELLINFO)

  'Lesen der "normalen" Werte aus der Ini-Datei
  IniData.WonGames = INI_GetKey(IniPath, "FreeCell", "gewonnen")
  IniData.LostGames = INI_GetKey(IniPath, "FreeCell", "verloren")
  IniData.SType = INI_GetKey(IniPath, "FreeCell", "stype")
  IniData.Streak = INI_GetKey(IniPath, "FreeCell", "Strähne")
  'Die zwei fehlenden Werte aus der Registry lesen
  Registry.ValueKey = "wins"
  IniData.WonSMax = Registry.Value
  Registry.ValueKey = "losses"
  IniData.LostSMax = Registry.Value

 '--------------------------------------------------------------------------------
 End Sub

 Private Sub DisplayData(DataOne As FREECELLINFO, DataTwo As FREECELLINFO)

  Dim Total As Long, PlayTotal As Long
  Dim PlayWon As Long, PlayLost As Long
  Dim WonPercent As Single, PlayGoal As Single

  Dim TotalNow As Long, WonPercNow As Single

  Dim EinE As String

  'Anzeige initialisieren
  lblAbsolutWon.Caption = Trim$(Str$(DataOne.WonGames)) & " von " & _
    Trim$(Str$(DataOne.WonGames + DataOne.LostGames))
  lblAbsWonNow.Caption = Trim$(Str$(DataTwo.WonGames)) & " von " & _
    Trim$(Str$(DataTwo.WonGames + DataTwo.LostGames))
  lblStreakWons.Caption = Trim$(Str$(DataOne.WonSMax))
  lblStreakLosses.Caption = Trim$(Str$(DataOne.LostSMax))

  'Sind Werte vorhanden?
  TotalNow = DataTwo.WonGames + DataTwo.LostGames
  Total = DataOne.WonGames + DataOne.LostGames
  If Total = 0 Then Exit Sub

  'Weiterverarbeitung (gewonnene Spiele)
  If TotalNow > 0 Then
    WonPercNow = (DataTwo.WonGames / TotalNow) * 100
  Else
    WonPercNow = 0
  End If
  lblPercWonNow.Caption = Format$(WonPercNow, "##0") & "%" & _
    " (" & Format$(WonPercNow, "##0.00") & "%)"
  WonPercent = (DataOne.WonGames / Total) * 100
  lblPercentWon.Caption = Format$(WonPercent, "##0") & "%" & _
    " (" & Format$(WonPercent, "##0.00") & "%)"

  'Weiterverarbeitung (letzte Serie)
  lblStreakAct.Caption = Trim$(Str$(DataOne.Streak)) & " mal "
  If DataOne.SType = 1 Then
    lblStreakAct.Caption = lblStreakAct.Caption & "gewonnen"
  Else
    lblStreakAct.Caption = lblStreakAct.Caption & "verloren"
  End If

  'Weiterverarbeitung (Wieviel Spiele noch bis zum nächsten Prozent?)
  PlayWon = DataOne.WonGames
  PlayTotal = Total
  PlayGoal = WonPercent
  Do Until Format$(WonPercent, "##0") <> Format$(PlayGoal, "##0") _
   Or PlayGoal = 100
    PlayWon = PlayWon + 1
    PlayTotal = PlayTotal + 1
    PlayGoal = (PlayWon / PlayTotal) * 100
  Loop

  'Ausgabe der "Zukunftsvision"
   If PlayWon - DataOne.WonGames = 1 Then
     EinE = ""
   Else
     EinE = "e"
   End If
   If PlayGoal < 100 Then
     lblMoreWins.Caption = Trim$(Str$(PlayWon - DataOne.WonGames)) & _
       " Gewinn" & EinE & " in Folge"
   Else
     lblMoreWins.Caption = "[Maximum erreicht]"
   End If

   'Weiterverarbeitung (Wieviel Spiele noch bis zum nächsten Prozent?)
   PlayLost = DataOne.LostGames
   PlayTotal = Total
   PlayGoal = 100 - WonPercent
   Do Until Format$(100 - WonPercent, "##0") <> Format$(PlayGoal, "##0") _
    Or PlayGoal = 100
     PlayLost = PlayLost + 1
     PlayTotal = PlayTotal + 1
     PlayGoal = (PlayLost / PlayTotal) * 100
   Loop

   'Ausgabe der "Zukunftsvision"
   If PlayLost - DataOne.LostGames = 1 Then
     EinE = ""
   Else
     EinE = "e"
   End If
   If PlayGoal < 100 Then
     lblMoreLosses.Caption = Trim$(Str$(PlayLost - DataOne.LostGames)) & _
       " Verlust" & EinE & " in Folge"
   Else
     lblMoreLosses.Caption = "[Maximum erreicht]"
   End If

 '--------------------------------------------------------------------------------
 End Sub

 Private Sub Form_Unload(Cancel As Integer)
   'Rücksetzen der Registry-Klasse
   Set Registry = Nothing
 End Sub

windows.bas  

'Konstante für "GetWindow"
Const GW_HWNDFIRST = 0
Const GW_HWNDNEXT = 2

'Konstante für "GetWindowLong"
Const GWL_STYLE = (-16)

'Konstante für "IsTask"
Const WIN_VISIBLE = &H10000000
Const WIN_BORDER = &H800000

'Konstante für "SetWindowPos"
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2

'Typ für "GetWindowRect"
Type RECT
 Left As Long
 Top As Long
 Right As Long
 Bottom As Long
End Type

Declare Function GetWindowText Lib "user32" _
 Alias "GetWindowTextA" _
 (ByVal hwnd As Long, _
 ByVal lpString As String, _
 ByVal cch As Long) As Long

Declare Function GetWindow Lib "user32" _
 (ByVal hwnd As Long, _
 ByVal wCmd As Long) As Long

Declare Function GetWindowLong Lib "user32" _
 Alias "GetWindowLongA" _
 (ByVal hwnd As Long, _
 ByVal wIndx As Long) As Long

Declare Function GetWindowTextLength Lib "user32" _
 Alias "GetWindowTextLengthA" _
 (ByVal hwnd As Long) As Long

Declare Function GetParent Lib "user32" _
 (ByVal hwnd As Long) As Long

Declare Function FindWindow Lib "user32" _
 Alias "FindWindowA" _
 (ByVal lpClassName As String, _
 ByVal lpWindowName As String) As Long

Declare Function GetWindowRect Lib "user32" _
 (ByVal hwnd As Long, _
 lpRect As RECT) As Long

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

Declare Function IsIconic Lib "user32" _
 (ByVal hwnd As Long) As Long

Declare Function GetForegroundWindow Lib "user32" _
 () As Long

Declare Function SetActiveWindow Lib "user32" _
 (ByVal hwnd As Long) As Long

Declare Function SetForegroundWindow Lib "user32" _
 (ByVal hwnd As Long) As Long

Dim IsTask As Long
'--------------------------------------------------------------------------------

Public Sub GetAllParentWindows(ByRef ArrayName() As String, SourceForm, _
 Optional ByVal SearchFor As String)

 Dim Count As Integer
 Dim Fore As Long
 Dim hwCurr As Long
 Dim intLen As Long
 Dim strTitle As String
 Dim TitleMatches As Boolean
 Dim isTop As Boolean
 Static State As Boolean

 Erase ArrayName
 ReDim Preserve ArrayName(0)
 hwCurr = GetWindow(SourceForm.hwnd, GW_HWNDFIRST)

 Fore = GetForegroundWindow

 IsTask = WIN_VISIBLE Or WIN_BORDER
 Do While hwCurr
   If hwCurr <> SourceForm.hwnd And TaskWindow(hwCurr) Then
     intLen = GetWindowTextLength(hwCurr) + 1
     strTitle = Space$(intLen)
     intLen = GetWindowText(hwCurr, strTitle, intLen)
     If SearchFor <> "" Then
       TitleMatches = (InStr(UCase$(strTitle), UCase$(SearchFor)) <> 0)
     Else
       TitleMatches = True
     End If
     If intLen > 0 And TitleMatches Then
       If GetParent(hwCurr) = 0 Then
         ArrayName(UBound(ArrayName)) = strTitle
         ReDim Preserve ArrayName(UBound(ArrayName) + 1)
         If Not IsIconic(hwCurr) Then Count = Count + 1
         If Fore = hwCurr Then isTop = True
       End If
     End If
   End If
   hwCurr = GetWindow(hwCurr, GW_HWNDNEXT)
 Loop
 If UBound(ArrayName) > 0 Then
   ReDim Preserve ArrayName(UBound(ArrayName) - 1)
 End If

 If Count <> 0 Then
   If Not Main.Visible Then
     Main.Visible = True
     SetForegroundWindow (Main.hwnd)
   End If
   If isTop Then
     If State = False Then
     SetWindowPos Main.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
       State = True
     End If
     State = True
   Else
     If State = True Then SetWindowPos Main.hwnd, HWND_NOTOPMOST, _
       0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
     State = False
   End If
 Else
   Main.Visible = False
 End If

 SetForegroundWindow (Fore)
 SetActiveWindow (Fore)

'--------------------------------------------------------------------------------
End Sub

Public Function GetWindowTitle(SearchFor As String, SourceForm) As String

 Dim hwCurr As Long
 Dim intLen As Long
 Dim strTitle As String

 hwCurr = GetWindow(SourceForm.hwnd, GW_HWNDFIRST)

 IsTask = WIN_VISIBLE Or WIN_BORDER
 Do While hwCurr
   If hwCurr <> SourceForm.hwnd And TaskWindow(hwCurr) Then
     intLen = GetWindowTextLength(hwCurr) + 1
     strTitle = Space$(intLen)
     intLen = GetWindowText(hwCurr, strTitle, intLen)
     If intLen > 0 And InStr(UCase(strTitle), UCase(SearchFor)) Then
       GetWindowTitle = strTitle
       Exit Function
     End If
   End If
   hwCurr = GetWindow(hwCurr, GW_HWNDNEXT)
 Loop
 GetWindowTitle = ""

End Function
'--------------------------------------------------------------------------------

Public Function GetWindowHandle(SearchFor As String, SourceForm) As Long

 Dim hwCurr As Long
 Dim intLen As Long
 Dim strTitle As String

 hwCurr = GetWindow(SourceForm.hwnd, GW_HWNDFIRST)

 IsTask = WIN_VISIBLE Or WIN_BORDER
 Do While hwCurr
   If hwCurr <> SourceForm.hwnd And TaskWindow(hwCurr) Then
     intLen = GetWindowTextLength(hwCurr) + 1
     strTitle = Space$(intLen)
     intLen = GetWindowText(hwCurr, strTitle, intLen)
     If intLen > 0 And InStr(UCase(strTitle), UCase(SearchFor)) Then
       GetWindowHandle = hwCurr
       Exit Function
     End If
   End If
   hwCurr = GetWindow(hwCurr, GW_HWNDNEXT)
 Loop
 GetWindowHandle = &H0&

End Function
'--------------------------------------------------------------------------------

Private Function TaskWindow(hwCurr As Long) As Long

 Dim lngStyle As Long

 lngStyle = GetWindowLong(hwCurr, GWL_STYLE)
 If (lngStyle And IsTask) = IsTask Then TaskWindow = True

End Function

INIFiles.bat  

 Option Explicit

 Declare Function GetPrivateProfileString Lib "KERNEL32" _
  Alias "GetPrivateProfileStringA" _
  (ByVal lpApplicationName As String, _
  ByVal lpKeyName As Any, _
  ByVal lpDefault As String, _
  ByVal lpReturnedString As String, _
  ByVal nSize As Long, _
  ByVal lpFileName As String) As Long

 Declare Function WritePrivateProfileString Lib "KERNEL32" _
  Alias "WritePrivateProfileStringA" _
  (ByVal lpApplicationName As String, _
  ByVal lpKeyName As Any, _
  ByVal lpString As Any, _
  ByVal lpFileName As String) As Long
'--------------------------------------------------------------------------------

 Public Function INI_WriteKey(FileName As String, Section As String, _
  Key As String, Value As String) As Long

  INI_WriteKey = WritePrivateProfileString(Section, Key, Value, FileName)

 End Function
 '--------------------------------------------------------------------------------

 Public Function INI_GetKey(FileName As String, Section As String, _
  Key As String) As String

  Dim Temp As String
  Dim x As String

  Temp = String(255, 0)
  x = GetPrivateProfileString(Section, Key, "", Temp, 255, FileName)
  Temp = Left$(Temp, x)
  INI_GetKey = Temp

 End Function

cRegistry.bas  

Option Explicit

' =========================================================
' Class:    cRegistry
' Author:   Steve McMahon
' Date  :   21 Feb 1997
'
' A nice class wrapper around the registry functions
' Allows searching,deletion,modification and addition
' of Keys or Values.
'
' Updated 29 April 1998 for VB5.
'   * Fixed GPF in EnumerateValues
'   * Added support for all registry types, not just strings
'   * Put all declares in local class
'   * Added VB5 Enums
'   * Added CreateKey and DeleteKey methods
'
' Updated 2 January 1999
'   * The CreateExeAssociation method failed to set up the
'     association correctly if the optional document icon
'     was not provided.
'   * Added new parameters to CreateExeAssociation to set up
'     other standard handlers: Print, Add, New
'   * Provided the CreateAdditionalEXEAssociations method
'     to allow non-standard menu items to be added (for example,
'     right click on a .VBP file.  VB installs Run and Make
'     menu items).
'
' Updated 8 February 2000
'   * Ensure CreateExeAssociation and related items sets up the
'     registry keys in the
'           HKEY_LOCAL_MACHINE\SOFTWARE\Classes
'     branch as well as the HKEY_CLASSES_ROOT branch.
'
' ---------------------------------------------------------------------------
' vbAccelerator - free, advanced source code for VB programmers.
'     http://vbaccelerator.com
' =========================================================

'Registry Specific Access Rights
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_ALL_ACCESS = &H3F

'Open/Create Options
Private Const REG_OPTION_NON_VOLATILE = 0&
Private Const REG_OPTION_VOLATILE = &H1

'Key creation/open disposition
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_OPENED_EXISTING_KEY = &H2

'masks for the predefined standard access types
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF

'Define severity codes
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_ACCESS_DENIED = 5
Private Const ERROR_INVALID_DATA = 13&
Private Const ERROR_MORE_DATA = 234 '  dderror
Private Const ERROR_NO_MORE_ITEMS = 259


'Structures Needed For Registry Prototypes
Private Type SECURITY_ATTRIBUTES
 nLength As Long
 lpSecurityDescriptor As Long
 bInheritHandle As Boolean
End Type

Private Type FILETIME
 dwLowDateTime As Long
 dwHighDateTime As Long
End Type

'Registry Function Prototypes
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _
 (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
 ByVal samDesired As Long, phkResult As Long) As Long

Private Declare Function RegSetValueExStr Lib "advapi32" Alias "RegSetValueExA" _
 (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
  ByVal dwType As Long, ByVal szData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32" Alias "RegSetValueExA" _
 (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
  ByVal dwType As Long, szData As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "advapi32" Alias "RegSetValueExA" _
 (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
  ByVal dwType As Long, szData As Byte, ByVal cbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Declare Function RegQueryValueExStr Lib "advapi32" Alias "RegQueryValueExA" _
 (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
  ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32" Alias "RegQueryValueExA" _
 (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
  ByRef lpType As Long, szData As Long, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExByte Lib "advapi32" Alias "RegQueryValueExA" _
 (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
  ByRef lpType As Long, szData As Byte, ByRef lpcbData As Long) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" _
 (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
  ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
  lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, _
  lpdwDisposition As Long) As Long

Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _
 (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
  lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, _
  lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long

Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" ( _
   ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
   ByVal cbName As Long) As Long

Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
 (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  lpcbValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, _
  ByVal lpData As Long, ByVal lpcbData As Long) As Long

Private Declare Function RegEnumValueLong Lib "advapi32.dll" Alias "RegEnumValueA" _
 (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
  lpData As Long, lpcbData As Long) As Long
Private Declare Function RegEnumValueStr Lib "advapi32.dll" Alias "RegEnumValueA" _
 (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
  ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumValueByte Lib "advapi32.dll" Alias "RegEnumValueA" _
 (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
  lpData As Byte, lpcbData As Long) As Long

Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
  (ByVal hKey As Long, ByVal lpClass As String, _
  lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, _
  lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, _
  lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, _
  lpftLastWriteTime As Any) As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
 (ByVal hKey As Long, ByVal lpSubKey As String) As Long

Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
 (ByVal hKey As Long, ByVal lpValueName As String) As Long

' Other declares:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function ExpandEnvironmentStrings Lib        _
 "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, _
 ByVal lpDst As String, ByVal nSize As Long) As Long


Public Enum ERegistryClassConstants
   HKEY_CLASSES_ROOT = &H80000000
   HKEY_CURRENT_USER = &H80000001
   HKEY_LOCAL_MACHINE = &H80000002
   HKEY_USERS = &H80000003
End Enum

Public Enum ERegistryValueTypes
'Predefined Value Types
   REG_NONE = (0)                         'No value type
   REG_SZ = (1)                           'Unicode nul terminated string
   REG_EXPAND_SZ = (2)                    'Unicode nul terminated string w/enviornment var
   REG_BINARY = (3)                       'Free form binary
   REG_DWORD = (4)                        '32-bit number
   REG_DWORD_LITTLE_ENDIAN = (4)          '32-bit number (same as REG_DWORD)
   REG_DWORD_BIG_ENDIAN = (5)             '32-bit number
   REG_LINK = (6)                         'Symbolic Link (unicode)
   REG_MULTI_SZ = (7)                     'Multiple Unicode strings
   REG_RESOURCE_LIST = (8)                'Resource list in the resource map
   REG_FULL_RESOURCE_DESCRIPTOR = (9)     'Resource list in the hardware description
   REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum

Private m_hClassKey As Long
Private m_sSectionKey As String
Private m_sValueKey As String
Private m_vValue As Variant
Private m_sSetValue As String
Private m_vDefault As Variant
Private m_eValueType As ERegistryValueTypes

Public Property Get KeyExists() As Boolean
   'KeyExists = bCheckKeyExists( _
   '                m_hClassKey, _
   '                m_sSectionKey _
   '            )
Dim hKey As Long
   If RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, 1, hKey) = ERROR_SUCCESS Then
       KeyExists = True
       RegCloseKey hKey
   Else
       KeyExists = False
   End If

End Property
'--------------------------------------------------------------------------------
Public Function CreateKey() As Boolean
Dim tSA As SECURITY_ATTRIBUTES
Dim hKey As Long
Dim lCreate As Long
Dim e As Long

   'Open or Create the key
   e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
                KEY_ALL_ACCESS, tSA, hKey, lCreate)
   If e Then
       Err.Raise 26001, App.EXEName & ".cRegistry", Failed To create registry Key: _
        '" & m_sSectionKey
   Else
       CreateKey = (e = ERROR_SUCCESS)
       'Close the key
       RegCloseKey hKey
   End If
End Function
'--------------------------------------------------------------------------------
Public Function DeleteKey() As Boolean
Dim e As Long
   e = RegDeleteKey(m_hClassKey, m_sSectionKey)
   If e Then
       Err.Raise 26001, App.EXEName & ".cRegistry",  _
        "Failed to delete registry Key: '" _
        & m_hClassKey & "',Section: '" & m_sSectionKey
   Else
       DeleteKey = (e = ERROR_SUCCESS)
   End If

End Function
'--------------------------------------------------------------------------------
Public Function DeleteValue() As Boolean
Dim e As Long
Dim hKey As Long

   e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ALL_ACCESS, hKey)
   If e Then
       Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to open key '" _
        & m_hClassKey & "',Section: '" & _
        m_sSectionKey & "' for delete access"
   Else
       e = RegDeleteValue(hKey, m_sValueKey)
       If e Then
           Err.Raise 26001, App.EXEName & ".cRegistry",  _
            Failed To delete registry Key: '"  _& m_hClassKey & _
            "',Section: '" & m_sSectionKey & "',Key: '" & _
            m_sValueKey
       Else
           DeleteValue = (e = ERROR_SUCCESS)
       End If
   End If

'--------------------------------------------------------------------------------
End Function
Public Property Get Value() As Variant
Dim vValue As Variant
Dim cData As Long, sData As String, ordType As Long, e As Long
Dim hKey As Long

   e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
   'ApiRaiseIf e

   e = RegQueryValueExLong(hKey, m_sValueKey, 0&, ordType, 0&, cData)
   If e And e <> ERROR_MORE_DATA Then
       Value = m_vDefault
       Exit Property
   End If

   m_eValueType = ordType
   Select Case ordType
   Case REG_BINARY, REG_DWORD, REG_DWORD_LITTLE_ENDIAN
       Dim iData As Long
       e = RegQueryValueExLong(hKey, m_sValueKey, 0&, _
                              ordType, iData, cData)
       vValue = CLng(iData)

   Case REG_DWORD_BIG_ENDIAN  ' Unlikely, but you never know
       Dim dwData As Long
       e = RegQueryValueExLong(hKey, m_sValueKey, 0&, _
                              ordType, dwData, cData)
       vValue = SwapEndian(dwData)

   Case REG_SZ, REG_MULTI_SZ ' Same thing to Visual Basic
       sData = String$(cData - 1, 0)
       e = RegQueryValueExStr(hKey, m_sValueKey, 0&, _
                              ordType, sData, cData)
       vValue = sData

   Case REG_EXPAND_SZ
       sData = String$(cData - 1, 0)
       e = RegQueryValueExStr(hKey, m_sValueKey, 0&, _
                              ordType, sData, cData)
       vValue = ExpandEnvStr(sData)

   ' Catch anything else
   Case Else
       Dim abData() As Byte
       ReDim abData(cData)
       e = RegQueryValueExByte(hKey, m_sValueKey, 0&, _
                               ordType, abData(0), cData)
       vValue = abData

   End Select
   Value = vValue

End Property
'--------------------------------------------------------------------------------
Public Property Let Value( _
       ByVal vValue As Variant _
   )
Dim ordType As Long
Dim c As Long
Dim hKey As Long
Dim e As Long
Dim lCreate As Long
Dim tSA As SECURITY_ATTRIBUTES

   'Open or Create the key
   e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, _
                KEY_ALL_ACCESS, tSA, hKey, lCreate)

   If e Then
       Err.Raise 26001, App.EXEName & ".cRegistry", _
        " _Failed to set registry value Key: '" & m_hClassKey & _
        "',Section: '" & m_sSectionKey &  _"',Key: '" & _
        m_sValueKey & "' to value: '" & m_vValue & "'"
   Else

       Select Case m_eValueType
       Case REG_BINARY
           If (VarType(vValue) = vbArray + vbByte) Then
               Dim ab() As Byte
               ab = vValue
               ordType = REG_BINARY
               c = UBound(ab) - LBound(ab) - 1
               e = RegSetValueExByte(hKey, m_sValueKey, 0&, ordType, ab(0), c)
           Else
               Err.Raise 26001
           End If
       Case REG_DWORD, REG_DWORD_BIG_ENDIAN, REG_DWORD_LITTLE_ENDIAN
           If (VarType(vValue) = vbInteger) Or (VarType(vValue) = vbLong) Then
               Dim i As Long
               i = vValue
               ordType = REG_DWORD
               e = RegSetValueExLong(hKey, m_sValueKey, 0&, ordType, i, 4)
           End If
       Case REG_SZ, REG_EXPAND_SZ
           Dim s As String, iPos As Long
           s = vValue
           ordType = REG_SZ
           ' Assume anything with two non-adjacent percents is expanded string
           iPos = InStr(s, "%")
           If iPos Then
               If InStr(iPos + 2, s, "%") Then ordType = REG_EXPAND_SZ
           End If
           c = Len(s) + 1
           e = RegSetValueExStr(hKey, m_sValueKey, 0&, ordType, s, c)

       ' User should convert to a compatible type before calling
       Case Else
           e = ERROR_INVALID_DATA

       End Select

       If Not e Then
           m_vValue = vValue
       Else
           Err.Raise vbObjectError + 1048 + 26001, App.EXEName & ".cRegistry" _
           , "Failed to set registry value Key: '" & _ m_hClassKey & _
           "',Section: '" & m_sSectionKey & "',Key: _ '" & m_sValueKey & _
           "' to value: '" & m_vValue & "'"
       End If

       'Close the key
       RegCloseKey hKey

   End If

End Property
'--------------------------------------------------------------------------------
Public Function EnumerateValues( _
       ByRef sKeyNames() As String, _
       ByRef iKeyCount As Long _
   ) As Boolean
Dim lResult As Long
Dim hKey As Long
Dim sName As String
Dim lNameSize As Long
Dim sData As String
Dim lIndex As Long
Dim cJunk As Long
Dim cNameMax As Long
Dim ft As Currency

  ' Log "EnterEnumerateValues"

  iKeyCount = 0
  Erase sKeyNames()

  lIndex = 0
  lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
  If (lResult = ERROR_SUCCESS) Then
     ' Log "OpenedKey:" & m_hClassKey & "," & m_sSectionKey
     lResult = RegQueryInfoKey(hKey, "", cJunk, 0, _
                              cJunk, cJunk, cJunk, cJunk, _
                              cNameMax, cJunk, cJunk, ft)
      Do While lResult = ERROR_SUCCESS

          'Set buffer space
          lNameSize = cNameMax + 1
          sName = String$(lNameSize, 0)
          If (lNameSize = 0) Then lNameSize = 1

          ' Log "Requesting Next Value"

          'Get value name:
          lResult = RegEnumValue(hKey, lIndex, sName, lNameSize, _
                                 0&, 0&, 0&, 0&)
          ' Log "RegEnumValue returned:" & lResult
          If (lResult = ERROR_SUCCESS) Then

               ' Although in theory you can also retrieve the actual
               ' value and type here, I found it always (ultimately) resulted in
               ' a GPF, on Win95 and NT.  Why?  Can anyone help?

              sName = Left$(sName, lNameSize)
              ' Log "Enumerated value:" & sName

              iKeyCount = iKeyCount + 1
              ReDim Preserve sKeyNames(1 To iKeyCount) As String
              sKeyNames(iKeyCount) = sName
          End If
          lIndex = lIndex + 1
      Loop
  End If
  If (hKey <> 0) Then
     RegCloseKey hKey
  End If

  ' Log "Exit Enumerate Values"
  EnumerateValues = True
  Exit Function

EnumerateValuesError:
  If (hKey <> 0) Then
     RegCloseKey hKey
  End If
  Err.Raise vbObjectError + 1048 + 26003, App.EXEName & ".cRegistry", Err.Description
  Exit Function

'--------------------------------------------------------------------------------
End Function
Public Function EnumerateSections( _
       ByRef sSect() As String, _
       ByRef iSectCount As Long _
   ) As Boolean
Dim lResult As Long
Dim hKey As Long
Dim dwReserved As Long
Dim szBuffer As String
Dim lBuffSize As Long
Dim lIndex As Long
Dim lType As Long
Dim sCompKey As String
Dim iPos As Long

On Error Goto EnumerateSectionsError

  iSectCount = 0
  Erase sSect

  lIndex = 0

  lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ENUMERATE_SUB_KEYS, hKey)
  Do While lResult = ERROR_SUCCESS
      'Set buffer space
      szBuffer = String$(255, 0)
      lBuffSize = Len(szBuffer)

     'Get next value
      lResult = RegEnumKey(hKey, lIndex, szBuffer, lBuffSize)

      If (lResult = ERROR_SUCCESS) Then
          iSectCount = iSectCount + 1
          ReDim Preserve sSect(1 To iSectCount) As String
          iPos = InStr(szBuffer, Chr$(0))
          If (iPos > 0) Then
             sSect(iSectCount) = Left(szBuffer, iPos - 1)
          Else
             sSect(iSectCount) = Left(szBuffer, lBuffSize)
          End If
      End If

      lIndex = lIndex + 1
  Loop
  If (hKey <> 0) Then
     RegCloseKey hKey
  End If
  EnumerateSections = True
  Exit Function

EnumerateSectionsError:
  If (hKey <> 0) Then
     RegCloseKey hKey
  End If
  Err.Raise vbObjectError + 1048 + 26002, App.EXEName & ".cRegistry", Err.Description
  Exit Function
End Function
'--------------------------------------------------------------------------------
Private Sub pSetClassValue(ByVal sValue As String)
Dim sSection As String
  ClassKey = HKEY_CLASSES_ROOT
  Value = sValue
  sSection = SectionKey
  ClassKey = HKEY_LOCAL_MACHINE
  SectionKey = "SOFTWARE\Classes\" & sSection
  Value = sValue
  SectionKey = sSection
End Sub
'--------------------------------------------------------------------------------
Public Sub CreateEXEAssociation( _
       ByVal sExePath As String, _
       ByVal sClassName As String, _
       ByVal sClassDescription As String, _
       ByVal sAssociation As String, _
       Optional ByVal sOpenMenuText As String = "&Open", _
       Optional ByVal bSupportPrint As Boolean = False, _
       Optional ByVal sPrintMenuText As String = "&Print", _
       Optional ByVal bSupportNew As Boolean = False, _
       Optional ByVal sNewMenuText As String = "&New", _
       Optional ByVal bSupportInstall As Boolean = False, _
       Optional ByVal sInstallMenuText As String = "", _
       Optional ByVal lDefaultIconIndex As Long = -1 _
   )
  ' Check if path is wrapped in quotes:
  sExePath = Trim$(sExePath)
  If (Left$(sExePath, 1) <> ""quot;) Then
     sExePath = ""quot; & sExePath
  End If
  If (Right$(sExePath, 1) <> ""quot;) Then
     sExePath = sExePath & ""quot;
  End If

   ' Create the .File to Class association:
  SectionKey = "." & sAssociation
  ValueType = REG_SZ
  ValueKey = ""
  pSetClassValue sClassName

  ' Create the Class shell open command:
  SectionKey = sClassName
  pSetClassValue sClassDescription

  SectionKey = sClassName & "\shell\open"
  If (sOpenMenuText = "") Then sOpenMenuText = "&Open"
  ValueKey = ""
  pSetClassValue sOpenMenuText
  SectionKey = sClassName & "\shell\open\command"
  ValueKey = ""
  pSetClassValue sExePath & " ""%1"""

  If (bSupportPrint) Then
     SectionKey = sClassName & "\shell\print"
     If (sPrintMenuText = "") Then sPrintMenuText = "&Print"
     ValueKey = ""
     pSetClassValue sPrintMenuText
     SectionKey = sClassName & "\shell\print\command"
     ValueKey = ""
     pSetClassValue sExePath & " /p ""%1"""
  End If

  If (bSupportInstall) Then
     If (sInstallMenuText = "") Then
        sInstallMenuText = "&Install " & sAssociation
     End If
     SectionKey = sClassName & "\shell\add"
     ValueKey = ""
     pSetClassValue sInstallMenuText
     SectionKey = sClassName & "\shell\add\command"
     ValueKey = ""
     pSetClassValue sExePath & " /a ""%1"""
  End If

  If (bSupportNew) Then
     SectionKey = sClassName & "\shell\new"
     ValueKey = ""
     If (sNewMenuText = "") Then sNewMenuText = "&New"
     pSetClassValue sNewMenuText
     SectionKey = sClassName & "\shell\new\command"
     ValueKey = ""
     pSetClassValue sExePath & " /n ""%1"""
  End If

  If lDefaultIconIndex > -1 Then
     SectionKey = sClassName & "\DefaultIcon"
     ValueKey = ""
     pSetClassValue sExePath & "," & CStr(lDefaultIconIndex)
  End If

End Sub
'--------------------------------------------------------------------------------
Public Sub CreateAdditionalEXEAssociations( _
     ByVal sClassName As String, _
     ParamArray vItems() As Variant _
  )
Dim iItems As Long
Dim iItem As Long

  On Error Resume Next
  iItems = UBound(vItems) + 1
  If (iItems Mod 3) <> 0 Or (Err.Number <> 0) Then
     Err.Raise vbObjectError + 1048 + 26004, App.EXEName & ".cRegistry", _
      "Invalid parameter list passed to CreateAdditionalEXEAssociations" & _
      " - expected _ Name/Text/Command"
  Else
     ' Check if it exists:
     SectionKey = sClassName
     If Not (KeyExists) Then
        Err.Raise vbObjectError + 1048 + 26005, App.EXEName & ".cRegistry", _
        "Error - _attempt to create additional associations before class defined."
     Else
        For iItem = 0 To iItems - 1 Step 3
           ValueType = REG_SZ
           SectionKey = sClassName & "\shell\" & vItems(iItem)
           ValueKey = ""
           pSetClassValue vItems(iItem + 1)
           SectionKey = sClassName & "\shell\" & vItems(iItem) & "\command"
           ValueKey = ""
           pSetClassValue vItems(iItem + 2)
        Next iItem
     End If
  End If

End Sub
'--------------------------------------------------------------------------------
Public Property Get ValueType() As ERegistryValueTypes
   ValueType = m_eValueType
End Property
'--------------------------------------------------------------------------------
Public Property Let ValueType(ByVal eValueType As ERegistryValueTypes)
   m_eValueType = eValueType
End Property
'--------------------------------------------------------------------------------
Public Property Get ClassKey() As ERegistryClassConstants
   ClassKey = m_hClassKey
End Property
'--------------------------------------------------------------------------------
Public Property Let ClassKey( _
       ByVal eKey As ERegistryClassConstants _
   )
   m_hClassKey = eKey
End Property
'--------------------------------------------------------------------------------
Public Property Get SectionKey() As String
   SectionKey = m_sSectionKey
End Property
'--------------------------------------------------------------------------------
Public Property Let SectionKey( _
       ByVal sSectionKey As String _
   )
   m_sSectionKey = sSectionKey
End Property
'--------------------------------------------------------------------------------
Public Property Get ValueKey() As String
   ValueKey = m_sValueKey
End Property
'--------------------------------------------------------------------------------
Public Property Let ValueKey( _
       ByVal sValueKey As String _
   )
   m_sValueKey = sValueKey
End Property
'--------------------------------------------------------------------------------
Public Property Get Default() As Variant
   Default = m_vDefault
End Property
'--------------------------------------------------------------------------------
Public Property Let Default( _
       ByVal vDefault As Variant _
   )
   m_vDefault = vDefault
End Property
'--------------------------------------------------------------------------------
Private Function SwapEndian(ByVal dw As Long) As Long
   CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
   CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
   CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
   CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
End Function
'--------------------------------------------------------------------------------
Private Function ExpandEnvStr(sData As String) As String
   Dim c As Long, s As String
   ' Get the length
   s = "" ' Needed to get around Windows 95 limitation
   c = ExpandEnvironmentStrings(sData, s, c)
   ' Expand the string
   s = String$(c - 1, 0)
   c = ExpandEnvironmentStrings(sData, s, c)
   ExpandEnvStr = s
End Function