By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
440,666 Members | 1,909 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 440,666 IT Pros & Developers. It's quick & easy.

Application Migration from VB6 to .NET

P: n/a
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

Nov 20 '05 #1
Share this Question
Share on Google+
3 Replies


P: n/a
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


Nov 20 '05 #2

P: n/a
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)
Nov 20 '05 #3

P: n/a
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)

Nov 20 '05 #4

This discussion thread is closed

Replies have been disabled for this discussion.