Excel VBA to email active Workbook via Hotmail or GMail

J

JohnnyC26

New Member
Joined
Jul 7, 2017
Messages
3
Hi all,


This one has been driving me crazy for days now. Finally time to admit defeat and 'Phone a Friend'


Firstly a bit of background...


I am the League Administrator for a regional Sports League and I'm looking to replace their, (currently paper based), 'Match Card' system with an online system using Excel. The requirement of the Match Card is to record basic fixture information such as Player Names, Goal Scorers, Red/Yellow Cards... etc..


I have created an Excel Template of the Match Card and am able to allow access to it via the Leagues Website. So far I am able to access the Excel Match Card via the web and complete it with relevant information. However, the issue I am having is that I am unable to correctly script a VBA code that, when a button is pressed, will:


A) Save a temporary version of the active Excel Workbook.
B) Use the Leagues existing Hotmail or GMail account to email me a copy of the Workbook as an attachment.
C) Delete the temporary file.


I had originally hoped to use Outlook to achieve this as I had managed to script some VBA that completes all required tasks with Outlook. However, I then realised that I cannot guarentee that every Club Representative, (the people who will be filling the online Match Cards), will have Outlook on their PCs so what I actually need is to script the VBA to use the League's web-based e-mail services such as Hotmail or GMail.


All of my efforts so far have led to dead-ends. Is this even possible?


Thanks in advance,
Johnny.
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
Try something like this:

Code: 
Option Explicit

' ====================================
' References Microsoft CDO for Windows
' and Microsoft ActiveX Data Objects
' ====================================

Public Sub SendEmail(strEmail As String, strPassword As String)
' The parameters are your (the sender's)
' email address and password
  
  Const strNAMESPACE = "http://schemas.microsoft.com/cdo/configuration/"
  Dim cdoConfig As CDO.Configuration
  Dim cdoMessage As CDO.Message
  Dim adoFields As ADODB.Fields
  Dim strTempName As String
  
  On Error GoTo ErrHandler
' Make a temporary copy of this workbook
  strTempName = RemoveExtension(ThisWorkbook.Name)
  strTempName = strTempName & Format(Now(), "_yyyy-mm-ddThhmmss")
  strTempName = strTempName & "." & GetExtension(ThisWorkbook.Name)
  strTempName = Environ("UserProfile") & "\Documents\" & strTempName
  ThisWorkbook.SaveCopyAs strTempName
  
  Set cdoConfig = New CDO.Configuration
  Set adoFields = cdoConfig.Fields
  adoFields(strNAMESPACE & "sendusing") = cdoSendUsingPort
  adoFields(strNAMESPACE & "smtpauthenticate") = cdoBasic
  adoFields(strNAMESPACE & "smtpconnectiontimeout") = 60
  adoFields(strNAMESPACE & "sendusername") = strEmail
  adoFields(strNAMESPACE & "sendpassword") = strPassword
  
' The following are the SMTP server settings for Gmail.
' You MUST also turn on access for less secure apps in
' your Gmail account security settings.
  adoFields(strNAMESPACE & "smtpserver") = "smtp.gmail.com"
  adoFields(strNAMESPACE & "smtpserverport") = 465
  adoFields(strNAMESPACE & "smtpusessl") = True
  adoFields.Update

  Set cdoMessage = New CDO.Message
  Set cdoMessage.Configuration = cdoConfig
  cdoMessage.From = strEmail
  cdoMessage.To = "user@domain.com"
  cdoMessage.Subject = "Enter the message subject here."
  cdoMessage.HTMLBody = "<html>******>Enter the message body here.</body></html>"
  cdoMessage.AddAttachment strTempName
  cdoMessage.Send
  MsgBox "Email was sent.", vbInformation

ExitProc:
  On Error Resume Next
  Kill strTempName
  Set cdoConfig = Nothing
  Set cdoMessage = Nothing
  Set adoFields = Nothing
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitProc
End Sub

Function GetExtension(strFilename As String) As String
  Dim x As Integer
  x = InStrRev(strFilename, ".")
  If x > 0 Then GetExtension = Right(strFilename, Len(strFilename) - x)
End Function

