Solved

VBS Email From

Posted on 2013-11-03
27
515 Views
Last Modified: 2013-11-04
Hello,
I'm using below code to send some scheduled emails with attachments.
I need to add the mail From section (this way I can choose which email account to send from).
Any help is appreciated.

' Define location and names for file selection
strBaseDir = "C:\Users\Wassim.QA-DOMAIN\Desktop\Export Invoices"
strBaseName = "4667-"

arrExt = Array(".csv", ".txt", ".pdf" ,"xls" ,"xlsx")

' Specify email related information
MailTo = "mail@mail.com"
Subject = "Files"
Body = "***** Please see attached *****"

' Create file system object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Access the folder where the files exist
Set objFolder = objFSO.GetFolder(strBaseDir)

' Process all files in this folder, and look for name matches
For Each objFile in objFolder.Files
   If CheckFileName(objFile.Name) Then
      Attachments = Attachments & "," & objFile.Path
   End If
Next

If Left(Attachments, 1) = "," Then
   Attachments = Mid(Attachments, 2)
End If

If Attachments <> "" Then
   Email MailTo, Subject, Body, Attachments
End If


' Subroutine to send the email with the file attached
Sub Email (MailTo, Subject, Body, Attachments)
   Set App = CreateObject("Outlook.Application")
   Set Item = App.CreateItem(0)
   With Item
      .To = MailTo
      .CC = ""
      .BCC = "mail@mail.com"
      .Subject = Subject
      .HTMLBody = "***** " & Body & " *****"
   End With
   Set MsgAttachments = Item.Attachments
   For Each Attachment In Split(Attachments, ",")
      MsgAttachments.Add Attachment
   Next
   Item.Send
End Sub

' Function to determine if we should process this file or not
Function CheckFileName(strName)
   ' Assume we don't process it
   CheckFileName = False

   ' Check start of file name for a match
   If LCase(Left(strName, Len(strBaseName))) = LCase(strBaseName) Then
      ' Check included file types and see if we want this one
      For Each strExt in arrExt
         If LCase(Right(strName, Len(strExt))) = LCase(strExt) Then
            CheckFileName = True
            Exit For
         End If
      Next
   End If
End Function

' Delete files that starts with
On Error Resume Next

Set obj = CreateObject("Scripting.FileSystemObject")
obj.DeleteFile("C:\Users\Wassim.QA-DOMAIN\Desktop\Export Invoices\4667-*.*")

 Thanks,
0
Comment
Question by:Wass_QA
  • 14
  • 12
27 Comments
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39619820
Hi,

pls try
' Subroutine to send the email with the file attached
Sub Email(MailFrom, MailTo, Subject, Body, Attachments)
    Set App = CreateObject("Outlook.Application")
   
    FoundAccount = False

    'loop through and find Outlook account based on from email address
    Set olAccounts = App.Application.Session.Accounts
    For Each olAccountTemp In olAccounts
        If (olAccountTemp.smtpAddress = MailFrom) Then
            Set olAccount = olAccountTemp
            FoundAccount = True
            Exit For
        End If
    Next


    If (FoundAccount) Then
        Set olMail = App.CreateItem(0)
        With olMail
            .SendUsingAccount = olAccount
            .To = MailTo
            .CC = ""
            .BCC = "mail@mail.com"
            .Subject = Subject
            .HTMLBody = "***** " & Body & " *****"
        End With
        Set MsgAttachments = Item.Attachments
        For Each Attachment In Split(Attachments, ",")
            MsgAttachments.Add Attachment
        Next
        Item.Send
    End If
End Sub

Open in new window

Regards
0
 

Author Comment

by:Wass_QA
ID: 39619832
Hello,
it is not sending any email.

where do I put the mailfrom account info?

Thanks,
0
 

Author Comment

by:Wass_QA
ID: 39619875
Hello,
I added the MailFrom into the Specify email related info section
but still not sending.

this is what I have


' Define location and names for file selection
strBaseDir = "C:\Users\Wassim.QA-DOMAIN\Desktop\Export Invoices"
strBaseName = "4667-"

arrExt = Array(".csv", ".txt", ".pdf" ,"xls" ,"xlsx")

