'Export Picture
'    for Excel 8.0 or later

'    Copyright Kazuyuki Housaka 1998


'The "Export" method in Excel create GIF or JPEG files.
'This script dose not create.
'The installation of the graphic filter program that Excel use
'is required.

'This macro use the working-sheet "ExportWork" in the same workbook.
'If the sheet dose not exist, this macro create it.

'Insert a new module, copy the following code and paste to the module.
'Select cell range or object, and run "ExportPicture" macro.


Option Explicit

Private Const sAppName = "Export Picture"
Private Const sWorkSheetName = "ExportWork"
Private Const MAX_CELL = 300

Public Function ExportClipboardBitmap(ByVal sFileName As String, _
        ByVal sFilterName As String, ByVal vInteractive As Variant) As Long
    Dim oSheet As Object
    Dim oChart As Object
    Dim obj As Object
    Dim vRet As Variant

    ExportClipboardBitmap = -1

    On Error Resume Next
    Set oSheet = ThisWorkbook.Worksheets(sWorkSheetName)
    On Error GoTo ErrorHandler

    If oSheet Is Nothing Then
        Set oSheet = ThisWorkbook.Worksheets.Add
        oSheet.Name = sWorkSheetName
    End If

    If oSheet.ChartObjects.Count = 0 Then
        Set oChart = oSheet.ChartObjects.Add(0, 0, 500, 500).Chart
    Else
        Set oChart = oSheet.ChartObjects(1).Chart
    End If

    For Each obj In oChart.DrawingObjects
        obj.Delete
    Next

    If Not IsClipboardFormat(xlClipboardFormatBitmap) Then
         Exit Function
    End If

    oChart.Paste
    Set obj = oChart.DrawingObjects(1)
    obj.Border.LineStyle = xlNone

    oChart.Export sFileName, sFilterName, vInteractive

    For Each obj In oChart.DrawingObjects
        obj.Delete
    Next

    ExportClipboardBitmap = 0
    Exit Function

ErrorHandler:
    Exit Function

End Function


Public Sub ExportPicture()
    Dim vFileName As Variant
    Dim sFilterName As String
    Dim iRet As Long

    If CheckCopyPicture(xlBitmap, sAppName) = 0 Then
        Exit Sub
    End If

    If Not IsClipboardFormat(xlClipboardFormatBitmap) Then
        MsgBox "No picture in clipboard.", vbExclamation, sAppName
        Exit Sub
    End If

    vFileName = Application.GetSaveAsFilename( _
        InitialFilename:="", _
        FileFilter:=StrConv("GIF (*.gif),*.gif,JPEG (*.jpg),*.jpg," & _
            "All files (*.*),*.*", vbNarrow), _
        Title:=sAppName)
    If VarType(vFileName) = vbBoolean Then Exit Sub
    If StrComp(Right(vFileName, 4), ".GIF", 1) = 0 Then
        sFilterName = "GIF"
    ElseIf StrComp(Right(vFileName, 4), ".JPG", 1) = 0 Then
        sFilterName = "JPEG"
    Else
        MsgBox "Illegal file name.", vbExclamation, sAppName
        Exit Sub
    End If

    If Dir$(vFileName) <> "" Then
        iRet = MsgBox("The file '" & vFileName & _
            "' already exists. Replace existing file?", _
            vbExclamation Or vbOKCancel Or vbDefaultButton2, sAppName)
        If iRet <> vbOK Then Exit Sub
    End If

    iRet = ExportClipboardBitmap(vFileName, sFilterName, True)
    Select Case iRet
        Case 0
            MsgBox "The picture was saved.", vbInformation, sAppName
        Case Else
            MsgBox "Unexpected error.", vbExclamation, sAppName
    End Select
End Sub


Public Function IsClipboardFormat(ByVal iFormat As Long) As Boolean
    Dim vFormats As Variant
    Dim vFormat As Variant
    IsClipboardFormat = False
    On Error GoTo ErrorHandler
    vFormats = Application.ClipboardFormats
    For Each vFormat In vFormats
        If vFormat = iFormat Then
            IsClipboardFormat = True
            Exit Function
        End If
    Next
    Exit Function
ErrorHandler:
    Exit Function
