Adding Date and changing file type using VBA in Outlook

[dwhite30518]

Good afternoon!!!

I found the following code and it works well but I would like to modify a few things. This is the code I found.


Public Sub SaveRSA()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

strFolderpath = "S:\Departments\Service & Production\Public\TDC Delivery Information"
On Error Resume Next

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection


strFolderpath = strFolderpath & "\RSA Received - 2013\"


For Each objMsg In objSelection

Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then



For i = lngCount To 1 Step -1


strFile = objAttachments.Item(i).FileName


strFile = strFolderpath & strFile


objAttachments.Item(i).SaveAsFile strFile

Next i
End If

Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub

This code just saves the attachment the same as it was emailed. I would like to modify it to save as a regular excel workbook rather than a CSV file. Also, I would like to be able to add the date the email was received to the file name. So if the attachment was "Repair Report.csv" and the email was received on 10/5/2013, then I want the file to save as "Repair Report 10.5.2013.xlsx(or .xls)

Any ideas on how I can make those changes to reflect this?

Thanks and look forward to your feedback!!!!!

[mrojas]

Add the following code below last Dim statement
Dim strDateFileName as String
Dim strFileExtension as String

Add the following code immediately above the For loop
' Format date to string with dashes
strDateFileName = Year(Now) & "-" & Month(Now) & "-" & Day(Now)
' Dot extension name
strFileExtension=".xls"

Replace the second strFile statement with the following:

strFile=strFolderPath & strFile & "-" & strDateFileName & strFileExtension

[dwhite30518]

So if I understand your changes correctly then the code should look like....


Public Sub SaveRSA()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim strDateFileName As String
Dim strFileExtension As String


strFolderpath = "S:\Departments\Service & Production\Public\TDC Delivery Information"
On Error Resume Next

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection


strFolderpath = strFolderpath & "\RSA Received - 2013\"

strDateFileName = Year(Now) & "-" & Month(Now) & "-" & Day(Now)

For Each objMsg In objSelection

Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then



For i = lngCount To 1 Step -1


strFile = objAttachments.Item(i).FileName

strFileExtension = ".xls"

strFile = strFolderpath & strFile & "-" & strDateFileName & strFileExtension


objAttachments.Item(i).SaveAsFile strFile

Next i
End If

Next

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub




Right???

[mrojas]

Correct. Your save file will have .csv followed by the date followed by .xls
If you want to change the date from Now to date received, you'll have to retrieve that date from the email.

[dwhite30518]

OK...let me clarify what I would like to do....I receive an email that has the attachment I want to save to a location. The attachment currently already has a name but I want to add the date the email was received and then save as an excel file not as a .csv file....what is the best way to do that?

[skatonni]

Here is one way to add a date.

strFile = Replace(strFile, ".csv", "")
strFile = strFolderpath & strFile & " " & Left(objMsg.ReceivedTime, 10)
objAttachments.item(i).SaveAsFile strFile & ".csv"

So now the file is saved with the received date.

But save it in a temporary folder, say C:\temp not S:\....

strFolderpath = "C:\temp"

To convert to an Excel file format, call this just before ExitSub:


Sub csv_to_xls()

Dim appexcel As Excel.Application

Dim wb As Workbook
Dim strFile As String
Dim strDir As String

Dim strFileXL As String
Dim strDirXL As String

Set appexcel = CreateObject("Excel.Application")

strDir = "C:\temp\"

strFile = Dir(strDir & "*.csv")

Do While strFile <> ""

strDirXL = "S:\Departments\Service & Production\Public\TDC Delivery Information\RSA Received - 2013\"

strFileXL = Replace(strFile, ".csv", "")

Set wb = Workbooks.Open(strDir & strFile)

With wb
.SaveAs strDirXL & strFileXL, xlWorkbookDefault
.Close True
End With

Set wb = Nothing

Kill strDir & strFile

strFile = Dir(strDir & "*.csv")

Loop

exitRoutine:
Set appexcel = Nothing

End Sub

[dwhite30518]

I added your code and when I run the code I get an error "User-defined type not defined"
and I can't get passed this line...
Dim appexcel As Excel.Application

Ideas???

[dwhite30518]

I figured out my issue with the user-defined and it was because I didn't have Excel references selected in my tools references. I have that resolved however, when I run the code, nothing happens and it seems to skip this portion of the code...

strDirXL = "S:\Departments\Service & Production\Public\Motorola THD Repair Reports\Repair Reports 2013"

strFileXL = Replace(strFile, ".csv", "")

Set wb = Workbooks.Open(strDir & strFile)

With wb
.SaveAs strDirXL & strFileXL, xlWorkbookDefault
.Close True
End With

Set wb = Nothing

Kill strDir & strFile

strFile = Dir(strDir & "*.csv")

Loop

Nothing happens. This is the entire code I am using...

Public Sub RepairReports()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim strDateFileName As String
Dim strFileExtension As String
Dim dtDate As Date
Dim dName As String

strFolderpath = "C:\Users\daniel.white\Documents"
On Error Resume Next

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection


For Each objMsg In objSelection

Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then

dtDate = objMsg.SentOn

