'***********************************************************************
'* Control : WWWTools.Tools
'*
'* Purpose : General system tools packed into an OCX
'*
'* References : None
'*
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
'***********************************************************************
'* All functions in WWWTools return one of the following
'***********************************************************************
Private Const WWW_ERROR = 0
Private Const WWW_OK = 1
'***********************************************************************
'* All functions in this library set one of the following error codes
'***********************************************************************
Private Const WWW_UNHANDLED_ERROR = 2
'***********************************************************************
'* Module level variables
'***********************************************************************
Private mblnKillProcess As Boolean
Private mlLastErrorNumber As Long
Private mstrLastErrorSource As String
Private mstrLastErrorDescription As String
Private mblnRaiseWMPaintEvent As Boolean
'***********************************************************************
'* Events
'***********************************************************************
Public Event WMPaint()
'***********************************************************************
'* Control Initilization and Termination
'***********************************************************************
Private Sub UserControl_Initialize()
mblnKillProcess = False
mblnRaiseWMPaintEvent = False
End Sub
Private Sub UserControl_Terminate()
UnHookWindowProc
End Sub
'***********************************************************************
'* Property : blnRaiseWMPaintEvent()
'* Purpose : If set to true, then raise WM_PAINT events
'* Revision : 1.0.0 08/07/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Property Let blnRaiseWMPaintEvent(ByVal vblnRaiseWMPaintEvent As Boolean)
mblnRaiseWMPaintEvent = vblnRaiseWMPaintEvent
End Property
'***********************************************************************
'* Property : blnKillProcess()
'* Purpose : If set to true, then all running processes will be killed.
'* Revision : 1.0.0 08/07/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Property Let blnKillProcess(ByVal vblnKillProcess As Boolean)
mblnKillProcess = vblnKillProcess
End Property
Public Property Get blnKillProcess() As Boolean
blnKillProcess = mblnKillProcess
End Property
'***********************************************************************
'* Property : lLastErrorNumber()
'* Purpose : Last error number logged by LogVBError
'* Revision : 1.0.0 08/07/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Property Get lLastErrorNumber() As Long
lLastErrorNumber = mlLastErrorNumber
End Property
'***********************************************************************
'* Property : strLastErrorSource()
'* Purpose : Last error source logged by LogVBError
'* Revision : 1.0.0 08/07/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Property Get strLastErrorSource() As String
strLastErrorSource = mstrLastErrorSource
End Property
'***********************************************************************
'* Property : strLastErrorDescription()
'* Purpose : Last error description logged by LogVBError
'* Revision : 1.0.0 08/07/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Property Get strLastErrorDescription() As String
strLastErrorDescription = mstrLastErrorDescription
End Property
'***********************************************************************
'* Registry Related Functions
'***********************************************************************
'***********************************************************************
'* Function : ParseRegKey()
'* Purpose : Parse a registration database key into the system key
'* handle and the key name
'* Inputs : strFullKeyName - The key name preceded by the system key
'* name in upper case.
'* Example HKEY_LOCAL_MACHINE\software\Test
'* strKeyName - The key name
'* lSystemKeyHandle - The system key handle
'* blnValue - If true, then treat the last part of
'* the key as a value
'* strValueName - If blnValue is true, this is where the
'* value name is placed
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Function ParseRegKey(ByVal strFullKeyName As String, _
ByRef strKeyName As String, _
ByRef hSystemKeyHandle As Long, _
Optional ByVal blnValue As Boolean = False, _
Optional ByRef strValueName As String) _
As Long
On Error GoTo ErrHandler
Dim lStrPosKey As Long
Dim lStrPosTemp As Long
Dim lStrPosValue As Long
Dim strSystemKey As String
ParseRegKey = WWW_OK
lStrPosKey = InStr(1, strFullKeyName, "\", vbTextCompare)
If lStrPosKey Then
strSystemKey = Left(strFullKeyName, lStrPosKey - 1)
Else
ParseRegKey = WWW_ERROR
LogVBError "WWWTools.Tools", _
"ParseRegKey - No sub key or value found under system key", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If blnValue Then
lStrPosTemp = lStrPosKey
Do
lStrPosValue = lStrPosTemp
lStrPosTemp = InStr(lStrPosTemp + 1, _
strFullKeyName, _
"\")
Loop Until lStrPosTemp = 0
strKeyName = Mid(strFullKeyName, _
lStrPosKey + 1, _
lStrPosValue - lStrPosKey)
strValueName = Right(strFullKeyName, _
Len(strFullKeyName) - lStrPosValue)
Else
strKeyName = Right(strFullKeyName, Len(strFullKeyName) - lStrPosKey)
End If
Select Case strSystemKey
Case "HKEY_CLASSES_ROOT":
hSystemKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER":
hSystemKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE":
hSystemKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS":
hSystemKeyHandle = HKEY_USERS
Case Else
ParseRegKey = WWW_ERROR
LogVBError "WWWTools.Tools", _
"ParseRegKey - Invalid system key", _
WWW_UNHANDLED_ERROR
Exit Function
End Select
Exit Function
ErrHandler:
ParseRegKey = WWW_ERROR
LogVBError Err.source, _
"ParseRegKey - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : RegKeyExists
'* Purpose : Determine if a registry key or value exists
'* Inputs : strRegName - The key or value name preceded by the
'* system key name in upper case and the
'* subkey. For example
'* HKEY_LOCAL_MACHINE\SOFTWARE\test\value
'* blnExists - True if the key or value exists
'* blnValue - If true then test for value under the key.
'* blnDefault - If true then test for key default value
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function RegKeyExists(ByVal strQueryRegName As Variant, _
ByRef blnExists As Variant, _
Optional ByVal blnValue As Boolean = False, _
Optional ByVal blnDefault As Boolean = False) _
As Long
On Error GoTo ErrHandler
Dim hKeyHandle As Long
Dim lDisposition As Long
Dim hSystemKey As Long
Dim strKeyName As String
Dim strValueName As String
Dim lValueType As Long
Dim strValueString As String
Dim lValueLong As Long
Dim lValueSize As Long
RegKeyExists = WWW_OK
If ParseRegKey(strQueryRegName, _
strKeyName, _
hSystemKey, _
blnValue, _
strValueName) <> WWW_OK Then
RegKeyExists = WWW_ERROR
LogVBError "WWWTools.Tools", _
"RegKeyExists - ParseRegKey Failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If RegOpenKeyEx(hSystemKey, _
strKeyName, _
0&, _
KEY_ALL_ACCESS, _
hKeyHandle) <> ERROR_SUCCESS Then
blnExists = False
RegCloseKey hKeyHandle
Exit Function
Else
blnExists = True
End If
If blnValue Then
If RegQueryValueExNULL(hKeyHandle, _
strValueName, _
0&, _
lValueType, _
0&, _
lValueSize) <> ERROR_SUCCESS Then
blnExists = False
Else
blnExists = True
End If
End If
If blnDefault Then
If RegQueryValueExNULL(hKeyHandle, _
vbNullString, _
0&, _
lValueType, _
0&, _
lValueSize) <> ERROR_SUCCESS Then
blnExists = False
Else
blnExists = True
End If
End If
RegCloseKey hKeyHandle
Exit Function
ErrHandler:
RegKeyExists = WWW_ERROR
LogVBError Err.source, _
"RegKeyExists - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : QueryRegValue
'* Purpose : Retrieve a registration database value
'* Inputs : strQueryValueName - The value name preceded by the
'* system key name in upper case and the
'* subkey. For example
'* HKEY_LOCAL_MACHINE\SOFTWARE\test\value
'* vntValue - The retrieved value is placed here
'* blnValue - If false then get value for the key, not
'* the value under the key.
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function QueryRegValue(ByVal strQueryValueName As String, _
ByRef vntValue As Variant, _
Optional ByVal blnValue As Boolean = True) _
As Long
On Error GoTo ErrHandler
Dim hNewKey As Long
Dim lDisposition As Long
Dim hSystemKey As Long
Dim strKeyName As String
Dim strValueName As String
Dim lValueType As Long
Dim strValueString As String
Dim lValueLong As Long
Dim lValueSize As Long
QueryRegValue = WWW_OK
If ParseRegKey(strQueryValueName, _
strKeyName, _
hSystemKey, _
blnValue, _
strValueName) <> WWW_OK Then
QueryRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"QueryRegValue - ParseRegKey Failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If RegCreateKeyEx(hSystemKey, _
strKeyName, _
0&, _
vbNullString, _
REG_OPTION_NON_VOLATILE, _
KEY_QUERY_VALUE, _
0&, _
hNewKey, _
lDisposition) <> ERROR_SUCCESS Then
QueryRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"QueryRegValue - Could not obtain key handle", _
GetLastError(), _
True
Exit Function
End If
If RegQueryValueExNULL(hNewKey, _
strValueName, _
0&, _
lValueType, _
0&, _
lValueSize) <> ERROR_SUCCESS Then
QueryRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"QueryRegValue - Could not query value", _
GetLastError(), _
True
Exit Function
End If
Select Case lValueType
Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ:
strValueString = String(lValueSize, 0)
If RegQueryValueExString(hNewKey, _
strValueName, _
0&, _
lValueType, _
strValueString, _
lValueSize) <> ERROR_SUCCESS Then
QueryRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"QueryRegValue - Could not obtain string value", _
GetLastError(), _
True
Exit Function
End If
vntValue = Left(strValueString, _
lValueSize)
Case REG_DWORD:
If RegQueryValueExLong(hNewKey, _
strValueName, _
0&, _
lValueType, _
lValueLong, _
lValueSize) <> ERROR_SUCCESS Then
QueryRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"QueryRegValue - Could not obtain long value", _
GetLastError(), _
True
Exit Function
End If
vntValue = lValueLong
Case Else
QueryRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"QueryRegValue - Unsupported registry value type", _
WWW_UNHANDLED_ERROR
Exit Function
End Select
RegCloseKey hNewKey
Exit Function
ErrHandler:
QueryRegValue = WWW_ERROR
LogVBError Err.source, _
"QueryRegValue - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : SetRegValue
'* Purpose : Create and set a registration database value
'* Inputs : strNewValueName - The new value name preceded by the
'* system key name in upper case and the
'* subkey. For example
'* HKEY_LOCAL_MACHINE\SOFTWARE\test\value
'* vntValue - The string or long to set
'* strValueType - Either the text "REG_SZ" or "REG_DWORD"
'* blnSetValue - If false then the default key value is
'* set, not a value under thekey
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function SetRegValue(ByVal strNewValueName As String, _
ByVal vntValue As Variant, _
ByVal strValueType As String, _
Optional ByVal blnSetValue As Boolean = True) _
As Long
On Error GoTo ErrHandler
Dim hNewKey As Long
Dim lDisposition As Long
Dim hSystemKey As Long
Dim strKeyName As String
Dim strValueName As String
Dim lValueType As Long
Dim strValueString As String
Dim lValueLong As Long
SetRegValue = WWW_OK
If ParseRegKey(strNewValueName, _
strKeyName, _
hSystemKey, _
blnSetValue, _
strValueName) <> WWW_OK Then
SetRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SetRegValue - ParseRegKey Failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If RegCreateKeyEx(hSystemKey, _
strKeyName, _
0&, _
vbNullString, _
REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, _
0&, _
hNewKey, _
lDisposition) <> ERROR_SUCCESS Then
SetRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SetRegValue - Could not obtain key handle", _
GetLastError(), _
True
Exit Function
End If
Select Case strValueType
Case "REG_SZ"
lValueType = REG_SZ
strValueString = CStr(vntValue) & Chr(0)
If RegSetValueExString(hNewKey, _
strValueName, _
0&, _
lValueType, _
strValueString, _
Len(strValueString)) <> ERROR_SUCCESS Then
SetRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SetRegValue - Could not set string value", _
GetLastError(), _
True
Exit Function
End If
Case "REG_MULTI_SZ"
lValueType = REG_MULTI_SZ
strValueString = CStr(vntValue) & Chr(0)
If RegSetValueExString(hNewKey, _
strValueName, _
0&, _
lValueType, _
strValueString, _
Len(strValueString)) <> ERROR_SUCCESS Then
SetRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SetRegValue - Could not set multi string value", _
GetLastError(), _
True
Exit Function
End If
Case "REG_EXPAND_SZ"
lValueType = REG_EXPAND_SZ
strValueString = CStr(vntValue) & Chr(0)
If RegSetValueExString(hNewKey, _
strValueName, _
0&, _
lValueType, _
strValueString, _
Len(strValueString)) <> ERROR_SUCCESS Then
SetRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SetRegValue - Could not set expand string value", _
GetLastError(), _
True
Exit Function
End If
Case "REG_DWORD"
lValueType = REG_DWORD
lValueLong = CLng(vntValue)
If RegSetValueExLong(hNewKey, _
strValueName, _
0&, _
lValueType, _
lValueLong, _
4) <> ERROR_SUCCESS Then
SetRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SetRegValue - Could not set long value", _
GetLastError(), _
True
Exit Function
End If
Case Else
SetRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SetRegValue - Unsupported regisrty key type", _
GetLastError(), _
True
Exit Function
End Select
RegCloseKey hNewKey
Exit Function
ErrHandler:
SetRegValue = WWW_ERROR
LogVBError Err.source, _
"SetRegValue - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : CreateRegKey
'* Purpose : Create a registration database key
'* Inputs : The new key name preceded by the system key name in upper
'* case. Example HKEY_LOCAL_MACHINE\SOFTWARE\test
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function CreateRegKey(ByVal strNewKeyName As String) As Long
On Error GoTo ErrHandler
Dim hNewKey As Long
Dim lDisposition As Long
Dim hSystemKey As Long
Dim strKeyName As String
CreateRegKey = WWW_OK
If ParseRegKey(strNewKeyName, _
strKeyName, _
hSystemKey) <> WWW_OK Then
CreateRegKey = WWW_ERROR
LogVBError "WWWTools.Tools", _
"CreateRegKey - ParseRegKey Failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If RegCreateKeyEx(hSystemKey, _
strKeyName, _
0&, _
vbNullString, _
REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, _
0&, _
hNewKey, _
lDisposition) <> ERROR_SUCCESS Then
CreateRegKey = WWW_ERROR
LogVBError "WWWTools.Tools", _
"CreateRegKey - Could not create key", _
GetLastError(), _
True
Exit Function
End If
RegCloseKey hNewKey
Exit Function
ErrHandler:
CreateRegKey = WWW_ERROR
LogVBError Err.source, _
"CreateRegKey - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : DeleteRegValue
'* Purpose : Delete a registration database value
'* Inputs : strDelValueName - The value name preceded by the
'* system key name in upper case and the
'* subkey. For example
'* HKEY_LOCAL_MACHINE\SOFTWARE\test\value
'* blnDelValue - If false then the default key value is
'* deleted, not a value under thekey
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function DeleteRegValue(ByVal strDelValueName As String, _
Optional ByVal blnDelValue As Boolean = True) _
As Long
On Error GoTo ErrHandler
Dim hNewKey As Long
Dim lDisposition As Long
Dim hSystemKey As Long
Dim strKeyName As String
Dim strValueName As String
DeleteRegValue = WWW_OK
If ParseRegKey(strDelValueName, _
strKeyName, _
hSystemKey, _
blnDelValue, _
strValueName) <> WWW_OK Then
DeleteRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"DeleteRegValue - ParseRegKey Failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If RegCreateKeyEx(hSystemKey, _
strKeyName, _
0&, _
vbNullString, _
REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, _
0&, _
hNewKey, _
lDisposition) <> ERROR_SUCCESS Then
DeleteRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"DeleteRegValue - Could not obtain key handle", _
GetLastError(), _
True
Exit Function
End If
If RegDeleteValue(hNewKey, _
strValueName) <> ERROR_SUCCESS Then
DeleteRegValue = WWW_ERROR
LogVBError "WWWTools.Tools", _
"DeleteRegValue - Could not delete value", _
GetLastError(), _
True
Exit Function
End If
RegCloseKey hNewKey
Exit Function
ErrHandler:
DeleteRegValue = WWW_ERROR
LogVBError Err.source, _
"DeleteRegValue - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : DeleteRegKey
'* Purpose : Delete a registration database key and its children
'* Inputs : The key name preceded by the system key name in upper
'* case. Example HKEY_LOCAL_MACHINE\SOFTWARE\test
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function DeleteRegKey(ByVal strDelKeyName As String) As Long
On Error GoTo ErrHandler
Dim hSystemKey As Long
Dim strKeyName As String
Dim hKeyHandle As Long
Dim lRetVal As Long
Dim lEnumIndex As Long
Dim strEnumKeyName As String
Dim lEnumKeyNameSize As Long
DeleteRegKey = WWW_OK
If ParseRegKey(strDelKeyName, _
strKeyName, _
hSystemKey) <> WWW_OK Then
DeleteRegKey = WWW_ERROR
LogVBError "WWWTools.Tools", _
"DeleteRegKey - ParseRegKey Failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If RegOpenKeyEx(hSystemKey, _
strKeyName, _
0&, _
KEY_ALL_ACCESS, _
hKeyHandle) <> ERROR_SUCCESS Then
DeleteRegKey = WWW_ERROR
LogVBError "WWWTools.Tools", _
"DeleteRegKey - Could not open key", _
GetLastError(), _
True
Exit Function
End If
Do
lEnumKeyNameSize = 500
strEnumKeyName = Space(lEnumKeyNameSize)
'Keep hitting index 0 since we are deleting them as we go!
lRetVal = RegEnumKey(hKeyHandle, _
lEnumIndex, _
strEnumKeyName, _
lEnumKeyNameSize)
If lRetVal <> ERROR_SUCCESS And _
lRetVal <> ERROR_NO_MORE_ITEMS Then
RegCloseKey hKeyHandle
DeleteRegKey = WWW_ERROR
LogVBError "WWWTools.Tools", _
"DeleteRegKey - Could not enumerate key", _
GetLastError(), _
True
Exit Function
End If
If lRetVal = ERROR_SUCCESS Then
DeleteRegKey strDelKeyName & "\" & _
vsRemoveNullFromString(strEnumKeyName)
End If
Loop Until lRetVal = ERROR_NO_MORE_ITEMS
RegCloseKey hKeyHandle
If RegDeleteKey(hSystemKey, _
strKeyName) <> ERROR_SUCCESS Then
DeleteRegKey = WWW_ERROR
LogVBError "WWWTools.Tools", _
"DeleteRegKey - Could not delete key", _
GetLastError(), _
True
Exit Function
End If
Exit Function
ErrHandler:
DeleteRegKey = WWW_ERROR
LogVBError Err.source, _
"DeleteRegKey - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* File Related Functions
'***********************************************************************
'***********************************************************************
'* Function : MaxFileVersion()
'* Purpose : See if a file exists
'* Inputs : strVersion1 - First 4 part file version
'* strVersion2 - Second 4 part file version
'* lMaxVersion - 0 if equal, 1 if first greater, 2 if second
'* greater
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function MaxFileVersion(ByVal strVersion1 As String, _
ByVal strVersion2 As String, _
ByRef lMaxVersion As Variant) _
As Long
On Error GoTo ErrHandler
Dim intNumVals As Integer
Dim intCount As Integer
Dim vntVersion1Array() As Variant
Dim vntVersion2Array() As Variant
Dim intCompVal1 As Integer
Dim intCompVal2 As Integer
MaxFileVersion = WWW_OK
If Len(strVersion1) = 0 Then
strVersion1 = "0"
End If
If Len(strVersion2) = 0 Then
strVersion2 = "0"
End If
If UnString(strVersion1, ".", vntVersion1Array) <> WWW_OK Then
MaxFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"MaxFileVersion - UnString failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If UnString(strVersion2, ".", vntVersion2Array) <> WWW_OK Then
MaxFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"MaxFileVersion - UnString failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If UBound(vntVersion1Array) >= UBound(vntVersion2Array) Then
intNumVals = UBound(vntVersion1Array)
Else
intNumVals = UBound(vntVersion2Array)
End If
For intCount = 0 To intNumVals - 1
If intCount > UBound(vntVersion1Array) Then
intCompVal1 = 0
Else
intCompVal1 = CInt(vntVersion1Array(intCount))
End If
If intCount > UBound(vntVersion2Array) Then
intCompVal2 = 0
Else
intCompVal2 = CInt(vntVersion2Array(intCount))
End If
If intCompVal1 > intCompVal2 Then
lMaxVersion = 1
Exit Function
End If
If intCompVal1 < intCompVal2 Then
lMaxVersion = 2
Exit Function
End If
Next
lMaxVersion = 0
Exit Function
ErrHandler:
MaxFileVersion = WWW_ERROR
LogVBError Err.source, _
"MaxFileVersion - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : FileExists()
'* Purpose : See if a file exists
'* Inputs : strFileName - File name
'* blnExists - True if file exists, false otherwise.
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function FileExists(ByVal strFileName As String, _
ByRef blnExists As Variant) _
As Long
On Error GoTo ErrHandler
Dim udtFindData As WIN32_FIND_DATA
Dim hFileHandle As Long
FileExists = WWW_OK
If Len(strFileName) > MAX_PATH Then
FileExists = WWW_ERROR
LogVBError "WWWTools.Tools", _
"FileExists - strFileName cannot exceed" & _
CStr(MAX_PATH) & "characters", _
WWW_UNHANDLED_ERROR
Exit Function
End If
hFileHandle = FindFirstFile(strFileName & Chr(0), _
udtFindData)
If hFileHandle = INVALID_HANDLE_VALUE Then
blnExists = False
Else
FindClose hFileHandle
blnExists = True
End If
Exit Function
ErrHandler:
FileExists = WWW_ERROR
LogVBError Err.source, _
"FileExists - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : GetFileVersion()
'* Purpose : Get the file version.
'* Inputs : strFileName - File name
'* : strVersion - The version string e.g. "3.02.01.04"
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetFileVersion(ByVal strFileName As String, _
ByRef strVersion As Variant) _
As Long
On Error GoTo ErrHandler
Dim bVersionBuffer() As Byte
Dim lVersionInfoSize As Long
Dim lNotUsedInWin32 As Long
Dim udtVersionInfo As VS_FIXEDFILEINFO
Dim lQueryValueBufferSize As Long
Dim ludtVersionInfoAddress As Long
Dim blnFileExists As Boolean
Dim strFileVersionMS As String
Dim strFileVersionLS As String
GetFileVersion = WWW_OK
If FileExists(strFileName, _
blnFileExists) = WWW_ERROR Then
GetFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileVersion - FileExists failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If Not blnFileExists Then
GetFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileVersion - File does not exist", _
WWW_UNHANDLED_ERROR
Exit Function
End If
lVersionInfoSize = GetFileVersionInfoSize(strFileName, _
lNotUsedInWin32)
If lVersionInfoSize = 0 Then
GetFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileVersion - No version information present", _
GetLastError(), _
True
Exit Function
End If
ReDim bVersionBuffer(lVersionInfoSize + 1)
If GetFileVersionInfo(strFileName, _
lNotUsedInWin32, _
lVersionInfoSize, _
bVersionBuffer(0)) = 0 Then
GetFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileVersion - Could not retrieve version information", _
GetLastError(), _
True
Exit Function
End If
If VerQueryValue(bVersionBuffer(0), _
"\", _
ludtVersionInfoAddress, _
lQueryValueBufferSize) = 0 Then
GetFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileVersion - Could not query the value of the version information", _
GetLastError(), _
True
Exit Function
End If
vbMemCopy ByVal ludtVersionInfoAddress, _
udtVersionInfo, _
Len(udtVersionInfo)
If CalcFileVersion(udtVersionInfo.dwFileVersionMS, _
strFileVersionMS) = WWW_ERROR Then
GetFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileVersion - CalcFileVersion failed", _
WWW_UNHANDLED_ERROR, _
True
Exit Function
End If
If CalcFileVersion(udtVersionInfo.dwFileVersionLS, _
strFileVersionLS) = WWW_ERROR Then
GetFileVersion = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileVersion - CalcFileVersion failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
strVersion = strFileVersionMS & "." & strFileVersionLS
Exit Function
ErrHandler:
GetFileVersion = WWW_ERROR
LogVBError Err.source, _
"GetFileVersion - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : CalcFileVersion
'* Purpose : Break a 32-bit file version into major and minor values
'* Inputs : lVersion - The 32-bit version
'* strVersion - The version as a string
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Function CalcFileVersion(ByVal lVersion As Long, _
ByRef strVersion As String) _
As Long
On Error GoTo ErrHandler
Dim lMajor As Long
Dim lMinor As Long
CalcFileVersion = WWW_OK
lMajor = CInt(lVersion / &H10000)
lMinor = CInt(lVersion And &HFFFF&)
strVersion = CStr(lMajor) & "." & CStr(lMinor)
Exit Function
ErrHandler:
CalcFileVersion = WWW_ERROR
LogVBError Err.source, _
"CalcFileVersion - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : GetFileDate()
'* Purpose : Get the file creation date/time.
'* Inputs : strFileName - File name
'* strFileDate - The date/time as a string
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetFileDate(ByVal strFileName As String, _
ByRef strFileDate As Variant) _
As Long
On Error GoTo ErrHandler
Dim udtFileInfo As OFSTRUCT
Dim udtFileCreationDate As FILETIME
Dim udtFileAccessDate As FILETIME
Dim udtFileWriteDate As FILETIME
Dim lFileHandle As Long
Dim udtSystemDate As SYSTEMTIME
Dim blnFileExists As Boolean
Dim strFileDateBuffer As String
Dim strFileTimeBuffer As String
Dim lFileDateBufferLength As Long
Dim lFileTimeBufferLength As Long
Dim udtTimeZoneInformation As TIME_ZONE_INFORMATION
Dim lTimeZoneReturn As Long
Dim lTimeZoneBias As Long
GetFileDate = WWW_OK
If FileExists(strFileName, blnFileExists) = WWW_ERROR Then
GetFileDate = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileDate - FileExists failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If Not blnFileExists Then
GetFileDate = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileDate - File does not exist", _
WWW_UNHANDLED_ERROR
Exit Function
End If
lFileHandle = OpenFile(strFileName, _
udtFileInfo, _
OF_READ)
If lFileHandle = INVALID_HANDLE_VALUE Then
GetFileDate = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileDate - Cannot open file handle", _
GetLastError(), _
True
Exit Function
End If
If GetFileTime(lFileHandle, _
udtFileCreationDate, _
udtFileAccessDate, _
udtFileWriteDate) = 0 Then
CloseHandle lFileHandle
GetFileDate = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileDate - Cannot get file date/time", _
GetLastError(), _
True
Exit Function
End If
CloseHandle lFileHandle
If FileTimeToSystemTime(udtFileCreationDate, _
udtSystemDate) = 0 Then
GetFileDate = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileDate - Cannot convert file date/time to system date/time", _
GetLastError(), _
True
Exit Function
End If
strFileDateBuffer = String(255, 0)
strFileTimeBuffer = String(255, 0)
lFileDateBufferLength = GetDateFormat(LOCALE_SYSTEM_DEFAULT, _
0, _
udtSystemDate, _
0, _
strFileDateBuffer, _
Len(strFileDateBuffer) - 1)
If lFileDateBufferLength = 0 Then
GetFileDate = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileDate - Cannot convert file datee to local date", _
GetLastError(), _
True
Exit Function
End If
lFileTimeBufferLength = GetTimeFormat(LOCALE_SYSTEM_DEFAULT, _
0, _
udtSystemDate, _
0, _
strFileTimeBuffer, _
Len(strFileTimeBuffer) - 1)
If lFileTimeBufferLength = 0 Then
GetFileDate = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileDate - Cannot convert file time to local time", _
GetLastError(), _
True
Exit Function
End If
lTimeZoneReturn = GetTimeZoneInformation(udtTimeZoneInformation)
If lTimeZoneReturn = TIME_ZONE_ID_INVALID Then
GetFileDate = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFileDate - Cannot get time zone information", _
GetLastError(), _
True
Exit Function
End If
If lTimeZoneReturn = TIME_ZONE_ID_DAYLIGHT Then
lTimeZoneBias = CInt((udtTimeZoneInformation.Bias + _
udtTimeZoneInformation.DaylightBias) / 30) / 2
Else
lTimeZoneBias = CInt(udtTimeZoneInformation.Bias / 30) / 2
End If
strFileDate = DateAdd("h", _
-1 * lTimeZoneBias, _
Left(strFileDateBuffer, _
lFileDateBufferLength - 1) & _
" " & _
Left(strFileTimeBuffer, _
lFileTimeBufferLength - 1))
Exit Function
ErrHandler:
GetFileDate = WWW_ERROR
LogVBError Err.source, _
"GetFileDate - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Network Related Functions
'***********************************************************************
'***********************************************************************
'* Function : GetNextDriveLetter
'* Purpose : Return the next available drive letter after C:.
'* Inputs : strDriveLetter - The next drive letter with a :, for
'* example D:
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetNextDriveLetter(ByRef strNextDriveLetter As Variant) _
As Long
On Error GoTo ErrHandler
Dim intDriveNumber As Integer
Dim strDriveLetter As String
Dim lDriveStatus As Long
GetNextDriveLetter = WWW_OK
intDriveNumber = 2 'Start with D:
Do
intDriveNumber = intDriveNumber + 1
strDriveLetter = Chr$(intDriveNumber + 65) & ":"
lDriveStatus = GetDriveType(strDriveLetter)
Loop Until lDriveStatus = 1 Or intDriveNumber > 25
If intDriveNumber > 25 Then
GetNextDriveLetter = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetNextDriveLetter - No Drives Available", _
WWW_UNHANDLED_ERROR
Exit Function
Else
strNextDriveLetter = strDriveLetter
End If
Exit Function
ErrHandler:
GetNextDriveLetter = WWW_ERROR
LogVBError Err.source, _
"GetNextDriveLetter - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : ConnectNetworkDrive()
'* Purpose : Map a network drive
'* Inputs : strDriveLetter - Local drive letter to map, for example D:
'* : strNetworkShare - Network share name as in \\server\share
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function ConnectNetworkDrive(ByVal strDriveLetter As String, _
ByVal strNetworkShare As String) _
As Long
On Error GoTo ErrHandler
Dim udtNetResource As NETRESOURCE
Dim lStatus As Integer
ConnectNetworkDrive = WWW_OK
udtNetResource.dwScope = RESOURCE_PUBLICNET
udtNetResource.dwType = RESOURCETYPE_DISK
udtNetResource.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
udtNetResource.dwUsage = RESOURCEUSAGE_CONNECTABLE
udtNetResource.lpLocalName = strDriveLetter & Chr$(0)
udtNetResource.lpRemoteName = strNetworkShare & Chr$(0)
udtNetResource.lpComment = vbNullString
udtNetResource.lpProvider = vbNullString
lStatus = WNetAddConnection2(udtNetResource, _
vbNullString, _
vbNullString, _
0&)
If lStatus <> WN_SUCCESS Then
ConnectNetworkDrive = WWW_ERROR
LogVBError "WWWTools.Tools", _
"ConnectNetworkDrive - Could not connect network drive", _
GetLastError(), _
True
Exit Function
End If
Exit Function
ErrHandler:
ConnectNetworkDrive = WWW_ERROR
LogVBError Err.source, _
"ConnectNetworkDrive - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : DisconnectNetworkDrive()
'* Purpose : Remove a network drive
'* Inputs : strDriveLetter - Local drive letter, for example D:
'* blnForce - If true then remove even if in use
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function DisconnectNetworkDrive(ByVal strDriveLetter As String, _
Optional ByVal blnForce As Boolean = True) _
As Long
On Error GoTo ErrHandler
Dim lStatus As Long
Dim vntDriveLetter As Variant
Dim lForce As Long
DisconnectNetworkDrive = WWW_OK
If blnForce Then
lForce = 1
Else
lForce = 0
End If
vntDriveLetter = strDriveLetter & Chr$(0)
lStatus = WNetCancelConnection(vntDriveLetter, _
lForce)
If lStatus <> WN_SUCCESS Then
DisconnectNetworkDrive = WWW_ERROR
LogVBError "WWWTools.Tools", _
"DisconnectNetworkDrive - Could not remove network drive", _
GetLastError(), _
True
Exit Function
End If
Exit Function
ErrHandler:
DisconnectNetworkDrive = WWW_ERROR
LogVBError Err.source, _
"DisconnectNetworkDrive - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : ParseUNC()
'* Purpose : Parse a UNC into the network share and the directory and/or
'* command
'* Inputs : strUNC - The UNC
'* strServer - The server name
'* strNetworkShare - The network sharename
'* strDirectory - The directory
'* strCommand - The command (may be vbNullString)
'* blnCommand - If true, last part of UNC is a command
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function ParseUNC(ByVal strUNC As String, _
ByRef strServer As Variant, _
ByRef strNetworkShare As Variant, _
ByRef strDirectory As Variant, _
ByRef strCommand As Variant, _
Optional ByVal blnCommand As Boolean = True) _
As Long
On Error GoTo ErrHandler
Const SERVER_START_POSITION = 3
Dim lStrPos As Long
Dim lStrPosServer As Long
Dim lStrPosNetShare As Long
Dim lStrPosDirectory As Long
Dim lStrPosTemp As Long
ParseUNC = WWW_OK
If Left(strUNC, SERVER_START_POSITION - 1) <> "\\" Or _
Len(strUNC) < SERVER_START_POSITION Then
ParseUNC = WWW_ERROR
LogVBError "WWWTools.Tools", _
"ParseUNC - strUNC must be a UNC", _
WWW_UNHANDLED_ERROR
Exit Function
End If
lStrPosServer = InStr(SERVER_START_POSITION, _
strUNC, _
"\", _
vbTextCompare)
If lStrPosServer = 0 Or _
Len(strUNC) = lStrPosServer Then
ParseUNC = WWW_ERROR
LogVBError "WWWTools.Tools", _
"ParseUNC - No Share present in strUNC" & vbCrLf & _
"strUNC must contain at least \\Server\Share", _
WWW_UNHANDLED_ERROR
Exit Function
End If
strServer = Mid(strUNC, _
SERVER_START_POSITION, _
lStrPosServer - SERVER_START_POSITION)
lStrPosNetShare = InStr(lStrPosServer + 1, _
strUNC, _
"\", _
vbTextCompare)
If lStrPosNetShare = 0 Then
If blnCommand Then
ParseUNC = WWW_ERROR
LogVBError "WWWTools.Tools", _
"ParseUNC - strUNC must contain a command " & _
"if blnCommand is True", _
WWW_UNHANDLED_ERROR
Exit Function
Else
strNetworkShare = Right(strUNC, _
Len(strUNC) - lStrPosServer)
strDirectory = vbNullString
strCommand = vbNullString
Exit Function
End If
Else
strNetworkShare = Mid(strUNC, _
lStrPosServer + 1, _
lStrPosNetShare - lStrPosServer - 1)
End If
If Len(strUNC) = lStrPosNetShare Then
If blnCommand Then
ParseUNC = WWW_ERROR
LogVBError "WWWTools.Tools", _
"ParseUNC - strUNC must contain a command " & _
"if blnCommand is True", _
WWW_UNHANDLED_ERROR
Exit Function
Else
strDirectory = vbNullString
strCommand = vbNullString
Exit Function
End If
End If
If blnCommand Then
lStrPosTemp = lStrPosNetShare
Do
lStrPosDirectory = lStrPosTemp
lStrPosTemp = InStr(lStrPosTemp + 1, _
strUNC, _
"\")
Loop Until lStrPosTemp = 0
If lStrPosDirectory = lStrPosNetShare Then
strDirectory = vbNullString
strCommand = Right(strUNC, _
Len(strUNC) - lStrPosNetShare)
Else
strDirectory = Mid(strUNC, _
lStrPosNetShare + 1, _
lStrPosDirectory - lStrPosNetShare - 1)
If Len(strUNC) = lStrPosDirectory Then
ParseUNC = WWW_ERROR
LogVBError "WWWTools.Tools", _
"ParseUNC - strUNC must contain a command " & _
"if blnCommand is True", _
WWW_UNHANDLED_ERROR
Exit Function
Else
strCommand = Right(strUNC, _
Len(strUNC) - lStrPosDirectory)
End If
End If
Else
If Len(strUNC) = lStrPosNetShare Then
strDirectory = vbNullString
strCommand = vbNullString
Else
If InStr(Len(strUNC), strUNC, "\") Then
strDirectory = Mid(strUNC, _
lStrPosNetShare + 1, _
Len(strUNC) - lStrPosNetShare - 1)
Else
strDirectory = Right(strUNC, _
Len(strUNC) - lStrPosNetShare)
End If
strCommand = vbNullString
End If
End If
Exit Function
ErrHandler:
ParseUNC = WWW_ERROR
LogVBError Err.source, _
"ParseUNC - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Process Related Functions
'***********************************************************************
'***********************************************************************
'* Function : Spawn()
'* Purpose : Start an external process
'* Inputs : strCommand - The command line to execute
'* blnMakeNetworkShare - Parse UNC into network share and
'* connect local drive from which
'* command line will be executed
'* blnSynchronous - Wait for process to complete or
'* terminate after timeout
'* lTimeoutSeconds - Terminate process after timeout
'* Default is to wait forever
'* blnTimeout - If the process was terminated,
'* then this is st to true
'* blnSeparateWOW - If true, then create 16-bit processes
'* in their own subsystem.
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function Spawn(ByVal strCommand As String, _
Optional ByVal blnMakeNetworkShare As Boolean = False, _
Optional ByVal blnSynchronous As Boolean = False, _
Optional ByVal lTimeoutSeconds As Long = -1, _
Optional ByRef blnTimeout As Variant, _
Optional ByVal blnSeparateWOW As Boolean = True) _
As Long
On Error GoTo ErrHandler
Dim lProcessID As Long
Dim lProcessHandle As Long
Dim lProcessStatus As Long
Dim lWaitStatus As Long
Dim lTerminateStatus As Long
Dim strDriveLetter As String
Dim lStrPos As Long
Dim lStrPosLast As Long
Dim strServer As String
Dim strNetworkShare As String
Dim strDirectory As String
Dim strProgram As String
Dim strOriginalDirectory As String
Dim dtmStartTime As Date
Dim intTimeRun As Integer
Dim lCreationFlags As Long
Dim udtStartupInfo As STARTUPINFO
Dim udtProcessInfo As PROCESS_INFORMATION
Spawn = WWW_OK
Screen.MousePointer = vbHourglass
udtStartupInfo.cb = Len(udtStartupInfo)
udtStartupInfo.lpReserved = vbNullString
udtStartupInfo.lpDesktop = vbNullString
udtStartupInfo.lpTitle = vbNullString
udtStartupInfo.dwFlags = 0
If blnMakeNetworkShare Then
blnSynchronous = True
strOriginalDirectory = CurDir
If ParseUNC(strCommand, _
strServer, _
strNetworkShare, _
strDirectory, _
strProgram, _
True) <> WWW_OK Then
Spawn = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - ParseUNC failed ", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If GetNextDriveLetter(strDriveLetter) <> WWW_OK Then
Spawn = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - GetNextDriveLetter failed ", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If ConnectNetworkDrive(strDriveLetter, _
"\\" & strServer & _
"\" & strNetworkShare) <> WWW_OK Then
Spawn = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - ConnectNetworkDrive failed ", _
WWW_UNHANDLED_ERROR
Exit Function
End If
ChDrive Left(strDriveLetter, 1)
If Len(strDirectory) Then
ChDir strDirectory
End If
If Len(strProgram) Then
strCommand = strProgram
Else
Spawn = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - No program specified in UNC", _
WWW_UNHANDLED_ERROR
Exit Function
End If
End If
If blnSeparateWOW Then
lCreationFlags = NORMAL_PRIORITY_CLASS Or _
CREATE_SEPARATE_WOW_VDM Or _
DETACHED_PROCESS
Else
lCreationFlags = NORMAL_PRIORITY_CLASS Or _
DETACHED_PROCESS
End If
lProcessStatus = CreateProcess(vbNullString, _
strCommand, _
0, _
0, _
True, _
lCreationFlags, _
ByVal 0&, _
vbNullString, _
udtStartupInfo, _
udtProcessInfo)
Screen.MousePointer = 0
If lProcessStatus Then
If blnSynchronous Then
blnTimeout = False
Call WaitForInputIdle(udtProcessInfo.hProcess, INFINITE)
dtmStartTime = Now
Do
lWaitStatus = WaitForSingleObject(udtProcessInfo.hProcess, _
100)
If lWaitStatus <> WAIT_TIMEOUT Then
Exit Do
ElseIf (lTimeoutSeconds <> -1 And _
DateDiff("s", dtmStartTime, Now) >= lTimeoutSeconds) Or _
mblnKillProcess Then
blnTimeout = True
lTerminateStatus = TerminateProcess(udtProcessInfo.hProcess, _
0&)
If lTerminateStatus = 0 Then
Spawn = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - Unable to terminate process", _
GetLastError(), _
True
CloseHandle udtProcessInfo.hThread
CloseHandle udtProcessInfo.hProcess
Exit Function
End If
Exit Do
End If
DoEvents
Loop While True
End If
CloseHandle udtProcessInfo.hThread
CloseHandle udtProcessInfo.hProcess
Else
Spawn = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - Unable to start process", _
GetLastError(), _
True
Exit Function
End If
If blnMakeNetworkShare Then
ChDrive Left(strOriginalDirectory, 2)
ChDir strOriginalDirectory
If DisconnectNetworkDrive(strDriveLetter, _
True) <> WWW_OK Then
Spawn = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - DisconnectNetworkDrive failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
End If
Exit Function
ErrHandler:
Spawn = WWW_ERROR
LogVBError Err.source, _
"Spawn - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : SpawnFile()
'* Purpose : Start an external process
'* Inputs : strCommand - The command line to execute
'* blnMakeNetworkShare - Parse UNC into network share and
'* connect local drive from which
'* command line will be executed
'* blnSynchronous - Wait for process to complete or
'* terminate after timeout
'* lTimeoutSeconds - Terminate process after timeout
'* Default is to wait forever
'* blnTimeout - If the process was terminated,
'* then this is st to true
'* blnSeparateWOW - If true, then create 16-bit processes
'* in their own subsystem.
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function SpawnFile(ByVal strCommand As String, _
Optional ByVal blnMakeNetworkShare As Boolean = False, _
Optional ByVal blnSynchronous As Boolean = False, _
Optional ByVal lTimeoutSeconds As Long = -1, _
Optional ByRef blnTimeout As Variant, _
Optional ByVal blnSeparateWOW As Boolean = True) _
As Long
On Error GoTo ErrHandler
Dim lProcessID As Long
Dim lProcessHandle As Long
Dim lProcessStatus As Long
Dim lWaitStatus As Long
Dim lTerminateStatus As Long
Dim strDriveLetter As String
Dim lStrPos As Long
Dim lStrPosLast As Long
Dim strServer As String
Dim strNetworkShare As String
Dim strDirectory As String
Dim strProgram As String
Dim strOriginalDirectory As String
Dim dtmStartTime As Date
Dim intTimeRun As Integer
Dim lCreationFlags As Long
Dim udtStartupInfo As STARTUPINFO
Dim udtProcessInfo As PROCESS_INFORMATION
SpawnFile = WWW_OK
Screen.MousePointer = vbHourglass
udtStartupInfo.cb = Len(udtStartupInfo)
udtStartupInfo.lpReserved = vbNullString
udtStartupInfo.lpDesktop = vbNullString
udtStartupInfo.lpTitle = vbNullString
udtStartupInfo.dwFlags = 0
If blnMakeNetworkShare Then
blnSynchronous = True
strOriginalDirectory = CurDir
If ParseUNC(strCommand, _
strServer, _
strNetworkShare, _
strDirectory, _
strProgram, _
True) <> WWW_OK Then
SpawnFile = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - ParseUNC failed ", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If GetNextDriveLetter(strDriveLetter) <> WWW_OK Then
SpawnFile = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - GetNextDriveLetter failed ", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If ConnectNetworkDrive(strDriveLetter, _
"\\" & strServer & _
"\" & strNetworkShare) <> WWW_OK Then
SpawnFile = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - ConnectNetworkDrive failed ", _
WWW_UNHANDLED_ERROR
Exit Function
End If
ChDrive Left(strDriveLetter, 1)
If Len(strDirectory) Then
ChDir strDirectory
End If
If Len(strProgram) Then
strCommand = strProgram
Else
SpawnFile = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - No program specified in UNC", _
WWW_UNHANDLED_ERROR
Exit Function
End If
End If
If blnSeparateWOW Then
lCreationFlags = NORMAL_PRIORITY_CLASS Or _
CREATE_SEPARATE_WOW_VDM Or _
DETACHED_PROCESS
Else
lCreationFlags = NORMAL_PRIORITY_CLASS Or _
DETACHED_PROCESS
End If
lProcessStatus = CreateProcess(strCommand, _
vbNullString, _
0, _
0, _
True, _
lCreationFlags, _
ByVal 0&, _
vbNullString, _
udtStartupInfo, _
udtProcessInfo)
Screen.MousePointer = 0
If lProcessStatus Then
If blnSynchronous Then
blnTimeout = False
Call WaitForInputIdle(udtProcessInfo.hProcess, INFINITE)
dtmStartTime = Now
Do
lWaitStatus = WaitForSingleObject(udtProcessInfo.hProcess, _
100)
If lWaitStatus <> WAIT_TIMEOUT Then
Exit Do
ElseIf (lTimeoutSeconds <> -1 And _
DateDiff("s", dtmStartTime, Now) >= lTimeoutSeconds) Or _
mblnKillProcess Then
blnTimeout = True
lTerminateStatus = TerminateProcess(udtProcessInfo.hProcess, _
0&)
If lTerminateStatus = 0 Then
SpawnFile = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - Unable to terminate process", _
GetLastError(), _
True
CloseHandle udtProcessInfo.hThread
CloseHandle udtProcessInfo.hProcess
Exit Function
End If
Exit Do
End If
DoEvents
Loop While True
End If
CloseHandle udtProcessInfo.hThread
CloseHandle udtProcessInfo.hProcess
Else
SpawnFile = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - Unable to start process", _
GetLastError(), _
True
Exit Function
End If
If blnMakeNetworkShare Then
ChDrive Left(strOriginalDirectory, 2)
ChDir strOriginalDirectory
If DisconnectNetworkDrive(strDriveLetter, _
True) <> WWW_OK Then
SpawnFile = WWW_ERROR
LogVBError "WWWTools.Tools", _
"Spawn - DisconnectNetworkDrive failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
End If
Exit Function
ErrHandler:
SpawnFile = WWW_ERROR
LogVBError Err.source, _
"Spawn - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : GetWindowHandle()
'* Purpose : Call the FindWindow API function
'* Inputs : strWindowTitle - The window title
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetWindowHandle(ByVal strWindowTitle As String, _
ByRef vntHandle As Variant) _
As Long
On Error GoTo ErrHandler
Dim lngHandle As Long
GetWindowHandle = WWW_OK
lngHandle = FindWindow(vbNullString, strWindowTitle)
vntHandle = CVar(lngHandle)
Exit Function
ErrHandler:
GetWindowHandle = WWW_ERROR
LogVBError Err.source, _
"GetWindowHandle - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : SendCloseMessage()
'* Purpose : Send a close message to a window
'* Inputs : strWindowTitle - The window title
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function SendCloseMessage(ByRef vntHandle As Variant) _
As Long
On Error GoTo ErrHandler
Dim lngHandle As Long
Dim lngRetVal As Long
SendCloseMessage = WWW_OK
lngHandle = CLng(vntHandle)
lngRetVal = PostMessage(lngHandle, WM_CLOSE, vbNull, vbNull)
Exit Function
ErrHandler:
SendCloseMessage = WWW_ERROR
LogVBError Err.source, _
"SendCloseMessage - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : SuperUser()
'* Purpose : Become a super user
'* Inputs : blnStatus - If true, then super user
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function SuperUser(ByVal blnStatus As Boolean) _
As Long
On Error GoTo ErrHandler
Dim hProcessToken As Long
Dim udtLuid As LUID
Dim udtPreviousPrivilege As TOKEN_PRIVILEGES
Dim udtNewPrivilege As TOKEN_PRIVILEGES
Dim lTokenPrivilegeSize As Long
Dim lReturnLength As Long
Dim udtDummyPrivilege As TOKEN_PRIVILEGES
SuperUser = WWW_OK
If OpenProcessToken(GetCurrentProcess(), _
TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, _
hProcessToken) = 0 Then
SuperUser = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SuperUser - Could not get process token", _
GetLastError(), _
True
Exit Function
End If
If LookupPrivilegeValue(vbNullString, _
SE_DEBUG_NAME, _
udtLuid) = 0 Then
CloseHandle hProcessToken
SuperUser = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SuperUser - Could not lookup privilege value", _
GetLastError(), _
True
Exit Function
End If
udtNewPrivilege.PrivilegeCount = 1
udtNewPrivilege.Privileges(0).pLuid = udtLuid
udtNewPrivilege.Privileges(0).Attributes = 0
lTokenPrivilegeSize = LenB(udtPreviousPrivilege)
If AdjustTokenPrivileges(hProcessToken, _
False, _
udtNewPrivilege, _
lTokenPrivilegeSize, _
udtPreviousPrivilege, _
lReturnLength) = 0 Then
CloseHandle hProcessToken
SuperUser = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SuperUser - Could not adjust token privileges", _
GetLastError(), _
True
Exit Function
End If
udtPreviousPrivilege.PrivilegeCount = 1
udtPreviousPrivilege.Privileges(0).pLuid = udtLuid
If blnStatus Then
udtPreviousPrivilege.Privileges(0).Attributes = udtPreviousPrivilege.Privileges(0).Attributes Or SE_PRIVILEGE_ENABLED
Else
udtPreviousPrivilege.Privileges(0).Attributes = udtPreviousPrivilege.Privileges(0).Attributes Xor SE_PRIVILEGE_ENABLED
End If
If AdjustTokenPrivileges(hProcessToken, _
False, _
udtPreviousPrivilege, _
lTokenPrivilegeSize, _
udtDummyPrivilege, _
lReturnLength) = 0 Then
CloseHandle hProcessToken
SuperUser = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SuperUser - Could not adjust token privileges", _
GetLastError(), _
True
Exit Function
End If
CloseHandle hProcessToken
Exit Function
ErrHandler:
SuperUser = WWW_ERROR
LogVBError Err.source, _
"SuperUser - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* General Utility Functions
'***********************************************************************
'***********************************************************************
'* Function : SizeWindow()
'* Purpose : Move and/or resize an object
'* Inputs :
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function SizeWindow(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nwidth As Long, _
ByVal nheight As Long, _
ByVal brepaint As Long) _
As Long
On Error GoTo ErrHandler
Dim lParentHandle As Long
SizeWindow = WWW_OK
If MoveWindow(hwnd, _
x, _
y, _
nwidth, _
nheight, _
brepaint) = 0 Then
SizeWindow = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SizeWindow - Could not move window", _
GetLastError(), _
True
Exit Function
End If
lParentHandle = GetParent(hwnd)
If lParentHandle = 0 Then
SizeWindow = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SizeWindow - Could not get parent window", _
GetLastError(), _
True
Exit Function
End If
If UpdateWindow(lParentHandle) = 0 Then
SizeWindow = WWW_ERROR
LogVBError "WWWTools.Tools", _
"SizeWindow - Could not update parent window", _
GetLastError(), _
True
Exit Function
End If
Exit Function
ErrHandler:
SizeWindow = WWW_ERROR
LogVBError Err.source, _
"SizeWindow - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Sub : GoToSleep()
'* Purpose : Sleep
'* Inputs : lMilliseconds - time to sleep
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Sub GoToSleep(ByVal lMilliseconds As Long)
On Error GoTo ErrHandler
Sleep lMilliseconds
Exit Sub
ErrHandler:
LogVBError Err.source, _
"GoToSleep - " & Err.Description, _
Err.Number
End Sub
'***********************************************************************
'* Sub : GoToSleepNice()
'* Purpose : Sleep with DoEvents
'* Inputs : lSeconds - time to sleep
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Sub GoToSleepNice(ByVal lSeconds As Long)
On Error GoTo ErrHandler
Dim dtmStart
dtmStart = Now()
Do
DoEvents
Loop Until DateDiff("s", Now(), DateAdd("s", lSeconds, dtmStart)) <= 0
Exit Sub
ErrHandler:
LogVBError Err.source, _
"GoToSleepNice - " & Err.Description, _
Err.Number
End Sub
'***********************************************************************
'* Function : UnString()
'* Purpose : Parse a string and load the components into an array.
'* Inputs : strString - File name
'* strDelimiter - True if file exists, false otherwise.
'* vntArray - An array of variants not dimensioned when
'* it was declared.
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function UnString(ByVal strString As String, _
ByVal strDelimiter As String, _
ByRef vntArray As Variant) _
As Long
On Error GoTo ErrHandler
Dim intCount As Integer
Dim intElements As Integer
Dim lStrPos As Long
Dim lStrPosLast As Long
Dim blnFirstOne As Boolean
UnString = WWW_OK
If Len(strDelimiter) <> 1 Then
UnString = WWW_ERROR
LogVBError "WWWTools.Tools", _
"UnString - strDelimiter must be one character", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If Right(strString, 1) = strDelimiter Then
strString = Left(strString, Len(strString) - 1)
End If
For intCount = 1 To Len(strString)
If Mid(strString, intCount, 1) = strDelimiter Then
intElements = intElements + 1
End If
Next
ReDim vntArray(intElements + 1)
blnFirstOne = True
For intCount = 0 To intElements - 1
lStrPosLast = lStrPos
lStrPos = InStr(lStrPosLast + 1, strString, strDelimiter)
If blnFirstOne Then
blnFirstOne = False
vntArray(intCount) = CVar(Mid(strString, lStrPosLast + 1, lStrPos - 1))
Else
vntArray(intCount) = CVar(Mid(strString, lStrPosLast + 1, lStrPos - lStrPosLast - 1))
End If
Next
vntArray(intCount) = CVar(Right(strString, Len(strString) - lStrPos))
Exit Function
ErrHandler:
UnString = WWW_ERROR
LogVBError Err.source, _
"UnString - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : vsRemoveNullFromString()
'* Purpose : Convert a null terminated string into a VB compatible
'* string
'* Inputs : A null terminated string
'* Returns : The VB compatible string
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Function vsRemoveNullFromString(vsString) As String
On Error Resume Next
Dim vsNull As String
vsNull = Chr$(0)
If InStr(1, vsString, vsNull) Then
vsRemoveNullFromString = Mid$(vsString, 1, _
InStr(1, vsString, vsNull) - 1)
Else
vsRemoveNullFromString = vsString
End If
End Function
'***********************************************************************
'* Function : GetSystemDir()
'* Purpose : Obtain the system directory (i.e. c:\winnt\system32)
'* Inputs : strSystemDir - The system directory
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetSystemDir(ByRef strSystemDir As Variant) _
As Long
On Error GoTo ErrHandler
Dim strBuffer As String
GetSystemDir = WWW_OK
strBuffer = String(MAX_PATH, 0)
If GetSystemDirectory(strBuffer, _
MAX_PATH) = 0 Then
GetSystemDir = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetSystemDir - Could not get system directory", _
GetLastError(), _
True
Exit Function
End If
strSystemDir = vsRemoveNullFromString(strBuffer)
Exit Function
ErrHandler:
GetSystemDir = WWW_ERROR
LogVBError Err.source, _
"GetSystemDir - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : GetWindowsDir()
'* Purpose : Obtain the windows directory (i.e. c:\winnt)
'* Inputs : strWindowsDir - The system directory
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 07/02/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetWindowsDir(ByRef strWindowsDir As Variant) _
As Long
On Error GoTo ErrHandler
Dim strBuffer As String
GetWindowsDir = WWW_OK
strBuffer = String(MAX_PATH, 0)
If GetWindowsDirectory(strBuffer, _
MAX_PATH) = 0 Then
GetWindowsDir = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetWindowsDir - Could not get system directory", _
GetLastError(), _
True
Exit Function
End If
strWindowsDir = vsRemoveNullFromString(strBuffer)
Exit Function
ErrHandler:
GetWindowsDir = WWW_ERROR
LogVBError Err.source, _
"GetSystemDir - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Error Handling Functions
'***********************************************************************
'***********************************************************************
'* Sub : LogVBError()
'* Purpose : Load the VB Err object with user defined settings
'* Inputs : strSource - The error source
'* strDescription - The error message
'* lNumber - The error number
'* blnWin32 - If true, then include last Win32 error
'* message
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Sub LogVBError(ByVal strSource As String, _
ByVal strDescription As String, _
ByVal lNumber As Long, _
Optional ByVal blnWin32 = False)
Dim strWin32Message As String
If blnWin32 Then
If GetWin32Message(strWin32Message, lNumber) = WWW_OK Then
If Len(strWin32Message) Then
strDescription = strDescription & vbCrLf & _
strWin32Message
End If
End If
End If
mlLastErrorNumber = lNumber
mstrLastErrorSource = strSource
mstrLastErrorDescription = strDescription
CreateEvent strSource, "ERROR", "Error #" & CStr(lNumber) & vbCrLf & _
strDescription
End Sub
'***********************************************************************
'* Function : GetWin32Message()
'* Purpose : Get the last win32 error message and number
'* Inputs : strMessage - The error message/number is placed here
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Function GetWin32Message(ByRef strMessage As String, _
ByVal lErrorNumber As Long) _
As Long
On Error GoTo ErrHandler
Dim strMessageBuffer As String
Dim lBufferLength As Long
GetWin32Message = WWW_OK
strMessageBuffer = String(MAX_MESSAGE_LENGTH, 0)
If lErrorNumber Then
lBufferLength = FormatMessage(FORMAT_MESSAGE_IGNORE_INSERTS Or _
FORMAT_MESSAGE_FROM_SYSTEM, _
vbNull, _
lErrorNumber, _
GetSystemDefaultLangID(), _
strMessageBuffer, _
Len(strMessageBuffer) - 1, _
vbNull)
If lBufferLength Then
strMessage = "Win32 - " & Left(strMessageBuffer, lBufferLength)
Else
GetWin32Message = WWW_ERROR
End If
End If
Exit Function
ErrHandler:
GetWin32Message = WWW_ERROR
Err.Description = "GetWin32Message : " & Err.Description
End Function
'***********************************************************************
'* Secutiry Related Functions
'***********************************************************************
'***********************************************************************
'* Function : LookupDomain()
'* Purpose : Determine what domain the user is logged into
'* Inputs : strSystem - The server that checks the login
'* strAccount - The account name
'* strDomain - The domain the user is logged into
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function LookupDomain(ByVal strSystem As String, _
ByVal strAccount As String, _
ByRef strDomain As Variant) _
As Long
On Error GoTo ErrHandler
Const MAX_SID_SIZE = 500
Dim lSID(MAX_SID_SIZE) As Byte
Dim lSIDSize As Long
Dim lDomainBufferLength As Long
Dim intAccountType As Integer
Dim lRetVal As Long
Dim strDomainBuffer As String
LookupDomain = WWW_OK
strSystem = strSystem
strAccount = strAccount
strDomainBuffer = String(255, 0)
lSIDSize = MAX_SID_SIZE
If LookupAccountName(strSystem, _
strAccount, _
lSID(0), _
lSIDSize, _
strDomainBuffer, _
Len(strDomainBuffer) - 1, _
intAccountType) = 0 Then
LookupDomain = WWW_ERROR
LogVBError "WWWTools.Tools", _
"LookupDomain - Could not lookup account information", _
GetLastError(), _
True
Exit Function
End If
strDomain = vsRemoveNullFromString(strDomainBuffer)
Exit Function
ErrHandler:
LookupDomain = WWW_ERROR
LogVBError Err.source, _
"LookupDomain - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : LookupDomainController()
'* Purpose : Get a domain controller server name for a domain
'* Inputs : strSystem - The server that checks the login
'* strDomain - The domain to check
'* strPDC - The domain PDC prefixed with a \\
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function LookupDomainController(ByVal strSystem As String, _
ByVal strDomain As String, _
ByRef strPDC As Variant) _
As Long
On Error GoTo ErrHandler
Dim bSystem() As Byte
Dim bDomain() As Byte
Dim bTempBuffer(MAX_SERVER_NAME_SIZE) As Byte
Dim pTempBuffer As Long
Dim strTempString As String
Dim lRetVal As Long
LookupDomainController = WWW_OK
bSystem = strSystem & vbNullChar
bDomain = strDomain & vbNullChar
If NetGetDCName(bSystem(0), _
bDomain(0), _
pTempBuffer) <> 0 Then
LookupDomainController = WWW_ERROR
LogVBError "WWWTools.Tools", _
"LookupDomainController - Could not lookup PDC", _
GetLastError(), _
True
Exit Function
End If
PtrToStr bTempBuffer(0), pTempBuffer
NetApiBufferFree pTempBuffer
strPDC = bTempBuffer
Exit Function
ErrHandler:
LookupDomainController = WWW_ERROR
LogVBError Err.source, _
"LookupDomainController - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : GetFullUserName()
'* Purpose : Determine what domain the user is logged into
'* Inputs : strAccount - The account name
'* strDomain - The domain the user is logged into
'* strFullName - The user's full name
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetFullUserName(ByVal strAccount As String, _
ByVal strServer As String, _
ByRef strFullName As Variant) _
As Long
On Error GoTo ErrHandler
Dim bServer() As Byte
Dim bAccount() As Byte
Dim lLevel As Long
Dim tmpBuffer As USER_INFO_3
Dim ptmpBuffer As Long
Dim strTempString As String
Dim bTempByte(MAX_FULL_USER_NAME_LENGTH) As Byte
GetFullUserName = WWW_OK
bServer = strServer & vbNullChar
bAccount = strAccount & vbNullChar
lLevel = 3
If NetUserGetInfo(bServer(0), _
bAccount(0), _
lLevel, _
ptmpBuffer) <> 0 Then
GetFullUserName = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetFullUserName - Could not lookup account information", _
GetLastError(), _
True
Exit Function
End If
vbMemCopy ByVal ptmpBuffer, tmpBuffer, LenB(tmpBuffer)
NetApiBufferFree ptmpBuffer
PtrToStr bTempByte(0), tmpBuffer.usri3_full_name
strTempString = bTempByte
strTempString = vsRemoveNullFromString(strTempString)
strFullName = Trim$(strTempString)
Exit Function
ErrHandler:
GetFullUserName = WWW_ERROR
LogVBError Err.source, _
"GetFullUserName - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : GetLogonUserName()
'* Purpose : Determine what user is currently logged in
'* Inputs : strAccount - The account name
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetLogonUserName(ByRef strAccount As Variant) _
As Long
On Error GoTo ErrHandler
Dim strBuffer As String
Dim lBufferSize As Long
lBufferSize = MAX_USER_NAME_LENGTH - 1
GetLogonUserName = WWW_OK
strBuffer = String(MAX_USER_NAME_LENGTH, 0)
If GetUserName(strBuffer, _
lBufferSize) = 0 Then
GetLogonUserName = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetLogonUserName - Could not lookup user information", _
GetLastError(), _
True
Exit Function
End If
strAccount = vsRemoveNullFromString(strBuffer)
Exit Function
ErrHandler:
GetLogonUserName = WWW_ERROR
LogVBError Err.source, _
"GetLogonUserName - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Text To Speeech Related Functions
'***********************************************************************
'***********************************************************************
'* Function : TextToSpeechEngineExists()
'* Purpose : See if the text to speech engine can be initialized
'* Inputs : blnExists - True if the engine can be initialized
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function TextToSpeechEngineExists(ByRef blnExists As Variant) _
As Long
On Error GoTo ErrHandler
Dim objVoiceText As Object
Dim lRetVal As Long
TextToSpeechEngineExists = WWW_OK
Set objVoiceText = CreateObject("Speech.VoiceText")
blnExists = Not CBool(objVoiceText.Register("", "Test"))
Set objVoiceText = Nothing
Exit Function
ErrHandler:
TextToSpeechEngineExists = WWW_ERROR
LogVBError Err.source, _
"TextToSpeechEngineExists - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Event Log Related Functions
'***********************************************************************
'***********************************************************************
'* Function : RegisterAppWithEventLog()
'* Purpose : Register the message resource DLL for an application.
'* Inputs : strAppName - Application Name
'* strMessageDLL - Event log message DLL
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function RegisterAppWithEventLog(ByVal strAppName As String, _
ByVal strMessageDLL As String) _
As Long
On Error GoTo ErrHandler
Dim strBaseKeyName As String
Dim strKeyName As String
Dim lTypesSupported As Long
Dim strMultiSources As String
Dim blnMultiStringUpdated As Boolean
RegisterAppWithEventLog = WWW_OK
lTypesSupported = EVENTLOG_ERROR_TYPE Or _
EVENTLOG_WARNING_TYPE Or _
EVENTLOG_INFORMATION_TYPE
strBaseKeyName = "HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\EventLog\Application\"
strKeyName = strBaseKeyName & strAppName
If CreateRegKey(strKeyName) <> WWW_OK Then
RegisterAppWithEventLog = WWW_ERROR
LogVBError "WWWTools.Tools", _
"RegisterAppWithEventLog - Create registry key failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If SetRegValue(strKeyName & "\EventMessageFile", _
strMessageDLL, _
"REG_EXPAND_SZ") <> WWW_OK Then
RegisterAppWithEventLog = WWW_ERROR
LogVBError "WWWTools.Tools", _
"RegisterAppWithEventLog - Create registry value failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If SetRegValue(strKeyName & "\TypesSupported", _
lTypesSupported, _
"REG_DWORD") <> WWW_OK Then
RegisterAppWithEventLog = WWW_ERROR
LogVBError "WWWTools.Tools", _
"RegisterAppWithEventLog - Create registry value failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If QueryRegValue(strBaseKeyName & "Sources", _
strMultiSources) <> WWW_OK Then
RegisterAppWithEventLog = WWW_ERROR
LogVBError "WWWTools.Tools", _
"RegisterAppWithEventLog - Create registry value failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If UpdateMultiString(strMultiSources, _
strAppName, _
blnMultiStringUpdated) <> WWW_OK Then
RegisterAppWithEventLog = WWW_ERROR
LogVBError "WWWTools.Tools", _
"RegisterAppWithEventLog - UpdateMultiString failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
If blnMultiStringUpdated Then
If SetRegValue(strBaseKeyName & "Sources", _
strMultiSources, _
"REG_MULTI_SZ") <> WWW_OK Then
RegisterAppWithEventLog = WWW_ERROR
LogVBError "WWWTools.Tools", _
"RegisterAppWithEventLog - Create registry value failed", _
WWW_UNHANDLED_ERROR
Exit Function
End If
End If
Exit Function
ErrHandler:
RegisterAppWithEventLog = WWW_ERROR
LogVBError Err.source, _
"RegisterAppWithEventLog - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : UpdateMultiString()
'* Purpose : Add a string to the end of a multistring if it does not
'* already exist.
'* Inputs : strMultiString - Original multistring
'* strNewString - String to add to multistring list
'* blnStringUpdated - True if string updated
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Private Function UpdateMultiString(ByRef strMultiString As String, _
ByVal strNewString As String, _
ByRef blnStringUpdated As Boolean) _
As Long
On Error GoTo ErrHandler
Dim lStartPos As Long
Dim lEndPos As Long
Dim blnFound As Boolean
Dim strTemp As String
UpdateMultiString = WWW_OK
lStartPos = 1
Do
lEndPos = InStr(lStartPos, strMultiString, Chr$(0))
If lEndPos = 0 Then
Exit Do
End If
If lEndPos > 0 Then
strTemp = Mid$(strMultiString, _
lStartPos, _
(lEndPos - lStartPos))
End If
If UCase$(Trim$(strTemp)) = UCase$(Trim$(strNewString)) Then
blnFound = True
Exit Do
End If
lStartPos = lEndPos + 1
Loop While lStartPos > 0
If blnFound = False Then
blnStringUpdated = True
strMultiString = Mid$(strMultiString, 1, Len(strMultiString) - 1) & strNewString$ & Chr$(0)
Else
blnStringUpdated = False
End If
Exit Function
ErrHandler:
UpdateMultiString = WWW_ERROR
LogVBError Err.source, _
"UpdateMultiString - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : CreateEvent()
'* Purpose : Log an event
'* Inputs : strAppName - Application Name registered with
'* RegisterAppWithEventLog()
'* strEventType - "ERROR", "WARNING", or "INFORMATION"
'* strMessage - The event message to write
'* lEventID - EventID from the message resource file
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function CreateEvent(ByVal strAppName As String, _
ByVal strEventType As String, _
ByVal strMessage As String, _
Optional ByVal lEventID As Long = 1) _
As Long
On Error GoTo ErrHandler
Dim lEventType As Long
Dim lEventLogHandle As Long
Dim lMessageSize As Long
Dim lMessageHandle As Long
Dim strAppMessage As String
Dim strMessageDLL As String
Dim strRegisteredAppName As String
CreateEvent = WWW_OK
strRegisteredAppName = "Web Tools"
strMessageDLL = "%SystemRoot%\system32\WWWToolsMsg.dll"
RegisterAppWithEventLog strRegisteredAppName, _
strMessageDLL
strAppMessage = "Message From : " & strAppName & vbCrLf & _
strMessage
lMessageSize = Len(strAppMessage) + 1
lMessageHandle = GlobalAlloc(GPTR, lMessageSize)
vbMemCopy ByVal strAppMessage, ByVal lMessageHandle, lMessageSize
Select Case UCase(strEventType)
Case "ERROR":
lEventType = EVENTLOG_ERROR_TYPE
Case "WARNING":
lEventType = EVENTLOG_WARNING_TYPE
Case "INFORMATION":
lEventType = EVENTLOG_INFORMATION_TYPE
Case Else
CreateEvent = WWW_ERROR
mlLastErrorNumber = WWW_UNHANDLED_ERROR
mstrLastErrorSource = "WWWTools.Tools"
mstrLastErrorDescription = "CreateEvent - Invalid Event Type"
Exit Function
End Select
lEventLogHandle = RegisterEventSource("", strRegisteredAppName)
If lEventLogHandle = 0 Then
CreateEvent = WWW_ERROR
mlLastErrorNumber = WWW_UNHANDLED_ERROR
mstrLastErrorSource = "WWWTools.Tools"
mstrLastErrorDescription = "CreateEvent - Could not register event source"
Exit Function
End If
If ReportEvent(lEventLogHandle, _
lEventType, _
0, _
lEventID, _
0&, _
1, _
lMessageSize, _
lMessageHandle, _
vbNull) = 0 Then
CreateEvent = WWW_ERROR
mlLastErrorNumber = WWW_UNHANDLED_ERROR
mstrLastErrorSource = "WWWTools.Tools"
mstrLastErrorDescription = "CreateEvent - Could not log event"
End If
If DeregisterEventSource(lEventLogHandle) = 0 Then
CreateEvent = WWW_ERROR
mlLastErrorNumber = WWW_UNHANDLED_ERROR
mstrLastErrorSource = "WWWTools.Tools"
mstrLastErrorDescription = "CreateEvent - Could not deregister event source"
Exit Function
End If
Exit Function
ErrHandler:
CreateEvent = WWW_ERROR
mlLastErrorNumber = Err.Number
mstrLastErrorSource = Err.source
mstrLastErrorDescription = "CreateEvent - " & Err.Description
End Function
'***********************************************************************
'* Window Object Related Functions
'***********************************************************************
'***********************************************************************
'* Function : HookWindowProc()
'* Purpose : Hook a window objects WindowProc and trap WM_PAINT messages
'* Inputs : hWindowHandle - Handle of window object whose WindowProc
'* is hooked
'* Returns : WWW_OK on success, WWW_ERROR on failure
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function HookWindowProc(ByVal hWindowHandle As Long) _
As Long
On Error GoTo ErrHandler
HookWindowProc = WWW_OK
If objWindowProcTools Is Nothing Then
mblnRaiseWMPaintEvent = False
mWindowHandle = hWindowHandle
mPrevWndProc = SetWindowLong(hWindowHandle, _
GWL_WNDPROC, _
AddressOf WindowProc)
If mPrevWndProc = 0 Then
HookWindowProc = WWW_ERROR
LogVBError "WWWTools.Tools", _
"HookWindowProc - Could not hook message handler", _
GetLastError(), _
True
Exit Function
End If
Set objWindowProcTools = Me
Else
HookWindowProc = WWW_ERROR
LogVBError "WWWTools.Tools", _
"HookWindowProc - Another object is using the windowproc hook", _
WWW_UNHANDLED_ERROR
End If
Exit Function
ErrHandler:
HookWindowProc = WWW_ERROR
LogVBError Err.source, _
"HookWindowProc - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : UnHookWindowProc()
'* Purpose : Unhook the window object's WindowProc hooked with the
'* previous function.
'* Inputs : None - We know who we hooked earlier
'* Returns : WWW_OK on success, WWW_ERROR on failure
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function UnHookWindowProc()
On Error GoTo ErrHandler
Dim lngReturnValue As Long
If objWindowProcTools Is Me Then
lngReturnValue = SetWindowLong(mWindowHandle, _
GWL_WNDPROC, _
mPrevWndProc)
Set objWindowProcTools = Nothing
If lngReturnValue = 0 Then
UnHookWindowProc = WWW_ERROR
LogVBError "WWWTools.Tools", _
"UnHookWindowProc - Could not unhook message handler", _
GetLastError(), _
True
Exit Function
End If
End If
Exit Function
ErrHandler:
UnHookWindowProc = WWW_ERROR
LogVBError Err.source, _
"UnHookWindowProc - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Sub : PaintEvent()
'* Purpose : Called by the WindowProc in the MessageHook module so that
'* the object can raise the WMPaint event
'* Inputs : None
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Friend Sub PaintEvent()
If mblnRaiseWMPaintEvent Then
RaiseEvent WMPaint
End If
End Sub
'***********************************************************************
'* Function : GetParentWindowHandle()
'* Purpose : Log an event
'* Inputs : hWindowHandle - The window whose parent is desired
'* lParentHandle - The parent window's handle
'* Returns : WWW_OK on success or WWW_ERROR on error
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetParentWindowHandle(ByVal hWindowHandle As Long, _
ByRef lParentHandle As Variant) _
As Long
On Error GoTo ErrHandler
GetParentWindowHandle = WWW_OK
lParentHandle = GetParent(hWindowHandle)
If lParentHandle = 0 Then
GetParentWindowHandle = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetParentWindowHandle - Could not get parent window", _
GetLastError(), _
True
Exit Function
End If
Exit Function
ErrHandler:
GetParentWindowHandle = WWW_ERROR
LogVBError Err.source, _
"GetParentWindowHandle - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Function : GetWindowSize()
'* Purpose : Get a window's height and width
'* Inputs :
'* Returns : WWW_OK on success, WWW_ERROR on failure
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function GetWindowSize(ByVal hwnd As Long, _
ByRef lHeight As Variant, _
ByRef lWidth As Variant) _
As Long
On Error GoTo ErrHandler
Dim udtRect As RECT
GetWindowSize = WWW_OK
If GetClientRect(hwnd, udtRect) = 0 Then
GetWindowSize = WWW_ERROR
LogVBError "WWWTools.Tools", _
"GetWindowSize - Could not get window size", _
GetLastError(), _
True
Exit Function
End If
lHeight = udtRect.Bottom
lWidth = udtRect.Right
Exit Function
ErrHandler:
GetWindowSize = WWW_ERROR
LogVBError Err.source, _
"GetWindowSize - " & Err.Description, _
Err.Number
End Function
'***********************************************************************
'* Module : MessageHook
'*
'* Purpose : WindowProc procedure to process messages sent to hooked
'* window.
'*
'* References : None
'*
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
'***********************************************************************
'* Module level variables
'***********************************************************************
Public mPrevWndProc As Long
Public mWindowHandle As Long
Public objWindowProcTools As Tools
'***********************************************************************
'* Function : WindowProc()
'* Purpose : See if message is WM_PAINT, and if it is, then call a
'* function in the object that initiated the hook so that
'* it can raise an event. Always pass on the message to the
'* original WindowProc.
'* Inputs : None
'* Returns : The return from the original WindowProc.
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Public Function WindowProc(ByVal hw As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Select Case uMsg
Case WM_PAINT
objWindowProcTools.PaintEvent
Debug.Print "Got Paint Message"
Case Else
Debug.Print "Got Other Message"
End Select
WindowProc = CallWindowProc(mPrevWndProc, _
hw, _
uMsg, _
wParam, _
lParam)
End Function
'***********************************************************************
'* Module : WWWToolsSupport.Bas
'*
'* Purpose : VB Header for WWWToolsSupport.dll
'*
'* References : None
'*
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
Public Declare Sub vbMemMove Lib "WWWToolsSupport.dll" ( _
source As Any, _
dest As Any, _
ByVal nCount As Long)
Public Declare Sub vbMemCopy Lib "WWWToolsSupport.dll" ( _
source As Any, _
dest As Any, _
ByVal nCount As Long)
'***********************************************************************
'* Module : Win32.Bas
'*
'* Purpose : VB Header for Win32 API calls
'*
'* References : None
'*
'* Revision : 1.0.0 08/03/1997 James Bischoff
'* Initial release
'***********************************************************************
Option Explicit
'***********************************************************************
'* General Win32 constants and declares
'***********************************************************************
Public Const VB_RESERVED_ERROR As Long = 512
Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Public Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Public Const MAX_MESSAGE_LENGTH = 500
Public Const GMEM_FIXED = &H0
Public Const GMEM_ZEROINIT = &H40
Public Const GPTR = GMEM_FIXED Or GMEM_ZEROINIT
Public Declare Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As Long) _
As Long
Public Declare Function GlobalFree Lib "kernel32" ( _
ByVal hMem As Long) _
As Long
Public Declare Function GetLastError Lib "kernel32" () _
As Long
Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( _
ByVal dwFlags As Long, _
lpSource As Any, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
Arguments As Long) _
As Long
Public Declare Function GetSystemDefaultLangID Lib "kernel32" () _
As Integer
Public Declare Sub Sleep Lib "kernel32" ( _
ByVal dwMilliseconds As Long)
Public Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyW" ( _
RetVal As Byte, _
ByVal Ptr As Long) _
As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) _
As Long
Public Declare Function MoveWindow Lib "user32" ( _
ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nwidth As Long, _
ByVal nheight As Long, _
ByVal brepaint As Long) _
As Long
Public Declare Function GetParent Lib "user32" ( _
ByVal hwnd As Long) _
As Long
Public Declare Function UpdateWindow Lib "user32" ( _
ByVal hwnd As Long) _
As Long
'***********************************************************************
'* Network related constants, types and declares
'***********************************************************************
Public Const RESOURCETYPE_DISK = &H1
Public Const RESOURCEDISPLAYTYPE_SHARE = &H3
Public Const RESOURCEUSAGE_CONNECTABLE = &H1
Public Const RESOURCE_PUBLICNET = &H2
Public Const WN_SUCCESS = &H0
Public Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" ( _
ByVal strDriveLetter As String) _
As Long
Public Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" ( _
lpNetResource As NETRESOURCE, _
ByVal lpPassword As String, _
ByVal lpUserName As String, _
ByVal dwFlags As Long) _
As Long
Public Declare Function WNetCancelConnection Lib "mpr.dll" Alias "WNetCancelConnectionA" ( _
ByVal lpszName As String, _
ByVal bForce As Long) _
As Long
'***********************************************************************
'* Process related constants, types and declares
'***********************************************************************
Public Const INFINITE = &HFFFFFFFF
Public Const WAIT_TIMEOUT = &H102&
Public Const NORMAL_PRIORITY_CLASS = &H20
Public Const CREATE_SEPARATE_WOW_VDM = &H800
Public Const DETACHED_PROCESS = &H8
Public Const TOKEN_QUERY = &H8
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Public Const SE_DEBUG_NAME = "SeDebugPrivilege"
Public Const ANYSIZE_ARRAY = 1
Public Const SE_PRIVILEGE_ENABLED = &H2
Public Const WM_CLOSE = &H10
Type LUID
LowPart As Long
HighPart As Long
End Type
Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Public Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Public 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 Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" ( _
ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
ByVal lpProcessAttributes As Long, _
ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcesudtStartupInformation As PROCESS_INFORMATION) _
As Long
Public Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) _
As Long
Public Declare Function WaitForInputIdle Lib "user32" ( _
ByVal hProcess As Long, _
ByVal dwMilliseconds As Long) _
As Long
Public Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) _
As Long
Public Declare Function TerminateProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
ByVal uExitCode As Long) _
As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () _
As Long
Public Declare Function OpenProcessToken Lib "advapi32.dll" ( _
ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
TokenHandle As Long) _
As Long
Public Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" ( _
ByVal lpSystemName As String, _
ByVal lpName As String, _
lpLuid As LUID) _
As Long
Public Declare Function AdjustTokenPrivileges Lib "advapi32.dll" ( _
ByVal TokenHandle As Long, _
ByVal DisableAllPrivileges As Long, _
NewState As TOKEN_PRIVILEGES, _
ByVal BufferLength As Long, _
PreviousState As Any, _
ReturnLength As Long) _
As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Private Declare Function IsWindow Lib "user32" ( _
ByVal hwnd As Long) _
As Long
'***********************************************************************
'* Registry related constants, types, and declares
'***********************************************************************
Public Const KEY_ALL_ACCESS = &H3F
Public Const KEY_QUERY_VALUE = &H1
Public Const REG_OPTION_NON_VOLATILE = 0
Public Const ERROR_SUCCESS = &H0
Public Const ERROR_NO_MORE_ITEMS = 259&
Public Const REG_SZ = 1
Public Const REG_DWORD = 4
Public Const REG_MULTI_SZ = 7
Public Const REG_EXPAND_SZ = 2
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hKey As Long) _
As Long
Public Declare Function RegCreateKeyEx Lib "advapi32.dll" 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, _
ByVal lpSecurityAttributes As Long, _
phkResult As Long, _
lpdwDisposition As Long) _
As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String) _
As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) _
As Long
Public 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
Public Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
ByVal lpData As String, _
ByVal cbData As Long) _
As Long
Public Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) _
As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String) _
As Long
Public Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As String, _
lpcbData As Long) _
As Long
Public Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Long, _
lpcbData As Long) _
As Long
Public Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As Long, _
lpcbData As Long) _
As Long
'***********************************************************************
'* File related constants, types, and declares
'***********************************************************************
Public Const MAX_PATH = 260
Public Const INVALID_HANDLE_VALUE = -1
Public Const OF_READ = &H0
Public Const OFS_MAXPATHNAME = 128
Public Const LOCALE_SYSTEM_DEFAULT& = &H800
Public Const TIME_ZONE_ID_INVALID = &HFFFFFFFF
Public Const TIME_ZONE_ID_UNKNOWN = 0
Public Const TIME_ZONE_ID_STANDARD = 1
Public Const TIME_ZONE_ID_DAYLIGHT = 2
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Public Type TIME_ZONE_INFORMATION
Bias As Long
StandardName As String * 64
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName As String * 64
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Public Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersion As Long ' e.g. 0x00000042 = "0.42"
dwFileVersionMS As Long ' e.g. 0x00030075 = "3.75"
dwFileVersionLS As Long ' e.g. 0x00000031 = "0.31"
dwProductVersionMS As Long ' e.g. 0x00030010 = "3.10"
dwProductVersionLS As Long ' e.g. 0x00000031 = "0.31"
dwFileFlagsMask As Long ' = 0x3F for version "0.42"
dwFileFlags As Long ' e.g. VFF_DEBUG Or VFF_PRERELEASE
dwFileOS As Long ' e.g. VOS_DOS_WINDOWS16
dwFileType As Long ' e.g. VFT_DRIVER
dwFileSubtype As Long ' e.g. VFT2_DRV_KEYBOARD
dwFileDateMS As Long ' e.g. 0
dwFileDateLS As Long ' e.g. 0
End Type
Public Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Public Declare Function FindClose Lib "kernel32" ( _
ByVal hFindFile As Long) _
As Long
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) _
As Long
Public Declare Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" ( _
ByVal lptstrFilename As String, _
ByVal dwHandle As Long, _
ByVal dwLen As Long, _
lpData As Any) _
As Long
Public Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" ( _
ByVal lptstrFilename As String, _
lpdwHandle As Long) _
As Long
Public Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" ( _
pBlock As Byte, _
ByVal lpSubBlock As String, _
lplpBuffer As Long, _
puLen As Long) _
As Long
Public Declare Function OpenFile Lib "kernel32" ( _
ByVal lpFileName As String, _
lpReOpenBuff As OFSTRUCT, _
ByVal wStyle As Long) _
As Long
Public Declare Function GetFileTime Lib "kernel32" ( _
ByVal hFile As Long, _
lpCreationTime As FILETIME, _
lpLastAccessTime As FILETIME, _
lpLastWriteTime As FILETIME) _
As Long
Public Declare Function FileTimeToSystemTime Lib "kernel32" ( _
lpFileTime As FILETIME, _
lpSystemTime As SYSTEMTIME) _
As Long
Public Declare Function GetTimeFormat Lib "kernel32" Alias "GetTimeFormatA" ( _
ByVal Locale As Long, _
ByVal dwFlags As Long, _
lpTime As SYSTEMTIME, _
ByVal lpFormat As Long, _
ByVal lpTimeStr As String, _
ByVal cchTime As Long) _
As Long
Public Declare Function GetDateFormat Lib "kernel32" Alias "GetDateFormatA" ( _
ByVal Locale As Long, _
ByVal dwFlags As Long, _
lpTime As SYSTEMTIME, _
ByVal lpFormat As Long, _
ByVal lpDateStr As String, _
ByVal cchDate As Long) _
As Long
Public Declare Function GetTimeZoneInformation Lib "kernel32" ( _
lpTimeZoneInformation As TIME_ZONE_INFORMATION) _
As Long
'***********************************************************************
'* Security related constants, types, and declares
'***********************************************************************
Public Const MAX_FULL_USER_NAME_LENGTH = 255
Public Const MAX_USER_NAME_LENGTH = 50
Public Const MAX_SERVER_NAME_SIZE = 20
Public Type USER_INFO_3
usri3_name As Long 'LPWSTR in SDK
usri3_password As Long 'LPWSTR in SDK
usri3_password_age As Long 'DWORD in SDK
usri3_priv As Long 'DWORD in SDK
usri3_home_dir As Long 'LPWSTR in SDK
usri3_comment As Long 'LPWSTR in SDK
usri3_flags As Long 'DWORD in SDK
usri3_script_path As Long 'LPWSTR in SDK
usri3_auth_flags As Long 'DWORD in SDK
usri3_full_name As Long 'LPWSTR in SDK
usri3_usr_comment As Long 'LPWSTR in SDK
usri3_parms As Long 'LPWSTR in SDK
usri3_workstations As Long 'LPWSTR in SDK
usri3_last_logon As Long 'DWORD in SDK
usri3_last_logoff As Long 'DWORD in SDK
usri3_acct_expires As Long 'DWORD in SDK
usri3_max_storage As Long 'DWORD in SDK
usri3_units_per_week As Long 'DWORD in SDK
usri3_logon_hours As Long 'PBYTE in SDK
usri3_bad_pw_count As Long 'DWORD in SDK
usri3_num_logons As Long 'DWORD in SDK
usri3_logon_server As Long 'LPWSTR in SDK
usri3_country_code As Long 'DWORD in SDK
usri3_code_page As Long 'DWORD in SDK
usri3_user_id As Long 'DWORD in SDK
usri3_primary_group_id As Long 'DWORD in SDK
usri3_profile As Long 'LPWSTR in SDK
usri3_home_dir_drive As Long 'LPWSTR in SDK
usri3_password_expired As Long 'DWORD in SDK
End Type
Public Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" ( _
ByVal lpSystemName As String, _
ByVal lpAccountName As String, _
Sid As Any, _
cbSid As Long, _
ByVal ReferencedDomainName As String, _
cbReferencedDomainName As Long, _
peUse As Integer) _
As Long
Public Declare Function NetUserGetInfo Lib "netapi32.dll" ( _
Servername As Any, _
UserName As Any, _
ByVal dwLevel As Long, _
pBuffer As Long) _
As Long
Public Declare Function NetApiBufferFree Lib "netapi32.dll" ( _
pBuffer As Long) _
As Long
Public Declare Function NetGetDCName Lib "netapi32.dll" ( _
Servername As Any, _
Domainname As Any, _
pBuffer As Long) _
As Long
Public Declare Function NetGetAnyDCName Lib "netapi32.dll" ( _
Servername As Any, _
Domainname As Any, _
pBuffer As Long) _
As Long
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" ( _
ByVal lpBuffer As String, _
nSize As Long) _
As Long
'***********************************************************************
'* Event Log related constants, types, and declares
'***********************************************************************
Public Const EVENTLOG_ERROR_TYPE = &H1
Public Const EVENTLOG_WARNING_TYPE = &H2
Public Const EVENTLOG_INFORMATION_TYPE = &H4
Public Declare Function OpenEventLog Lib "advapi32" Alias "OpenEventLogA" ( _
ByVal lpUNCServerName As String, _
ByVal lpSourceName As String) _
As Long
Public Declare Function CloseEventLog Lib "advapi32" ( _
ByVal hEventLog As Long) _
As Long
Public Declare Function RegisterEventSource Lib "advapi32" Alias "RegisterEventSourceA" ( _
ByVal lpUNCServerName As String, _
ByVal lpSourceName As String) _
As Long
Public Declare Function DeregisterEventSource Lib "advapi32" ( _
ByVal hEventLog As Long) _
As Long
Public Declare Function ReportEvent Lib "advapi32" Alias "ReportEventA" ( _
ByVal hEventLog As Long, _
ByVal wType As Long, _
ByVal wCategory As Long, _
ByVal dwEventID As Long, _
ByVal lpUserSid As Long, _
ByVal wNumStrings As Long, _
ByVal dwDataSize As Long, _
lpStrings As Any, _
lpRawData As Any) _
As Long
'***********************************************************************
'* Message Hook related constants, types, and declares
'***********************************************************************
Public Const GWL_WNDPROC = -4
Public Const WM_PAINT = &HF
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) _
As Long
Public Declare Function GetClientRect Lib "user32" ( _
ByVal hwnd As Long, _
lpRect As RECT) _
As Long
|