' Specify email related information
MailFrom = "mail@mail.com"
MailTo = "mail@mail.com"
Subject = "Files"
Body = "***** Please see attached *****"

' Create file system object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Access the folder where the files exist
Set objFolder = objFSO.GetFolder(strBaseDir)

' Process all files in this folder, and look for name matches
For Each objFile in objFolder.Files
   If CheckFileName(objFile.Name) Then
      Attachments = Attachments & "," & objFile.Path
   End If
Next

If Left(Attachments, 1) = "," Then
   Attachments = Mid(Attachments, 2)
End If

If Attachments <> "" Then
   Email MailFrom, MailTo, Subject, Body, Attachments
End If

' Subroutine to send the email with the file attached
Sub Email(MailFrom, MailTo, Subject, Body, Attachments)
    Set App = CreateObject("Outlook.Application")
   
    FoundAccount = False

    'loop through and find Outlook account based on from email address
    Set olAccounts = App.Application.Session.Accounts
    For Each olAccountTemp In olAccounts
        If (olAccountTemp.smtpAddress = MailFrom) Then
            Set olAccount = olAccountTemp
            FoundAccount = True
            Exit For
        End If
    Next

    If (FoundAccount) Then
        Set olMail = App.CreateItem(0)
        With olMail
            .SendUsingAccount = olAccount
            .To = MailTo
            .CC = ""
            .BCC = "mail@mail.com"
            .Subject = Subject
            .HTMLBody = "***** " & Body & " *****"
        End With
        Set MsgAttachments = Item.Attachments
        For Each Attachment In Split(Attachments, ",")
            MsgAttachments.Add Attachment
        Next
        Item.Send
    End If
End Sub
     
' Function to determine if we should process this file or not
Function CheckFileName(strName)
   ' Assume we don't process it
   CheckFileName = False

   ' Check start of file name for a match
   If LCase(Left(strName, Len(strBaseName))) = LCase(strBaseName) Then
      ' Check included file types and see if we want this one
      For Each strExt in arrExt
         If LCase(Right(strName, Len(strExt))) = LCase(strExt) Then
            CheckFileName = True
            Exit For
         End If
      Next
   End If
End Function
0
 

Author Comment

by:Wass_QA
ID: 39619920
I forgot to mention,
I get error

Line 62
Char 9
Error Object required: Item

thanks
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620237
Hi,

Corrected code
' Define location and names for file selection
strBaseDir = "C:\Users\Wassim.QA-DOMAIN\Desktop\Export Invoices"
strBaseName = "4667-"

arrExt = Array(".csv", ".txt", ".pdf" ,"xls" ,"xlsx")

' Specify email related information
MailFrom = "mail@mail.com"
MailTo = "mail@mail.com"
Subject = "Files"
Body = "***** Please see attached *****"

' Create file system object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Access the folder where the files exist
Set objFolder = objFSO.GetFolder(strBaseDir)

' Process all files in this folder, and look for name matches
For Each objFile in objFolder.Files
   If CheckFileName(objFile.Name) Then
      Attachments = Attachments & "," & objFile.Path
   End If
Next

If Left(Attachments, 1) = "," Then
   Attachments = Mid(Attachments, 2)
End If

If Attachments <> "" Then
   Email MailFrom, MailTo, Subject, Body, Attachments
End If

' Subroutine to send the email with the file attached
Sub Email(MailFrom, MailTo, Subject, Body, Attachments)
    Set App = CreateObject("Outlook.Application")
   
    FoundAccount = False

    'loop through and find Outlook account based on from email address
    Set olAccounts = App.Application.Session.Accounts
    For Each olAccountTemp In olAccounts
        If (olAccountTemp.smtpAddress = MailFrom) Then
            Set olAccount = olAccountTemp
            FoundAccount = True
            Exit For
        End If
    Next

    If (FoundAccount) Then
        Set olMail = App.CreateItem(0)
        With olMail
            .SendUsingAccount = olAccount
            .To = MailTo
            .CC = ""
            .BCC = "mail@mail.com"
            .Subject = Subject
            .HTMLBody = "***** " & Body & " *****"
        End With
        Set MsgAttachments = olMail.Attachments
        For Each Attachment In Split(Attachments, ",")
            MsgAttachments.Add Attachment
        Next
        Item.Send
    End If
End Sub
     
