Keeping the format structure on attached Spread sheet for eamil

[menor59]

Hallo all,

The Macro works perfectly, this is a form, it takes the work sheet, starts my email and Attaches the worksheet as an attachment, but its not keeping the Structure inplace....ie. Borders, and cells that are filled with colors, its just the worksheet with txt if that makes sense.....please help..

Private Sub SendEmailButton_Click()
If eMailAddress.Text = "" Then
    MsgBox "You have Forgotten to add an Email Address", vbAbortRetryIgnore, "Email Address Please"
    Exit Sub
    
End If
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem


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


    Set Sourcewb = ActiveWorkbook


    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook


    With Destwb
        If Val(Application.Version) < 12 Then
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
          FileExtStr = ".xlsx": FileFormatNum = 51
        End If
    End With
    
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


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


    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = Me.eMailAddress.Value
            .Subject = Me.Subject.Value
            .Body = Me.Greetings.Value & vbCrLf & Me.MessageBody.Value
            .Attachments.Add Destwb.FullName
            .Attachments.Add (Me.Attachment.Value)
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            '____________________________
            .Display   'or use .Send
            '____________________________
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With


    'Delete the file you have sent
    Kill TempFilePath & TempFileName & FileExtStr


    Set OutMail = Nothing
    Set OutApp = Nothing


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
Call ClearButton_Click


End Sub


Private Sub ClearButton_Click()
With Me
    .RecipientName.Text = ""
    .eMailAddress.Text = ""
    .Subject.Text = ""
    .MessageBody.Text = ""
    .Attachment.Text = ""
    End With
    Call UserForm_Initialize
End Sub


Private Sub HelpButton_Click()
Dim Msg As String
Msg = "This is the help file" & vbCrLf & vbCrLf
Msg = Msg & "Writh the recipient name in the Recipient Box." & vbCrLf & vbCrLf
Msg = Msg & "In the email please write the correct email Address of the Reciever" & vbCrLf & vbCrLf
Msg = Msg & "In the Greetings section select the Greeting which you want to Apply "
Msg = Msg & "Before the Message." & vbCrLf & vbCrLf
Msg = Msg & "Besides Attachments click the button or Press CTRL + O to Browse for the"
Msg = Msg & "Attachment" & vbCrLf & vbCrLf
Msg = Msg & "Press CTRL + S to SAVE, or CTRL + C to Close the Form" & vbCrLf & vbCrLf
Msg = Msg & "The was Developed by Me"
note = MsgBox(Msg, vbInformation, "Help?")
End Sub


Private Sub UserForm_Initialize()
Me.Greetings.Clear
rec = Me.RecipientName.Text
With Me.Greetings
    .AddItem "Hi " & rec
    .AddItem "Dear Sir"
    .AddItem "Dear Madam"
    .AddItem "Dear " & rec
End With
End Sub


Private Sub BrowseButton_Click()
Dim myfliepath As String
myfilepath = Application.GetOpenFilename
Attachment.Text = myfilepath
End Sub


Private Sub RecipientName_Change()
Me.Greetings.Clear
rec = Me.RecipientName.Text
With Me.Greetings
    .AddItem "Hi " & rec
    .AddItem "Dear Sir"
    .AddItem "Dear Madam"
    .AddItem "Dear " & rec
End With
End Sub


Private Sub CancelButton_Click()
Unload Me
End Sub

your thoughts or comments. I took this off the web, and im not a VBA expert, but i need the structures intacted, in the worksheet that it attaches.

Heres the Outlook sub script also if needed..

'&&&&&&&&&&&&&&&&&&&&&&&&&&&&
' Check if Outlook is open.  If not, Open it
' Then Start the EmailForm
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&


#Const LateBind = True


Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6


#If LateBind Then


Public Function OutlookApp( _
    Optional WindowState As Long = olMinimized, _
    Optional ReleaseIt As Boolean = False _
    ) As Object
    Static o As Object
#Else
Public Function OutlookApp( _
    Optional WindowState As Outlook.OlWindowState = olMinimized, _
    Optional ReleaseIt As Boolean _
) As Outlook.Application
    Static o As Outlook.Application
#End If
On Error GoTo ErrHandler
 
    Select Case True
        Case o Is Nothing, Len(o.Name) = 0
            Set o = GetObject(, "Outlook.Application")
            If o.Explorers.Count = 0 Then
InitOutlook:
                'Open inbox to prevent errors with security prompts
                o.Session.GetDefaultFolder(olFolderInbox).Display
                o.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set o = Nothing
    End Select
    Set OutlookApp = o
 
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set o = Nothing
        Case 429, 462
            Set o = GetOutlookApp()
            If o Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function


#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
    
    Set GetOutlookApp = CreateObject("Outlook.Application")
    
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            'Do not raise any errors
            Set GetOutlookApp = Nothing
    End Select
    Resume ExitProc
    Resume
End Function


Sub MyMacroThatUseOutlook()
    Dim OutApp  As Object
    Set OutApp = OutlookApp()
    EmailForm.Show
    'Automate OutApp as desired
End Sub