'An example to export a picture of cell range
'    for Excel 2000 or later versions.

Function ExportPicture(ByVal Target As Object, ByVal Filename As String, _
        Optional ByVal CopyBitmap As Boolean = False) As Long
    Dim sHtml As String, sFolder As String
    Dim sFile As String, sFormat As String
    Dim Wb As Workbook
    Dim timeout As Date
    Dim ErrNo As Long

    On Error GoTo ErrorHandler
    ExportPicture = 1
    If Val(Application.Version) < 9 Then ExportPicture = 2: Exit Function

    sHtml = ThisWorkbook.Path & "\_tmp.htm"
    sFolder = ThisWorkbook.Path & "\_tmp.files"

    GoSub RemoveTmpFiles

    Select Case UCase(Right(Filename, 3))
        Case "GIF": sFormat = "Picture (GIF)"
        Case "JPG": sFormat = "Picture (JPEG)"
        Case "PNG": sFormat = "Picture (PNG)"
        Case Else: ExportPicture = 3: Exit Function
    End Select

    Select Case Application.International(1)
        Case 81: sFormat = Replace(sFormat, "Picture", ChrW(&H56F3))
    End Select

    If CopyBitmap Then
        Target.CopyPicture xlScreen, xlBitmap
    Else
        Target.CopyPicture xlScreen, xlPicture
    End If

    Application.DisplayAlerts = False
    Set Wb = Workbooks.Add(xlWorksheet)
    Wb.WebOptions.AllowPNG = True
    Wb.Worksheets(1).Paste
    Selection.Cut
    Wb.Worksheets(1).PasteSpecial sFormat
    Wb.SaveAs Filename:=sHtml, FileFormat:=xlHtml, AddToMru:=False
    Wb.Close Savechanges:=False
    Set Wb = Nothing
    Application.DisplayAlerts = True

    sFile = Dir(sFolder & "\*." & Right(Filename, 3))
    If sFile <> "" Then
        FileCopy sFolder & "\" & sFile, Filename
        ExportPicture = 0
    End If
    GoSub RemoveTmpFiles
    Exit Function

RemoveTmpFiles:
    ErrNo = 0
    On Error Resume Next
    timeout = Now() + TimeSerial(0, 0, 2)
    Do While Len(Dir(sFolder & "\*")) And Now() < timeout
        On Error Resume Next
        Kill sFolder & "\*"
        If Err = 0 Then Exit Do
    Loop
    ErrNo = ErrNo Or Err

    On Error Resume Next
    timeout = Now() + TimeSerial(0, 0, 2)
    Do While Len(Dir(sHtml)) And Now() < timeout
        On Error Resume Next
        Kill sHtml
        If Err = 0 Then Exit Do
    Loop
    ErrNo = ErrNo Or Err

    On Error Resume Next
    timeout = Now() + TimeSerial(0, 0, 2)
    Do While Len(Dir(sFolder, vbDirectory)) And Now() < timeout
        On Error Resume Next
        RmDir sFolder
        If Err = 0 Then Exit Do
    Loop
    ErrNo = ErrNo Or Err

    On Error GoTo ErrorHandler
    If ErrNo Then ExportPicture = 4: Exit Function
    Return

ErrorHandler:
    If Not Wb Is Nothing Then Wb.Close Savechanges:=False
    ExportPicture = 1
    Exit Function

End Function


Sub ExportRangePicture()
    Dim vFilename As Variant
    Dim sAddress As String
    Dim lRet As Long
    Dim r As Range

    If ThisWorkbook.Path = "" Then Exit Sub

    If TypeName(Selection) = "Range" Then sAddress = Selection.Address
    On Error Resume Next
    Set r = Application.InputBox(Prompt:="Select a range to export.", _
        Default:=sAddress, Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    Set r = r.Areas(1)

    vFilename = Replace(r.Worksheet.Name & "_" & r.Address(False, False), ":", "_")
    vFilename = Application.GetSaveAsFilename(InitialFilename:=vFilename, _
        FileFilter:="PNG (*.png),*.png,GIF (*.gif),*.gif,JPEG (*.jpg),*.jpg")
    If VarType(vFilename) <> vbString Then Exit Sub

    Application.ScreenUpdating = False
    lRet = ExportPicture(Target:=r, Filename:=vFilename)
    Application.ScreenUpdating = True
    Select Case lRet
        Case 0
            MsgBox "The picture was saved."
            'ActiveSheet.Pictures.Insert vFilename
        Case 1: MsgBox "Fail to export a picture."
        Case 2: MsgBox "This function is available in Excel 2000 or later."
        Case 3: MsgBox "Invalid prefix of filename."
        Case 4: MsgBox "Fail to remove temporary files."
    End Select
End Sub