Export pictures from excel file into jpg using VBA

Question

I have an Excel file which includes pictures in column B and I want like to export them into several files as .jpg (or any other picture file format). The name of the file s

Answer 1

New versions of excel have made old answers obsolete. It took a long time to make this, but it does a pretty good job. Note that the maximum image size is limited and the aspect ratio is ever so slightly off, as I was not able to perfectly optimize the reshaping math. Note that I've named one of my worksheets wsTMP, you can replace it with Sheet1 or the like. Takes about 1 second to print the screenshot to target path.

Option Explicit

Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Sub weGucciFam()

Dim tmp As Variant, str As String, h As Double, w As Double

Application.PrintCommunication = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If Application.StatusBar = False Then Application.StatusBar = "EVENTS DISABLED"

keybd_event vbKeyMenu, 0, 0, 0 'these do just active window
keybd_event vbKeySnapshot, 0, 0, 0
keybd_event vbKeySnapshot, 0, 2, 0
keybd_event vbKeyMenu, 0, 2, 0 'sendkeys alt+printscreen doesn't work
wsTMP.Paste
DoEvents
Const dw As Double = 1186.56
Const dh As Double = 755.28

str = "C:\Users\YOURUSERNAMEHERE\Desktop\Screenshot.jpeg"
w = wsTMP.Shapes(1).Width
h = wsTMP.Shapes(1).Height

Application.DisplayAlerts = False
Set tmp = Charts.Add
On Error Resume Next
With tmp
    .PageSetup.PaperSize = xlPaper11x17
    .PageSetup.TopMargin = IIf(w > dw, dh - dw * h / w, dh - h) + 28
    .PageSetup.BottomMargin = 0
    .PageSetup.RightMargin = IIf(h > dh, dw - dh * w / h, dw - w) + 36
    .PageSetup.LeftMargin = 0
    .PageSetup.HeaderMargin = 0
    .PageSetup.FooterMargin = 0
    .SeriesCollection(1).Delete
    DoEvents
    .Paste
    DoEvents
    .Export Filename:=str, Filtername:="jpeg"
    .Delete
End With
On Error GoTo 0
Do Until wsTMP.Shapes.Count < 1
    wsTMP.Shapes(1).Delete
Loop

Application.PrintCommunication = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False

End Sub