在下一列excel vba中保存范围的图像

在列A中的活动页上，我有要保存图像的文本并将其放在B列中。

我不知道如何删除线和轴等，只是得到范围的图像。 目前它在图像中显示线条和轴线。

Sub Generate_Images() Dim wK As Worksheet Dim oCht As Chart Dim i As Long, fI As Long Dim fName As String Application.DisplayAlerts = False Set wK = ActiveSheet fI = wK.Range("A" & wK.Rows.Count).End(xlUp).Row wK.Columns("B:B").ColumnWidth = wK.Columns("A:A").ColumnWidth For i = 1 To fI wK.Range("A" & i).CopyPicture xlScreen, xlBitmap Set oCht = ThisWorkbook.Charts.Add With oCht .ChartArea.Border.LineStyle = xlNone .Paste fName = ThisWorkbook.Path & "\" & Format(Now(), "DDMMYYHHMMSS") & ".png" .Export Filename:=fName, Filtername:="PNG" .Delete End With With wK.Pictures.Insert(fName) With .ShapeRange .LockAspectRatio = msoTrue .Width = wK.Range("A" & i).Width .Height = wK.Range("A" & i).Height End With .Left = wK.Range("B" & i).Left .Top = wK.Range("B" & i).Top .Placement = 1 .PrintObject = True End With Application.Wait Now + TimeValue("00:00:01") Next i Application.DisplayAlerts = True End Sub 

Answer 1

为什么出口，然后重新导入图像时，你可以直接粘贴到表单？

 Sub Generate_Images() Dim wK As Worksheet Dim oCht As Chart Dim i As Long, fI As Long Dim fName As String Application.DisplayAlerts = False Set wK = ActiveSheet fI = wK.Range("A" & wK.Rows.Count).End(xlUp).Row wK.Columns("B:B").ColumnWidth = wK.Columns("A:A").ColumnWidth For i = 1 To fI wK.Range("A" & i).CopyPicture xlScreen, xlBitmap wK.Paste With wK.Pictures(wK.Pictures.Count) .Left = wK.Range("B" & i).Left .Top = wK.Range("B" & i).Top .Placement = 1 .PrintObject = True End With Application.Wait Now + TimeValue("00:00:01") Next i Application.DisplayAlerts = True End Sub 

Answer 2

如果将图像保存为图片文件，请尝试此操作。

而是图表，使用chartobject。 可以更改图表的大小。 如果您的活动单元格不是空的，Excel会自动创build图表数据。 所以，你必须删除图表的节选。

 Sub Generate_Images() Dim wK As Worksheet Dim oCht As Chart Dim i As Long, fI As Long, j As Long Dim fName As String Dim obj As ChartObject Dim n As Long Dim w As Single, h As Single Application.DisplayAlerts = False Set wK = ActiveSheet wK.Pictures.Delete fI = wK.Range("A" & wK.Rows.Count).End(xlUp).Row wK.Columns("B:B").ColumnWidth = wK.Columns("A:A").ColumnWidth For i = 1 To fI w = wK.Range("A" & i).Width h = wK.Range("A" & i).Height wK.Range("A" & i).CopyPicture xlScreen, xlBitmap Set obj = wK.ChartObjects.Add(Range("c1").Left, 0, w, h) Set oCht = obj.Chart With oCht n = .SeriesCollection.Count For j = n To 1 Step -1 .SeriesCollection(j).Delete Next j .ChartArea.Border.LineStyle = xlNone .Paste fName = ThisWorkbook.Path & "\" & Format(Now(), "DDMMYYHHMMSS") & ".png" .Export Filename:=fName, Filtername:="PNG" obj.Delete End With With wK.Pictures.Insert(fName) .Left = wK.Range("B" & i).Left .Top = wK.Range("B" & i).Top .Placement = 1 .PrintObject = True End With Application.Wait Now + TimeValue("00:00:01") Next i Application.DisplayAlerts = True End Sub