Hi,
Take a look at the open source project INDY.
http://www.nevrona.com/Indy/Indy.html
Ken
----------------------
"Lumpierbritches" <lumpierbritches@aol.com> wrote in message
news:20040427165343.20035.00000293@mb-m24.aol.com...[color=blue]
>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
>
>
>
>
>[/color]
