Add file as attachment to error reporting email

[sharky12345]

I've come across this great piece of code which enables error reporting within a project;

Option Explicit
Private Const AddressTo As String = "my email address"
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Const VER_NT_WORKSTATION = 1&
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const Synchronize = &H100000
Private Const MAXLEN = 256
Private Const ERROR_SUCCESS = &H0&
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not Synchronize))
Private Const REG_SZ = 1
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const RET_OK As Long = 0
Private Const RET_FAIL As Long = vbObjectError - 503
#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "SHELL32.DLL" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
    Private Declare Function ShellExecute Lib "SHELL32.DLL" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Type OSVERSIONINFOEX
    OSVSize As Long
    dwVerMajor As Long
    dwVerMinor As Long
    dwBuildNumber As Long
    PlatformID As Long
    szCSDVersion As String * 128
    wServicePackMajor As Integer
    wServicePackMinor As Integer
    wSuiteMask As Integer
    wProductType As Byte
    wReserved As Byte
End Type
#If VBA7 Then
    Declare PtrSafe Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As Any) As Long
#Else
    Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As Any) As Long
#End If
#If VBA7 Then
    Private Declare PtrSafe Function apiRegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
    Private Declare PtrSafe Function apiRegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, ByRef lpcbClass As Long, ByVal lpReserved As Long, ByRef lpcSubKeys As Long, ByRef lpcbMaxSubKeyLen As Long, ByRef lpcbMaxClassLen As Long, ByRef lpcValues As Long, ByRef lpcbMaxValueNameLen As Long, ByRef lpcbMaxValueLen As Long, ByRef lpcbSecurityDescriptor As Long, ByRef lpftLastWriteTime As FILETIME) As Long
    Private Declare PtrSafe Function apiRegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, lpData As Any, ByRef lpcbData As Long) As Long
    Private Declare PtrSafe Function apiRegCloseKey Lib "advapi32.dll" Alias "RegCloseKey" (ByVal hKey As Long) As Long
    Private Declare PtrSafe Function apiGetTempDir Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
#Else
    Private Declare Function apiRegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
    Private Declare Function apiRegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, ByRef lpcbClass As Long, ByVal lpReserved As Long, ByRef lpcSubKeys As Long, ByRef lpcbMaxSubKeyLen As Long, ByRef lpcbMaxClassLen As Long, ByRef lpcValues As Long, ByRef lpcbMaxValueNameLen As Long, ByRef lpcbMaxValueLen As Long, ByRef lpcbSecurityDescriptor As Long, ByRef lpftLastWriteTime As FILETIME) As Long
    Private Declare Function apiRegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, lpData As Any, ByRef lpcbData As Long) As Long
    Private Declare Function apiRegCloseKey Lib "advapi32.dll" Alias "RegCloseKey" (ByVal hKey As Long) As Long
    Private Declare Function apiGetTempDir Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
#End If
Private Const MAX_PATH As Integer = 255
Sub ErrorHandle(Err As ErrObject, ErrLine As Long, Optional strProcedure As String, Optional strComment As String, Optional bShowMessage As Boolean = True, Optional bReportError As Boolean = True, Optional bLogError As Boolean = True)
    Dim strDescription As String
    Dim ErrNo As Long
    Dim strSource As String
    Dim strExtendedErrInfo As String
    Dim strProductVersion As String
    With Err
        ErrNo = .number
        strDescription = .Description
        strSource = .Source
    End With
    If bShowMessage Then ErrorMessage ErrNo, ErrLine, strDescription, strComment, strSource, strProcedure, bReportError, strExtendedErrInfo
    If bLogError Then
    End If
HandleExit:
End Sub
Sub ErrorMessageTest()
    ErrorMessage 1, 0, "Description", "Comment", "Source", "Procedure"
