導出範圍爲圖片

Question

有一段時間，我和我的同事們一直在使用各種方法創建一個模板，以便輕鬆製作志願者空缺表格。

理想情況下，項目負責人只應輸入詳細信息，自動生成空缺表格。

在這一點上，我儘可能自動完成表格，但我們仍然必須複製範圍並手動將其粘貼到繪圖中以將其保存爲圖像。同樣在圖像的頂部左側，還有一個非常薄的白色左側空間，我們必須調整。所以我的兩個問題：什麼代碼會使我成功實現將範圍（A1：F19）導出爲圖像（格式對我無關緊要，除非你們在任何方面看到（dis）優點），而薄的白色空間得到糾正？

如果將圖像保存在與執行代碼相同的文件夾中，並且文件名將是單元格J3的文件名，那將是理想的選擇。

我一直在嘗試幾個宏，我發現這裏和其他網站，但無法做任何工作，但這對我來說似乎最邏輯/實用 - 信用Our Man In Bananas; Using VBA Code how to export excel worksheets as image in Excel 2003?：

dim sSheetName as string 
dim oRangeToCopy as range 
Dim oCht As Chart 

sSheetName ="Sheet1" ' worksheet to work on 
set oRangeToCopy =Range("B2:H8") ' range to be copied 

Worksheets(sSheetName).Range(oRangeToCopy).CopyPicture xlScreen, xlBitmap 
set oCht =charts.add 

with oCht 
    .paste 
    .Export FileName:="C:\SavedRange.jpg", Filtername:="JPG" 
end with 

嗨！感謝您的回答！所以我稍微修改了代碼，因爲沒有擴展名的文件正在創建，並且在圖像的頂部和左側留下了一點空白區域。這是結果：

Sub Tester() 
    Dim sht As Worksheet 
    Set sht = ThisWorkbook.Worksheets("Activiteit") 

    ExportRange sht.Range("A1:F19"), _ 
       ThisWorkbook.Path & "\" & sht.Range("J3").Value & ".png" 

End Sub 


Sub ExportRange(rng As Range, sPath As String) 

    Dim cob, sc 

    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture 

    Set cob = rng.Parent.ChartObjects.Add(0, 0, 200, 200) 
    'remove any series which may have been auto-added... 
    Set sc = cob.Chart.SeriesCollection 
    Do While sc.Count > 0 
     sc(1).Delete 
    Loop 

    With cob 
     .Height = rng.Height 
     .Width = rng.Width 
     .Chart.Paste 
     .Chart.Export FileName:=sPath, Filtername:="PNG" 
     .Delete 
    End With 

End Sub 

現在，除了一個小細節外，它是完美的;圖像現在有一個（非常非常）薄的灰色邊框。這不是什麼大問題，只有訓練有素的人才會注意到它。如果沒有辦法擺脫它 - 沒有biggie。但以防萬一，如果你知道一種絕對好的方式。

我已經在這一行

Set cob = rng.Parent.ChartObjects.Add(0, 0, 200, 200) 

-10更改值嘗試過，但似乎並沒有幫助。

Answer 1

編輯：添加了一行到來自各地的chartobject

Sub Tester() 
    Dim sht as worksheet 
    Set sht = ThisWorkbook.Worksheets("Sheet1") 

    ExportRange sht.Range("B2:H8"), _ 
       ThisWorkbook.Path & "\" & sht.Range("J3").Value 

End Sub 


Sub ExportRange(rng As Range, sPath As String) 

    Dim cob, sc 

    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture 

    Set cob = rng.Parent.ChartObjects.Add(10, 10, 200, 200) 
    'remove any series which may have been auto-added... 
    Set sc = cob.Chart.SeriesCollection 
    Do While sc.Count > 0 
     sc(1).Delete 
    Loop 

    With cob 
     .ShapeRange.Line.Visible = msoFalse '<<< remove chart border 
     .Height = rng.Height 
     .Width = rng.Width 
     .Chart.Paste 
     .Chart.Export Filename:=sPath, Filtername:="PNG" 
     .Delete 
    End With 

End Sub