Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

VBS Email From

Posted on 2013-11-03
27
Medium Priority
?
545 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:W.E.B
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 14
  • 12
27 Comments
 
LVL 52

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:W.E.B
ID: 39619832
Hello,
it is not sending any email.

where do I put the mailfrom account info?

Thanks,
0
 

Author Comment

by:W.E.B
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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 

Author Comment

by:W.E.B
ID: 39619920
I forgot to mention,
I get error

Line 62
Char 9
Error Object required: Item

thanks
0
 
LVL 52

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:W.E.B
ID: 39620243
Hello,
I still get error

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

Thanks,
0
 
LVL 52

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:W.E.B
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 52

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:W.E.B
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 52

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:W.E.B
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 52

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
 

Author Comment

by:W.E.B
ID: 39620334
Hello,

Compile Error
Assignment  to constant not permitted.

olAccounts =

Thanks
0
 
LVL 52

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:W.E.B
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 52

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:W.E.B
ID: 39620361
outlook,
thanks
0
 
LVL 52

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:W.E.B
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 52

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:W.E.B
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 52

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:W.E.B
ID: 39621450
Hello,

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

    Dim olSession As Outlook.Namespace

Thanks,
0
 
LVL 52

Accepted Solution

by:
Rgonzo1971 earned 1200 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:W.E.B
ID: 39622728
very much appreciated.
thank you for your time and help.
works great.
0

Featured Post

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Welcome back!  My apologies for taking so long to write part two of this series; it's been a long time coming!  As I promised in Part 1, this article will focus on how to locate those elusive AD properties that you are searching for.  Why is this us…
Introduction During my participation as a VBScript contributor at Experts Exchange, one of the most common questions I come across is this: "I have a script that runs against only one computer. How can I make it run against a list of computers in …
In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…
In this video, Percona Solution Engineer Rick Golba discuss how (and why) you implement high availability in a database environment. To discuss how Percona Consulting can help with your design and architecture needs for your database and infrastr…
Suggested Courses

715 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