Function RemoveExtension(strFilename As String) As String
  Dim x As Integer
  x = InStrRev(strFilename, ".")
  If x > 0 Then
    RemoveExtension = Left(strFilename, x - 1)
  Else
    RemoveExtension = strFilename
  End If
End Function
 
Upvote 0
Hi, thanks for getting back to me on this one, very much appreciated. I am afraid this isn't working though.

I initially came up against an error in relation to the : 'Dim adoFields As ADODB.Fields' line.
The error message was : "Compile Error : User-defined type not defined"

I deleted this line to see what effect that had and I am now getting the following message:

"Microsoft Excel cannot access the file
'C:\Users"*************"\Documents\TestBook_2017-07-10T110846.xlsm'.
There are several possible reasons:

>The file name or path does not exist.
>The file is being used by another program.
>The workbook you are trying to save has the same name as a currently open workbook."




As things stand the code I am using is as follows:

Sub SendEmail()

Const strNAMESPACE = "http://schemas.microsoft.com/cdo/configuration/"
Dim cdoConfig As CDO.Configuration
Dim cdoMessage As CDO.Message
Dim strTempName As String

On Error GoTo ErrHandler
strTempName = RemoveExtension(ThisWorkbook.Name)
strTempName = strTempName & Format(Now(), "_yyyy-mm-ddThhmmss")
strTempName = strTempName & "." & GetExtension(ThisWorkbook.Name)
strTempName = Environ("UserProfile") & "\Documents" & strTempName
ThisWorkbook.SaveCopyAs strTempName

Set cdoConfig = New CDO.Configuration
Set adoFields = cdoConfig.Fields
adoFields(strNAMESPACE & "sendusing") = cdoSendUsingPort
adoFields(strNAMESPACE & "smtpauthenticate") = cdoBasic
adoFields(strNAMESPACE & "smtpconnectiontimeout") = 60
adoFields(strNAMESPACE & "sendusername") = "*********"
adoFields(strNAMESPACE & "sendpassword") = "*********"


adoFields(strNAMESPACE & "smtpserver") = "smtp-mail.outlook.com"
adoFields(strNAMESPACE & "smtpserverport") = 587
adoFields(strNAMESPACE & "smtpusessl") = True
adoFields.Update

Set cdoMessage = New CDO.Message
Set cdoMessage.Configuration = cdoConfig
cdoMessage.From = strEmail
cdoMessage.To = "nehlc@live.co.uk"
cdoMessage.Subject = "Subject Mail Test"
cdoMessage.HTMLBody = "Message body..."
cdoMessage.AddAttachment strTempName
cdoMessage.Send
MsgBox "Email was sent.", vbInformation

ExitProc:
On Error Resume Next
Kill strTempName
Set cdoConfig = Nothing
Set cdoMessage = Nothing
Set adoFields = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitProc
End Sub


Function GetExtension(strFilename As String) As String
Dim x As Integer
x = InStrRev(strFilename, ".")
If x > 0 Then GetExtension = Right(strFilename, Len(strFilename) - x)
End Function


Function RemoveExtension(strFilename As String) As String
Dim x As Integer
x = InStrRev(strFilename, ".")
If x > 0 Then
RemoveExtension = Left(strFilename, x - 1)
Else
RemoveExtension = strFilename
End If
End Function




Any further ideas/suggestions?
Thank you!!!
 
Upvote 0
You can't just delete the line (!!) - you need to add the appropriate references, as explained at the top of the module, via Tools --> References in the IDE. Also it appears you have modified the code that creates the temporary file (!!) - change it back. I have tested this and it works very well.
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question Question
Automatically Send Emails everyday from Excel Based on Cell date comes to today date
Replies
5
Views
2K
ganesh0604
G
I
  • Solved
Excel VBA Question: Button Click to create a new email
Replies
5
Views
546
mumps
mumps
B
  • Question Question
Macro to open a new email via Outlook
Replies
3
Views
809
skillilea
S
V
  • Question Question
Excel for Mac 2021 v16.81. Send bulk email with an attachmen
Replies
2
Views
583
vk2023
V
A
  • Solved
Copy Entire Workbook, save as sheet name with current date, hide all sheets except one, & attach to email
Replies
2
Views
641
Amo840812
A

Forum statistics

Threads
1,224,827
Messages
6,181,194
Members
453,021
Latest member
pingpong7117

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top