' Function to determine if we should process this file or not
Function CheckFileName(strName)
   ' Assume we don't process it
   CheckFileName = False

   ' Check start of file name for a match
   If LCase(Left(strName, Len(strBaseName))) = LCase(strBaseName) Then
      ' Check included file types and see if we want this one
      For Each strExt in arrExt
         If LCase(Right(strName, Len(strExt))) = LCase(strExt) Then
            CheckFileName = True
            Exit For
         End If
      Next
   End If
End Function 

Open in new window

Regards
0
 

Author Comment

by:Wass_QA
ID: 39620243
Hello,
I still get error

Line 64
Char 9
Error Object Required:  Item
code 800A01A8

Thanks,
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620256
forgot the last "item"

' Define location and names for file selection
strBaseDir = "C:\Users\Wassim.QA-DOMAIN\Desktop\Export Invoices"
strBaseName = "4667-"

arrExt = Array(".csv", ".txt", ".pdf" ,"xls" ,"xlsx")

' Specify email related information
MailFrom = "mail@mail.com"
MailTo = "mail@mail.com"
Subject = "Files"
Body = "***** Please see attached *****"

' Create file system object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Access the folder where the files exist
Set objFolder = objFSO.GetFolder(strBaseDir)

' Process all files in this folder, and look for name matches
For Each objFile in objFolder.Files
   If CheckFileName(objFile.Name) Then
      Attachments = Attachments & "," & objFile.Path
   End If
Next

If Left(Attachments, 1) = "," Then
   Attachments = Mid(Attachments, 2)
End If

If Attachments <> "" Then
   Email MailFrom, MailTo, Subject, Body, Attachments
End If

' Subroutine to send the email with the file attached
Sub Email(MailFrom, MailTo, Subject, Body, Attachments)
    Set App = CreateObject("Outlook.Application")
   
    FoundAccount = False

    'loop through and find Outlook account based on from email address
    Set olAccounts = App.Application.Session.Accounts
    For Each olAccountTemp In olAccounts
        If (olAccountTemp.smtpAddress = MailFrom) Then
            Set olAccount = olAccountTemp
            FoundAccount = True
            Exit For
        End If
    Next

    If (FoundAccount) Then
        Set olMail = App.CreateItem(0)
        With olMail
            .SendUsingAccount = olAccount
            .To = MailTo
            .CC = ""
            .BCC = "mail@mail.com"
            .Subject = Subject
            .HTMLBody = "***** " & Body & " *****"
        End With
        Set MsgAttachments = olMail.Attachments
        For Each Attachment In Split(Attachments, ",")
            MsgAttachments.Add Attachment
        Next
        olMail.Send
    End If
End Sub
     
' Function to determine if we should process this file or not
Function CheckFileName(strName)
   ' Assume we don't process it
   CheckFileName = False

   ' Check start of file name for a match
   If LCase(Left(strName, Len(strBaseName))) = LCase(strBaseName) Then
      ' Check included file types and see if we want this one
      For Each strExt in arrExt
         If LCase(Right(strName, Len(strExt))) = LCase(strExt) Then
            CheckFileName = True
            Exit For
         End If
      Next
   End If
End Function 

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 39620264
Appreciate your time and help,
it is working, but , it is not sending from the set MAILFROM email address.

it is sending the email from the outlook default address.

thanks,
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620279
Just to be sure which Office Version do you have

because this a function new in OL2007
0
 

Author Comment

by:Wass_QA
ID: 39620286
Outlook 2007.

I have about  9 email accounts

it is always picking up the default email address to send from.

Thanks,
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620313
Hi

pls try this to see which account you can Access

Sub TestMail()
    Set App = CreateObject("Outlook.Application")
    
    'loop through and find Outlook account based on from email address
    Set olAccounts = App.Application.Session.Accounts
    For Each olAccountTemp In olAccounts
        MsgBox olAccountTemp
    Next
End Sub

Open in new window

Regards
0
 

Author Comment

by:Wass_QA
ID: 39620320
If  I run the Sub from Outlook,
I get this error message.

Compile Error
Assigned to constant and permitted.
 
olAccounts =

thanks.
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620329
Hi,

try this one

