VBA micro help needed

[rawr19911]

I am close but still not getting it- when i use this code it kills the workbook I'm working in completely- If i take out wb2.Close False then it keeps work book open but changes the name at the top- what i am wanting is it to send the workbook with the new name- however; the workbook you are working in should stay the same- ( if you change ActiveWorkbook.copy to ActiveSheet.copy that is what i had before and it did everything i needed it to do- except it sent only the active sheet and they are now wanting the whole workbook sent- i put X's where there may be sensitive information..

So what i need is the workbook sent with the date and time attached and the work book that has the current name with out date and time to remain open and not close or change- just the one in email to be adjusted.


Sub Committoplan()
'
' Committoplan Macro
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "I hope all is well. I have attached XXXXXXX " & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & _
""
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
Activeworkbook.Copy
Set wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.Name & Format(Now, " mm-dd-yy h-mm-ss")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
With xOutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Commit to XXXXXXXXXX" & Date & " " & Range("A3")
.Body = xMailBody
.Attachments.Add wb2.FullName
.Display 'or use .Send
End With
On Error GoTo 0
wb2.Close False
Set xOutMail = Nothing
Set xOutApp = Nothing

End Sub

 

[juddaaaa]

I think this will do what you're looking for

Sub Committoplan()

    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Dim xPath As String
    Dim xFilename As String
    Dim xExtension As String
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    
    xMailBody = "I hope all is well. I have attached XXXXXXX " & vbNewLine & vbNewLine & _
    "Thank you," & vbNewLine & _
    ""
    
    Application.ScreenUpdating = False
    
    Select Case ThisWorkbook.FileFormat
        Case xlOpenXMLWorkbook
            xExtension = ".xlsx"
        Case xlOpenXMLWorkbookMacroEnabled
            If ThisWorkbook.HasVBProject Then
                xExtension = ".xlsm"
            Else
                xExtension = ".xlsx"
            End If
        Case "Excel8"
            xExtension = ".xls"
        Case "xlExcel12"
            xExtension = ".xlsb"
    End Select
    
    xPath = Environ("TEMP") & "\"
    xFilename = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & " " & Format(Now, "mm-dd-yy h-mm-ss") & xExtension
    
    ThisWorkbook.Worksheets.Copy
    
    Debug.Print xFilename
    
    With ActiveWorkbook
        .SaveAs _
            Filename:=xPath & xFilename, _
            FileFormat:=ThisWorkbook.FileFormat

        .Close _
            SaveChanges:=False
    End With
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    
    With xOutMail
        .To = ""
        .cc = ""
        .BCC = ""
        .Subject = "Commit to XXXXXXXXXX" & Date & " " & Range("A3")
        .Body = xMailBody
        .Attachments.Add xPath & xFilename
        .Display 'or use .Send
    End With
    
    Set xOutMail = Nothing
    Set xOutApp = Nothing
    
    Application.ScreenUpdating = True
    

End Sub

 

[rawr19911]

thanks ! that works perfect !!