'***********************************************************************
'* 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 = & |
