Save File Name based on Text in Named Range on Users Desktop & Email that file. Has to work for Windows & Mac

[Armygeddan]

Hello,


I'm looking for a code or a good starting point where a users clicks a button and the following happens:


1. The Excel File first gets Saved with a naming convention of the Text that has the Named Range of AcquisitonTitle.
2. The the file is to be saved on the users Desktop (this possible or would just creating a temp file be better?)
3. An Email is generated but not sent with that file attached
4. This has to work on goth Windows & Mac (I know Macs use backslash instead of forward slash so somehow it needs to figure out what operating system the user is using)


Even a good starting point is helpful. I'm not an Excel expert but any help is appreciated. Current code I have works 100% on Windows but not Macs so I'm thinking maybe delete the save entirely to avoid the slashes issue?

Current Code I have:

Sub SaveAndEmailAcquisition()


Dim OutApp                As Object
Dim OutMail               As Object


Dim StrBody               As String
Dim StrTo                 As String
Dim StrSubject            As String
Dim StrAtt                As String
Dim StrSignature          As String
Dim strGenericFilePath    As String: strGenericFilePath = "\\FILE LOCATION FOR WINDOWS"
Dim strYearSlash          As String: strYearSlash = Year(Date) & "\"
Dim strMonthSlash         As String: strMonthSlash = CStr(Format(DateAdd("M", 0, Date), "MM")) & "\"
Dim strYearBracket        As String: strYearBracket = Year(Date) & "_"
Dim strMonthBracket       As String: strMonthBracket = CStr(Format(DateAdd("M", 0, Date), "MM")) & "_"
Dim strFileName           As String: strFileName = Sheets("Acquisition").Range("AcquisitionTitle") & " Acquisition Request Form"


 ' Creates Message Box asking if Form has been complete. If not, it cancels code to continue
MSG1 = MsgBox("Have you filled out EVERY box of information on this form?", vbYesNo)


If MSG1 = vbNo Then GoTo No
If MSG1 = vbYes Then GoTo Yes
No:
  MsgBox "Please fill out the remaining missing information and then click Save & Email"
  Exit Sub
Yes:
  MsgBox "Thank you, please proceed"


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


' Check for year folder and create if needed


