104.将选择定单元格作成镜像图片

'###############################################################

'函数作用：将选择定单元格作成镜像图片

'###############################################################

Sub Test()

    'ExportRangeAsImage "d:\a.gif", "GIF"

    'ExportRangeAsImage "d:\a.JPG", "JPG"

End Sub

Sub ExportRangeAsImage(varFileName As Variant, ImageFilter As String)

    Dim objChart As ChartObject

    Dim chtChart As Chart

    Dim picPicture As Picture

    Dim sglWidth As Single

    Dim sglHeight As Single

    Dim rngSelection As Range

    Dim blnRet As Boolean

    On Error GoTo ExportRangeError

    Set rngSelection = Selection

    With Application

        .StatusBar = "Exporting range..."

        .ScreenUpdating = False

    End With

    rngSelection.CopyPicture Appearance

    = xlScreen, Format

    = xlPicture

    Set objChart = ActiveSheet.ChartObjects.Add(0, 0, 5000, 5000)

    Set chtChart = objChart.Chart

    objChart.Activate

    With chtChart

        .ChartArea.Select

        .Paste

        Set picPicture = .Pictures(1)

    End With

    With picPicture

        sglWidth = .Width + 7

        sglHeight = .Height + 7

        .Left = 0

        .Top = 0

    End With

    With objChart

        .Border.LineStyle = xlNone

        .Width = sglWidth

        .Height = sglHeight

    End With

    blnRet = chtChart.Export(FileName

    = varFileName, Filtername    = ImageFilter, Interactive

    = False)

    objChart.Delete

    Set objChart = Nothing

    Application.StatusBar = False

    If Not blnRet Then

        MsgBox "Sorry, the export failed: please verify that you " & vbLf & _

            "have the appropriate filter installed on your PC.", vbExclamation, AT & " ‐ Export range as image"

    Else

    End If

Continue:

    With Application

        .StatusBar = False

        .ScreenUpdating = True

    End With

    Exit Sub

ExportRangeError:

    MsgBox "Sorry, the export failed: please verify that you " & vbLf & _

        "have the appropriate filter installed on your PC." & vbLf & _

        "Error nr. " & Err.Number & ": " & Err.Description, vbExclamation, AT & " ‐ Export range as image"

    If Not objChart Is Nothing Then objChart.Delete

    Resume Continue

End Sub