L
LeAnn
Hi,
I have followed Ron's instructions from http://www.rondebruin.nl/cdo.htm and
I am not getting any emails. A few things I know:
I am able to send .csv & .xls as attachments through our firewall.
The copy doesn't contain any VBA code so the firewall isn't blocking it.
I am able to manually email as an attachment, the orignally saved file.
Yes my email account is setup.
I receive no errors and the code appears to work as expected.
I even tried the simple text example on Ron's page and never got the email.
My code is below. Can anyone see a problem with it or suggest some
investigative actions I should take? I'm not sure how to "Check your
firewall settings".
Thanks
LeAnn
Sub Button1_Click()
Dim strUnit As String
Dim strFname As String
Worksheets(1).Activate
Range("A2").Select
strUnit = ActiveCell.Value
strFname = Worksheets("Parameters").Range("B1").Value & Format(Now(),
"mmddyyyyhhnn") & ".csv"
Do Until strUnit = ""
If Left(strUnit, 1) = "=" Then
strUnit = Mid(strUnit, 2, 15)
ActiveCell.Value = strUnit
End If
ActiveCell.Value = UCase(strUnit)
ActiveCell.Offset(1, 0).Select
strUnit = ActiveCell.Value
Loop
ActiveWorkbook.SaveAs strFname, xlCSV
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
' Dim Flds As Variant
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no
VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro
again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name
wb.SaveCopyAs TempFilePath & TempFileName
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in
your SMTP server here"
'
..Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With
With iMsg
Set .Configuration = iConf
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.From = """Center XXX"" <someone@somewhere>"
.Subject = "List"
.TextBody = ""
.AddAttachment TempFilePath & TempFileName
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Application.Quit
End Sub
I have followed Ron's instructions from http://www.rondebruin.nl/cdo.htm and
I am not getting any emails. A few things I know:
I am able to send .csv & .xls as attachments through our firewall.
The copy doesn't contain any VBA code so the firewall isn't blocking it.
I am able to manually email as an attachment, the orignally saved file.
Yes my email account is setup.
I receive no errors and the code appears to work as expected.
I even tried the simple text example on Ron's page and never got the email.
My code is below. Can anyone see a problem with it or suggest some
investigative actions I should take? I'm not sure how to "Check your
firewall settings".
Thanks
LeAnn
Sub Button1_Click()
Dim strUnit As String
Dim strFname As String
Worksheets(1).Activate
Range("A2").Select
strUnit = ActiveCell.Value
strFname = Worksheets("Parameters").Range("B1").Value & Format(Now(),
"mmddyyyyhhnn") & ".csv"
Do Until strUnit = ""
If Left(strUnit, 1) = "=" Then
strUnit = Mid(strUnit, 2, 15)
ActiveCell.Value = strUnit
End If
ActiveCell.Value = UCase(strUnit)
ActiveCell.Offset(1, 0).Select
strUnit = ActiveCell.Value
Loop
ActiveWorkbook.SaveAs strFname, xlCSV
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
' Dim Flds As Variant
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no
VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro
again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name
wb.SaveCopyAs TempFilePath & TempFileName
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in
your SMTP server here"
'
..Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
' End With
With iMsg
Set .Configuration = iConf
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.From = """Center XXX"" <someone@somewhere>"
.Subject = "List"
.TextBody = ""
.AddAttachment TempFilePath & TempFileName
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Application.Quit
End Sub