Bypassing "Check Spelling" before send ?

N

noone

Hello all,
Below is code that I am using to automate forwarding messages to our
"junk box". It is working perfect unless a user has "Check spelling before
send"
option enabled.

Is there any via VBA to disable then re-enable this option ?
Thanks.

Sub Unsolicited()
Dim objApp As Application
Dim objSelection As Selection
Dim objItem As Object

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

Set objApp = Nothing
Set objSelection = Nothing
Set objItem = Nothing
End Sub
 
N

noone

Is there any via VBA to disable then re-enable this option ?

After some testing and googlin', this is what the code looks like now:
The registry reads/writes are working fine, however Outlook is IGNORING
the value of 0 (Check spelling off). Am I missing another setting somewhere
?

NOTE: I did not include all of the versioning / registry API code. I can, if
it needed.

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
sType = REG_DWORD
SetKeyValue HKEY_CURRENT_USER, sKey, sValue, 0, sType
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

SetKeyValue HKEY_CURRENT_USER, sKey, sValue, vOrigSetting, sType

Set objApp = Nothing
Set objSelection = Nothing
Set objItem = Nothing
End Sub
 
N

noone

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top