Hello,
Ive a got VBA script that runs of 5 PCs.
When run (via a associated button), the Hightlighted (or opened) email is "read" if a Specific recepitent email address is located (IE BOB@email1.co.uk ) then that email address is used as the reply address, then body of the incoming email is copied into the new message, and the correct Footer is added.
If the recepitent email address is Bob@email2.co.uk, then that is used as the reply address etc, and a different footer is used.
If neither of these email address' is presents, then is ask which one it should use.
HOWEVER, it's not working on a new PC I'm setting up.
Office is the same version as everyone elses, and it fully patched.
OS is the same, and is fully patched.
The VBA is as follows
<Code>
Sub RunAs()
Dim Msg As Outlook.MailItem
Dim MsgReply As Outlook.MailItem
Dim strGreetName As String
Dim SignatureType As String
Dim SigString2 As String
Dim SigString1 As String
Dim Spacer As String
Dim AccountName As String
Dim SendAsName
Dim strSentTo
SigStringDVH = "C:\Signatures\email1.htm"
SigStringTVS = "C:\Signatures\email2.htm"
SigStringGEN = "C:\Signatures\personal.htm"
Spacer = "-----Original Message-----"
' set reference to open/selected mail item
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set Msg = ActiveExplorer.Selection.Item(1)
strSentTo = Msg.To
Case "Inspector"
Set Msg = ActiveInspector.CurrentItem
strSentTo = Msg.To
Case Else
End Select
If Msg Is Nothing Then GoTo ExitProc
If strSentTo = "Bob@email1.co.uk" Then
SigString = SigString1
SendAsName = "Bob@email1.co.uk"
ElseIf strSentTo = "Bob@email2.co.uk" Then
SigString = SigString2
SendAsName = "Bob@email2.co.uk"
Else
SignatureType = InputBox("Select Reply From:" & vbCr & vbCr & "Type 'D' for email1, 'V' for email2", , " ")
On Error GoTo 0
Select Case SignatureType
Case "D", "d"
SigString = SigString2
SendAsName = "Bob@email2.co.uk"
Case "V", "v"
SigString = SigString1
SendAsName = "Bob@email1.co.uk"
Case " " ' User Clicked Okay so used default Personal Signature
SigString = SigStringGEN
SendAsName = "Microsoft Exchange Server" ' CHANGE FOR OTHER USERS
Case Else
If SignatureType = "" Then
GoTo ExitProc
End If
End Select
End If
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Set MsgReply = Msg.Reply
With MsgReply
.Subject = "RE:" & Msg.Subject
.HTMLBody = Chr(32) & Chr(32) & vbCrLf & vbCrLf & Signature & Spacer & .HTMLBody
.SentOnBehalfOfName = ""
.Display
End With
Set_Account SendAsName, MsgReply ' Change the Account to send as (POP Accounts or personal)
ExitProc:
Set Msg = Nothing
Set MsgReply = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function Set_Account(ByVal AccountName As String, M As Outlook.MailItem) As String
Dim OLI As Outlook.Inspector
Dim strAccountBtnName As String
Dim intLoc As Integer
Const ID_ACCOUNTS = 31224
Dim CBs As Office.CommandBars
Dim CBP As Office.CommandBarPopup
Dim MC As Office.CommandBarControl
Set OLI = M.GetInspector
If Not OLI Is Nothing Then
Set CBs = OLI.CommandBars
Set CBP = CBs.FindControl(, ID_ACCOUNTS)
If Not CBP Is Nothing Then
For Each MC In CBP.Controls
intLoc = InStr(MC.Caption, " ")
If intLoc > 0 Then
strAccountBtnName = Mid(MC.Caption, intLoc + 1)
Else
strAccountBtnName = MC.Caption
End If
If strAccountBtnName = AccountName Then
MC.Execute
Set_Account = AccountName
GoTo Exit_Function
End If
Next
End If
End If
Set_Account = ""
Exit_Function:
Set MC = Nothing
Set CBP = Nothing
Set CBs = Nothing
Set OLI = Nothing
End Function
<Code>
Ive a got VBA script that runs of 5 PCs.
When run (via a associated button), the Hightlighted (or opened) email is "read" if a Specific recepitent email address is located (IE BOB@email1.co.uk ) then that email address is used as the reply address, then body of the incoming email is copied into the new message, and the correct Footer is added.
If the recepitent email address is Bob@email2.co.uk, then that is used as the reply address etc, and a different footer is used.
If neither of these email address' is presents, then is ask which one it should use.
HOWEVER, it's not working on a new PC I'm setting up.
Office is the same version as everyone elses, and it fully patched.
OS is the same, and is fully patched.
The VBA is as follows
<Code>
Sub RunAs()
Dim Msg As Outlook.MailItem
Dim MsgReply As Outlook.MailItem
Dim strGreetName As String
Dim SignatureType As String
Dim SigString2 As String
Dim SigString1 As String
Dim Spacer As String
Dim AccountName As String
Dim SendAsName
Dim strSentTo
SigStringDVH = "C:\Signatures\email1.htm"
SigStringTVS = "C:\Signatures\email2.htm"
SigStringGEN = "C:\Signatures\personal.htm"
Spacer = "-----Original Message-----"
' set reference to open/selected mail item
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set Msg = ActiveExplorer.Selection.Item(1)
strSentTo = Msg.To
Case "Inspector"
Set Msg = ActiveInspector.CurrentItem
strSentTo = Msg.To
Case Else
End Select
If Msg Is Nothing Then GoTo ExitProc
If strSentTo = "Bob@email1.co.uk" Then
SigString = SigString1
SendAsName = "Bob@email1.co.uk"
ElseIf strSentTo = "Bob@email2.co.uk" Then
SigString = SigString2
SendAsName = "Bob@email2.co.uk"
Else
SignatureType = InputBox("Select Reply From:" & vbCr & vbCr & "Type 'D' for email1, 'V' for email2", , " ")
On Error GoTo 0
Select Case SignatureType
Case "D", "d"
SigString = SigString2
SendAsName = "Bob@email2.co.uk"
Case "V", "v"
SigString = SigString1
SendAsName = "Bob@email1.co.uk"
Case " " ' User Clicked Okay so used default Personal Signature
SigString = SigStringGEN
SendAsName = "Microsoft Exchange Server" ' CHANGE FOR OTHER USERS
Case Else
If SignatureType = "" Then
GoTo ExitProc
End If
End Select
End If
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Set MsgReply = Msg.Reply
With MsgReply
.Subject = "RE:" & Msg.Subject
.HTMLBody = Chr(32) & Chr(32) & vbCrLf & vbCrLf & Signature & Spacer & .HTMLBody
.SentOnBehalfOfName = ""
.Display
End With
Set_Account SendAsName, MsgReply ' Change the Account to send as (POP Accounts or personal)
ExitProc:
Set Msg = Nothing
Set MsgReply = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Function Set_Account(ByVal AccountName As String, M As Outlook.MailItem) As String
Dim OLI As Outlook.Inspector
Dim strAccountBtnName As String
Dim intLoc As Integer
Const ID_ACCOUNTS = 31224
Dim CBs As Office.CommandBars
Dim CBP As Office.CommandBarPopup
Dim MC As Office.CommandBarControl
Set OLI = M.GetInspector
If Not OLI Is Nothing Then
Set CBs = OLI.CommandBars
Set CBP = CBs.FindControl(, ID_ACCOUNTS)
If Not CBP Is Nothing Then
For Each MC In CBP.Controls
intLoc = InStr(MC.Caption, " ")
If intLoc > 0 Then
strAccountBtnName = Mid(MC.Caption, intLoc + 1)
Else
strAccountBtnName = MC.Caption
End If
If strAccountBtnName = AccountName Then
MC.Execute
Set_Account = AccountName
GoTo Exit_Function
End If
Next
End If
End If
Set_Account = ""
Exit_Function:
Set MC = Nothing
Set CBP = Nothing
Set CBs = Nothing
Set OLI = Nothing
End Function
<Code>