Sub TestMail()
    Set App = CreateObject("Outlook.Application")
    
    'loop through and find Outlook account based on from email address
    Set olAccounts = App.Session.Accounts
    For Each olAccountTemp In olAccounts
        MsgBox olAccountTemp
    Next
End Sub

Open in new window

0
Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

 

Author Comment

by:Wass_QA
ID: 39620334
Hello,

Compile Error
Assignment  to constant not permitted.

olAccounts =

Thanks
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620347
Assignment  to constant not permitted.

•You tried to assign a new value to a variable declared with Const, or to a type library constant. If you need to assign a new value, declare an ordinary variable of the type desired and assign your value to that variable. If you need a variable with a restricted set of values, you can declare an enumeration, using the Enum statement.

maybe try the code in a new Project

regards
0
 

Author Comment

by:Wass_QA
ID: 39620354
if I run the sub in Excel,
I get no errors.
I hit an OK message for each email account.

thanks
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620360
Where was the code before?

and was the email you wanted to send with typed as you typed it in the code?
0
 

Author Comment

by:Wass_QA
ID: 39620361
outlook,
thanks
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620371
Hi,

Because it doesn't make sense to call Outlook inside Outlook

' Subroutine to send the email with the file attached
Sub Email(MailFrom, MailTo, Subject, Body, Attachments)
   Set App = CreateObject("Outlook.Application")

pls try now

' Subroutine to send the email with the file attached
Sub Email(MailFrom, MailTo, Subject, Body, Attachments)
   
    FoundAccount = False

    'loop through and find Outlook account based on from email address
    Set olAccounts = Application.Session.Accounts
    For Each olAccountTemp In olAccounts
        If (olAccountTemp.smtpAddress = MailFrom) Then
            Set olAccount = olAccountTemp
            FoundAccount = True
            Exit For
        End If
    Next

    If (FoundAccount) Then
        Set olMail = CreateItem(0)
        With olMail
            .SendUsingAccount = olAccount
            .To = MailTo
            .CC = ""
            .BCC = "mail@mail.com"
            .Subject = Subject
            .HTMLBody = "***** " & Body & " *****"
        End With
        Set MsgAttachments = olMail.Attachments
        For Each Attachment In Split(Attachments, ",")
            MsgAttachments.Add Attachment
        Next
        olMail.Send
    End If
End Sub

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 39620416
Sorry, I think I misunderstood ,
when you sent me the 2 test subs,
I was testing them by themselves outside the Main script.

if I try the full code in vbs (DOUBLE CLICKING)
I get error
LINE 41
CHAR 2
ERROR: OBJECT REQUIRED: APPLICATION


' Define location and names for file selection
strBaseDir = "C:\Users\Wassim.QA-DOMAIN\Desktop\Export Invoices"
strBaseName = "4667-"

arrExt = Array(".csv", ".txt", ".pdf" ,"xls" ,"xlsx")

' Specify email related information
MailFrom = "mail@mail.com"
MailTo = "mail@mail.com"
Subject = "Files"
Body = "***** Please see attached *****"

' Create file system object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' Access the folder where the files exist
Set objFolder = objFSO.GetFolder(strBaseDir)

' Process all files in this folder, and look for name matches
For Each objFile in objFolder.Files
   If CheckFileName(objFile.Name) Then
      Attachments = Attachments & "," & objFile.Path
   End If
Next

If Left(Attachments, 1) = "," Then
   Attachments = Mid(Attachments, 2)
End If

If Attachments <> "" Then
   Email MailFrom, MailTo, Subject, Body, Attachments
End If


' Subroutine to send the email with the file attached
Sub Email(MailFrom, MailTo, Subject, Body, Attachments)

    FoundAccount = False

    'loop through and find Outlook account based on from email address
      Set olAccounts = Application.Session.Accounts
    For Each olAccountTemp In olAccounts
        If (olAccountTemp.smtpAddress = MailFrom) Then
            Set olAccount = olAccountTemp
            FoundAccount = True
            Exit For
        End If
    Next

    If (FoundAccount) Then
        Set olMail = CreateItem(0)
        With olMail
            .SendUsingAccount = olAccount
            .To = MailTo
            .CC = ""
            .BCC = "mail@mail.com"
            .Subject = Subject
            .HTMLBody = "***** " & Body & " *****"
        End With
        Set MsgAttachments = olMail.Attachments
        For Each Attachment In Split(Attachments, ",")
            MsgAttachments.Add Attachment
        Next
        olMail.Send
    End If
