Charts as pictures; file size too long

[fredalina]

I receive an Excel file with a chart that is driven by 2 drop-down selection boxes. My task is to cycle through all the combinations and generate all the charts, then copy/paste each of them in to PowerPoint at a certain size. I created a macro that cycles through the combinations and creates a new tab for each chart, and then it takes the pictures on each of the tabs and pastes them into a PowerPoint for me. The problem is that the manual process produces a .ppt that is about 3MB and the automated process produces a .ppt that is about 12MB and too large to email at our company (limit is 10MB).

I have tried JPEG, GIF, PNG, BMP, and Advanced Metafile. All produce similarly sized .ppt files. I have tried compressing the file sizes either in Excel or PowerPoint, but the final version is the same size as the original version.

My final result must have the picture formatted to a specific size, and the text (axes, labels) must be legible, but the charts aren't that complicated and can have a slightly lower resolution.

        'Activate Copy Sheet
    
        Sheets(pLongName).Activate
        Range("A1:B1").Select
        Range("A1:B1").Value = pName
        
    
            
       'Copy to name sheet and name picture
        Sheets("Detailed Pareto").Activate
        Range("A1:B1").Select
        Range("A1:B1").Value = pName
        
      'Copy to name sheet and name picture
        Sheets("Detailed Pareto").Select
         ActiveSheet.ChartObjects("Chart 1").Activate
        ActiveChart.ChartArea.Copy
        Sheets(parName).Select
        ActiveSheet.PasteSpecial Format:="Picture (GIF)", Link:=False, _
            DisplayAsIcon:=False
            

        'Re-size picture
        ActiveSheet.Shapes.Range(Array("Picture 1")).Select
        With Selection
            .Height = 400
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.ScaleWidth 0.78, msoTrue, msoScaleFromTopLeft
        End With
    
        
        Next i
        Sheets(1).Activate  'Goes to first worksheet
        Application.ScreenUpdating = True  'Makes it visible again
        'If there is an error, go to Screen() and run that
        Application.CommandBars.ExecuteMso "PicturesCompress"

Thanks in advance for any help you can provide.