VBS Email From

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,
W.E.BAsked:
Who is Participating?
 
Rgonzo1971Commented:
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
 
Rgonzo1971Commented:
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
 
W.E.BAuthor Commented:
Hello,
it is not sending any email.

where do I put the mailfrom account info?

Thanks,
0
Cloud Class® Course: Microsoft Office 2010

This course will introduce you to the interfaces and features of Microsoft Office 2010 Word, Excel, PowerPoint, Outlook, and Access. You will learn about the features that are shared between all products in the Office suite, as well as the new features that are product specific.

 
W.E.BAuthor Commented:
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
 
W.E.BAuthor Commented:
I forgot to mention,
I get error

Line 62
Char 9
Error Object required: Item

thanks
0
 
Rgonzo1971Commented:
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
 
W.E.BAuthor Commented:
Hello,
I still get error

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

Thanks,
0
 
Rgonzo1971Commented:
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
 
W.E.BAuthor Commented:
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
 
Rgonzo1971Commented:
Just to be sure which Office Version do you have

because this a function new in OL2007
0
 
W.E.BAuthor Commented:
Outlook 2007.

I have about  9 email accounts

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

Thanks,
0
 
Rgonzo1971Commented:
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
 
W.E.BAuthor Commented:
If  I run the Sub from Outlook,
I get this error message.

Compile Error
Assigned to constant and permitted.
 
olAccounts =

thanks.
0
 
Rgonzo1971Commented:
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
 
W.E.BAuthor Commented:
Hello,

Compile Error
Assignment  to constant not permitted.

olAccounts =

Thanks
0
 
Rgonzo1971Commented:
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
 
W.E.BAuthor Commented:
if I run the sub in Excel,
I get no errors.
I hit an OK message for each email account.

thanks
0
 
Rgonzo1971Commented:
Where was the code before?

and was the email you wanted to send with typed as you typed it in the code?
0
 
W.E.BAuthor Commented:
outlook,
thanks
0
 
Rgonzo1971Commented:
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
 
W.E.BAuthor Commented:
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
 
Rgonzo1971Commented:
Hi,

Do you mean?

Set olMail = CreateItem(0) then replace by Set olMail = Application.CreateItem(0)
0
 
W.E.BAuthor Commented:
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
 
Rgonzo1971Commented:
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
 
W.E.BAuthor Commented:
Hello,

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

    Dim olSession As Outlook.Namespace

Thanks,
0
 
W.E.BAuthor Commented:
very much appreciated.
thank you for your time and help.
works great.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.