Search computer name, set the folder destination, save and email the file with attachment.

Pioneer · Jun 8, 2015

Hello,
I am doing a form which will be used on multiple device. ~50+
I am wondering if this is possible:
At a click of a button, I want following things to happen:
1. Save the file as excel format with a predefined file name. (remember location is multiple device, hence a macros to identify the computer name)
2. Open an outlook email (new email screed) with TO: prepopulate SUBJECT: File name with date Body: Prepopluate. ATTACHMENT: automatically attach the file.
3. let the user click the send button to send the file.

Currently i have separate buttons to save the file as pdf. and then email for users to email the file by manually attaching the file. THis wil be possible if the macros is able to determine the computer name to save the file in a folder.

I have the below seperate macros:

MACROS to save the file (I want save and email to operate with a clink of one button and use on 50+ users devices.)

SAVE MACROS:

Code:

Sub SavePDF1()

    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C3")) < 1 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub
  
    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C4")) < 1 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub
  
    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C5")) < 1 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub
  
    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C6")) < 1 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub
    End If
  

Dim Opendialog As Variant

Opendialog = Application.GetSaveAsFilename(Sheet1.[Sheet2!$CI$267].Value & Format(Date, "mmddyyyy"))

If Not Opendialog <> False Then MsgBox "File not saved.", vbCritical: Exit Sub

ActiveSheet.ExportAsFixedFormat Type:=xlType, Filename:=Opendialog _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True

MsgBox "File Saved.", vbInformation
                                        
End Sub

EMAIL MACROS without attachment. (i want one with attachment)

Code:

Sub Mail_Workbook_Outlook()
    Dim OlApp As Object
    Dim OlMail As Object, Recip
    Recip = [Sheet2!$CJ$264].Value
    Set OlApp = CreateObject("Outlook.Application")
    Set OlMail = OlApp.CreateItem(0)
 
    On Error Resume Next
    With OlMail
        .To = Recip
        .Subject = "HHA tool"
        .Body = "Please find the attached HHA tool"
        Select Case attachAWB
            Case True
                .attachments.Add ActiveWorkbook.FullName
        End Select
        If AttachmentPath <> "" Then
            .attachments.Add (AttachmentPath)
        End If
     
        Select Case displayMail
            Case True
                .Display
            Case True
                .Send
            Case Else
                .Display
        End Select
    End With
    On Error GoTo 0
 
    Set OlMail = Nothing
    Set OlApp = Nothing
End Sub

Deepak · Jun 9, 2015

Pls always use code tags to tag your macro!!
I have did for the now.

Pioneer · Jun 9, 2015

Deepak said:
Pls always use code tags to tag your macro!!
I have did for the now.

Thank you.

Can you help me in getting a solution for my request.

Deepak · Jun 9, 2015

Pioneer said:
Thank you.

Can you help me in getting a solution for my request.

I am leaving the desk for the day!!
If you didn't got a reply till tomorrow noon then i will post the solution.

Pioneer · Jun 9, 2015

Some updated:

I am not sure if this can be done with a click of one button - send an email with attached file as pdf and save a copy of the file as excel, taking into consideration there will be ~50+ users.

Below VB code is working, but i am not able to make some updated like changing the file type. i.e. email in pdf and save as excel.

If, one button is not possible, can you help in correcting the below code :-
I need two buttons, one to send an email with the active sheet attached as pdf file and second button to open a dialogue box and save the file as excel letting the users to save the file as a desired location.

I have updated the VB codes.

Code:

'i want this code to save the file as excel, with dialogue box to open.
Sub Save_Excel()

    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C3")) < 1 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub

    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C4")) < 1 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub

    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C5")) < 1 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub

    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C6")) < 1 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub
    End If


Dim Opendialog As Variant

Opendialog = Application.GetSaveAsFilename(Sheet1.[Sheet2!$CI$267].Value & Format(Date, "yyyymmdd"), fileFilter:="Excel Files (*.xlsm), *.xlsm")

If Not Opendialog <> False Then MsgBox "File not saved.", vbCritical: Exit Sub

ActiveSheet.ExportAsFixedFormat Type:=xlType, Filename:=Opendialog _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True

MsgBox "File Saved.", vbInformation

                                      
End Sub

another code

Code:

'i want following code to attached the active file as pdf to an email


Sub Mail_with_attachment()

If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C3")) < 1 Then
    MsgBox "Workbook will not be emailed unless" & vbCrLf & "all required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub

    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C4")) < 1 Then
    MsgBox "Workbook will not be emailed unless" & vbCrLf & "all required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub

    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C5")) < 1 Then
    MsgBox "Workbook will not be emailed unless" & vbCrLf & "all required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub

    End If
    If WorksheetFunction.CountA( _
    Worksheets("Sheet1").Range("C6")) < 1 Then
    MsgBox "Workbook will not be emailed unless" & vbCrLf & "all required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub
    End If

