Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Outlook VBS script not working on 1 PC only

Status
Not open for further replies.

gezster

Technical User
Jul 12, 2010
12
GB
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>
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top