I have an application my partner wrote that would allow an autoresponse to any
Mapi compliant email that apparently in .Net won't, can someone assist me with
fixing this?
Here is the code:
Utilities Module:
Option Explicit
Option Base 1
Public StrSQL As String
Public objSession As MAPI.Session
Public objNewMessage As Message
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
Global Const HKEY_CURRENT_USER = &H80000001
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
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByRef
lpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As
Long
Public 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
Public 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
Public 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
Public 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
Public Function QueryValue(sKeyName As String, sValueName As String)
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim vValue As Variant 'setting of queried value
lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_ALL_ACCESS,
hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function
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
' Determine the size and type of data to be read
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If ' For DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function
Public Sub SendMail(Recip As String, Subj As String, Body As String)
Dim objOutBox As Folder
Dim objNewMessage As Message
Dim objRecipients As Recipients
Dim objOneRecip As Recipient
'StartMessagingAndLogon
objSession.Logon frmLogin.txtUserName, frmLogin.txtPassword, True, True
Set objOutBox = objSession.Outbox
Set objNewMessage = objOutBox.Messages.Add
Set objRecipients = objNewMessage.Recipients
Set objOneRecip = objRecipients.Add
objOneRecip = Recip
With objNewMessage
.Subject = Subj
.Text = Body
.Send
End With
End Sub
Sub StartMessagingAndLogon()
Dim sKeyName As String
Dim sValueName As String
Dim sDefaultUserProfile As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
On Error GoTo ErrorHandler
Set objSession = CreateObject("MAPI.Session")
'Try to logon. If this fails, the most likely reason is
'that you do not have an open session. The error
'-2147221231 MAPI_E_LOGON_FAILED will return. Trap
'the error in the ErrorHandler
objSession.Logon ShowDialog:=False, NewSession:=False
Exit Sub
ErrorHandler:
Select Case Err.Number
Case -2147221231 'MAPI_E_LOGON_FAILED
'Need to find out what OS is in use, the keys are different
'for WinNT and Win95.
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionEx(osinfo)
Select Case osinfo.dwPlatformId
Case 0 'Unidentified
MsgBox "Unidentified Operating System. Can't log onto
messaging."
Exit Sub
Case 1 'Win95
sKeyName = "Software\Microsoft\Windows Messaging
Subsystem\Profiles"
Case 2 'NT
sKeyName = "Software\Microsoft\Windows NT\CurrentVersion\Windows
Messaging Subsystem\Profiles"
End Select
sValueName = "DefaultProfile"
sDefaultUserProfile = QueryValue(sKeyName, sValueName)
objSession.Logon ProfileName:=sDefaultUserProfile, ShowDialog:=False
Exit Sub
Case Else
MsgBox "An error has occured while attempting" & Chr(10) & _
"To create and logon to a new ActiveMessage session." & _
Chr(10) & "Please report the following error to your " & _
"System Administrator." & Chr(10) & Chr(10) & _
"Error Location: frmMain.StartMessagingAndLogon" & _
Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
"Description: " & Err.Description
End Select
End Sub
Public Function CheckInbox(LastChecked As Date)
Dim objInbox As Folder
Dim objMessages As Messages
'Dim objMsgFilter As MessageFilter
Dim objOneMessage As Message
Dim MailBox(1 To 1000, 1 To 6) As Variant
Dim I As Integer
Dim X As Integer
Dim Y As Integer
Dim temp As String
X = 0
'StartMessagingAndLogon
objSession.Logon frmLogin.txtUserName, frmLogin.txtPassword, True, True
Set objInbox = objSession.Inbox
Set objMessages = objInbox.Messages
'Set objMsgFilter = objMessages.Filter
'objMsgFilter.Unread = False
For I = 1 To objMessages.Count
Set objOneMessage = objMessages.Item(I)
If objOneMessage.TimeReceived > LastChecked Then
X = X + 1
MailBox(X, 1) = X
For Y = 2 To 6
Select Case Y
Case 2
temp = objOneMessage.Sender
Case 3
temp = objOneMessage.Subject
Case 4
temp = objOneMessage.Text
Case 5
temp = objOneMessage.TimeReceived
Case 6
On Error Resume Next
If IsNull(objOneMessage.Recipients(1)) Then
temp = ""
Else
temp = objOneMessage.Recipients(1)
End If
On Error GoTo 0
End Select
MailBox(X, Y) = temp
Next Y
End If
Next I
CheckInbox = MailBox
Set objSession = Nothing
End Function
Public Function Resolver(Email As String) As String
Dim objOutBox As Folder
Dim objNewMessage As Message
Dim objRecipients As Recipients
Dim objOneRecip As Recipient
StartMessagingAndLogon
Set objOutBox = objSession.Outbox
Set objNewMessage = objOutBox.Messages.Add
Set objRecipients = objNewMessage.Recipients
Set objOneRecip = objRecipients.Add
With objOneRecip
'Fill in an appropriate alias here
.Name = Email
.Type = ActMsgTo
Resolver = .Resolve ' get MAPI to determine complete e-mail address
End With
Set objOutBox = Nothing
Set objNewMessage = Nothing
Set objRecipients = Nothing
Set objOneRecip = Nothing
End Function
Sub Respond(TimeChecked As Date)
Dim Arr As Variant
Dim Con As New ADODB.Connection
Dim RSEmails As New ADODB.Recordset
Dim RSCustomers As New ADODB.Recordset
Dim Addy As String
Dim temp As String
Dim I As Integer
Dim J As Integer
Dim X As Integer
Set Con = New ADODB.Connection
With Con
.ConnectionString = "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=" &
App.Path & "\ARBack.mdb;"
.Open
End With
RSEmails.Open "SELECT * FROM Outgoing", Con, adOpenForwardOnly,
adLockOptimistic, adCmdText
RSCustomers.Open "SELECT * FROM Customers", Con, adOpenDynamic,
adLockOptimistic, adCmdText
RSEmails.MoveFirst
Arr = CheckInbox(TimeChecked)
For I = 1 To UBound(Arr)
For J = 1 To 6
If Arr(I, J) = "" Then
Exit Sub
End If
Next J
'this is where we do the comparison
Do While Not RSEmails.EOF
Select Case RSEmails!qualifier
Case "sent from"
X = 2
Case "sent to"
X = 6
Case "with subject of"
X = 3
End Select
If InStr(0, Arr(I, 2), "@", vbBinaryCompare) = 0 Then
temp = Arr(I, 2)
Addy = Resolver(temp)
Else
Addy = Arr(I, 2)
End If
If Arr(I, X) = RSEmails!object Then
SendMail Addy, RSEmails!Subject, RSEmails!Body
RSCustomers.AddNew
RSCustomers![login ID] = frmLogin.txtUserName
RSCustomers!emailname = Addy
RSCustomers!Category = RSEmails!Category
RSCustomers!LetterSent = RSEmails!EmailID
RSCustomers.Update
End If
Loop
RSEmails.MoveFirst
Next I
End Sub
System Tray Module:
'user defined type required by Shell_NotifyIcon API call
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
'constants required by Shell_NotifyIcon API call:
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" _
Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public nid As NOTIFYICONDATA
There is Forms frmLogin, frmOutgoing1, frmUndercover, which is the start up
screen.
frmLogin Code:
Option Explicit
Dim MyCount As Integer
Public LoginSucceeded As Boolean
Private Sub cmdCancel_Click()
'set the global var to false
'to denote a failed login
LoginSucceeded = False
End
End Sub
Private Sub cmdOK_Click()
If MyCount <= 1 Then
MyCount = MyCount + 1
CheckPass
Else
MsgBox "You don't have an account or you are not using the correct
password. Good bye.", vbCritical
End
End If
End Sub
Private Sub CheckPass()
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim MyText As String
Set DB = DBEngine.OpenDatabase(App.Path & "\ARBack.mdb")
Set RS = DB.OpenRecordset("users", dbOpenDynaset)
RS.FindFirst "[Login ID] = '" & txtUserName & "'"
If RS.NoMatch Then
On Error Resume Next
MyText = InputBox("You are a new user. Please verify your Password, or
click cancel to exit.", "AutoResoponder Request for Information")
If MyText = "" Then
MsgBox "You must assign a password."
Exit Sub
Else
If MyText = txtPassword Then
RS.AddNew
RS("Login ID") = txtUserName
RS("Password") = MyText
RS.Update
Me.Hide
StrSQL = "SELECT * FROM Outgoing WHERE [Login ID] = '" &
Me("txtUserName") & "'"
MsgBox StrSQL
Load frmOutgoing1
frmOutgoing1("datPrimaryRS").RecordSource = StrSQL
frmUnderCover.Show
Exit Sub
End If
End If
Else
If RS("password") = txtPassword Then
Me.Hide
StrSQL = "SELECT * FROM Outgoing WHERE [Login ID] = '" &
Me("txtUserName") & "'"
'MsgBox StrSQL
Load frmOutgoing1
frmOutgoing1("datPrimaryRS").RecordSource = StrSQL
frmUnderCover.Show
Exit Sub
Else
MsgBox "You have entered an invalid password. Please try again.",
vbOKOnly, "Invalid Password"
txtPassword = ""
txtPassword.SetFocus
Exit Sub
End If
End If
End Sub
frmOutgoing1 Code:
Option Explicit
Dim AddRec As Boolean
Private Sub cboQualifier_Validate(Cancel As Boolean)
If Me("cboqualifier") = "Sent to" Or Me("cboqualifier") = "Sent from" Or
Me("cboqualifier") = "With subject of" Then
Cancel = False
Exit Sub
Else
MsgBox "You must enter an item from the list", vbCritical, "Validation
error"
Me!cboQualifier = "With subject of"
Cancel = True
End If
End Sub
Private Sub CmdClose_Click()
frmUnderCover.Show
Unload Me
End Sub
Private Sub cmdEdit_Click(Index As Integer)
UnlockAllControls
End Sub
'Private Sub cmdEdit_Click()
' UnlockAllControls
'End Sub
Private Sub Form_Load()
With Me("datPrimaryRS")
.ConnectionString = "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=" &
App.Path & "\ARBack.mdb;"
.RecordSource = StrSQL
End With
Me("datPrimaryRS").Refresh
If Not AddRec Then
LockAllControls
End If
AddRec = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
frmUnderCover.Show
Screen.MousePointer = vbDefault
End Sub
Private Sub datPrimaryRS_Error(ByVal ErrorNumber As Long, Description As
String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String,
ByVal HelpContext As Long, fCancelDisplay As Boolean)
'This is where you would put error handling code
'If you want to ignore errors, comment out the next line
'If you want to trap them, add code here to handle them
MsgBox "Data error event hit err:" & Description
End Sub
'Private Sub datPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum,
ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal
pRecordset As ADODB.Recordset)
' 'This will display the current record position for this recordset
' Dim ThisRec As String
' Dim LastRec As String
'
' ThisRec = CStr(datPrimaryRS.Recordset.AbsolutePosition)
'
' If Not datPrimaryRS.Recordset.EOF Then
'
' LastRec = CStr(datPrimaryRS.Recordset.RecordCount)
' Else
' ThisRec = 0
' LastRec = ThisRec
' End If
'
' datPrimaryRS.Caption = "
Outgoing Mail Record " & ThisRec & " of " & LastRec
'
' If AddRec Then
' UnlockAllControls
' Else
' LockAllControls
' End If
'
'End Sub
'Private Sub datPrimaryRS_WillChangeRecord(ByVal adReason As
ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As
ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
' 'This is where you put validation code
' 'This event gets called when the following actions occur
' Dim bCancel As Boolean
'
' Select Case adReason
' Case adRsnAddNew
' Case adRsnClose
' Case adRsnDelete
' Case adRsnFirstChange
' Case adRsnMove
' Case adRsnRequery
' Case adRsnResynch
' Case adRsnUndoAddNew
' Case adRsnUndoDelete
' Case adRsnUndoUpdate
' Case adRsnUpdate
' End Select
If bCancel Then adStatus = adStatusCancel
End Sub
Private Sub cmdAdd_Click()
On Error GoTo AddErr
UnlockAllControls
Me!LoginID = frmLogin!txtUserName
AddRec = True
datPrimaryRS.Recordset.AddNew
Me.txtFields(0).SetFocus
Exit Sub
AddErr:
MsgBox Err.Description
End Sub
Private Sub cmdDelete_Click()
On Error GoTo DeleteErr
With datPrimaryRS.Recordset
.Delete
.MoveNext
If .EOF Then .MoveLast
End With
Exit Sub
DeleteErr:
MsgBox Err.Description
End Sub
Private Sub cmdUpdate_Click()
On Error GoTo UpdateErr
Me.LoginID = frmLogin("txtUsername")
datPrimaryRS.Recordset.UpdateBatch adAffectAll
LockAllControls
Exit Sub
UpdateErr:
MsgBox Err.Description
End Sub
Private Sub UnlockAllControls()
Dim CTL As Control
For Each CTL In Me.Controls
If CTL.Tag = "Tan" Then
CTL.Enabled = True
End If
Next CTL
End Sub
Private Sub LockAllControls()
Dim CTL As Control
For Each CTL In Me.Controls
If CTL.Tag = "Tan" Then
CTL.Enabled = False
End If
Next CTL
End Sub
frmUnderCover Code:
Option Explicit
Dim Working As Boolean
Private Sub Form_Load()
Me!Image3.Picture = Me!Image1.Picture
Me!imgExit.Picture = Me!ExitUnclick.Picture
Me!imgStartService.Picture = Me!StartServiceUnclick.Picture
'the form must be fully visible before calling Shell_NotifyIcon
Me.Show
Me.Refresh
With nid
.cbSize = Len(nid)
.hwnd = Me.hwnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.szTip = "Autoresponder (tm)" & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, nid
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim Frm As Form
'this removes the icon from the system tray
Shell_NotifyIcon NIM_DELETE, nid
For Each Frm In Forms
Unload Frm
Next Frm
End
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y
As Single)
'this procedure receives the callbacks from the System Tray icon.
Dim Result As Long
Dim msg As Long
'the value of X will vary depending upon the scalemode setting
If Me.ScaleMode = vbPixels Then
msg = X
Else
msg = X / Screen.TwipsPerPixelX
End If
Select Case msg
Case WM_LBUTTONUP '514 restore form window
Me.WindowState = vbNormal
Result = SetForegroundWindow(Me.hwnd)
Me.Show
Case WM_LBUTTONDBLCLK '515 restore form window
Me.WindowState = vbNormal
Result = SetForegroundWindow(Me.hwnd)
Me.Show
Case WM_RBUTTONUP '517 display popup menu
Result = SetForegroundWindow(Me.hwnd)
Me.PopupMenu Me.mPopupSys
End Select
End Sub
Private Sub Form_Resize()
'this is necessary to assure that the minimized window is hidden
If Me.WindowState = vbMinimized Then Me.Hide
End Sub
Private Sub Image3_Click()
Load frmOutgoing1
Me.Hide
Working = False
frmOutgoing1.Show
End Sub
Private Sub Image3_MouseDown(Button As Integer, Shift As Integer, X As Single,
Y As Single)
Me!Image3.Picture = Me!Image2.Picture
End Sub
Private Sub Image3_MouseUp(Button As Integer, Shift As Integer, X As Single, Y
As Single)
Me!Image3.Picture = Me!Image1.Picture
End Sub
Private Sub imgExit_Click()
Unload Me
End Sub
Private Sub imgExit_MouseDown(Button As Integer, Shift As Integer, X As Single,
Y As Single)
Me!imgExit.Picture = Me!ExitClick.Picture
End Sub
Private Sub imgExit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y
As Single)
Me!imgExit.Picture = Me!ExitUnclick.Picture
End Sub
Private Sub imgStartService_Click()
StartLoop
Me.WindowState = 1
End Sub
Private Sub imgStartService_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Me!imgStartService.Picture = Me!StartServiceClick.Picture
End Sub
Private Sub imgStartService_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Me!imgStartService.Picture = Me!StartServiceUnclick.Picture
End Sub
Private Sub mPopExit_Click()
'called when user clicks the popup menu Exit command
Unload Me
End Sub
Private Sub mPopRestore_Click()
Dim Result As Long
'called when the user clicks the popup menu Restore command
Me.WindowState = vbNormal
Result = SetForegroundWindow(Me.hwnd)
Me.Show
End Sub
Private Sub StartLoop()
Dim DB As DAO.Database
Dim Sender As String
Dim RSUsers As DAO.Recordset
Dim RSOutgoing As DAO.Recordset
Dim RSCustomer As DAO.Recordset
Dim TempUser As String
Dim I As Integer
On Error GoTo ServiceHandler
Working = True
Set DB = DBEngine.OpenDatabase(App.Path & "\ARBack.mdb")
DoEvents
On Error GoTo 0
Set RSUsers = DB.OpenRecordset("Users", dbOpenSnapshot)
Set RSOutgoing = DB.OpenRecordset("SELECT * FROM outgoing WHERE [Login ID]
= '" & RSUsers("Login ID") & "'", dbOpenDynaset)
Set RSCustomer = DB.OpenRecordset("Customers", dbOpenDynaset)
If RSOutgoing.EOF Then
MsgBox "You have no outgoing messages entered. Please go back to the
main menu and select 'Add\Edit Emails'", vbInformation, "No Valid outgoing
messages"
imgStartService.Picture = Me.StartServiceUnclick.Picture
Exit Sub
End If
DoEvents
TempUser = RSUsers("Login ID")
Do While Not RSUsers.EOF
If TempUser <> RSUsers("Login ID") Then
GetSessID RSUsers("Login ID"), RSUsers("Password")
Set RSOutgoing = DB.OpenRecordset("SELECT * FROM outgoing WHERE
[Login ID] = '" & RSUsers("Login ID") & "'", dbOpenDynaset)
Me.MAPIMessages1.Fetch
End If
Do While I <= Me.MAPIMessages1.MsgCount - 1
If Me.MAPIMessages1.MsgCount = 0 Then
Exit Do
End If
Me.MAPIMessages1.MsgIndex = I
If CDate(Me.MAPIMessages1.MsgDateReceived) >
DB.Properties("lastchecked") Then
Do While Not RSOutgoing.EOF
If InStrRev(Me.MAPIMessages1.MsgOrigAddress, "=") = 0 And
Me.MAPIMessages1.MsgOrigAddress <> "" Then
Sender = Right(Me.MAPIMessages1.MsgOrigAddress,
Len(Me.MAPIMessages1.MsgOrigAddress) - 5)
Else
Sender = Right(Me.MAPIMessages1.MsgOrigAddress,
(Len(Me.MAPIMessages1.MsgOrigAddress) -
InStrRev(Me.MAPIMessages1.MsgOrigAddress, "=")))
End If
If RSOutgoing("Qualifier") = "sent from" And UCase(Sender)
= UCase(RSOutgoing("Object")) Then
SendMail RSOutgoing("subject"), RSOutgoing("Body"),
Sender
AddCustomer RSOutgoing("category"), Sender,
RSOutgoing("Email ID"), False
End If
If RSOutgoing("Qualifier") = "sent to" And
UCase(RSOutgoing("Login ID")) = UCase(Left(Me.MAPIMessages1.RecipAddress,
InStr(Me.MAPIMessages1.RecipAddress, "@"))) Then
SendMail RSOutgoing("subject"), RSOutgoing("Body"),
Sender
AddCustomer RSOutgoing("category"), Sender,
RSOutgoing("Email ID"), False
End If
If RSOutgoing("Qualifier") = "with subject of" And
UCase(Me.MAPIMessages1.MsgSubject) = UCase(RSOutgoing("object")) Then
If UCase(Me.MAPIMessages1.MsgSubject) <> "REMOVE" Then
SendMail RSOutgoing("subject"), RSOutgoing("Body"),
Sender
AddCustomer RSOutgoing("category"), Sender,
RSOutgoing("Email ID"), False
Else
AddCustomer RSOutgoing("category"), Sender,
RSOutgoing("email ID"), True
End If
End If
RSOutgoing.MoveNext
Loop
RSOutgoing.MoveFirst
End If
If I = Me.MAPIMessages1.MsgCount - 1 Then
Me.MAPIMessages1.MsgIndex = I
DB.Properties("LastChecked") = Me.MAPIMessages1.MsgDateReceived
End If
I = I + 1
DoEvents
Loop
TempUser = RSUsers("Login ID")
RSUsers.MoveNext
Loop
Set DB = Nothing
Set RSOutgoing = Nothing
Set RSCustomer = Nothing
DoEvents
Working = False
Exit Sub
ServiceHandler:
If Err.Number = 3270 Then
Dim Prop As DAO.Property
Set Prop = DB.CreateProperty("LastChecked", dbDate, Now(), True)
DB.Properties.Append Prop
Err.Clear
Resume Next
End If
If Err.Number = 32002 Then
Err.Clear
Exit Sub
End If
End Sub
Private Sub Timer1_Timer()
If Not Working Then
StartLoop
End If
End Sub
Private Sub AddCustomer(Category As String, Sender As String, LetterSent As
String, Remove As Boolean)
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Set DB = DBEngine.OpenDatabase(App.Path & "\ARBack.mdb")
Set RS = DB.OpenRecordset("Customers", dbOpenDynaset)
If Not Remove Then
RS.FindFirst "[Email Name] = '" & Sender & "'"
If RS.NoMatch Then
RS.AddNew
RS("Login ID") = frmLogin.txtUserName
RS("Email Name") = Sender
RS("Category") = Category
RS("letter Sent") = LetterSent
RS.Update
Else
RS.Edit
RS("letter sent") = LetterSent
RS.Update
End If
Else
RS.FindFirst "[Email Name] = '" & Sender & "'"
RS.Delete
End If
Set RS = Nothing
Set DB = Nothing
End Sub
Private Sub SendMail(Subject As String, Body As String, Sender As String)
Me.MAPIMessages1.Compose
Me.MAPIMessages1.MsgSubject = Subject
Me.MAPIMessages1.MsgNoteText = Body
Me.MAPIMessages1.RecipAddress = Sender
Me.MAPIMessages1.AddressResolveUI = True
Me.MAPIMessages1.ResolveName
Me.MAPIMessages1.Send False
End Sub
Private Sub GetSessID(uId As String, PWD As String)
On Error GoTo GetSesshandler
Me.MAPISession1.UserName = uId
Me.MAPISession1.Password = PWD
Me.MAPISession1.SignOn
Me.MAPIMessages1.SessionID = Me.MAPISession1.SessionID
Exit Sub
GetSesshandler:
If Err.Number = 32003 Then
MsgBox "You failed to enter a valid User ID and Password. You will now
be logged off. If you know the name of your mail server, you can set up a new
profile and password by clicking the 'New' button when prompted for a
password.", vbCritical, "Invalid UID and PWD"
Unload Me
End If
End Sub
If this can be done, the code is here for you to make your own Autoresponder,
but even in VB6, with all the Security updates it won't work now. I hope there
is a workaround?
Michael
3  2900 
Hi,
Take a look at the open source project INDY. http://www.nevrona.com/Indy/Indy.html
Ken
----------------------
"Lumpierbritches" <lu*************@aol.com> wrote in message
news:20***************************@mb-m24.aol.com... I have an application my partner wrote that would allow an autoresponse to
any
Mapi compliant email that apparently in .Net won't, can someone assist me
with
fixing this?
Here is the code:
Utilities Module:
Option Explicit
Option Base 1
Public StrSQL As String
Public objSession As MAPI.Session
Public objNewMessage As Message
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
Global Const HKEY_CURRENT_USER = &H80000001
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
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByRef
lpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As
Long) As
Long
Public 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
Public 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
Public 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
Public 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
Public Function QueryValue(sKeyName As String, sValueName As String)
Dim lRetVal As Long 'result of the API functions
Dim hKey As Long 'handle of opened key
Dim vValue As Variant 'setting of queried value
lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_ALL_ACCESS,
hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function
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
' Determine the size and type of data to be read
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue,
cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If ' For DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue,
cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'all other data types not supported
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function
Public Sub SendMail(Recip As String, Subj As String, Body As String)
Dim objOutBox As Folder
Dim objNewMessage As Message
Dim objRecipients As Recipients
Dim objOneRecip As Recipient
'StartMessagingAndLogon
objSession.Logon frmLogin.txtUserName, frmLogin.txtPassword, True, True
Set objOutBox = objSession.Outbox
Set objNewMessage = objOutBox.Messages.Add
Set objRecipients = objNewMessage.Recipients
Set objOneRecip = objRecipients.Add
objOneRecip = Recip
With objNewMessage
.Subject = Subj
.Text = Body
.Send
End With
End Sub
Sub StartMessagingAndLogon()
Dim sKeyName As String
Dim sValueName As String
Dim sDefaultUserProfile As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
On Error GoTo ErrorHandler
Set objSession = CreateObject("MAPI.Session")
'Try to logon. If this fails, the most likely reason is
'that you do not have an open session. The error
'-2147221231 MAPI_E_LOGON_FAILED will return. Trap
'the error in the ErrorHandler
objSession.Logon ShowDialog:=False, NewSession:=False
Exit Sub
ErrorHandler:
Select Case Err.Number
Case -2147221231 'MAPI_E_LOGON_FAILED
'Need to find out what OS is in use, the keys are different
'for WinNT and Win95.
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionEx(osinfo)
Select Case osinfo.dwPlatformId
Case 0 'Unidentified
MsgBox "Unidentified Operating System. Can't log onto
messaging."
Exit Sub
Case 1 'Win95
sKeyName = "Software\Microsoft\Windows Messaging
Subsystem\Profiles"
Case 2 'NT
sKeyName = "Software\Microsoft\Windows
NT\CurrentVersion\Windows
Messaging Subsystem\Profiles"
End Select
sValueName = "DefaultProfile"
sDefaultUserProfile = QueryValue(sKeyName, sValueName)
objSession.Logon ProfileName:=sDefaultUserProfile, ShowDialog:=False
Exit Sub
Case Else
MsgBox "An error has occured while attempting" & Chr(10) & _
"To create and logon to a new ActiveMessage session." & _
Chr(10) & "Please report the following error to your " & _
"System Administrator." & Chr(10) & Chr(10) & _
"Error Location: frmMain.StartMessagingAndLogon" & _
Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
"Description: " & Err.Description
End Select
End Sub
Public Function CheckInbox(LastChecked As Date)
Dim objInbox As Folder
Dim objMessages As Messages
'Dim objMsgFilter As MessageFilter
Dim objOneMessage As Message
Dim MailBox(1 To 1000, 1 To 6) As Variant
Dim I As Integer
Dim X As Integer
Dim Y As Integer
Dim temp As String
X = 0
'StartMessagingAndLogon
objSession.Logon frmLogin.txtUserName, frmLogin.txtPassword, True, True
Set objInbox = objSession.Inbox
Set objMessages = objInbox.Messages
'Set objMsgFilter = objMessages.Filter
'objMsgFilter.Unread = False
For I = 1 To objMessages.Count
Set objOneMessage = objMessages.Item(I)
If objOneMessage.TimeReceived > LastChecked Then
X = X + 1
MailBox(X, 1) = X
For Y = 2 To 6
Select Case Y
Case 2
temp = objOneMessage.Sender
Case 3
temp = objOneMessage.Subject
Case 4
temp = objOneMessage.Text
Case 5
temp = objOneMessage.TimeReceived
Case 6
On Error Resume Next
If IsNull(objOneMessage.Recipients(1)) Then
temp = ""
Else
temp = objOneMessage.Recipients(1)
End If
On Error GoTo 0
End Select
MailBox(X, Y) = temp
Next Y
End If
Next I
CheckInbox = MailBox
Set objSession = Nothing
End Function
Public Function Resolver(Email As String) As String
Dim objOutBox As Folder
Dim objNewMessage As Message
Dim objRecipients As Recipients
Dim objOneRecip As Recipient
StartMessagingAndLogon
Set objOutBox = objSession.Outbox
Set objNewMessage = objOutBox.Messages.Add
Set objRecipients = objNewMessage.Recipients
Set objOneRecip = objRecipients.Add
With objOneRecip
'Fill in an appropriate alias here
.Name = Email
.Type = ActMsgTo
Resolver = .Resolve ' get MAPI to determine complete e-mail address
End With
Set objOutBox = Nothing
Set objNewMessage = Nothing
Set objRecipients = Nothing
Set objOneRecip = Nothing
End Function
Sub Respond(TimeChecked As Date)
Dim Arr As Variant
Dim Con As New ADODB.Connection
Dim RSEmails As New ADODB.Recordset
Dim RSCustomers As New ADODB.Recordset
Dim Addy As String
Dim temp As String
Dim I As Integer
Dim J As Integer
Dim X As Integer
Set Con = New ADODB.Connection
With Con
.ConnectionString = "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data
Source=" &
App.Path & "\ARBack.mdb;"
.Open
End With
RSEmails.Open "SELECT * FROM Outgoing", Con, adOpenForwardOnly,
adLockOptimistic, adCmdText
RSCustomers.Open "SELECT * FROM Customers", Con, adOpenDynamic,
adLockOptimistic, adCmdText
RSEmails.MoveFirst
Arr = CheckInbox(TimeChecked)
For I = 1 To UBound(Arr)
For J = 1 To 6
If Arr(I, J) = "" Then
Exit Sub
End If
Next J
'this is where we do the comparison
Do While Not RSEmails.EOF
Select Case RSEmails!qualifier
Case "sent from"
X = 2
Case "sent to"
X = 6
Case "with subject of"
X = 3
End Select
If InStr(0, Arr(I, 2), "@", vbBinaryCompare) = 0 Then
temp = Arr(I, 2)
Addy = Resolver(temp)
Else
Addy = Arr(I, 2)
End If
If Arr(I, X) = RSEmails!object Then
SendMail Addy, RSEmails!Subject, RSEmails!Body
RSCustomers.AddNew
RSCustomers![login ID] = frmLogin.txtUserName
RSCustomers!emailname = Addy
RSCustomers!Category = RSEmails!Category
RSCustomers!LetterSent = RSEmails!EmailID
RSCustomers.Update
End If
Loop
RSEmails.MoveFirst
Next I
End Sub
System Tray Module:
'user defined type required by Shell_NotifyIcon API call
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
'constants required by Shell_NotifyIcon API call:
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click
Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" _
Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public nid As NOTIFYICONDATA
There is Forms frmLogin, frmOutgoing1, frmUndercover, which is the start
up
screen.
frmLogin Code:
Option Explicit
Dim MyCount As Integer
Public LoginSucceeded As Boolean
Private Sub cmdCancel_Click()
'set the global var to false
'to denote a failed login
LoginSucceeded = False
End
End Sub
Private Sub cmdOK_Click()
If MyCount <= 1 Then
MyCount = MyCount + 1
CheckPass
Else
MsgBox "You don't have an account or you are not using the correct
password. Good bye.", vbCritical
End
End If
End Sub
Private Sub CheckPass()
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim MyText As String
Set DB = DBEngine.OpenDatabase(App.Path & "\ARBack.mdb")
Set RS = DB.OpenRecordset("users", dbOpenDynaset)
RS.FindFirst "[Login ID] = '" & txtUserName & "'"
If RS.NoMatch Then
On Error Resume Next
MyText = InputBox("You are a new user. Please verify your
Password, or
click cancel to exit.", "AutoResoponder Request for Information")
If MyText = "" Then
MsgBox "You must assign a password."
Exit Sub
Else
If MyText = txtPassword Then
RS.AddNew
RS("Login ID") = txtUserName
RS("Password") = MyText
RS.Update
Me.Hide
StrSQL = "SELECT * FROM Outgoing WHERE [Login ID] = '" &
Me("txtUserName") & "'"
MsgBox StrSQL
Load frmOutgoing1
frmOutgoing1("datPrimaryRS").RecordSource = StrSQL
frmUnderCover.Show
Exit Sub
End If
End If
Else
If RS("password") = txtPassword Then
Me.Hide
StrSQL = "SELECT * FROM Outgoing WHERE [Login ID] = '" &
Me("txtUserName") & "'"
'MsgBox StrSQL
Load frmOutgoing1
frmOutgoing1("datPrimaryRS").RecordSource = StrSQL
frmUnderCover.Show
Exit Sub
Else
MsgBox "You have entered an invalid password. Please try
again.",
vbOKOnly, "Invalid Password"
txtPassword = ""
txtPassword.SetFocus
Exit Sub
End If
End If
End Sub
frmOutgoing1 Code:
Option Explicit
Dim AddRec As Boolean
Private Sub cboQualifier_Validate(Cancel As Boolean)
If Me("cboqualifier") = "Sent to" Or Me("cboqualifier") = "Sent from"
Or
Me("cboqualifier") = "With subject of" Then
Cancel = False
Exit Sub
Else
MsgBox "You must enter an item from the list", vbCritical,
"Validation
error"
Me!cboQualifier = "With subject of"
Cancel = True
End If
End Sub
Private Sub CmdClose_Click()
frmUnderCover.Show
Unload Me
End Sub
Private Sub cmdEdit_Click(Index As Integer)
UnlockAllControls
End Sub
'Private Sub cmdEdit_Click()
' UnlockAllControls
'End Sub
Private Sub Form_Load()
With Me("datPrimaryRS")
.ConnectionString = "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source="
&
App.Path & "\ARBack.mdb;"
.RecordSource = StrSQL
End With
Me("datPrimaryRS").Refresh
If Not AddRec Then
LockAllControls
End If
AddRec = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
frmUnderCover.Show
Screen.MousePointer = vbDefault
End Sub
Private Sub datPrimaryRS_Error(ByVal ErrorNumber As Long, Description As
String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As
String,
ByVal HelpContext As Long, fCancelDisplay As Boolean)
'This is where you would put error handling code
'If you want to ignore errors, comment out the next line
'If you want to trap them, add code here to handle them
MsgBox "Data error event hit err:" & Description
End Sub
'Private Sub datPrimaryRS_MoveComplete(ByVal adReason As
ADODB.EventReasonEnum,
ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal
pRecordset As ADODB.Recordset)
' 'This will display the current record position for this recordset
' Dim ThisRec As String
' Dim LastRec As String
'
' ThisRec = CStr(datPrimaryRS.Recordset.AbsolutePosition)
'
' If Not datPrimaryRS.Recordset.EOF Then
'
' LastRec = CStr(datPrimaryRS.Recordset.RecordCount)
' Else
' ThisRec = 0
' LastRec = ThisRec
' End If
'
' datPrimaryRS.Caption = "
Outgoing Mail Record " & ThisRec & " of " &
LastRec
'
' If AddRec Then
' UnlockAllControls
' Else
' LockAllControls
' End If
'
'End Sub
'Private Sub datPrimaryRS_WillChangeRecord(ByVal adReason As
ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As
ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
' 'This is where you put validation code
' 'This event gets called when the following actions occur
' Dim bCancel As Boolean
'
' Select Case adReason
' Case adRsnAddNew
' Case adRsnClose
' Case adRsnDelete
' Case adRsnFirstChange
' Case adRsnMove
' Case adRsnRequery
' Case adRsnResynch
' Case adRsnUndoAddNew
' Case adRsnUndoDelete
' Case adRsnUndoUpdate
' Case adRsnUpdate
' End Select
If bCancel Then adStatus = adStatusCancel
End Sub
Private Sub cmdAdd_Click()
On Error GoTo AddErr
UnlockAllControls
Me!LoginID = frmLogin!txtUserName
AddRec = True
datPrimaryRS.Recordset.AddNew
Me.txtFields(0).SetFocus
Exit Sub
AddErr:
MsgBox Err.Description
End Sub
Private Sub cmdDelete_Click()
On Error GoTo DeleteErr
With datPrimaryRS.Recordset
.Delete
.MoveNext
If .EOF Then .MoveLast
End With
Exit Sub
DeleteErr:
MsgBox Err.Description
End Sub
Private Sub cmdUpdate_Click()
On Error GoTo UpdateErr
Me.LoginID = frmLogin("txtUsername")
datPrimaryRS.Recordset.UpdateBatch adAffectAll
LockAllControls
Exit Sub
UpdateErr:
MsgBox Err.Description
End Sub
Private Sub UnlockAllControls()
Dim CTL As Control
For Each CTL In Me.Controls
If CTL.Tag = "Tan" Then
CTL.Enabled = True
End If
Next CTL
End Sub
Private Sub LockAllControls()
Dim CTL As Control
For Each CTL In Me.Controls
If CTL.Tag = "Tan" Then
CTL.Enabled = False
End If
Next CTL
End Sub
frmUnderCover Code:
Option Explicit
Dim Working As Boolean
Private Sub Form_Load()
Me!Image3.Picture = Me!Image1.Picture
Me!imgExit.Picture = Me!ExitUnclick.Picture
Me!imgStartService.Picture = Me!StartServiceUnclick.Picture
'the form must be fully visible before calling Shell_NotifyIcon
Me.Show
Me.Refresh
With nid
.cbSize = Len(nid)
.hwnd = Me.hwnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.szTip = "Autoresponder (tm)" & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, nid
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim Frm As Form
'this removes the icon from the system tray
Shell_NotifyIcon NIM_DELETE, nid
For Each Frm In Forms
Unload Frm
Next Frm
End
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As
Single, Y
As Single)
'this procedure receives the callbacks from the System Tray icon.
Dim Result As Long
Dim msg As Long
'the value of X will vary depending upon the scalemode setting
If Me.ScaleMode = vbPixels Then
msg = X
Else
msg = X / Screen.TwipsPerPixelX
End If
Select Case msg
Case WM_LBUTTONUP '514 restore form window
Me.WindowState = vbNormal
Result = SetForegroundWindow(Me.hwnd)
Me.Show
Case WM_LBUTTONDBLCLK '515 restore form window
Me.WindowState = vbNormal
Result = SetForegroundWindow(Me.hwnd)
Me.Show
Case WM_RBUTTONUP '517 display popup menu
Result = SetForegroundWindow(Me.hwnd)
Me.PopupMenu Me.mPopupSys
End Select
End Sub
Private Sub Form_Resize()
'this is necessary to assure that the minimized window is hidden
If Me.WindowState = vbMinimized Then Me.Hide
End Sub
Private Sub Image3_Click()
Load frmOutgoing1
Me.Hide
Working = False
frmOutgoing1.Show
End Sub
Private Sub Image3_MouseDown(Button As Integer, Shift As Integer, X As
Single,
Y As Single)
Me!Image3.Picture = Me!Image2.Picture
End Sub
Private Sub Image3_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y
As Single)
Me!Image3.Picture = Me!Image1.Picture
End Sub
Private Sub imgExit_Click()
Unload Me
End Sub
Private Sub imgExit_MouseDown(Button As Integer, Shift As Integer, X As
Single,
Y As Single)
Me!imgExit.Picture = Me!ExitClick.Picture
End Sub
Private Sub imgExit_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y
As Single)
Me!imgExit.Picture = Me!ExitUnclick.Picture
End Sub
Private Sub imgStartService_Click()
StartLoop
Me.WindowState = 1
End Sub
Private Sub imgStartService_MouseDown(Button As Integer, Shift As Integer,
X As
Single, Y As Single)
Me!imgStartService.Picture = Me!StartServiceClick.Picture
End Sub
Private Sub imgStartService_MouseUp(Button As Integer, Shift As Integer, X
As
Single, Y As Single)
Me!imgStartService.Picture = Me!StartServiceUnclick.Picture
End Sub
Private Sub mPopExit_Click()
'called when user clicks the popup menu Exit command
Unload Me
End Sub
Private Sub mPopRestore_Click()
Dim Result As Long
'called when the user clicks the popup menu Restore command
Me.WindowState = vbNormal
Result = SetForegroundWindow(Me.hwnd)
Me.Show
End Sub
Private Sub StartLoop()
Dim DB As DAO.Database
Dim Sender As String
Dim RSUsers As DAO.Recordset
Dim RSOutgoing As DAO.Recordset
Dim RSCustomer As DAO.Recordset
Dim TempUser As String
Dim I As Integer
On Error GoTo ServiceHandler
Working = True
Set DB = DBEngine.OpenDatabase(App.Path & "\ARBack.mdb")
DoEvents
On Error GoTo 0
Set RSUsers = DB.OpenRecordset("Users", dbOpenSnapshot)
Set RSOutgoing = DB.OpenRecordset("SELECT * FROM outgoing WHERE [Login
ID]
= '" & RSUsers("Login ID") & "'", dbOpenDynaset)
Set RSCustomer = DB.OpenRecordset("Customers", dbOpenDynaset)
If RSOutgoing.EOF Then
MsgBox "You have no outgoing messages entered. Please go back to
the
main menu and select 'Add\Edit Emails'", vbInformation, "No Valid outgoing
messages"
imgStartService.Picture = Me.StartServiceUnclick.Picture
Exit Sub
End If
DoEvents
TempUser = RSUsers("Login ID")
Do While Not RSUsers.EOF
If TempUser <> RSUsers("Login ID") Then
GetSessID RSUsers("Login ID"), RSUsers("Password")
Set RSOutgoing = DB.OpenRecordset("SELECT * FROM outgoing WHERE
[Login ID] = '" & RSUsers("Login ID") & "'", dbOpenDynaset)
Me.MAPIMessages1.Fetch
End If
Do While I <= Me.MAPIMessages1.MsgCount - 1
If Me.MAPIMessages1.MsgCount = 0 Then
Exit Do
End If
Me.MAPIMessages1.MsgIndex = I
If CDate(Me.MAPIMessages1.MsgDateReceived) >
DB.Properties("lastchecked") Then
Do While Not RSOutgoing.EOF
If InStrRev(Me.MAPIMessages1.MsgOrigAddress, "=") = 0
And
Me.MAPIMessages1.MsgOrigAddress <> "" Then
Sender = Right(Me.MAPIMessages1.MsgOrigAddress,
Len(Me.MAPIMessages1.MsgOrigAddress) - 5)
Else
Sender = Right(Me.MAPIMessages1.MsgOrigAddress,
(Len(Me.MAPIMessages1.MsgOrigAddress) -
InStrRev(Me.MAPIMessages1.MsgOrigAddress, "=")))
End If
If RSOutgoing("Qualifier") = "sent from" And
UCase(Sender)
= UCase(RSOutgoing("Object")) Then
SendMail RSOutgoing("subject"), RSOutgoing("Body"),
Sender
AddCustomer RSOutgoing("category"), Sender,
RSOutgoing("Email ID"), False
End If
If RSOutgoing("Qualifier") = "sent to" And
UCase(RSOutgoing("Login ID")) = UCase(Left(Me.MAPIMessages1.RecipAddress,
InStr(Me.MAPIMessages1.RecipAddress, "@"))) Then
SendMail RSOutgoing("subject"), RSOutgoing("Body"),
Sender
AddCustomer RSOutgoing("category"), Sender,
RSOutgoing("Email ID"), False
End If
If RSOutgoing("Qualifier") = "with subject of" And
UCase(Me.MAPIMessages1.MsgSubject) = UCase(RSOutgoing("object")) Then
If UCase(Me.MAPIMessages1.MsgSubject) <> "REMOVE"
Then
SendMail RSOutgoing("subject"),
RSOutgoing("Body"),
Sender
AddCustomer RSOutgoing("category"), Sender,
RSOutgoing("Email ID"), False
Else
AddCustomer RSOutgoing("category"), Sender,
RSOutgoing("email ID"), True
End If
End If
RSOutgoing.MoveNext
Loop
RSOutgoing.MoveFirst
End If
If I = Me.MAPIMessages1.MsgCount - 1 Then
Me.MAPIMessages1.MsgIndex = I
DB.Properties("LastChecked") =
Me.MAPIMessages1.MsgDateReceived
End If
I = I + 1
DoEvents
Loop
TempUser = RSUsers("Login ID")
RSUsers.MoveNext
Loop
Set DB = Nothing
Set RSOutgoing = Nothing
Set RSCustomer = Nothing
DoEvents
Working = False
Exit Sub
ServiceHandler:
If Err.Number = 3270 Then
Dim Prop As DAO.Property
Set Prop = DB.CreateProperty("LastChecked", dbDate, Now(), True)
DB.Properties.Append Prop
Err.Clear
Resume Next
End If
If Err.Number = 32002 Then
Err.Clear
Exit Sub
End If
End Sub
Private Sub Timer1_Timer()
If Not Working Then
StartLoop
End If
End Sub
Private Sub AddCustomer(Category As String, Sender As String, LetterSent
As
String, Remove As Boolean)
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Set DB = DBEngine.OpenDatabase(App.Path & "\ARBack.mdb")
Set RS = DB.OpenRecordset("Customers", dbOpenDynaset)
If Not Remove Then
RS.FindFirst "[Email Name] = '" & Sender & "'"
If RS.NoMatch Then
RS.AddNew
RS("Login ID") = frmLogin.txtUserName
RS("Email Name") = Sender
RS("Category") = Category
RS("letter Sent") = LetterSent
RS.Update
Else
RS.Edit
RS("letter sent") = LetterSent
RS.Update
End If
Else
RS.FindFirst "[Email Name] = '" & Sender & "'"
RS.Delete
End If
Set RS = Nothing
Set DB = Nothing
End Sub
Private Sub SendMail(Subject As String, Body As String, Sender As String)
Me.MAPIMessages1.Compose
Me.MAPIMessages1.MsgSubject = Subject
Me.MAPIMessages1.MsgNoteText = Body
Me.MAPIMessages1.RecipAddress = Sender
Me.MAPIMessages1.AddressResolveUI = True
Me.MAPIMessages1.ResolveName
Me.MAPIMessages1.Send False
End Sub
Private Sub GetSessID(uId As String, PWD As String)
On Error GoTo GetSesshandler
Me.MAPISession1.UserName = uId
Me.MAPISession1.Password = PWD
Me.MAPISession1.SignOn
Me.MAPIMessages1.SessionID = Me.MAPISession1.SessionID
Exit Sub
GetSesshandler:
If Err.Number = 32003 Then
MsgBox "You failed to enter a valid User ID and Password. You will
now
be logged off. If you know the name of your mail server, you can set up a
new
profile and password by clicking the 'New' button when prompted for a
password.", vbCritical, "Invalid UID and PWD"
Unload Me
End If
End Sub
If this can be done, the code is here for you to make your own
Autoresponder,
but even in VB6, with all the Security updates it won't work now. I hope
there
is a workaround?
Michael
On Tue, 27 Apr 2004 17:32:18 -0400, Ken Tucker [MVP] wrote: Hi,
Take a look at the open source project INDY.
http://www.nevrona.com/Indy/Indy.html
Ken
----------------------
"Lumpierbritches" <lu*************@aol.com> wrote in message
news:20***************************@mb-m24.aol.com...
[snip]
Ken, did you really have to include the OP's entire 1000+ line post in
your 6-line reply?
--
auric "underscore" "underscore" "at" hotmail "dot" com
*****
You can't exchange pleasantries with an attractive woman and feel
entirely like a stranger.
-- Isaac Asimov (Prelude to Foundation)
Hi,
Sorry forgot to delete it.
Ken
--------------
"Auric__" <no*********@email.address> wrote in message
news:kl********************************@4ax.com... On Tue, 27 Apr 2004 17:32:18 -0400, Ken Tucker [MVP] wrote:
Hi,
Take a look at the open source project INDY.
http://www.nevrona.com/Indy/Indy.html
Ken
----------------------
"Lumpierbritches" <lu*************@aol.com> wrote in message
news:20***************************@mb-m24.aol.com...
[snip]
Ken, did you really have to include the OP's entire 1000+ line post in
your 6-line reply?
--
auric "underscore" "underscore" "at" hotmail "dot" com
*****
You can't exchange pleasantries with an attractive woman and feel
entirely like a stranger.
-- Isaac Asimov (Prelude to Foundation) This thread has been closed and replies have been disabled. Please start a new discussion. Similar topics
by: Paddy McCarthy |
last post by:
Frustrated at being prevented from using Python at work I went
gunning for Perl.
Time to roll out some useless Google statistics to make me feel
better
Google Phrase count...
|
by: mountain man |
last post by:
Greetings to all database professionals and laymen,
Let us make a bold assumption that we have developed a software
tool for the SQL Server environment which simply acts as an interface
between...
|
by: abcd |
last post by:
I have an asp based web applicaiton and that is targeted to be used by
intranet users say 10-500 or may be more. Currently, I have prototyped my
Web application using MS Access as my backend. Can...
|
by: Mike Owen |
last post by:
Hi,
I have just used the import Wizard to import a VS 2003 app to VS 2005.
I have a lot of work to do to enable it to compile successfully with all the
errors and warnings it gave me, but as a...
|
by: sac |
last post by:
I am using DB2 v8.1 on UNIX.
A few weeks ago the DBAs carried out node migration activity on the
database.
After the node migration I observed that the queries that execute on
temporary tables...
|
by: Carl |
last post by:
Help!!
What are the best concepts / startegies to deploy an ASP.NET web
application? My idea is work first in Production PC then after completing
the project deploy it on the Web Server. But...
|
by: Ritesh |
last post by:
Hi All,
It will be great if any one of you can suggest which strategy to take
for porting an Asp application to Asp.Net.
Just to give you an idea about the present architecture of the...
|
by: pjdouillard |
last post by:
Hello all,
Here is the context of my problem:
We have an ASP.NET 1.1 application that has its own application pool
setup and that runs under the identity of a NT Domain service account
(this...
|
by: mustapha.jouad |
last post by:
j ai une tache dont le theme est la migration de C#1.1 vers C#2.0.
Ma question consiste surthout sur la strategie la methodologie,et meme
les etapes de la migrations en generale, et dans un cas...
|
by: miles.jg |
last post by:
Have a application (custom written for a vetical market) which has been
developed in VB over the last several years. Now that MS has done what MS
does best and is to relegated VB to the twilight...
|
by: Charles Arthur |
last post by:
How do i turn on java script on a villaon, callus and itel keypad mobile phone
|
by: BarryA |
last post by:
What are the essential steps and strategies outlined in the Data Structures and Algorithms (DSA) roadmap for aspiring data scientists? How can individuals effectively utilize this roadmap to progress...
|
by: nemocccc |
last post by:
hello, everyone, I want to develop a software for my android phone for daily needs, any suggestions?
|
by: Sonnysonu |
last post by:
This is the data of csv file
1 2 3
1 2 3
1 2 3
1 2 3
2 3
2 3
3
the lengths should be different i have to store the data by column-wise with in the specific length.
suppose the i have to...
|
by: Hystou |
last post by:
Most computers default to English, but sometimes we require a different language, especially when relocating. Forgot to request a specific language before your computer shipped? No problem! You can...
|
by: Oralloy |
last post by:
Hello folks,
I am unable to find appropriate documentation on the type promotion of bit-fields when using the generalised comparison operator "<=>".
The problem is that using the GNU compilers,...
|
by: Hystou |
last post by:
Overview:
Windows 11 and 10 have less user interface control over operating system update behaviour than previous versions of Windows. In Windows 11 and 10, there is no way to turn off the Windows...
|
by: tracyyun |
last post by:
Dear forum friends,
With the development of smart home technology, a variety of wireless communication protocols have appeared on the market, such as Zigbee, Z-Wave, Wi-Fi, Bluetooth, etc. Each...
|
by: agi2029 |
last post by:
Let's talk about the concept of autonomous AI software engineers and no-code agents. These AIs are designed to manage the entire lifecycle of a software development project—planning, coding, testing,...
| |