Dim ABC As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set ABC = ActiveWorkbook

    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sheet1.[Sheet2!$CI$267].Value & Format(Date, "yyyymmdd ")
    FileExtStr = "." & LCase(Right(ABC.Name, Len(ABC.Name) - InStrRev(ABC.Name, ".", , 1)))

    ABC.SaveCopyAs TempFilePath & TempFileName & FileExtStr

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

    On Error Resume Next
    With OutMail
        .to = Range("Sheet2!$CJ$264").Value
        .CC = ""
        .BCC = ""
        .Subject = "ABC for " & Range("Sheet2!$CI$267").Value & Format(Date, "yyyymmdd ")
        .Body = "Please find the attached ABC schedule for " & Range("$C$3").Value & " submitted on " & Format(Date, "mm-dd-yy ")
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        .Display
    End With
    On Error GoTo 0

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Deepak · Jun 10, 2015

Hi,

Need some clarity!!

U want to say that Save active sheet as xl but attached the same as PDF.

Where to save [On desktop] or elsewhere like as
"C:\Users\<user_change>\myfol\xlfol"

I am missed something ?

Pioneer · Jun 10, 2015

Deepak said:
Hi,

Need some clarity!!

U want to say that Save active sheet as xl but attached the same as PDF.

Where to save [On desktop] or elsewhere like as
"C:\Users\<user_change>\myfol\xlfol"

I am missed something ?

That is correct. The folder can be same as the current file location. If we can automatically save the file as .xl in current location with the desired name and using the current macros that I have , save a active file as odd in temp folder and attach odd to the email.

Thanks

Deepak · Jun 10, 2015

Check this...

Code:

Sub Save_Excel()

Dim mystr As String, mypdf As String

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

If Not Application.CountA(Sheets("Sheet1").Range("C3:C6")) = 4 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub
End If

mystr = Range("Sheet1!$CI$267").Value & Format(Date, "yyyymmdd")

Dim Opendialog As Variant

Opendialog = Application.GetSaveAsFilename(mystr, fileFilter:="Excel Files (*.xlsm), *.xlsm")

If Not Opendialog <> False Then MsgBox "File not saved.", vbCritical: Exit Sub

ThisWorkbook.SaveCopyAs Opendialog

mypdf = Left(Opendialog, InStrRev(Opendialog, ".") - 1)

ActiveSheet.ExportAsFixedFormat Type:=xlType, Filename:=mypdf _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True

    With CreateObject("Outlook.Application").CreateItem(0)
        .To = Range("Sheet2!$CJ$264").Value
        .CC = ""
        .BCC = ""
        .Subject = "ABC for " & mystr
        .Body = "Please find the attached ABC schedule for " & Range("$C$3").Value & " submitted on " & Format(Date, "mm-dd-yy ")
        .Attachments.Add mypdf & ".pdf"
        .Display
    End With
    Kill mypdf & ".pdf"
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Pioneer · Jun 10, 2015

Deepak said:

Check this...

Code:

Sub Save_Excel()

Dim mystr As String, mypdf As String

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

If Not Application.CountA(Sheets("Sheet1").Range("C3:C6")) = 4 Then
    MsgBox "Workbook will not be saved unless" & vbCrLf & "All required fields have been filled in!", vbCritical, "Missing info"
    Exit Sub
End If

mystr = Range("Sheet1!$CI$267").Value & Format(Date, "yyyymmdd")

Dim Opendialog As Variant

Opendialog = Application.GetSaveAsFilename(mystr, fileFilter:="Excel Files (*.xlsm), *.xlsm")

If Not Opendialog <> False Then MsgBox "File not saved.", vbCritical: Exit Sub

ThisWorkbook.SaveCopyAs Opendialog

mypdf = Left(Opendialog, InStrRev(Opendialog, ".") - 1)

ActiveSheet.ExportAsFixedFormat Type:=xlType, Filename:=mypdf _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True

    With CreateObject("Outlook.Application").CreateItem(0)
        .To = Range("Sheet2!$CJ$264").Value
        .CC = ""
        .BCC = ""
        .Subject = "ABC for " & mystr
        .Body = "Please find the attached ABC schedule for " & Range("$C$3").Value & " submitted on " & Format(Date, "mm-dd-yy ")
        .Attachments.Add mypdf & ".pdf"
        .Display
    End With
    Kill mypdf & ".pdf"
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

This is magical. Its working.
Thank you so much.

Deepak · Jun 10, 2015

Pioneer said:
This is magical. Its working.
Thank you so much.

Welcome!!

Just like it if helped!!

Search computer name, set the folder destination, save and email the file with attachment.

Pioneer

New Member

Deepak

Excel Ninja

Pioneer

New Member

Deepak

Excel Ninja

Pioneer

New Member

Deepak

Excel Ninja

Pioneer

New Member

Deepak

Excel Ninja

Pioneer

New Member

Deepak

Excel Ninja