End Sub
Private Sub ErrorMessage(ErrNo As Long, ErrLine As Long, strDescription As String, Optional strComment As String, Optional strSource As String, Optional strProcedure As String, Optional bReportError As Boolean = True, Optional strExtendedErrInfo As String = "")
    Const cstrError As String = "Error"
    Dim strOfficeApplication As String
    Dim strDocument As String
    Dim strErrorTitle As String
    Dim strMessage As String
    Dim strMessage2 As String
    Dim strSubject As String
    On Error Resume Next
    If Len(strComment) > 0 Then strComment = vbCrLf & vbCrLf & strComment
    If Len(strProcedure) > 0 Or Len(strSource) > 0 Then strProcedure = strProcedure
    Dim app As Object: Set app = Application
    strOfficeApplication = app.Name & " (" & app.Version & ")"
    Select Case app.Name
    Case "Microsoft Excel"
        strDocument = app.ThisWorkbook.Name
    Case "Microsoft Access"
        strDocument = app.CodeProject.Name
    End Select
    If bReportError = True Then
        strErrorTitle = ThisWorkbook.BuiltinDocumentProperties("Title") & " - Debug Error Report"
        strMessage = cstrError
    End If
    strMessage = "An error has occurred, details of which are below: " & vbCrLf & vbCrLf & strMessage & " " & ErrNo & ": " & strDescription & " " & _
                 strProcedure & " line " & ErrLine & " " & strComment
    strMessage2 = "Error: " & ErrNo & vbCrLf & "Description: " & strDescription & vbCrLf & "Module: " & strProcedure & vbCrLf & "Line: " & ErrLine & " " & strComment
    If bReportError = False Then
        MsgBox strMessage, vbCritical, strErrorTitle
    Else
        Dim iPos As Long
        iPos = InStr(strMessage, "@")
        If iPos > 0 Then strMessage = Left(strMessage, iPos - 1)
        Dim lngRet As Long
        Dim strMsg As String
        strMsg = "Error reporting email - details below." & vbCrLf & _
                 "Support Information:" & _
                 vbCrLf & vbCrLf & strMessage2 & vbCrLf & _
                 "Software Title: " & ThisWorkbook.BuiltinDocumentProperties("Title") & vbCrLf & _
                 "Project Version: " & ThisWorkbook.BuiltinDocumentProperties("Comments") & vbCrLf & _
                 "Operating System: " & WindowsVersion & vbCrLf & _
                 "Office Version: " & strOfficeApplication & _
                 vbCrLf & strExtendedErrInfo
        If CheckForOLEMessaging() = True Then
            If (vbYes = MsgBox(strMessage & vbCrLf & vbCrLf & _
                               "Please click Yes to report the problem or No to ignore - error recovery will attempt to continue " & _
                               "the process regardless of your choice", vbYesNo + vbCritical + vbDefaultButton2, strErrorTitle)) Then
                Send AddressTo, strErrorTitle, strMsg
            End If
        Else
            Dim strReportFile As String
            Dim intFn As Long
            strReportFile = DirTemporary() & "~" & Format(Now, "YYYYMMDDHHNNSS") & ".txt"
            intFn = FreeFile
            Open strReportFile For Output Access Write As #intFn
            Print #intFn, strMsg
            Close #intFn
            Shell "notepad.exe """ & strReportFile & """"
            Kill strReportFile
        End If
    End If
End Sub
Private Function CheckForOLEMessaging() As Boolean
    On Error GoTo errHandle
    Dim bOK As Boolean
    CheckForOLEMessaging = (RegistryValueGet(&H80000002, "SOFTWARE\Microsoft\Windows Messaging Subsystem\", "OleMessaging", bOK) = "1")
errHandle:
End Function
Private Function DirTemporary() As String
    Dim strTemp As String
    Dim lngRtn As Long
    On Error GoTo HandleErr
    strTemp = String$(MAX_PATH, 0)
    lngRtn = apiGetTempDir(MAX_PATH, strTemp)
    If lngRtn <> 0 Then
        DirTemporary = Left$(strTemp, lngRtn)
    Else
        DirTemporary = ""
    End If
HandleExit:
    Exit Function
HandleErr:
    Resume HandleExit
End Function
Private Function RegistryValueGet(ByVal lngKeyToGet As Long, ByVal strKeyName As String, ByVal strValueName As String, bOK As Boolean) As String
    Dim lnghKey As Long
    Dim strClassName As String
    Dim lngClassLen As Long
    Dim lngReserved As Long
    Dim lngSubKeys As Long
    Dim lngMaxSubKeyLen As Long
    Dim lngMaxClassLen As Long
    Dim lngValues As Long
    Dim lngMaxValueNameLen As Long
    Dim lngMaxValueLen As Long
    Dim lngSecurity As Long
    Dim ftLastWrite As FILETIME
    Dim lngType As Long
    Dim lngData As Long
    Dim lngTmp As Long
    Dim strRet As String
    Dim varRet As Variant
    Dim lngRet As Long
    On Error GoTo RegistryValueGet_Err
    lngTmp = apiRegOpenKeyEx(lngKeyToGet, strKeyName, 0&, KEY_READ, lnghKey)
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise lngTmp + vbObjectError
    lngReserved = 0&
    strClassName = String$(MAXLEN, 0): lngClassLen = MAXLEN
    lngTmp = apiRegQueryInfoKey(lnghKey, strClassName, lngClassLen, lngReserved, lngSubKeys, lngMaxSubKeyLen, lngMaxClassLen, lngValues, lngMaxValueNameLen, lngMaxValueLen, lngSecurity, ftLastWrite)
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise lngTmp + vbObjectError
    strRet = String$(MAXLEN - 1, 0)
    lngTmp = apiRegQueryValueEx(lnghKey, strValueName, lngReserved, lngType, ByVal strRet, lngData)
    Select Case lngType
    Case REG_SZ
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData - 1)
    Case REG_DWORD
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, lngReserved, lngType, lngRet, lngData)
        varRet = lngRet
    Case REG_BINARY
        lngTmp = apiRegQueryValueEx(lnghKey, strValueName, lngReserved, lngType, ByVal strRet, lngData)
        varRet = Left(strRet, lngData)
    End Select
    If Not (lngTmp = ERROR_SUCCESS) Then
        Err.Raise lngTmp + vbObjectError
    Else
        bOK = True
    End If
RegistryValueGet_Exit:
    RegistryValueGet = varRet
    lngTmp = apiRegCloseKey(lnghKey)
    Exit Function
RegistryValueGet_Err:
    varRet = vbNullString
    Resume RegistryValueGet_Exit
End Function
Private Function WindowsVersion(Optional lngPlatformId As Long, Optional lngMajorVersion As Long, Optional lngMinorVersion As Long, Optional lngBuildNumber As Long) As String
    Dim v As OSVERSIONINFO, retval As Long
    Dim strWindowsVersion As String, BuildVersion As String
    Const cDiv As String = "/"
    On Error GoTo HandleErr
    v.dwOSVersionInfoSize = Len(v)
    retval = GetVersionEx(v)
    lngPlatformId = v.dwPlatformId
    lngMajorVersion = v.dwMajorVersion
    lngMinorVersion = v.dwMinorVersion
    lngBuildNumber = v.dwBuildNumber
    strWindowsVersion = v.dwMajorVersion & "." & v.dwMinorVersion
    BuildVersion = v.dwBuildNumber And &HFFFF&
    Select Case v.dwPlatformId
    Case VER_PLATFORM_WIN32_WINDOWS
        Select Case v.dwMinorVersion
        Case 0
            WindowsVersion = "Windows 95"
        Case 10
            WindowsVersion = "Windows 98"
        End Select
    Case VER_PLATFORM_WIN32_NT
        Select Case v.dwMajorVersion
        Case 3
            WindowsVersion = "WinNT 3.51"
        Case 4
            WindowsVersion = "WinNT 4"
        Case 5
            If v.dwMinorVersion = 0 Then
                WindowsVersion = "Windows 2000"
            ElseIf v.dwMinorVersion = 1 Then
                WindowsVersion = "Windows XP"
            ElseIf v.dwMinorVersion = 2 Then
                WindowsVersion = "Windows Server 2003"
            End If
        Case 6
            Dim osvex As OSVERSIONINFOEX
            osvex.OSVSize = Len(osvex)
            retval = GetVersionEx(osvex)
            If v.dwMinorVersion = 0 Then
                If osvex.wProductType = VER_NT_WORKSTATION Then
                    WindowsVersion = "Windows Vista"
                Else
                    WindowsVersion = "Windows Server 2008"
                End If
            ElseIf v.dwMinorVersion = 1 Then
                If osvex.wProductType = VER_NT_WORKSTATION Then
                    WindowsVersion = "Windows 7"
                Else
                    WindowsVersion = "Windows Server 2008 R2"
                End If
                WindowsVersion = "Windows 7"
            ElseIf v.dwMinorVersion = 2 Then
                If osvex.wProductType = VER_NT_WORKSTATION Then
                    WindowsVersion = "Windows 8"
                Else
                    WindowsVersion = "Windows Server 2012"
                End If
            ElseIf v.dwMinorVersion = 3 Then
                If osvex.wProductType = VER_NT_WORKSTATION Then
                    WindowsVersion = "Windows 8.1"
                Else
                    WindowsVersion = "Windows Server 2012 R2"
                End If
            End If
        End Select
    Case VER_PLATFORM_WIN32s
        WindowsVersion = "NT < 3.51"
    End Select
HandleExit:
    Exit Function
HandleErr:
    WindowsVersion = "System Info not available"
    Resume HandleExit
End Function
Private Function Send(ByVal vstrAddrTo As String, ByVal vstrSubject As String, ByVal vstrBodyText As String, Optional ByVal vstrAddrCC As String = "", Optional ByVal vstrAddrBCC As String = "", Optional ByVal vfTruncateUntilLastVbCrlf As Boolean = False) As Long
    On Error GoTo HandleErr
    Dim strMsg As String
    Dim lngRet As Long
    Dim lngIdx As Long
    strMsg = "mailto:" & vstrAddrTo & "?"
    If Len(vstrAddrCC) > 0 Then
        strMsg = strMsg & "CC=" & vstrAddrCC & "&"
    End If
    If Len(vstrAddrBCC) > 0 Then
        strMsg = strMsg & "BCC=" & vstrAddrBCC & "&"
    End If
    vstrSubject = Replace(vstrSubject, vbCrLf, "%0d%0a")
    vstrSubject = Replace(vstrSubject, " ", "%20")
    strMsg = strMsg & "Subject=" & vstrSubject & "&"
    vstrBodyText = Replace(vstrBodyText, vbCrLf, "%0d%0a")
    vstrBodyText = Replace(vstrBodyText, " ", "%20")
    strMsg = strMsg & "Body=" & vstrBodyText
    If Len(strMsg) > 2000 Then
        strMsg = Left(strMsg, 2000) & "..."
        If vfTruncateUntilLastVbCrlf = True Then
            For lngIdx = Len(strMsg) To 1 Step -1
                If Mid(strMsg, lngIdx, 6) = "%0d%0a" Then
                    strMsg = Left(strMsg, lngIdx + 5) & "..."
                    Exit For
                End If
            Next lngIdx
        End If
    End If
    lngRet = ShellExecute(0&, vbNullString, strMsg, vbNullString, vbNullString, vbNormalFocus)
    If lngRet >= 42 Then
        Send = RET_OK
    Else
        Send = RET_FAIL
    End If
HandleExit:
    Exit Function
HandleErr:
    Send = Err.number
    Resume HandleExit
End Function

Simple question really - how can I attach a copy of the activeworkbook to the email that's sent?