Private Const HKEY_CURRENT_USER = &H80000001
Private Const REG_SZ = 1
Private Const REG_DWORD = 4
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Sub ActiverComptesPerso()
Dim LcBuffer As String
Dim hKey As Long
Dim hSousKey As Long
Dim LcKeyIndex As Long
Dim LcResult As Long
Dim LcValueType As Long
Dim LcDataBufferSize As Long
LcKeyIndex = 0
RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Office\Outlook\OMI Account Manager\Accounts", hKey
Do
'Create a buffer
LcBuffer = String(255, 0)
'Enumerate the keys
If RegEnumKeyEx(hKey, LcKeyIndex, LcBuffer, 255, 0, vbNullString, ByVal 0&, ByVal 0& ) <> 0 Then Exit Do
'Open a new key
RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Office\Outlook\OMI Account Manager\Accounts\" & LcBuffer, hSousKey
'est-ce un compte perso ?
'retrieve information about the key
LcResult = RegQueryValueEx(hSousKey, "SMTP Email Address", 0, LcValueType, ByVal 0, LcDataBufferSize)
If LcResult = 0 Then
'Create a buffer
LcBuffer = String(LcDataBufferSize, Chr$(0))
'retrieve the key's content
LcResult = RegQueryValueEx(hSousKey, "SMTP Email Address", 0, 0, ByVal LcBuffer, LcDataBufferSize)
If Len(LcBuffer) > 1 Then LcBuffer = Left(LcBuffer, Len(LcBuffer) - 1)
If InStr("adr1,adr2,...", LcBuffer) > 0 Then
'activer le compte
LcResult = RegSetValueEx(hSousKey, "POP3 Skip Account", 0, REG_DWORD, CLng(0), 4)
End If
End If
'Close the registry
RegCloseKey hSousKey
LcKeyIndex = LcKeyIndex + 1
Loop
'Close the registry key
RegCloseKey hKey
MsgBox "Activés ! Il faut relancer Outlook"
End Sub
Public Sub DesactiverComptesPerso()
Dim LcBuffer As String
Dim hKey As Long
Dim hSousKey As Long
Dim LcKeyIndex As Long
Dim LcResult As Long
Dim LcValueType As Long
Dim LcDataBufferSize As Long
LcKeyIndex = 0
RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Office\Outlook\OMI Account Manager\Accounts", hKey
Do
'Create a buffer
LcBuffer = String(255, 0)
'Enumerate the keys
If RegEnumKeyEx(hKey, LcKeyIndex, LcBuffer, 255, 0, vbNullString, ByVal 0&, ByVal 0& ) <> 0 Then Exit Do
'Open a new key
RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Office\Outlook\OMI Account Manager\Accounts\" & LcBuffer, hSousKey
'est-ce un compte perso ?
'retrieve information about the key
LcResult = RegQueryValueEx(hSousKey, "SMTP Email Address", 0, LcValueType, ByVal 0, LcDataBufferSize)
If LcResult = 0 Then
'Create a buffer
LcBuffer = String(LcDataBufferSize, Chr$(0))
'retrieve the key's content
LcResult = RegQueryValueEx(hSousKey, "SMTP Email Address", 0, 0, ByVal LcBuffer, LcDataBufferSize)
If Len(LcBuffer) > 1 Then LcBuffer = Left(LcBuffer, Len(LcBuffer) - 1)
If InStr("adr1,adr2,...", LcBuffer) > 0 Then
'désactiver le compte
LcResult = RegSetValueEx(hSousKey, "POP3 Skip Account", 0, REG_DWORD, CLng(1), 4)
End If
End If
'Close the registry
RegCloseKey hSousKey
LcKeyIndex = LcKeyIndex + 1
Loop
'Close the registry key
RegCloseKey hKey
MsgBox "Desactivés ! Il faut relancer Outlook"
End Sub
voilà, faut relancer Outlook après
