screw it. here's the code and it works great.
Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003
Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259
Global Const KEY_ALL_ACCESS = &H3F
Global Const REG_OPTION_NON_VOLATILE = 0
Global gstrAppVersion As String
Private Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersion As Long
dwFileVersionMS As Long
dwFileVersionLS As Long
dwProductVersionLS As Long
dwFileFlagsMask As Long
dwProductVersionMS As Long
dwFileFlags As Long
dwFileOS As Long
dwFileType As Long
dwFileSubtype As Long
dwFileDateMS As Long
dwFileDateLS As Long
End Type
Private Declare Function apiGetFileVersionInfoSize _
Lib "version.dll" Alias "GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, _
lpdwHandle As Long) _
As Long
Private Declare Function apiGetFileVersionInfo Lib _
"version.dll" Alias "GetFileVersionInfoA" _
(ByVal lptstrFilename As String, _
ByVal dwHandle As Long, _
ByVal dwLen As Long, _
lpData As Any) _
As Long
Private Declare Function apiVerQueryValue Lib _
"version.dll" Alias "VerQueryValueA" _
(pBlock As Any, _
ByVal lpSubBlock As String, _
lplpBuffer As Long, _
puLen As Long) _
As Long
Private Declare Sub sapiCopyMem _
Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Declare Function RegCloseKey Lib "advapi32.dll" ( _
ByVal hKey As Long _
) As Long
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
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
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
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
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
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 lpValue As _
String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long
Function fGetProductVersion(strExeFullPath As String) As String
On Error GoTo ErrHandler
Dim lngSize As Long
Dim lngRet As Long
Dim pBlock() As Byte
Dim lpfi As VS_FIXEDFILEINFO
Dim lppBlock As Long
lngSize = apiGetFileVersionInfoSize( _
strExeFullPath, _
lngRet)
If lngSize Then
ReDim pBlock(lngSize)
lngRet = apiGetFileVersionInfo(strExeFullPath, 0, _
lngSize, pBlock(0))
If Not lngRet = 0 Then
lngRet = apiVerQueryValue(pBlock(0), _
"\", lppBlock, lngSize)
Call sapiCopyMem(lpfi, ByVal lppBlock, lngSize)
With lpfi
fGetProductVersion = HIWord(.dwFileVersionMS) & "." & _
LOWord(.dwFileVersionMS) &
"." & _
HIWord(.dwFileVersionLS) &
"." & _
LOWord(.dwFileVersionLS)
End With
End If
End If
ExitHere:
Erase pBlock
Exit Function
ErrHandler:
Resume ExitHere
End Function
Private Function LOWord(dw As Long) As Integer
If dw And &H8000& Then
LOWord = dw Or &HFFFF0000
Else
LOWord = dw And &HFFFF&
End If
End Function
Private Function HIWord(dw As Long) As Integer
HIWord = (dw And &HFFFF0000) \ &H10000
End Function
Public Function SetValueEx( _
ByVal hKey As Long, _
sValueName As String, _
lType As Long, _
vValue As Variant _
) As Long
Dim lValue As Long
Dim sValue As String
Select Case lType
Case REG_SZ
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType,
sValue, Len(sValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType,
lValue, 4)
End Select
End Function
Private Function QueryValueEx( _
ByVal lhKey As Long, _
ByVal szValueName As String, _
vValue As Variant _
) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
On Error GoTo QueryValueExError
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType,
sValue, cch)
If lrc = ERROR_NONE Then
If Mid(sValue, cch, 1) = Chr(0) Then
vValue = Left$(sValue, cch - 1)
Else
vValue = Left$(sValue, cch)
End If
Else
vValue = Empty
End If
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue,
cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function
Public Sub CreateNewKey(sNewKeyName As String, lPredefinedKey As Long)
Dim hNewKey As Long
Dim lRetVal As Long
lRetVal = RegCreateKeyEx( _
lPredefinedKey, _
sNewKeyName, _
0&, _
vbNullString, _
REG_OPTION_NON_VOLATILE, _
KEY_ALL_ACCESS, _
0&, _
hNewKey, _
lRetVal _
)
RegCloseKey hNewKey
End Sub
Public Sub SetKeyValue( _
ByVal lpParentKey As Long, _
sKeyName As String, _
sValueName As String, _
vValueSetting As Variant, _
lValueType As Long _
)
Dim lRetVal As Long
Dim hKey As Long
lRetVal = RegOpenKeyEx(lpParentKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
RegCloseKey (hKey)
End Sub
Public Function QueryValue( _
ByVal lpParentKey As Long, _
sKeyName As String, _
sValueName As String _
) As Variant
Dim lRetVal As Long
Dim hKey As Long
Dim vValue As Variant
lRetVal = RegOpenKeyEx(lpParentKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
RegCloseKey (hKey)
QueryValue = vValue
End Function
Sub CreateKeyDriver()
Dim sNewKey As String
Dim lPredefinedKeyValue As Long
sKey = "Software\Microsoft\Office\9.0\Outlook\Options\NewKey"
lPredefinedKeyValue = HKEY_CURRENT_USER
CreateNewKey sNewKey, lPredefinedKeyValue
End Sub
Sub SetStringValueDriver()
Dim sKey As String
Dim sValue As String
Dim vSetting As Variant
Dim sType As Long
sKey = "Software\Microsoft\Office\9.0\Outlook\Options\Spelling"
sValue = "TestString"
vSetting = "Test"
sType = REG_SZ
SetKeyValue HKEY_CURRENT_USER, sKey, sValue, vSetting, sType
End Sub
Sub SetNumberValueDriver()
Dim sKey As String
Dim sValue As String
Dim vSetting As Variant
Dim sType As Long
sKey = "Software\Microsoft\Office\9.0\Outlook\Options\Spelling"
sValue = "Check"
vSetting = 0
sType = REG_DWORD
SetKeyValue HKEY_CURRENT_USER, sKey, sValue, vSetting, sType
End Sub
Sub ReadValueDriver()
Dim sKey As String
Dim sValue As String
Dim vSetting As Variant
sKey = "Software\Microsoft\Office\9.0\Outlook\Options\Spelling"
sValue = "Check"
vSetting = QueryValue(HKEY_CURRENT_USER, sKey, sValue)
Debug.Print "Spelling : " & vSetting
End Sub
Sub Unsolicited()
Dim objApp As Application
Dim objSelection As Selection
Dim objItem As Object
Dim sKey As String
Dim sValue As String
Dim vSetting As Variant
Dim vOrigSetting As Variant
Dim sType As Long
Dim pid_ver As String
If Len("C:\Program Files\Microsoft Office\Office\outlook.exe") Then
pid_ver = fGetProductVersion("C:\Program Files\Microsoft
Office\Office\outlook.exe")
If Left(pid_ver, 1) = "9" Then
sKey = "Software\Microsoft\Office\9.0\Outlook\Options\Spelling"
sValue = "Check"
End If
End If
If Len("C:\Program Files\Microsoft Office\Office10\outlook.exe") Then
pid_ver = fGetProductVersion("C:\Program Files\Microsoft
Office\Office10\outlook.exe")
If Left(pid_ver, 1) = "1" Then
sKey = "Software\Microsoft\Office\10.0\Outlook\Options\Spelling"
sValue = "Check"
End If
End If
vSetting = QueryValue(HKEY_CURRENT_USER, sKey, sValue)
vOrigSetting = QueryValue(HKEY_CURRENT_USER, sKey, sValue)
If vSetting = 1 Then
If Left(pid_ver, 1) = "9" Then
SendKeys "%TO"
SendKeys
"{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{RIGHT}{RIGHT}{RIGHT}"
SendKeys "{TAB}{TAB}"
SendKeys " "
SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{ENTER}"
End If
If Left(pid_ver, 1) = "1" Then
SendKeys "%TO"
SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{RIGHT}{RIGHT}{RIGHT}"
SendKeys "{TAB}{TAB}"
SendKeys " "
SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{ENTER}"
End If
End If
Set objApp = CreateObject("Outlook.Application")
Set objSelection = objApp.ActiveExplorer.Selection
Select Case objSelection.Count
Case 0
Case Is > 1
For Each objItem In objSelection
If TypeOf objItem Is MailItem Then
SendKeys "^f"
SendKeys "#Unsolicited Email"
SendKeys "%s"
End If
Next
SendKeys "{DELETE}"
Case Is <= 1
For Each objItem In objSelection
If TypeOf objItem Is MailItem Then
SendKeys "^f"
SendKeys "#Unsolicited Email"
SendKeys "%s"
SendKeys "{DELETE}"
End If
Next
End Select
If vOrigSetting = 1 Then
If Left(pid_ver, 1) = "9" Then
SendKeys "%TO"
SendKeys
"{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{RIGHT}{RIGHT}{RIGHT}"
SendKeys "{TAB}{TAB}"
SendKeys " "
SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{ENTER}"
End If
If Left(pid_ver, 1) = "1" Then
SendKeys "%TO"
SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{RIGHT}{RIGHT}{RIGHT}"
SendKeys "{TAB}{TAB}"
SendKeys " "
SendKeys "{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}{TAB}"
SendKeys "{ENTER}"
End If
End If
Set objApp = Nothing
Set objSelection = Nothing
Set objItem = Nothing
End Sub