dName = Format(dtDate, "mm.dd.yyyy", vbUseSystemDayOfWeek, vbUseSystem)

For i = lngCount To 1 Step -1
If objAttachments.Item(i).Size > 5200 Then

strFile = objAttachments.Item(i).FileName

sName = Left$(strFile, 10)

strFileExtension = ".xls"

strFile = strFolderpath & sName & strFileExtension

objAttachments.Item(i).SaveAsFile strFile
End If
Next i
End If

Next
Call csv_to_xls
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub
and

Sub csv_to_xls()


Dim appexcel As Excel.Application
Dim wb As Workbook
Dim strFile As String
Dim strDir As String

Dim strFileXL As String
Dim strDirXL As String

Set appexcel = CreateObject("Excel.Application")

strDir = "C:\Users\daniel.white\Documents"

strFile = Dir(strDir & "*.csv")

Do While strFile <> ""

strDirXL = "S:\Departments\Service & Production\Public\Motorola THD Repair Reports\Repair Reports 2013"

strFileXL = Replace(strFile, ".csv", "")

Set wb = Workbooks.Open(strDir & strFile)

With wb
.SaveAs strDirXL & strFileXL, xlWorkbookDefault
.Close True
End With

Set wb = Nothing

Kill strDir & strFile

strFile = Dir(strDir & "*.csv")

Loop

exitRoutine:
Set appexcel = Nothing

End Sub

Any ideas why it is not converting the .csv file to and .xls file?????

[skatonni]

You added a fake .xls extension.


strFileExtension = ".xls"

Keep the .csv extension.

Files will be found with


strFile = Dir(strDir & "*.csv")

[dwhite30518]

The attachment is sent as a .csv file but I want this script to convert it from a .csv to a .xls spreadsheet...if I make that simple change will it make the conversion???

[skatonni]

Do not change .csv to the fake .xls in your code.

Try this.

Manually save .csv attachments to the C:\Users\daniel.white\Documents folder. Run the Sub csv_to_xls().

All .csv files with a .csv extension in the C:\Users\daniel.white\Documents folder will be converted.

The problem you had was due to there being no "*.csv" named files in the C:\Users\daniel.white\Documents folder, since you changed the extension to .xls.

[dwhite30518]

OK...so just to make sure I am clear...If I amend the code to...


Public Sub RepairReports()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim strDateFileName As String
Dim strFileExtension As String
Dim dtDate As Date
Dim dName As String

strFolderpath = "C:\Users\daniel.white\Documents"
On Error Resume Next

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection


For Each objMsg In objSelection

Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count

If lngCount > 0 Then

dtDate = objMsg.SentOn

dName = Format(dtDate, "mm.dd.yyyy", vbUseSystemDayOfWeek, vbUseSystem)

For i = lngCount To 1 Step -1
If objAttachments.Item(i).Size > 5200 Then

strFile = objAttachments.Item(i).FileName

sName = Left$(strFile, 10)



strFile = strFolderpath & sName

objAttachments.Item(i).SaveAsFile strFile
End If
Next i
End If

Next
Call csv_to_xls
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub [CODE]

By removing...
[CODE]strFileExtension = ".xls"

and also change...

strFile = strFolderpath & sName & strFileExtension
to

strFile = strFolderpath & sName

then run Sub csv_to_xls(), it should convert from .csv to .xls....right??

[skatonni]

Option Explicit ' <----

Public Sub RepairReports()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.mailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim strDateFileName As String
Dim strFileExtension As String
Dim dtDate As Date
Dim dName As String

strFolderpath = "C:\Users\daniel.white\Documents\" '<-- note the path separator at the end

' On Error Resume Next ' <-- Do not use this unless you know why.
' Follow as soon as possible with On Error GoTo 0

Set objOL = CreateObject("Outlook.Application")

Set objSelection = objOL.ActiveExplorer.Selection

For Each objMsg In objSelection

Set objAttachments = objMsg.Attachments
lngCount = objAttachments.count

If lngCount > 0 Then

dtDate = objMsg.SentOn

' I found dots in the name did not work
dName = Format(dtDate, "mm-dd-yyyy", vbUseSystemDayOfWeek, vbUseSystem)

For i = lngCount To 1 Step -1

If objAttachments.Item(i).Size > 5200 Then

strFile = objAttachments.Item(i).FileName

' There are likely better ways to rename the file than my suggestion
strFile = Replace(strFile, ".csv", "") ' drop the extension
strFile = strFile & " " & dName ' add the date to the name
strFile = strFolderpath & strFile & ".csv" ' put the extension back in the name

Debug.Print strFile ' To see the path has all the path separators as required

objAttachments.Item(i).SaveAsFile strFile

End If

Next i

End If

Next

Call csv_to_xls

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub

[dwhite30518]

OK...So it saves the file to the correct path and folder but it still shows as a .csv file rather than a normal .xls file...ideas???

[skatonni]

If the files are in the temporary folder C:\Users\daniel.white\Documents then they are not being processed since Kill should delete them.

Click anywhere in Sub csv_to_xls()
Hit F8 and take a look at what the code is doing.