将Excel内容捕获为图像 [英] To capture content of excel as image

问题描述

你好，

我编写了以下代码，用于将excel内容捕获为图像，在excel中添加新工作表并将图像粘贴到添加的新工作表中.
较早之前，我用于捕获图像的代码可以正常工作，但是现在却出现了一些错误.请让我知道该错误，因为我无法识别它.
代码也正在图像中创建图表，但我不想要图表.

Hello,

I have written the below code for capturing the excel content as image, adding new sheet in excel and pasting the image in added new sheet.
Earlier my code for capturing the image was working but now its giving some error. Please let me know the error as i am unable to identify it.
Also the code is creating chart in the image but i dont want the chart.

' To copy content as image
Sub Export_Range_Images()
 

Dim oRange As Range
Dim oCht As Chart
Dim oImg As Picture
 

Set oRange = Range("A1:I84")
Set oCht = Charts.Add
Set oImg = Picture.Add
oCht.Paste
oCht.Export Filename:="E:\img\SavedRange.jpg", Filtername:="JPG"
End Sub
 
' To add new sheet
Sub AddSheet()
Dim ActNm As String
 

With ActiveWorkbook.Sheets
.Add after:=Worksheets(Worksheets.Count)
End With
ActNm = ActiveSheet.Name
On Error Resume Next
ActiveSheet.Name = "Jul 16 2012"
NoName: If Err.Number = 1004 Then ActiveSheet.Name = InputBox("Give name.")
If ActiveSheet.Name = ActNm Then GoTo NoName
On Error GoTo 0
End Sub
 
'Code to paste image in newly added sheet
Sub TestInsertPictureInRange()
InsertPictureInRange "E:\img\SavedRange.jpg", _
Range("A1:I84")
End Sub
 

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub
 
/*Calling all macros*/
Sub All_codes()
Export_Range_Images
AddSheet
TestInsertPictureInRange
End Sub

谢谢！
Archie

Thanks!
Archie

推荐答案

最重要的是未对代码进行优化！是什么意思?

1)如果过程的一部分被多次使用，则需要将该过程用作单独的函数/过程或将其作为参数发送！
在InsertPictureInRange过程中使用图像时，过程TestInsertPictureInRange和Export_Range_Images应具有图像名称作为输入参数.

The most important thing is that the code is not optimised! What it means?

1) if the part of procedure is used more than one time, you need to use this as a separatly function/procedure or to send it as a parameter!
The procedures TestInsertPictureInRange and Export_Range_Images should have as an input parameter the name of image, as you use it in InsertPictureInRange procedure.

Sub TestInsertPictureInRange (ByVal PictureFileName AS String)
'...

End Sub
Sub Export_Range_Images (ByVal PictureFileName AS String)
'...
End Sub

2)如果代码没有上下文，其工作效果可能会带来意想不到的结果！
例如，尝试运行以下过程:

2) if the code has no context, the effect of its job can bring unexpected results!
For example, try to run this procedure:

Sub Test
Range("A1") = "Hello Kitty!"
End Sub

3个打开的工作簿以及其中的每个工作表.





请查看我的代码(带有错误处理程序):

for 3 opened workbooks and for each sheet in them.





Please, see my code (with error-handler):

Option Explicit

Sub Test()
    InsertImageInRange "F:\Download\Saalbach009.jpg", Format(Date, "yyyyMMdd")
    InsertImageInRange "F:\Download\Saalbach009.jpg", Format(Date, "yyyyMMdd"), "A1:I29"
End Sub

'Code to insert a picture/image in the current/active workbook into newly added sheet
' and resizes it to fit the TargetCells range

Sub InsertImageInRange(ByVal PictureFileName As String, ByVal DefaultSheetName As String, Optional ByVal DefaultTargetRange As String = "G10:N30")
Dim wsh As Worksheet, rng As Range, pic As Shape

'On error go to error-handler
On Error GoTo Err_ExportRangeAsImage

Set wsh = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))

wsh.Name = DefaultSheetName
Set rng = wsh.Range(DefaultTargetRange)

Set pic = wsh.Shapes.AddPicture(PictureFileName, msoFalse, msoCTrue, rng.Left, rng.Top, _
                rng.Offset(0, rng.Columns.Count).Left - rng.Left, rng.Offset(rng.Rows.Count, 0).Top - rng.Top)


Exit_ExportRangeAsImage:
    On Error Resume Next
    Set wsh = Nothing
    Set rng = Nothing
    Set pic = Nothing
    Exit Sub

Err_ExportRangeAsImage:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_ExportRangeAsImage

End Sub

更多信息，请访问:
http://www.jpsoftwaretech.com/export-excel-range-to-a -picture-file/ [ ^ ]
http://dmcritchie.mvps.org/excel/xl2gif.htm [ http://www.ozgrid.com/forum/showthread.php?t=65781 [ ^ ]

More you''ll find at:
http://www.jpsoftwaretech.com/export-excel-range-to-a-picture-file/[^]
http://dmcritchie.mvps.org/excel/xl2gif.htm[^]
http://www.ozgrid.com/forum/showthread.php?t=65781[^]

这篇关于将Excel内容捕获为图像的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！