Email Details to Excel & Save as .MSG on one macro - combination of 2 macros

Hi all, I have a macro at the minute which i have found and changed to suit my needs which saves an email in a file location on my server at work. I have just found another macro which inputs details from an email message into an excel spreadsheet. i was wondering if anyone would be able to help me combine the two macros so it completes both on one macro. When i select the file location to save the email it save the details to an excel spreadsheet (called Email Register - COPY ATTACHED) which will be in the same location as the emails are saved.

Option ExplicitFunction BrowseForFolder(Optional OpenAt As Variant) As Variant 
Dim ShellApp As Object 
Set ShellApp = CreateObject("Shell.Application"). _ 
BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 
 
On Error Resume Next 
BrowseForFolder = ShellApp.self.Path 
On Error GoTo 0 
 
Set ShellApp = Nothing 
Select Case Mid(BrowseForFolder, 2, 1) 
Case Is = ":" 
    If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 
Case Is = "\" 
    If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 
Case Else 
    GoTo Invalid 
End Select 
Exit Function 
 
Invalid: 
BrowseForFolder = False 
End Function 
 
 
Public Sub SaveMessageAsMsg() 
    Dim oMail As Outlook.MailItem 
    Dim sPath As String 
    Dim dtDate As Date 
    Dim sName As String 
    Dim enviro As String 
    Dim strFolderpath As String 
    Dim objItem As Outlook.MailItem 
     
    enviro = CStr(Environ("FILEDIRECTORY")) 
    strFolderpath = BrowseForFolder(enviro & "\\NEWBENSON\Projects\Drawings") 
     
    For Each objItem In ActiveExplorer.Selection 
        If objItem.MessageClass = "IPM.Note" Then 
            Set oMail = objItem 
             
            sName = oMail.Subject 
            ReplaceCharsForFileName sName, "-" 
             
            dtDate = oMail.ReceivedTime 
            sName = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _ 
            vbUseSystem) & Format(dtDate, "-hhnnss", _ 
            vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg" 
             
            sPath = strFolderpath & "\" 
            Debug.Print sPath & sName 
            oMail.SaveAs sPath & sName, olMsg 
             
        End If 
    Next 
    If MsgBox("Delete saved email ?", vbYesNo, "Deleting saved email ?") = vbYes Then 
        oMail.Delete 
    End If 
     
End Sub 
 
 
Private Sub ReplaceCharsForFileName(sName As String, _ 
    sChr As String _ 
) 
    sName = Replace(sName, "'", sChr) 
    sName = Replace(sName, "*", sChr) 
    sName = Replace(sName, "/", sChr) 
    sName = Replace(sName, "\", sChr) 
    sName = Replace(sName, ":", sChr) 
    sName = Replace(sName, "?", sChr) 
    sName = Replace(sName, Chr(34), sChr) 
    sName = Replace(sName, "<", sChr) 
    sName = Replace(sName, ">", sChr) 
    sName = Replace(sName, "|", sChr) 
End Sub 
 
 
Sub CopyToExcel() 
    Dim xlApp As Object 
    Dim xlWB As Object 
    Dim xlSheet As Object 
    Dim rCount As Long 
    Dim bXStarted As Boolean 
    Dim enviro As String 
    Dim strPath As String 
     
     
    Dim objOL As Outlook.Application 
    Dim objFolder As Outlook.MAPIFolder 
    Dim objItems As Outlook.Items 
    Dim obj As Object 
    Dim olItem 'As Outlook.MailItem
    Dim strColA, strColB, strColC, strColD, strColE, strColF As String 
     
     ' Get Excel set up
    enviro = CStr(Environ("USERPROFILE")) 
     'the path of the workbook
    strPath = enviro & "\Documents\Book1.xlsx" 
    On Error Resume Next 
    Set xlApp = GetObject(, "Excel.Application") 
    If Err <> 0 Then 
        Application.StatusBar = "Please wait while Excel source is opened ... " 
        Set xlApp = CreateObject("Excel.Application") 
        bXStarted = True 
    End If 
    On Error GoTo 0 
     
     
    On Error Resume Next 
     ' Open the workbook to input the data
     ' Create workbook if doesn't exist
    Set xlWB = xlApp.Workbooks.Open(strPath) 
    If Err <> 0 Then 
        Set xlWB = xlApp.Workbooks.Add 
        xlWB.SaveAs FileName:=strPath 
    End If 
    On Error GoTo 0 
    Set xlSheet = xlWB.Sheets("Sheet1") 
     
    On Error Resume Next 
     ' add the headers if not present
    If xlSheet.Range("A1") = "" Then 
        xlSheet.Range("A1") = "Sender Name" 
        xlSheet.Range("B1") = "Sender Email" 
        xlSheet.Range("C1") = "Subject" 
        xlSheet.Range("D1") = "Body" 
        xlSheet.Range("E1") = "Sent To" 
        xlSheet.Range("F1") = "Date" 
    End If 
     
     
     'Find the next empty line of the worksheet
    rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row 
     'needed for Exchange 2016. Remove if causing blank lines.
    rCount = rCount + 1 
     
     
     ' get the values from outlook
    Set objOL = Outlook.Application 
    Set objFolder = objOL.ActiveExplorer.CurrentFolder 
    Set objItems = objFolder.Items 
    For Each obj In objItems 
         
         
        Set olItem = obj 
         
         'collect the fields
         
        strColA = olItem.SenderName 
        strColB = olItem.SenderEmailAddress 
        strColC = olItem.Subject 
        strColD = olItem.Body 
        strColE = olItem.To 
        strColF = olItem.ReceivedTime 
         
         
         
         ' Get the Exchange address
         ' if not using Exchange, this block can be removed
        Dim olEU As Outlook.ExchangeUser 
        Dim oEDL As Outlook.ExchangeDistributionList 
        Dim recip As Outlook.Recipient 
        Set recip = Application.Session.CreateRecipient(strColC) 
         
         
        If InStr(1, strColB, "/") > 0 Then 
             ' if exchange, get smtp address
            Select Case recip.AddressEntry.AddressEntryUserType 
            Case OlAddressEntryUserType.olExchangeUserAddressEntry 
                Set olEU = recip.AddressEntry.GetExchangeUser 
                If Not (olEU Is Nothing) Then 
                    strColC = olEU.PrimarySmtpAddress 
                End If 
            Case OlAddressEntryUserType.olOutlookContactAddressEntry 
                Set olEU = recip.AddressEntry.GetExchangeUser 
                If Not (olEU Is Nothing) Then 
                    strColC = olEU.PrimarySmtpAddress 
                End If 
            Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry 
                Set oEDL = recip.AddressEntry.GetExchangeDistributionList 
                If Not (oEDL Is Nothing) Then 
                    strColC = olEU.PrimarySmtpAddress 
                End If 
            End Select 
        End If 
         ' End Exchange section
         
         
         'write them in the excel sheet
        xlSheet.Range("A" & rCount) = strColA 
        xlSheet.Range("B" & rCount) = strColB 
        xlSheet.Range("c" & rCount) = strColC 
        xlSheet.Range("d" & rCount) = strColD 
        xlSheet.Range("e" & rCount) = strColE 
        xlSheet.Range("f" & rCount) = strColF 
         
         'Next row
        rCount = rCount + 1 
        xlWB.Save 
         
         
    Next 
     
     ' don't wrap lines
    xlSheet.Rows.WrapText = False 
     
     
    xlWB.Save 
    xlWB.Close 1 
    If bXStarted Then 
        xlApp.Quit 
    End If 
     
    Set olItem = Nothing 
    Set obj = Nothing 
    Set xlApp = Nothing 
    Set xlWB = Nothing 
    Set xlSheet = Nothing 
End Sub

I have attached my code for your assistance.