Picture/Image Height & Width resize in MS Outlook from Excel

[Xiao]

Hi,

I have the below macro that I am trying to edit to resize the grapg and it's related table from excel into MS Outlook 2013. Currently the image is too broad or huge when it is pasted into outlook from excel and I was hoping the is a was to edit the macro to get the image resized or formatted when it paste into Outlook (preferably Height 11.32'' Width 12.95'')

Private Sub PackagFck(sRegion As String)
    
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rBody As range
    Dim rCell As range
    Dim wscontrol As Worksheet
    Dim dDate As Date
    Dim sFilePath As String
    Dim sTo As String
    Dim sCc As String
    
    Set wscontrol = Worksheets("InputWS")
    
    'Set Date
    dDate = ThisWorkbook.Sheets("InputWS").range("B5").Value
    
'****PREPARE PDF FILE
    'Create Temp Workook
    Set wb = Workbooks.Add
    
    Select Case sRegion
        Case "Income Y:Y"
            'Calculate
            application.Calculate
            'Copy  Sheet to Temp
                ThisWorkbook.Sheets("SummaryY45").Copy after:=wb.Sheets(wb.Sheets.Count)
            'Copy All Detail Sheets to Temp Workook
                ThisWorkbook.Sheets("SetpoartRange").Copy after:=wb.Sheets(wb.Sheets.Count)


            'Set Email Body
            Set rBody = wb.Sheets("SummaryY45").range("D3:AO84")
        Case Else
            'Calculate
            application.Calculate
            'Copy GDTS Sheet to Temp Workook
            ThisWorkbook.Sheets("SummaryY45").Copy after:=wb.Sheets(wb.Sheets.Count)
            'Copy Local Sheet to Temp Workook
            ThisWorkbook.Sheets("SetpoartRange").Copy after:=wb.Sheets(wb.Sheets.Count)
            'Copy Branch Sheet to Temp Workook
            'ThisWorkbook.Sheets("Branch (" & Left(sRegion, 1) & ")").Copy after:=wb.Sheets(wb.Sheets.Count)
            'Set Email Body
            Set rBody = wb.Sheets("SetpoartRange").range("A1:AN84")
    End Select
    
    'For Each Worksheet in Temp Workbook
    For Each ws In wb.Worksheets
        'Paste Values
        ws.Activate
        ws.Cells.Copy
        ws.range("A1").PasteSpecial Paste:=xlPasteValues
        'Scroll to Range A1 in Each Sheet
        ws.Activate
        application.GoTo ws.range("A1"), scroll:=True
        'Collapse All Groups
        ws.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
            'Update Date in Page Header
            'For Each rCell In ws.Range("A1:D5")
            '    If InStr(rCell.Value, "date") > 0 Then
            '        rCell.Characters(InStr(rCell.Value, "date"), 4).Text = Format(dDate, "m/d/yy")
            '    End If
            'Next rCell
        'Delete Blank Worksheets
        'If Left(ws.Name, 5) = "Sheet" Then ws.Delete
    Next ws
    
    'Return to First Sheet
    'wb.Sheets("SetpoartRange").Activate
    
    'Save as PDF
    sFilePath = ThisWorkbook.Path & "SetpoartRange /PDF Archive/" & sRegion & " (" & Format(DateTime.Now, "dddd, mmmm, yyyy") & ").pdf"
    ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFilePath, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
    
'*****PREPARE EMAIL
    application.ScreenUpdating = True
    sTo = wscontrol.range("B" & application.Match(sRegion, wscontrol.Columns(1), 0))
    sCc = wscontrol.range("C" & application.Match(sRegion, wscontrol.Columns(1), 0))
    SendEmail sRegion & "  (" & Format(DateTime.Now, "dddd, mmmm, yyyy") & ")", sTo, rBody, sCc, sFilePath
    
    'Close Temp Workook
    wb.Close False
    
    'Clear Memory
    Set wb = Nothing
    Set ws = Nothing
    Set rBody = Nothing
    Set rCell = Nothing
    
    [F38] = Now
    
End Sub




Private Sub SendEmail(sSubject As String, sTo As String, rBody As range, _
    Optional sCc As String, Optional sAttachmentPath As String)
    
    On Error GoTo Err_CleanUpAndTryAgain
    
    Dim oOutlook As Object
    Dim oMailItem As Object
    Dim vWordEdit As Variant
    Dim shp As Object
    
Err_TryAgain:
    
    'Instantiate Outlook
    Set oOutlook = CreateObject("Outlook.Application")
    
    'Prepare Email Image
    rBody.CopyPicture xlScreen, xlBitmap
    
    'Create Mail Item
    Set oMailItem = oOutlook.CreateItem(0)
    For Each shp In ObjDoc.InlineShapes
    If shp.HasPicture Then
    shp.ScaleHeight = 22
    shp.ScaleWidth = 10
    End If
    Next
    
    With oMailItem
        .BodyFormat = 2
        .Display
        Set vWordEdit = oOutlook.ActiveInspector.WordEditor
        vWordEdit.application.Selection.Paste
        .SentOnBehalfOfName = "SetpoartRange"
        .To = sTo
        .cc = sCc
        .Subject = sSubject
        .Attachments.Add sAttachmentPath
        '.Send
    End With
    
    'Clear memory
    Set oOutlook = Nothing
    Set oMailItem = Nothing
    Set vWordEdit = Nothing
    
    Exit Sub
    
Err_CleanUpAndTryAgain:
    'Error handling will give two attempts to send email
    'Known error on first email, after user opens file
    Dim iTrapCount As Long
    If Err.Number = 4605 And iTrapCount <= 2 Then
        On Error Resume Next
        iTrapCount = iTrapCount + 1
        Debug.Print sSubject & " -- Error Attempt " & iTrapCount
        oMailItem.Delete
        Set oOutlook = Nothing
        Set oMailItem = Nothing
        Set vWordEdit = Nothing
        GoTo Err_TryAgain
    Else:
        Resume Next
    End If
    
[F38] = Now
    
End Sub

I appreciate your time or if there is a much better macro to achieve the save goal I will appreciate it too.