End Sub
                                           
' Function to determine if we should process this file or not
Function CheckFileName(strName)
   ' Assume we don't process it
   CheckFileName = False

   ' Check start of file name for a match
   If LCase(Left(strName, Len(strBaseName))) = LCase(strBaseName) Then
      ' Check included file types and see if we want this one
      For Each strExt in arrExt
         If LCase(Right(strName, Len(strExt))) = LCase(strExt) Then
            CheckFileName = True
            Exit For
         End If
      Next
   End If
End Function
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39620822
Hi,

Do you mean?

Set olMail = CreateItem(0) then replace by Set olMail = Application.CreateItem(0)
0
 

Author Comment

by:Wass_QA
ID: 39621146
Hello,
I replaced
Set olMail = CreateItem(0)  WITH  Set olMail = Application.CreateItem(0)

I still get error
Line 43
Char 5
Error: Object required: Aapplication

Line 43 is
    Set olAccounts = Application.Session.Accounts

thanks,
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39621436
let's try a diferent approach dclaring all the OL variables:
Sub Email(MailFrom, MailTo, Subject, Body, Attachments)

    Dim olSession As Outlook.Namespace
    Dim olAccounts As Outlook.Accounts
    Dim olAccount As Outlook.Account
    Dim olAccountTemp As Outlook.Account
    
    Set olSession = Application.Session
    
    Set olAccounts = olSession.Accounts

    FoundAccount = False

    'loop through and find Outlook account based on from email address

    For Each olAccountTemp In olAccounts
        If (olAccountTemp.smtpAddress = MailFrom) Then
            Set olAccount = olAccountTemp
            FoundAccount = True
            Exit For
        End If
    Next

    If (FoundAccount) Then
        Set olMail = CreateItem(0)
        With olMail
            .SendUsingAccount = olAccount
            .To = MailTo
            .CC = ""
            .BCC = "mail@mail.com"
            .Subject = Subject
            .HTMLBody = "***** " & Body & " *****"
        End With
        Set MsgAttachments = olMail.Attachments
        For Each Attachment In Split(Attachments, ",")
            MsgAttachments.Add Attachment
        Next
        olMail.Send
    End If
End Sub

Open in new window

0
 

Author Comment

by:Wass_QA
ID: 39621450
Hello,

Line 38
Char 19
Error: Expected end of statement
code 800A0401

    Dim olSession As Outlook.Namespace

Thanks,
0
 
LVL 48

Accepted Solution

by:
Rgonzo1971 earned 300 total points
ID: 39621512
Now I have another idea

Sub Email(MailFrom, MailTo, Subject, Body, Attachments)

    Set App = CreateObject("Outlook.Application")
    FoundAccount = False
    
    Set olAccounts = App.Application.Session.Accounts
    For Idx = 1 To olAccounts.Count
        If (olAccounts(Idx).smtpaddress = MailFrom) Then
            idxAccount = Idx
            FoundAccount = True
            Exit For
        End If
    Next


    If (FoundAccount) Then
        Set olMail = App.CreateItem(0)
        With olMail
            Set .SendUsingAccount = .Session.Accounts.Item(IdxAccount)
            .To = MailTo
            .CC = ""
            .BCC = "mail@mail.com"
            .Subject = Subject
            .HTMLBody = "***** " & Body & " *****"
        End With
        Set MsgAttachments = olMail.Attachments
        For Each Attachment In Split(Attachments, ",")
            MsgAttachments.Add Attachment
        Next
        olMail.Display
    End If
End Sub

Open in new window

0
 

Author Closing Comment

by:Wass_QA
ID: 39622728
very much appreciated.
thank you for your time and help.
works great.
0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

This is pretty cool.  The purpose of this VB Script is to help you document where JAR (Java ARchive) files and specifically java class files are located so that you can address issues seen with a client or that you can speak intelligently with a dev…
Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
This video discusses moving either the default database or any database to a new volume.
In this tutorial you'll learn about bandwidth monitoring with flows and packet sniffing with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're interested in additional methods for monitoring bandwidt…

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now