VBA保存选择区域Range为图片GIF

分类:代码, 博客 标签:

Excel中有时需要保存当前选择区域为图片,以便插入其它程序中使用,同时又保持Excel中的布局及样式,这里水文工具集介绍一个使用VBA编写的过程来实现这一功能,具体源代码如下:

Option Explicit
'================================
'VBA保存选择区域Range为图片GIF
'
' http://www.cnhup.com
'================================
'XL2GIF_module -- GIF_Snapshot
Dim container As Chart
Dim containerbok As Workbook
Dim Obnavn As String
Dim Sourcebok As Workbook

Function SelectArea() As String
Dim Internrange As Range
On Error GoTo Brutt
Set Internrange = Application.InputBox("Select " _
    & "range to be photographed:", "Picture Selection", _
    Selection.AddressLocal, Type:=8)
SelectArea = Internrange.Address
Exit Function
Brutt:
SelectArea = "A1"
End Function

Function sShortname(ByVal Orrginal As String) As String
Dim iii As Long
sShortname = ""
For iii = 1 To Len(Orrginal)
If Mid(Orrginal, iii, 1) <> " " Then _
      sShortname = sShortname & Mid(Orrginal, iii, 1)
Next
End Function

Private Sub ImageContainer_init()
Workbooks.Add (1)
ActiveSheet.Name = "GIFcontainer"
Charts.Add
    ActiveChart.ChartType = xlColumnClustered
    ActiveChart.SetSourceData Source:=Worksheets(1).Range("A1")
    ActiveChart.Location Where:=xlLocationAsObject, _
      Name:="GIFcontainer"
ActiveChart.ChartArea.ClearContents
Set containerbok = ActiveWorkbook
Set container = ActiveChart
End Sub

Sub MakeAndSizeChart(ih As Long, iv As Long)
Dim Hincrease As Single
Dim Vincrease As Single
Obnavn = Mid(ActiveChart.Name, Len(ActiveSheet.Name) + 1)
Hincrease = ih / ActiveChart.ChartArea.Height
ActiveSheet.Shapes(Obnavn).ScaleHeight Hincrease, _
   msoFalse, msoScaleFromTopLeft
Vincrease = iv / ActiveChart.ChartArea.Width
ActiveSheet.Shapes(Obnavn).ScaleWidth Vincrease, _
   msoFalse, msoScaleFromTopLeft
End Sub

Public Sub GIF_Snapshot()
Dim varReturn As Variant
Dim MyAddress As String
Dim SaveName As Variant
Dim MySuggest As String
Dim Hi As Long
Dim Wi As Long
Dim Suffiks As Long

Set Sourcebok = ActiveWorkbook
MySuggest = sShortname(ActiveSheet.Name)
ImageContainer_init
Sourcebok.Activate
MyAddress = SelectArea
If MyAddress <> "A1" Then
    SaveName = Application.GetSaveAsFilename( _
      initialfilename: =MySuggest _
      & ".gif", fileFilter:="Gif Files (*.gif), *.gif")
    Range(MyAddress).Select
    Selection.CopyPicture Appearance:=xlScreen, _
       Format:=xlBitmap
    If SaveName = False Then
        GoTo Avbryt
    End If
    If InStr(SaveName, ".") Then SaveName _
        = Left(SaveName, InStr(SaveName, ".") - 1)
    Selection.CopyPicture Appearance:=xlScreen, _
       Format:=xlBitmap
    Hi = Selection.Height + 4  'adjustment for gridlines
    Wi = Selection.Width + 6   'adjustment for gridlines
    containerbok.Activate
    ActiveSheet.ChartObjects(1).Activate
    MakeAndSizeChart ih:=Hi, iv:=Wi
    ActiveChart.Paste
    ActiveChart.Export Filename:=LCase(SaveName) & _
         ".gif", FilterName:="GIF"
    ActiveChart.Pictures(1).Delete
    Sourcebok.Activate
End If
Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
End Sub


分类:代码, 博客 标签:

发表评论

You must be logged in to post a comment.