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

时间:2017-09-09 21:07:42

标签: excel vba 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

2 个答案:

答案 0 :(得分:2)

为什么要导出然后重新导入图像,只需将其直接粘贴到工作表中即可?

int remainder;
char Hex[8];
int quotient, power;
remainder = (original_value*-1)-1;
for (int k = len; k > 0 ; k--)
{
    if (sign == 1)
    {
        power = pow(16, k-1);
        quotient = 15 - (remainder/power);
        remainder = remainder%power;
        if (quotient < 10)
            Hex[len - k] = (int)quotient;
        else if (quotient == 10)
            Hex[len - k] = 'A';
        else if (quotient == 11)
            Hex[len - k] = 'B';
        else if (quotient == 12)
            Hex[len - k] = 'C';
        else if (quotient == 13)
            Hex[len - k] = 'D';
        else if (quotient == 14)
            Hex[len - k] = 'E';
        else if (quotient == 15)
            Hex[len - k] = 'F';
    }
}


for(int k = 0; k < len; k++)
    printf("%s", Hex[k]);

答案 1 :(得分:0)

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

相反图表,使用chartobject。可以更改图表的大小。 如果您的活动单元格不为空,Excell会根据数据自动创建图表。 因此,您必须删除图表的seriescollecton。

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