End Function


Public Function SelectionCopyPicture(iFormat As Long) As Boolean
    Dim iLineNo As Integer
    Dim iStatus As Integer

    On Error GoTo ErrorHandler

    iLineNo = 1
    If Not (ActiveChart Is Nothing) Then
        If CopyChartPicture(ActiveChart, iFormat) = 0 Then
            SelectionCopyPicture = True
        End If
        Exit Function
    End If

    iLineNo = 2
    iStatus = 0
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=iFormat, Size:=xlScreen
    If iStatus = 0 Then
        SelectionCopyPicture = True
        Exit Function
    End If

    iLineNo = 3
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=iFormat
    SelectionCopyPicture = True

    Exit Function

ErrorHandler:
    Select Case iLineNo
        Case 2
            iStatus = 1
            Resume Next
        Case Else
            SelectionCopyPicture = False
            Exit Function
    End Select
End Function


Public Function CheckCopyPicture(iFormat As Long, sAppName As String) As Long
    Dim iRet As Long
    CheckCopyPicture = 0
    iRet = MsgBox("Copy the picture of selected object?", _
        vbExclamation Or vbYesNoCancel, sAppName)

    If iRet = vbCancel Then
        Exit Function
    End If

    If iRet = vbYes Then
        If iFormat = xlBitmap Then
            If TypeName(Selection) = "Range" Then
                If Selection.Count > MAX_CELL Then
                    MsgBox "Too large picture.", _
                        vbExclamation, sAppName
                    Exit Function
                End If
            End If
            If TypeName(ActiveSheet) = "Chart" Then
                MsgBox "Too large picture.", vbExclamation, sAppName
                Exit Function
            End If
        End If

        If Not SelectionCopyPicture(iFormat) Then
            MsgBox "Error copying the picture of selected object.", _
                vbExclamation, sAppName
            Exit Function
        End If
    End If
    CheckCopyPicture = 1
End Function


Public Function CopyChartPicture(ByVal oChart As Object, _
        ByVal iFormat As Long) As Long
    Dim oChartObject As Object
    Dim iLineStyle As Long
    Dim iWeight As Long
    Dim iColorIndex As Long
    Dim bRoundedCorners As Boolean
    Dim bShadow As Boolean
    Dim bBorder As Boolean
    Dim iRet As Long

    CopyChartPicture = -1

    On Error GoTo ErrorHandler

    Set oChartObject = oChart.Parent
    If TypeName(oChartObject) = "ChartObject" Then
        iLineStyle = oChartObject.Border.LineStyle
        If iLineStyle <> xlNone Then
            iRet = MsgBox("Crop the border line?", _
                vbQuestion Or vbYesNo, sAppName)
            bBorder = (iRet = vbYes)
        End If
    End If

    If bBorder Then
        Application.ScreenUpdating = False

        With oChartObject.Border
            iLineStyle = .LineStyle
            iWeight = .Weight
            iColorIndex = .ColorIndex
        End With
        bRoundedCorners = oChartObject.RoundedCorners
        bShadow = oChartObject.Shadow

        On Error Resume Next
        oChartObject.Border.LineStyle = xlNone
        oChartObject.RoundedCorners = False
        oChartObject.Shadow = False
        On Error GoTo ErrorHandler

        oChart.CopyPicture Appearance:=xlScreen, _
            Size:=xlScreen, Format:=iFormat

        On Error Resume Next
        If iLineStyle <> xlNone Then
            oChartObject.Border.LineStyle = iLineStyle
            oChartObject.Border.Weight = iWeight
            oChartObject.Border.ColorIndex = iColorIndex
        End If
        oChartObject.RoundedCorners = bRoundedCorners
        oChartObject.Shadow = bShadow
        iRet = Err
        On Error GoTo ErrorHandler

        Application.ScreenUpdating = True
        If iRet <> 0 Then
            MsgBox "Cannot crop the border line.", _
                vbExclamation, sAppName
        End If
    Else
        oChart.CopyPicture Appearance:=xlScreen, _
            Size:=xlScreen, Format:=iFormat
    End If
    CopyChartPicture = 0
    Exit Function

ErrorHandler:
    Exit Function

End Function