kcscdf
09-16-2011, 08:29 PM
Currently i am using the following VB codes to forward emails to my mobile device. It works perfectly but i have 2 issues,
1. It does not forward the attachments - so any email forwarded only contains text. Nowhere in this code are there any portion that handles attachment. My question here would be, how can i add lines of code to ensure that attachments are forwarded as well?
2. I cannot reply through my mobile device even though i have a few lines of code that will help me handle my replies on the outlook account - i suspect this is due to the grabbing of content by the codes which does not match the status of a valid email. The outlook function GetOriginalFromEmail() is grabbing content belonging to "FROM" instead of "NAME" within this startmessageheader/endmessageheader, hence it is unable to perform replies. My question is how can i grab the content from "Name:" instead to put it simply.
For example:
--------StartMessageHeader--------
From: /O=RESOE/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=SARAH_TOH1
Name: SARAH TOH (XYZ)
To:
Cc:
--------EndMessageHeader--------
Attached is the chunk of code that i use in my editor:
Private Const FORWARD_TO_EMAIL As String = "your_email@your_domain.com "
Private Const START_MESSAGE_HEADER As String = "--------StartMessageHeader--------"
Private Const END_MESSAGE_HEADER As String = "--------EndMessageHeader--------"
Private Const FROM_MESSAGE_HEADER As String = "From: "
Private Const DESKTOP_SWITCHDESKTOP As Long = &H100
Private Declare Sub LockWorkStation Lib "User32.dll" ()
Private Declare Function SwitchDesktop Lib "user32" _
(ByVal hDesktop As Long) As Long
Private Declare Function OpenDesktop _
Lib "user32" Alias "OpenDesktopA" _
(ByVal lpszDesktop As Any, _
ByVal dwFlags As Long, _
ByVal fInherit As Long, _
ByVal dwDesiredAccess As Long) As Long
Sub ForwardEmail(MyMail As MailItem)
On Error GoTo EndSub
Dim strBody As String
Dim objMail As Outlook.MailItem
Dim MailItem As Outlook.MailItem
Set objMail = Application.Session.GetItemFromID(MyMail.EntryID)
' Initialize email to send
Set MailItem = Application.CreateItem(olMailItem)
MailItem.Subject = objMail.Subject
If (objMail.SenderEmailAddress <> FORWARD_TO_EMAIL) Then
' Only forward emails when the workstation is locked
If (Not IsWorkstationLocked()) Then
Return
End If
' Compose email and send it to your other email
strBody = START_MESSAGE_HEADER + Chr$(13) + _
FROM_MESSAGE_HEADER + objMail.SenderEmailAddress + Chr$(13) + _
"Name: " + objMail.SenderName + Chr$(13) + _
"To: " + objMail.To + Chr$(13) + _
"CC: " + objMail.CC + Chr$(13) + _
END_MESSAGE_HEADER + Chr$(13) + Chr$(13) + _
objMail.body
MailItem.Recipients.Add (FORWARD_TO_EMAIL)
' Do not keep email sent to your mobile account
MailItem.DeleteAfterSubmit = True
Else
' Parse the original mesage and reply to the sender
strBody = objMail.body
Dim posStartHeader As Integer
posStartHeader = InStr(strBody, START_MESSAGE_HEADER)
Dim posEndHeader As Integer
posEndHeader = InStr(strBody, END_MESSAGE_HEADER)
'Remove the message header from the body
strBody = Mid(strBody, 1, posStartHeader - 1) + _
Mid(strBody, posEndHeader + Len(END_MESSAGE_HEADER) + 4)
Dim originalEmailFrom As String
originalEmailFrom = GetOriginalFromEmail(posStartHeader, _
posEndHeader, objMail.body)
If (originalEmailFrom = "") Then
Return
End If
MailItem.Recipients.Add (originalEmailFrom)
' Delete email received from your mobile account
objMail.Delete
End If
' Send email
MailItem.body = strBody
MailItem.Send
' Set variables to null to prevent memory leaks
Set MailItem = Nothing
Set Recipient = Nothing
Set objMail = Nothing
Exit Sub
EndSub:
'MsgBox "Unexpected error. Type: " & Err.Description
End Sub
Private Function GetOriginalFromEmail(posStartHeader As Integer, _
posEndHeader As Integer, strBody As String) As String
GetOriginalFromEmail = ""
If (posStartHeader < posEndHeader And posStartHeader > 0) Then
posStartHeader = posStartHeader + Len(START_MESSAGE_HEADER) + 1
Dim posFrom As Integer
posFrom = InStr(posStartHeader, strBody, FROM_MESSAGE_HEADER)
If (posFrom < posStartHeader) Then
Return
End If
posFrom = posFrom + Len(FROM_MESSAGE_HEADER)
Dim posReturn As Integer
posReturn = InStr(posFrom, strBody, Chr$(13))
If (posReturn > posFrom) Then
GetOriginalFromEmail = _
Mid(strBody, posFrom, posReturn - posFrom)
End If
End If
End Function
Private Function IsWorkstationLocked() As Boolean
IsWorkstationLocked = False
On Error GoTo EndFunction
Dim p_lngHwnd As Long
Dim p_lngRtn As Long
Dim p_lngErr As Long
p_lngHwnd = OpenDesktop(lpszDesktop:="Default", _
dwFlags:=0, _
fInherit:=False, _
dwDesiredAccess:=DESKTOP_SWITCHDESKTOP)
If p_lngHwnd <> 0 Then
p_lngRtn = SwitchDesktop(hDesktop:=p_lngHwnd)
p_lngErr = Err.LastDllError
If p_lngRtn = 0 Then
If p_lngErr = 0 Then
IsWorkstationLocked = True
End If
End If
End If
EndFunction:
End Function
Any idea how these 2 issues can be solved? Would appreciate if anyone can supply some sample codes. Thanks!
1. It does not forward the attachments - so any email forwarded only contains text. Nowhere in this code are there any portion that handles attachment. My question here would be, how can i add lines of code to ensure that attachments are forwarded as well?
2. I cannot reply through my mobile device even though i have a few lines of code that will help me handle my replies on the outlook account - i suspect this is due to the grabbing of content by the codes which does not match the status of a valid email. The outlook function GetOriginalFromEmail() is grabbing content belonging to "FROM" instead of "NAME" within this startmessageheader/endmessageheader, hence it is unable to perform replies. My question is how can i grab the content from "Name:" instead to put it simply.
For example:
--------StartMessageHeader--------
From: /O=RESOE/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=SARAH_TOH1
Name: SARAH TOH (XYZ)
To:
Cc:
--------EndMessageHeader--------
Attached is the chunk of code that i use in my editor:
Private Const FORWARD_TO_EMAIL As String = "your_email@your_domain.com "
Private Const START_MESSAGE_HEADER As String = "--------StartMessageHeader--------"
Private Const END_MESSAGE_HEADER As String = "--------EndMessageHeader--------"
Private Const FROM_MESSAGE_HEADER As String = "From: "
Private Const DESKTOP_SWITCHDESKTOP As Long = &H100
Private Declare Sub LockWorkStation Lib "User32.dll" ()
Private Declare Function SwitchDesktop Lib "user32" _
(ByVal hDesktop As Long) As Long
Private Declare Function OpenDesktop _
Lib "user32" Alias "OpenDesktopA" _
(ByVal lpszDesktop As Any, _
ByVal dwFlags As Long, _
ByVal fInherit As Long, _
ByVal dwDesiredAccess As Long) As Long
Sub ForwardEmail(MyMail As MailItem)
On Error GoTo EndSub
Dim strBody As String
Dim objMail As Outlook.MailItem
Dim MailItem As Outlook.MailItem
Set objMail = Application.Session.GetItemFromID(MyMail.EntryID)
' Initialize email to send
Set MailItem = Application.CreateItem(olMailItem)
MailItem.Subject = objMail.Subject
If (objMail.SenderEmailAddress <> FORWARD_TO_EMAIL) Then
' Only forward emails when the workstation is locked
If (Not IsWorkstationLocked()) Then
Return
End If
' Compose email and send it to your other email
strBody = START_MESSAGE_HEADER + Chr$(13) + _
FROM_MESSAGE_HEADER + objMail.SenderEmailAddress + Chr$(13) + _
"Name: " + objMail.SenderName + Chr$(13) + _
"To: " + objMail.To + Chr$(13) + _
"CC: " + objMail.CC + Chr$(13) + _
END_MESSAGE_HEADER + Chr$(13) + Chr$(13) + _
objMail.body
MailItem.Recipients.Add (FORWARD_TO_EMAIL)
' Do not keep email sent to your mobile account
MailItem.DeleteAfterSubmit = True
Else
' Parse the original mesage and reply to the sender
strBody = objMail.body
Dim posStartHeader As Integer
posStartHeader = InStr(strBody, START_MESSAGE_HEADER)
Dim posEndHeader As Integer
posEndHeader = InStr(strBody, END_MESSAGE_HEADER)
'Remove the message header from the body
strBody = Mid(strBody, 1, posStartHeader - 1) + _
Mid(strBody, posEndHeader + Len(END_MESSAGE_HEADER) + 4)
Dim originalEmailFrom As String
originalEmailFrom = GetOriginalFromEmail(posStartHeader, _
posEndHeader, objMail.body)
If (originalEmailFrom = "") Then
Return
End If
MailItem.Recipients.Add (originalEmailFrom)
' Delete email received from your mobile account
objMail.Delete
End If
' Send email
MailItem.body = strBody
MailItem.Send
' Set variables to null to prevent memory leaks
Set MailItem = Nothing
Set Recipient = Nothing
Set objMail = Nothing
Exit Sub
EndSub:
'MsgBox "Unexpected error. Type: " & Err.Description
End Sub
Private Function GetOriginalFromEmail(posStartHeader As Integer, _
posEndHeader As Integer, strBody As String) As String
GetOriginalFromEmail = ""
If (posStartHeader < posEndHeader And posStartHeader > 0) Then
posStartHeader = posStartHeader + Len(START_MESSAGE_HEADER) + 1
Dim posFrom As Integer
posFrom = InStr(posStartHeader, strBody, FROM_MESSAGE_HEADER)
If (posFrom < posStartHeader) Then
Return
End If
posFrom = posFrom + Len(FROM_MESSAGE_HEADER)
Dim posReturn As Integer
posReturn = InStr(posFrom, strBody, Chr$(13))
If (posReturn > posFrom) Then
GetOriginalFromEmail = _
Mid(strBody, posFrom, posReturn - posFrom)
End If
End If
End Function
Private Function IsWorkstationLocked() As Boolean
IsWorkstationLocked = False
On Error GoTo EndFunction
Dim p_lngHwnd As Long
Dim p_lngRtn As Long
Dim p_lngErr As Long
p_lngHwnd = OpenDesktop(lpszDesktop:="Default", _
dwFlags:=0, _
fInherit:=False, _
dwDesiredAccess:=DESKTOP_SWITCHDESKTOP)
If p_lngHwnd <> 0 Then
p_lngRtn = SwitchDesktop(hDesktop:=p_lngHwnd)
p_lngErr = Err.LastDllError
If p_lngRtn = 0 Then
If p_lngErr = 0 Then
IsWorkstationLocked = True
End If
End If
End If
EndFunction:
End Function
Any idea how these 2 issues can be solved? Would appreciate if anyone can supply some sample codes. Thanks!