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
dwOSVersionInfo Size 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_US ER = &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_OUTOFMEMO RY = 6
Global Const ERROR_INVALID_P ARAMETER = 7
Global Const ERROR_ACCESS_DE NIED = 8
Global Const ERROR_INVALID_P ARAMETERS = 87
Global Const ERROR_NO_MORE_I TEMS = 259
Global Const KEY_ALL_ACCESS = &H3F
Global Const REG_OPTION_NON_ VOLATILE = 0
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersion ExA" (ByRef
lpVersionInform ation As OSVERSIONINFO) As Long
Public Declare Function RegCloseKey Lib "advapi32.d ll" (ByVal hKey As Long) As
Long
Public Declare Function RegOpenKeyEx Lib "advapi32.d ll" Alias "RegOpenKey ExA"
(ByVal hKey As Long, _
ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As
Long, phkResult As Long) As Long
Public Declare Function RegQueryValueEx String Lib "advapi32.d ll" Alias
"RegQueryValueE xA" (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 RegQueryValueEx Long Lib "advapi32.d ll" Alias
"RegQueryValueE xA" (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 RegQueryValueEx NULL Lib "advapi32.d ll" Alias
"RegQueryValueE xA" (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(sKey Name 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(HK EY_CURRENT_USER , sKeyName, 0, KEY_ALL_ACCESS,
hKey)
lRetVal = QueryValueEx(hK ey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function
Function QueryValueEx(By Val 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 QueryValueExErr or
' Determine the size and type of data to be read
lrc = RegQueryValueEx NULL(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 = RegQueryValueEx String(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 = RegQueryValueEx Long(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
QueryValueExExi t:
QueryValueEx = lrc
Exit Function
QueryValueExErr or:
Resume QueryValueExExi t
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
'StartMessaging AndLogon
objSession.Logo n frmLogin.txtUse rName, frmLogin.txtPas sword, True, True
Set objOutBox = objSession.Outb ox
Set objNewMessage = objOutBox.Messa ges.Add
Set objRecipients = objNewMessage.R ecipients
Set objOneRecip = objRecipients.A dd
objOneRecip = Recip
With objNewMessage
.Subject = Subj
.Text = Body
.Send
End With
End Sub
Sub StartMessagingA ndLogon()
Dim sKeyName As String
Dim sValueName As String
Dim sDefaultUserPro file As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
On Error GoTo ErrorHandler
Set objSession = CreateObject("M API.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_FA ILED will return. Trap
'the error in the ErrorHandler
objSession.Logo n ShowDialog:=Fal se, NewSession:=Fal se
Exit Sub
ErrorHandler:
Select Case Err.Number
Case -2147221231 'MAPI_E_LOGON_F AILED
'Need to find out what OS is in use, the keys are different
'for WinNT and Win95.
osinfo.dwOSVers ionInfoSize = 148
osinfo.szCSDVer sion = Space$(128)
retvalue = GetVersionEx(os info)
Select Case osinfo.dwPlatfo rmId
Case 0 'Unidentified
MsgBox "Unidentifi ed Operating System. Can't log onto
messaging."
Exit Sub
Case 1 'Win95
sKeyName = "Software\Micro soft\Windows Messaging
Subsystem\Profi les"
Case 2 'NT
sKeyName = "Software\Micro soft\Windows NT\CurrentVersi on\Windows
Messaging Subsystem\Profi les"
End Select
sValueName = "DefaultProfile "
sDefaultUserPro file = QueryValue(sKey Name, sValueName)
objSession.Logo n ProfileName:=sD efaultUserProfi le, ShowDialog:=Fal se
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.StartMe ssagingAndLogon " & _
Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
"Descriptio n: " & Err.Description
End Select
End Sub
Public Function CheckInbox(Last Checked 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
'StartMessaging AndLogon
objSession.Logo n frmLogin.txtUse rName, frmLogin.txtPas sword, True, True
Set objInbox = objSession.Inbo x
Set objMessages = objInbox.Messag es
'Set objMsgFilter = objMessages.Fil ter
'objMsgFilter.U nread = False
For I = 1 To objMessages.Cou nt
Set objOneMessage = objMessages.Ite m(I)
If objOneMessage.T imeReceived > LastChecked Then
X = X + 1
MailBox(X, 1) = X
For Y = 2 To 6
Select Case Y
Case 2
temp = objOneMessage.S ender
Case 3
temp = objOneMessage.S ubject
Case 4
temp = objOneMessage.T ext
Case 5
temp = objOneMessage.T imeReceived
Case 6
On Error Resume Next
If IsNull(objOneMe ssage.Recipient s(1)) Then
temp = ""
Else
temp = objOneMessage.R ecipients(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
StartMessagingA ndLogon
Set objOutBox = objSession.Outb ox
Set objNewMessage = objOutBox.Messa ges.Add
Set objRecipients = objNewMessage.R ecipients
Set objOneRecip = objRecipients.A dd
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(TimeChe cked As Date)
Dim Arr As Variant
Dim Con As New ADODB.Connectio n
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.Connectio n
With Con
.ConnectionStri ng = "PROVIDER=Micro soft.Jet.OLEDB. 3.51;Data Source=" &
App.Path & "\ARBack.md b;"
.Open
End With
RSEmails.Open "SELECT * FROM Outgoing", Con, adOpenForwardOn ly,
adLockOptimisti c, adCmdText
RSCustomers.Ope n "SELECT * FROM Customers", Con, adOpenDynamic,
adLockOptimisti c, adCmdText
RSEmails.MoveFi rst
Arr = CheckInbox(Time Checked)
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!qualif ier
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!Subjec t, RSEmails!Body
RSCustomers.Add New
RSCustomers![login ID] = frmLogin.txtUse rName
RSCustomers!ema ilname = Addy
RSCustomers!Cat egory = RSEmails!Catego ry
RSCustomers!Let terSent = RSEmails!EmailI D
RSCustomers.Upd ate
End If
Loop
RSEmails.MoveFi rst
Next I
End Sub
System Tray Module:
'user defined type required by Shell_NotifyIco n API call
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessag e As Long
hIcon As Long
szTip As String * 64
End Type
'constants required by Shell_NotifyIco n 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_LBUTTONDBLCL K = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCL K = &H206 'Double-click
Public Declare Function SetForegroundWi ndow Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIco n Lib "shell32" _
Alias "Shell_NotifyIc onA" _
(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.OpenDa tabase(App.Path & "\ARBack.md b")
Set RS = DB.OpenRecordse t("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.", "AutoResopo nder 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("d atPrimaryRS").R ecordSource = StrSQL
frmUnderCover.S how
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("d atPrimaryRS").R ecordSource = StrSQL
frmUnderCover.S how
Exit Sub
Else
MsgBox "You have entered an invalid password. Please try again.",
vbOKOnly, "Invalid Password"
txtPassword = ""
txtPassword.Set Focus
Exit Sub
End If
End If
End Sub
frmOutgoing1 Code:
Option Explicit
Dim AddRec As Boolean
Private Sub cboQualifier_Va lidate(Cancel As Boolean)
If Me("cboqualifie r") = "Sent to" Or Me("cboqualifie r") = "Sent from" Or
Me("cboqualifie r") = "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.S how
Unload Me
End Sub
Private Sub cmdEdit_Click(I ndex As Integer)
UnlockAllContro ls
End Sub
'Private Sub cmdEdit_Click()
' UnlockAllContro ls
'End Sub
Private Sub Form_Load()
With Me("datPrimaryR S")
.ConnectionStri ng = "PROVIDER=Micro soft.Jet.OLEDB. 3.51;Data Source=" &
App.Path & "\ARBack.md b;"
.RecordSource = StrSQL
End With
Me("datPrimaryR S").Refresh
If Not AddRec Then
LockAllControls
End If
AddRec = False
End Sub
Private Sub Form_Unload(Can cel As Integer)
frmUnderCover.S how
Screen.MousePoi nter = vbDefault
End Sub
Private Sub datPrimaryRS_Er ror(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_Mo veComplete(ByVa l adReason As ADODB.EventReas onEnum,
ByVal pError As ADODB.Error, adStatus As ADODB.EventStat usEnum, 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(datPrimary RS.Recordset.Ab solutePosition)
'
' If Not datPrimaryRS.Re cordset.EOF Then
'
' LastRec = CStr(datPrimary RS.Recordset.Re cordCount)
' Else
' ThisRec = 0
' LastRec = ThisRec
' End If
'
' datPrimaryRS.Ca ption = "
Outgoing Mail Record " & ThisRec & " of " & LastRec
'
' If AddRec Then
' UnlockAllContro ls
' Else
' LockAllControls
' End If
'
'End Sub
'Private Sub datPrimaryRS_Wi llChangeRecord( ByVal adReason As
ADODB.EventReas onEnum, ByVal cRecords As Long, adStatus As
ADODB.EventStat usEnum, 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 adRsnFirstChang e
' 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
UnlockAllContro ls
Me!LoginID = frmLogin!txtUse rName
AddRec = True
datPrimaryRS.Re cordset.AddNew
Me.txtFields(0) .SetFocus
Exit Sub
AddErr:
MsgBox Err.Description
End Sub
Private Sub cmdDelete_Click ()
On Error GoTo DeleteErr
With datPrimaryRS.Re cordset
.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("txtUs ername")
datPrimaryRS.Re cordset.UpdateB atch adAffectAll
LockAllControls
Exit Sub
UpdateErr:
MsgBox Err.Description
End Sub
Private Sub UnlockAllContro ls()
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.Pictu re = Me!Image1.Pictu re
Me!imgExit.Pict ure = Me!ExitUnclick. Picture
Me!imgStartServ ice.Picture = Me!StartService Unclick.Picture
'the form must be fully visible before calling Shell_NotifyIco n
Me.Show
Me.Refresh
With nid
.cbSize = Len(nid)
.hwnd = Me.hwnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessa ge = WM_MOUSEMOVE
.hIcon = Me.Icon
.szTip = "Autorespon der (tm)" & vbNullChar
End With
Shell_NotifyIco n NIM_ADD, nid
End Sub
Private Sub Form_Unload(Can cel As Integer)
Dim Frm As Form
'this removes the icon from the system tray
Shell_NotifyIco n 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.TwipsPer PixelX
End If
Select Case msg
Case WM_LBUTTONUP '514 restore form window
Me.WindowState = vbNormal
Result = SetForegroundWi ndow(Me.hwnd)
Me.Show
Case WM_LBUTTONDBLCL K '515 restore form window
Me.WindowState = vbNormal
Result = SetForegroundWi ndow(Me.hwnd)
Me.Show
Case WM_RBUTTONUP '517 display popup menu
Result = SetForegroundWi ndow(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.Sh ow
End Sub
Private Sub Image3_MouseDow n(Button As Integer, Shift As Integer, X As Single,
Y As Single)
Me!Image3.Pictu re = Me!Image2.Pictu re
End Sub
Private Sub Image3_MouseUp( Button As Integer, Shift As Integer, X As Single, Y
As Single)
Me!Image3.Pictu re = Me!Image1.Pictu re
End Sub
Private Sub imgExit_Click()
Unload Me
End Sub
Private Sub imgExit_MouseDo wn(Button As Integer, Shift As Integer, X As Single,
Y As Single)
Me!imgExit.Pict ure = Me!ExitClick.Pi cture
End Sub
Private Sub imgExit_MouseUp (Button As Integer, Shift As Integer, X As Single, Y
As Single)
Me!imgExit.Pict ure = Me!ExitUnclick. Picture
End Sub
Private Sub imgStartService _Click()
StartLoop
Me.WindowState = 1
End Sub
Private Sub imgStartService _MouseDown(Butt on As Integer, Shift As Integer, X As
Single, Y As Single)
Me!imgStartServ ice.Picture = Me!StartService Click.Picture
End Sub
Private Sub imgStartService _MouseUp(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Me!imgStartServ ice.Picture = Me!StartService Unclick.Picture
End Sub
Private Sub mPopExit_Click( )
'called when user clicks the popup menu Exit command
Unload Me
End Sub
Private Sub mPopRestore_Cli ck()
Dim Result As Long
'called when the user clicks the popup menu Restore command
Me.WindowState = vbNormal
Result = SetForegroundWi ndow(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.OpenDa tabase(App.Path & "\ARBack.md b")
DoEvents
On Error GoTo 0
Set RSUsers = DB.OpenRecordse t("Users", dbOpenSnapshot)
Set RSOutgoing = DB.OpenRecordse t("SELECT * FROM outgoing WHERE [Login ID]
= '" & RSUsers("Login ID") & "'", dbOpenDynaset)
Set RSCustomer = DB.OpenRecordse t("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.StartService Unclick.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("Passwo rd")
Set RSOutgoing = DB.OpenRecordse t("SELECT * FROM outgoing WHERE
[Login ID] = '" & RSUsers("Login ID") & "'", dbOpenDynaset)
Me.MAPIMessages 1.Fetch
End If
Do While I <= Me.MAPIMessages 1.MsgCount - 1
If Me.MAPIMessages 1.MsgCount = 0 Then
Exit Do
End If
Me.MAPIMessages 1.MsgIndex = I
If CDate(Me.MAPIMe ssages1.MsgDate Received) >
DB.Properties(" lastchecked") Then
Do While Not RSOutgoing.EOF
If InStrRev(Me.MAP IMessages1.MsgO rigAddress, "=") = 0 And
Me.MAPIMessages 1.MsgOrigAddres s <> "" Then
Sender = Right(Me.MAPIMe ssages1.MsgOrig Address,
Len(Me.MAPIMess ages1.MsgOrigAd dress) - 5)
Else
Sender = Right(Me.MAPIMe ssages1.MsgOrig Address,
(Len(Me.MAPIMes sages1.MsgOrigA ddress) -
InStrRev(Me.MAP IMessages1.MsgO rigAddress, "=")))
End If
If RSOutgoing("Qua lifier") = "sent from" And UCase(Sender)
= UCase(RSOutgoin g("Object")) Then
SendMail RSOutgoing("sub ject"), RSOutgoing("Bod y"),
Sender
AddCustomer RSOutgoing("cat egory"), Sender,
RSOutgoing("Ema il ID"), False
End If
If RSOutgoing("Qua lifier") = "sent to" And
UCase(RSOutgoin g("Login ID")) = UCase(Left(Me.M APIMessages1.Re cipAddress,
InStr(Me.MAPIMe ssages1.RecipAd dress, "@"))) Then
SendMail RSOutgoing("sub ject"), RSOutgoing("Bod y"),
Sender
AddCustomer RSOutgoing("cat egory"), Sender,
RSOutgoing("Ema il ID"), False
End If
If RSOutgoing("Qua lifier") = "with subject of" And
UCase(Me.MAPIMe ssages1.MsgSubj ect) = UCase(RSOutgoin g("object")) Then
If UCase(Me.MAPIMe ssages1.MsgSubj ect) <> "REMOVE" Then
SendMail RSOutgoing("sub ject"), RSOutgoing("Bod y"),
Sender
AddCustomer RSOutgoing("cat egory"), Sender,
RSOutgoing("Ema il ID"), False
Else
AddCustomer RSOutgoing("cat egory"), Sender,
RSOutgoing("ema il ID"), True
End If
End If
RSOutgoing.Move Next
Loop
RSOutgoing.Move First
End If
If I = Me.MAPIMessages 1.MsgCount - 1 Then
Me.MAPIMessages 1.MsgIndex = I
DB.Properties(" LastChecked") = Me.MAPIMessages 1.MsgDateReceiv ed
End If
I = I + 1
DoEvents
Loop
TempUser = RSUsers("Login ID")
RSUsers.MoveNex t
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.CreateProper ty("LastChecked ", dbDate, Now(), True)
DB.Properties.A ppend 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(Cat egory As String, Sender As String, LetterSent As
String, Remove As Boolean)
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Set DB = DBEngine.OpenDa tabase(App.Path & "\ARBack.md b")
Set RS = DB.OpenRecordse t("Customers" , dbOpenDynaset)
If Not Remove Then
RS.FindFirst "[Email Name] = '" & Sender & "'"
If RS.NoMatch Then
RS.AddNew
RS("Login ID") = frmLogin.txtUse rName
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(Subjec t As String, Body As String, Sender As String)
Me.MAPIMessages 1.Compose
Me.MAPIMessages 1.MsgSubject = Subject
Me.MAPIMessages 1.MsgNoteText = Body
Me.MAPIMessages 1.RecipAddress = Sender
Me.MAPIMessages 1.AddressResolv eUI = True
Me.MAPIMessages 1.ResolveName
Me.MAPIMessages 1.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.MAPIMessages 1.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  2922 
Hi,
Take a look at the open source project INDY. http://www.nevrona.com/Indy/Indy.html
Ken
----------------------
"Lumpierbritche s" <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
dwOSVersionInfo Size 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_US ER = &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_OUTOFMEMO RY = 6
Global Const ERROR_INVALID_P ARAMETER = 7
Global Const ERROR_ACCESS_DE NIED = 8
Global Const ERROR_INVALID_P ARAMETERS = 87
Global Const ERROR_NO_MORE_I TEMS = 259
Global Const KEY_ALL_ACCESS = &H3F
Global Const REG_OPTION_NON_ VOLATILE = 0
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersion ExA" (ByRef
lpVersionInform ation As OSVERSIONINFO) As Long
Public Declare Function RegCloseKey Lib "advapi32.d ll" (ByVal hKey As
Long) As
Long
Public Declare Function RegOpenKeyEx Lib "advapi32.d ll" Alias
"RegOpenKey ExA"
(ByVal hKey As Long, _
ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As
Long, phkResult As Long) As Long
Public Declare Function RegQueryValueEx String Lib "advapi32.d ll" Alias
"RegQueryValueE xA" (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 RegQueryValueEx Long Lib "advapi32.d ll" Alias
"RegQueryValueE xA" (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 RegQueryValueEx NULL Lib "advapi32.d ll" Alias
"RegQueryValueE xA" (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(sKey Name 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(HK EY_CURRENT_USER , sKeyName, 0, KEY_ALL_ACCESS,
hKey)
lRetVal = QueryValueEx(hK ey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function
Function QueryValueEx(By Val 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 QueryValueExErr or
' Determine the size and type of data to be read
lrc = RegQueryValueEx NULL(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 = RegQueryValueEx String(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 = RegQueryValueEx Long(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
QueryValueExExi t:
QueryValueEx = lrc
Exit Function
QueryValueExErr or:
Resume QueryValueExExi t
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
'StartMessaging AndLogon
objSession.Logo n frmLogin.txtUse rName, frmLogin.txtPas sword, True, True
Set objOutBox = objSession.Outb ox
Set objNewMessage = objOutBox.Messa ges.Add
Set objRecipients = objNewMessage.R ecipients
Set objOneRecip = objRecipients.A dd
objOneRecip = Recip
With objNewMessage
.Subject = Subj
.Text = Body
.Send
End With
End Sub
Sub StartMessagingA ndLogon()
Dim sKeyName As String
Dim sValueName As String
Dim sDefaultUserPro file As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
On Error GoTo ErrorHandler
Set objSession = CreateObject("M API.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_FA ILED will return. Trap
'the error in the ErrorHandler
objSession.Logo n ShowDialog:=Fal se, NewSession:=Fal se
Exit Sub
ErrorHandler:
Select Case Err.Number
Case -2147221231 'MAPI_E_LOGON_F AILED
'Need to find out what OS is in use, the keys are different
'for WinNT and Win95.
osinfo.dwOSVers ionInfoSize = 148
osinfo.szCSDVer sion = Space$(128)
retvalue = GetVersionEx(os info)
Select Case osinfo.dwPlatfo rmId
Case 0 'Unidentified
MsgBox "Unidentifi ed Operating System. Can't log onto
messaging."
Exit Sub
Case 1 'Win95
sKeyName = "Software\Micro soft\Windows Messaging
Subsystem\Profi les"
Case 2 'NT
sKeyName = "Software\Micro soft\Windows
NT\CurrentVersi on\Windows
Messaging Subsystem\Profi les"
End Select
sValueName = "DefaultProfile "
sDefaultUserPro file = QueryValue(sKey Name, sValueName)
objSession.Logo n ProfileName:=sD efaultUserProfi le, ShowDialog:=Fal se
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.StartMe ssagingAndLogon " & _
Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
"Descriptio n: " & Err.Description
End Select
End Sub
Public Function CheckInbox(Last Checked 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
'StartMessaging AndLogon
objSession.Logo n frmLogin.txtUse rName, frmLogin.txtPas sword, True, True
Set objInbox = objSession.Inbo x
Set objMessages = objInbox.Messag es
'Set objMsgFilter = objMessages.Fil ter
'objMsgFilter.U nread = False
For I = 1 To objMessages.Cou nt
Set objOneMessage = objMessages.Ite m(I)
If objOneMessage.T imeReceived > LastChecked Then
X = X + 1
MailBox(X, 1) = X
For Y = 2 To 6
Select Case Y
Case 2
temp = objOneMessage.S ender
Case 3
temp = objOneMessage.S ubject
Case 4
temp = objOneMessage.T ext
Case 5
temp = objOneMessage.T imeReceived
Case 6
On Error Resume Next
If IsNull(objOneMe ssage.Recipient s(1)) Then
temp = ""
Else
temp = objOneMessage.R ecipients(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
StartMessagingA ndLogon
Set objOutBox = objSession.Outb ox
Set objNewMessage = objOutBox.Messa ges.Add
Set objRecipients = objNewMessage.R ecipients
Set objOneRecip = objRecipients.A dd
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(TimeChe cked As Date)
Dim Arr As Variant
Dim Con As New ADODB.Connectio n
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.Connectio n
With Con
.ConnectionStri ng = "PROVIDER=Micro soft.Jet.OLEDB. 3.51;Data
Source=" &
App.Path & "\ARBack.md b;"
.Open
End With
RSEmails.Open "SELECT * FROM Outgoing", Con, adOpenForwardOn ly,
adLockOptimisti c, adCmdText
RSCustomers.Ope n "SELECT * FROM Customers", Con, adOpenDynamic,
adLockOptimisti c, adCmdText
RSEmails.MoveFi rst
Arr = CheckInbox(Time Checked)
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!qualif ier
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!Subjec t, RSEmails!Body
RSCustomers.Add New
RSCustomers![login ID] = frmLogin.txtUse rName
RSCustomers!ema ilname = Addy
RSCustomers!Cat egory = RSEmails!Catego ry
RSCustomers!Let terSent = RSEmails!EmailI D
RSCustomers.Upd ate
End If
Loop
RSEmails.MoveFi rst
Next I
End Sub
System Tray Module:
'user defined type required by Shell_NotifyIco n API call
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessag e As Long
hIcon As Long
szTip As String * 64
End Type
'constants required by Shell_NotifyIco n 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_LBUTTONDBLCL K = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCL K = &H206 'Double-click
Public Declare Function SetForegroundWi ndow Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIco n Lib "shell32" _
Alias "Shell_NotifyIc onA" _
(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.OpenDa tabase(App.Path & "\ARBack.md b")
Set RS = DB.OpenRecordse t("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.", "AutoResopo nder 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("d atPrimaryRS").R ecordSource = StrSQL
frmUnderCover.S how
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("d atPrimaryRS").R ecordSource = StrSQL
frmUnderCover.S how
Exit Sub
Else
MsgBox "You have entered an invalid password. Please try
again.",
vbOKOnly, "Invalid Password"
txtPassword = ""
txtPassword.Set Focus
Exit Sub
End If
End If
End Sub
frmOutgoing1 Code:
Option Explicit
Dim AddRec As Boolean
Private Sub cboQualifier_Va lidate(Cancel As Boolean)
If Me("cboqualifie r") = "Sent to" Or Me("cboqualifie r") = "Sent from"
Or
Me("cboqualifie r") = "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.S how
Unload Me
End Sub
Private Sub cmdEdit_Click(I ndex As Integer)
UnlockAllContro ls
End Sub
'Private Sub cmdEdit_Click()
' UnlockAllContro ls
'End Sub
Private Sub Form_Load()
With Me("datPrimaryR S")
.ConnectionStri ng = "PROVIDER=Micro soft.Jet.OLEDB. 3.51;Data Source="
&
App.Path & "\ARBack.md b;"
.RecordSource = StrSQL
End With
Me("datPrimaryR S").Refresh
If Not AddRec Then
LockAllControls
End If
AddRec = False
End Sub
Private Sub Form_Unload(Can cel As Integer)
frmUnderCover.S how
Screen.MousePoi nter = vbDefault
End Sub
Private Sub datPrimaryRS_Er ror(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_Mo veComplete(ByVa l adReason As
ADODB.EventReas onEnum,
ByVal pError As ADODB.Error, adStatus As ADODB.EventStat usEnum, 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(datPrimary RS.Recordset.Ab solutePosition)
'
' If Not datPrimaryRS.Re cordset.EOF Then
'
' LastRec = CStr(datPrimary RS.Recordset.Re cordCount)
' Else
' ThisRec = 0
' LastRec = ThisRec
' End If
'
' datPrimaryRS.Ca ption = "
Outgoing Mail Record " & ThisRec & " of " &
LastRec
'
' If AddRec Then
' UnlockAllContro ls
' Else
' LockAllControls
' End If
'
'End Sub
'Private Sub datPrimaryRS_Wi llChangeRecord( ByVal adReason As
ADODB.EventReas onEnum, ByVal cRecords As Long, adStatus As
ADODB.EventStat usEnum, 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 adRsnFirstChang e
' 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
UnlockAllContro ls
Me!LoginID = frmLogin!txtUse rName
AddRec = True
datPrimaryRS.Re cordset.AddNew
Me.txtFields(0) .SetFocus
Exit Sub
AddErr:
MsgBox Err.Description
End Sub
Private Sub cmdDelete_Click ()
On Error GoTo DeleteErr
With datPrimaryRS.Re cordset
.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("txtUs ername")
datPrimaryRS.Re cordset.UpdateB atch adAffectAll
LockAllControls
Exit Sub
UpdateErr:
MsgBox Err.Description
End Sub
Private Sub UnlockAllContro ls()
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.Pictu re = Me!Image1.Pictu re
Me!imgExit.Pict ure = Me!ExitUnclick. Picture
Me!imgStartServ ice.Picture = Me!StartService Unclick.Picture
'the form must be fully visible before calling Shell_NotifyIco n
Me.Show
Me.Refresh
With nid
.cbSize = Len(nid)
.hwnd = Me.hwnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessa ge = WM_MOUSEMOVE
.hIcon = Me.Icon
.szTip = "Autorespon der (tm)" & vbNullChar
End With
Shell_NotifyIco n NIM_ADD, nid
End Sub
Private Sub Form_Unload(Can cel As Integer)
Dim Frm As Form
'this removes the icon from the system tray
Shell_NotifyIco n 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.TwipsPer PixelX
End If
Select Case msg
Case WM_LBUTTONUP '514 restore form window
Me.WindowState = vbNormal
Result = SetForegroundWi ndow(Me.hwnd)
Me.Show
Case WM_LBUTTONDBLCL K '515 restore form window
Me.WindowState = vbNormal
Result = SetForegroundWi ndow(Me.hwnd)
Me.Show
Case WM_RBUTTONUP '517 display popup menu
Result = SetForegroundWi ndow(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.Sh ow
End Sub
Private Sub Image3_MouseDow n(Button As Integer, Shift As Integer, X As
Single,
Y As Single)
Me!Image3.Pictu re = Me!Image2.Pictu re
End Sub
Private Sub Image3_MouseUp( Button As Integer, Shift As Integer, X As
Single, Y
As Single)
Me!Image3.Pictu re = Me!Image1.Pictu re
End Sub
Private Sub imgExit_Click()
Unload Me
End Sub
Private Sub imgExit_MouseDo wn(Button As Integer, Shift As Integer, X As
Single,
Y As Single)
Me!imgExit.Pict ure = Me!ExitClick.Pi cture
End Sub
Private Sub imgExit_MouseUp (Button As Integer, Shift As Integer, X As
Single, Y
As Single)
Me!imgExit.Pict ure = Me!ExitUnclick. Picture
End Sub
Private Sub imgStartService _Click()
StartLoop
Me.WindowState = 1
End Sub
Private Sub imgStartService _MouseDown(Butt on As Integer, Shift As Integer,
X As
Single, Y As Single)
Me!imgStartServ ice.Picture = Me!StartService Click.Picture
End Sub
Private Sub imgStartService _MouseUp(Button As Integer, Shift As Integer, X
As
Single, Y As Single)
Me!imgStartServ ice.Picture = Me!StartService Unclick.Picture
End Sub
Private Sub mPopExit_Click( )
'called when user clicks the popup menu Exit command
Unload Me
End Sub
Private Sub mPopRestore_Cli ck()
Dim Result As Long
'called when the user clicks the popup menu Restore command
Me.WindowState = vbNormal
Result = SetForegroundWi ndow(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.OpenDa tabase(App.Path & "\ARBack.md b")
DoEvents
On Error GoTo 0
Set RSUsers = DB.OpenRecordse t("Users", dbOpenSnapshot)
Set RSOutgoing = DB.OpenRecordse t("SELECT * FROM outgoing WHERE [Login
ID]
= '" & RSUsers("Login ID") & "'", dbOpenDynaset)
Set RSCustomer = DB.OpenRecordse t("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.StartService Unclick.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("Passwo rd")
Set RSOutgoing = DB.OpenRecordse t("SELECT * FROM outgoing WHERE
[Login ID] = '" & RSUsers("Login ID") & "'", dbOpenDynaset)
Me.MAPIMessages 1.Fetch
End If
Do While I <= Me.MAPIMessages 1.MsgCount - 1
If Me.MAPIMessages 1.MsgCount = 0 Then
Exit Do
End If
Me.MAPIMessages 1.MsgIndex = I
If CDate(Me.MAPIMe ssages1.MsgDate Received) >
DB.Properties(" lastchecked") Then
Do While Not RSOutgoing.EOF
If InStrRev(Me.MAP IMessages1.MsgO rigAddress, "=") = 0
And
Me.MAPIMessages 1.MsgOrigAddres s <> "" Then
Sender = Right(Me.MAPIMe ssages1.MsgOrig Address,
Len(Me.MAPIMess ages1.MsgOrigAd dress) - 5)
Else
Sender = Right(Me.MAPIMe ssages1.MsgOrig Address,
(Len(Me.MAPIMes sages1.MsgOrigA ddress) -
InStrRev(Me.MAP IMessages1.MsgO rigAddress, "=")))
End If
If RSOutgoing("Qua lifier") = "sent from" And
UCase(Sender)
= UCase(RSOutgoin g("Object")) Then
SendMail RSOutgoing("sub ject"), RSOutgoing("Bod y"),
Sender
AddCustomer RSOutgoing("cat egory"), Sender,
RSOutgoing("Ema il ID"), False
End If
If RSOutgoing("Qua lifier") = "sent to" And
UCase(RSOutgoin g("Login ID")) = UCase(Left(Me.M APIMessages1.Re cipAddress,
InStr(Me.MAPIMe ssages1.RecipAd dress, "@"))) Then
SendMail RSOutgoing("sub ject"), RSOutgoing("Bod y"),
Sender
AddCustomer RSOutgoing("cat egory"), Sender,
RSOutgoing("Ema il ID"), False
End If
If RSOutgoing("Qua lifier") = "with subject of" And
UCase(Me.MAPIMe ssages1.MsgSubj ect) = UCase(RSOutgoin g("object")) Then
If UCase(Me.MAPIMe ssages1.MsgSubj ect) <> "REMOVE"
Then
SendMail RSOutgoing("sub ject"),
RSOutgoing("Bod y"),
Sender
AddCustomer RSOutgoing("cat egory"), Sender,
RSOutgoing("Ema il ID"), False
Else
AddCustomer RSOutgoing("cat egory"), Sender,
RSOutgoing("ema il ID"), True
End If
End If
RSOutgoing.Move Next
Loop
RSOutgoing.Move First
End If
If I = Me.MAPIMessages 1.MsgCount - 1 Then
Me.MAPIMessages 1.MsgIndex = I
DB.Properties(" LastChecked") =
Me.MAPIMessages 1.MsgDateReceiv ed
End If
I = I + 1
DoEvents
Loop
TempUser = RSUsers("Login ID")
RSUsers.MoveNex t
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.CreateProper ty("LastChecked ", dbDate, Now(), True)
DB.Properties.A ppend 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(Cat egory As String, Sender As String, LetterSent
As
String, Remove As Boolean)
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Set DB = DBEngine.OpenDa tabase(App.Path & "\ARBack.md b")
Set RS = DB.OpenRecordse t("Customers" , dbOpenDynaset)
If Not Remove Then
RS.FindFirst "[Email Name] = '" & Sender & "'"
If RS.NoMatch Then
RS.AddNew
RS("Login ID") = frmLogin.txtUse rName
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(Subjec t As String, Body As String, Sender As String)
Me.MAPIMessages 1.Compose
Me.MAPIMessages 1.MsgSubject = Subject
Me.MAPIMessages 1.MsgNoteText = Body
Me.MAPIMessages 1.RecipAddress = Sender
Me.MAPIMessages 1.AddressResolv eUI = True
Me.MAPIMessages 1.ResolveName
Me.MAPIMessages 1.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.MAPIMessages 1.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
----------------------
"Lumpierbritch es" <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*********@em ail.address> wrote in message
news:kl******** *************** *********@4ax.c om... 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
----------------------
"Lumpierbritc hes" <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
------------- -----
"prefer perl to python" 26
"prefers perl to python" 0
|
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 an end-user in an organization and the database, through
the exclusive use of stored procedures which are authored by the
organization or by software developers.
All development work at the application software level may thereby
be conducted...
|
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
somebody justify me that I will get in trouble if I continue to use MS
Access in this multi connection situation. What other databases like Sybase
iAnywhere, MS Sql server Express edition, MSDE to be considered for the MS
Access replacement.
It...
|
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 starting point the compiler can no
longer find the function as at the bottom of this posting, that was in the
Global.asax.vb file.
All the function does is give an easy / quick way of getting the application
|
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 show extreme poor performance. One of the query was
partly optimized by declaring a partitioning key on the temporary
table. However it still takes longer than before the node migration.
I would appreciate if I could get information on the...
| | |
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 what about the database - do i
need to reconnect the database and the components-register again the
components in the Web Server. And question like how can i customize the
installation and how can i update the existing files on a deployed ASP.NET...
|
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
application:
GUI: is in Asp
|
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 is for security reason when accessing databases). We use the
Integrated Windows authentication to authenticate users, and we have
setup the Web.config file to authenticate those users against 3 NT
Domain Global Groups. Everything is working fine...
|
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 particuliers
ce quiconcerne la migration de WinForms de DotNet 1.1 vers DotNet 2.0.
tout docs, lien , aide sera le bienvenu
Cordialement
|
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 zone in feb of 08 I have
decided to rewrite in another language. The application is constatnly being
upgraded with new features and I would like to find someting that would have
long term support, if such is possible. Never would have thought MS...
|
by: jinu1996 |
last post by:
In today's digital age, having a compelling online presence is paramount for businesses aiming to thrive in a competitive landscape. At the heart of this digital strategy lies an intricately woven tapestry of website design and digital marketing. It's not merely about having a website; it's about crafting an immersive digital experience that captivates audiences and drives business growth.
The Art of Business Website Design
Your website is...
| | |
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 Update option using the Control Panel or Settings app; it automatically checks for updates and installs any it finds, whether you like it or not. For most users, this new feature is actually very convenient. If you want to control the update process,...
|
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 protocol has its own unique characteristics and advantages, but as a user who is planning to build a smart home system, I am a bit confused by the choice of these technologies. I'm particularly interested in Zigbee because I've heard it does some...
|
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, and deployment—without human intervention. Imagine an AI that can take a project description, break it down, write the code, debug it, and then launch it, all on its own....
Now, this would greatly impact the work of software developers. The idea...
|
by: isladogs |
last post by:
The next Access Europe User Group meeting will be on Wednesday 1 May 2024 starting at 18:00 UK time (6PM UTC+1) and finishing by 19:30 (7.30PM).
In this session, we are pleased to welcome a new presenter, Adolph Dupré who will be discussing some powerful techniques for using class modules.
He will explain when you may want to use classes instead of User Defined Types (UDT). For example, to manage the data in unbound forms.
Adolph will...
|
by: TSSRALBI |
last post by:
Hello
I'm a network technician in training and I need your help.
I am currently learning how to create and manage the different types of VPNs and I have a question about LAN-to-LAN VPNs.
The last exercise I practiced was to create a LAN-to-LAN VPN between two Pfsense firewalls, by using IPSEC protocols.
I succeeded, with both firewalls in the same network. But I'm wondering if it's possible to do the same thing, with 2 Pfsense firewalls...
|
by: adsilva |
last post by:
A Windows Forms form does not have the event Unload, like VB6. What one acts like?
| | |
by: 6302768590 |
last post by:
Hai team
i want code for transfer the data from one system to another through IP address by using C# our system has to for every 5mins then we have to update the data what the data is updated we have to send another system
|
by: bsmnconsultancy |
last post by:
In today's digital era, a well-designed website is crucial for businesses looking to succeed. Whether you're a small business owner or a large corporation in Toronto, having a strong online presence can significantly impact your brand's success. BSMN Consultancy, a leader in Website Development in Toronto offers valuable insights into creating effective websites that not only look great but also perform exceptionally well. In this comprehensive...
| |
