Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 553
  • Last Modified:

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,
0
W.E.B
Asked:
W.E.B
  • 14
  • 12
1 Solution
 
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
 
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
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
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
 
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
 
W.E.BAuthor Commented:
very much appreciated.
thank you for your time and help.
works great.
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 14
  • 12
Tackle projects and never again get stuck behind a technical roadblock.
Join Now