If Len(Dir(strGenericFilePath & strYearSlash, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYearSlash
End If


' Check for month folder and create if needed


If Len(Dir(strGenericFilePath & strYearSlash & strMonthSlash, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYearSlash & strMonthSlash
End If


' Saves as Excel Macro Enabled book


ActiveWorkbook.SaveAs strGenericFilePath & strYearSlash & strMonthSlash & strYearBracket & strMonthBracket & strFileName & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled


' Popup Message that the conversion and save is complete as "YYYY_MM_Acquisition Title Procurement Request Form"


MsgBox "File Saved As:" & vbNewLine & strYearBracket & strMonthBracket & strFileName


' Enter Subject here (Using NamedRange)
StrSubject = Sheets("Acquisition").Range("AcquisitionTitle") & " Acquisition Request Form"


' Enter content of Email here
StrBody = "Please see attached File," & "<BR><BR><BR>" & vbNewLine & "Please list any additional details that I should know here that aren't listed on the form" & _
"<br><br><br> Thanks,"


' Code that attaches the Document to the email
StrAtt = ActiveWorkbook.FullName


' Who the email will be sent to
StrTo = "EMAIL ADDRESS"


' Adds Company Signature to the end of the Email. No Signature without this code
  With OutMail
  .Display
  End With
    StrSignature = OutMail.Body


With OutMail
    .To = StrTo
    .CC = ""
    .BCC = ""
    .Subject = StrSubject
    .HTMLBody = StrBody & .HTMLBody & vbNewLine & vbNewLine
    .Attachments.Add StrAtt
    .Display
  ' .Send (Not active, otherwise it will automatically send the email without review)
End With


On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing


End Sub

 

[RoryA]

Probably the simplest thing is to build up the path as you need to for the windows machines, then before you use it, use something like:

ActiveWorkbook.SaveAs Replace(strGenericFilePath & strYearSlash & strMonthSlash, "\", application.pathseparator)

 

[Armygeddan]

So I'm still having trouble getting it to work.

Somebody advised that I could do something like

[FONT=&quot]Dim TheOS As StringTheOS = Application.OperatingSystemIf Left(TheOS, 1) = "W" Then    StrGenericFilePath = "\\company.org\folder1\folder2\folder3\"    strYearSlash = Year(Date) & "\"    strMonthSlash = CStr(Format(DateAdd("M", 0, Date), "MM")) & "\"ElseIf Left(TheOS, 1) = "M" Then    'What the mac path should beEnd If[/FONT]

But I'm still running into errors. It works perfectly fine on a PC but on a Mac it's causing an error on line 13 (Highlights the Date)
I ended up taking out all the folder creating stuff for the Mac users so it just saves in their Documents folder.

I input the recommended coding into Lines 37 and 94.


Here's my whole code

Sub SaveAndEmailAcquisition()
 
    Dim OutApp                As Object
    Dim OutMail               As Object
 
    Dim StrBody               As String
    Dim StrTo                 As String
    Dim StrSubject            As String
    Dim StrAtt                As String
    Dim StrSignature          As String
    Dim strGenericFilePath    As String: strGenericFilePath = "\\corp.company\folder1\folder2\folder3\"
    Dim strOSGenericFilePath  As String: strOSGenericFilePath = "~/Documents"
    Dim strYearSlash          As String: strYearSlash = Year(Date) & "\"
    Dim strMonthSlash         As String: strMonthSlash = CStr(Format(DateAdd("M", 0, Date), "MM")) & "\"
    Dim strYearBracket        As String: strYearBracket = Year(Date) & "_"
    Dim strMonthBracket       As String: strMonthBracket = CStr(Format(DateAdd("M", 0, Date), "MM")) & "_"
    Dim strFileName           As String: strFileName = Sheets("Acquisition").Range("AcquisitionTitle") & " Acquisition Request Form"
    Dim TheOS                 As String: TheOS = Application.OperatingSystem
 
 
    ' Creates Message Box asking if Form has been complete. If not, it cancels code to continue
    MSG1 = MsgBox("Have you filled out EVERY box of information on this form?", vbYesNo)
 
    If MSG1 = vbNo Then GoTo No
    If MSG1 = vbYes Then GoTo Yes
    No:
    MsgBox "Please fill out the remaining missing information and then click Save & Email"
    Exit Sub
    Yes:
    MsgBox "Thank you, please proceed"
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    ' VBA Command for Windows Users
 
    If Left(TheOS, 1) = "W" Then
 
    ' Check for Year Folder in V Drive and creates one if one doesn't exist
 
    If Len(Dir(strGenericFilePath & strYearSlash, vbDirectory)) = 0
    Then
    MkDir strGenericFilePath & strYearSlash
    End If
 
    ' Check for Month Folder in V Drive and creates one if one doesn't exist
 
    If Len(Dir(strGenericFilePath & strYearSlash & strMonthSlash, vbDirectory)) = 0 Then
    MkDir strGenericFilePath & strYearSlash & strMonthSlash
    End If
 
    ' Saves as Excel Macro Enabled book
 
    ActiveWorkbook.SaveAs strGenericFilePath & strYearSlash & strMonthSlash & strYearBracket & strMonthBracket & strFileName & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
 
    ' Popup Message that the conversion and save is complete as
    "YYYY_MM_Acquisition Title Procurement Request Form"
 
    MsgBox "File Saved As:" & vbNewLine & strYearBracket & strMonthBracket & strFileName
 
    ' Enter Subject here (Using NamedRange)
    StrSubject = Sheets("Acquisition").Range("AcquisitionTitle") & " Acquisition Request Form"
 
    ' Enter content of Email here
    StrBody = "Please see attached File," & "<BR><BR><BR>" &
    vbNewLine & "Please list any additional details that I should know here that aren't listed on the form" & _
    "<br><br><br> Thanks,"
 
    ' Code that attaches the Document to the email
    StrAtt = ActiveWorkbook.FullName
 
    ' Who the email will be sent to
    StrTo = "YOUREMAIL@COMPANY.COM"
 
    ' Adds Company Signature to the end of the Email. No Signature without this code
    With OutMail
    .Display
    End With
    StrSignature = OutMail.Body
 
    With OutMail
    .To = StrTo
    .CC = ""
    .BCC = ""
    .Subject = StrSubject
    .HTMLBody = StrBody & .HTMLBody & vbNewLine & vbNewLine
    .Attachments.Add StrAtt
    .Display
    ' .Send (Not active, otherwise it will automatically send the email without review once user clicks Save & Email Button)
    End With
 
    ' VBA Command for Mac Users
 
    ElseIf Left(TheOS, 1) = "M" Then
 
    ' Saves as Excel Macro Enabled book
 
    ActiveWorkbook.SaveAs strOSGenericFilePath & strFileName & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
 
    ' Popup Message that the conversion and save is complete as "Acquisition Title Procurement Request Form"
 
    MsgBox "File Saved As in your Documents Folder:" & vbNewLine & strFileName
 
    ' Enter Subject here (Using NamedRange)
    StrSubject = Sheets("Acquisition").Range("AcquisitionTitle") & " Acquisition Request Form"
 
    ' Enter content of Email here
    StrBody = "Please see attached File," & "<BR><BR><BR>" &
    vbNewLine & "Please list any additional details that I should know here that aren't listed on the form" & _
    "<br><br><br> Thanks,"
 
    ' Code that attaches the Document to the email
    StrAtt = ActiveWorkbook.FullName
 
    ' Who the email will be sent to
    StrTo = "YOUREMAIL@COMPANY.COM"
 
    ' Adds Company Signature to the end of the Email. No Signature without this code
    With OutMail
    .Display
    End With
    StrSignature = OutMail.Body
 
    With OutMail
    .To = StrTo
    .CC = ""
    .BCC = ""
    .Subject = StrSubject
    .HTMLBody = StrBody & .HTMLBody & vbNewLine & vbNewLine
    .Attachments.Add StrAtt
    .Display
    ' .Send (Not active, otherwise it will automatically send the email without review once user clicks Save & Email Button)
    End With
 
    End If
 
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
 
    End Sub

 

[Armygeddan]

Bump