تعديل كود حفظ كصورة

[Bayan20]

مطلوب تعديل كود حفظ صورة لنطاق محدد من الخلايا الممتلئة فقط

Book1.xlsm

[lionheart]

Try this code

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean

Sub Export_Range_As_Picture()
    Dim ws As Worksheet, oRng As Range, oChart As ChartObject, sFolder As String, sFile As String, rw As Long
    Application.ScreenUpdating = False
        Set ws = Sheet1
        sFolder = "D:\Pic\"
        MakeSureDirectoryPathExists sFolder
        sFile = sFolder & ws.Range("A1").Value & "." & "jpg"
        rw = FindErrorRow(ws, 2)
        If rw <> -1 Then
            Set oRng = ws.Range("A2:E" & rw)
        Else
            Set oRng = ws.Range("A2:E" & ws.Cells(Rows.Count, "B").End(xlUp).Row)
        End If
        oRng.CopyPicture xlScreen, xlPicture
        Set oChart = ws.ChartObjects.Add(Left:=0, Top:=0, Width:=oRng.Width * 1, Height:=oRng.Height * 1)
        With oChart
            .Activate
            .Chart.Paste
            .Chart.Export Filename:=sFile
            .Delete
        End With
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

Function FindErrorRow(ByVal ws As Worksheet, ByVal col As Long)
    Dim rng As Range
    On Error Resume Next
        Set rng = ws.Columns(col).SpecialCells(xlCellTypeFormulas, xlErrors)
    On Error GoTo 0
    If Not rng Is Nothing Then FindErrorRow = rng.Cells(1, 1).Row - 1 Else FindErrorRow = -1
End Function

 

[أ / محمد صالح]

يمكنك تعديل الكود المستعمل في الملف إلى هذا

وتم إضافة متغير لتحديد الصف الأخير من العمود A

Option Explicit
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean
Sub Export_Range_As_Picture()
    Dim Ws As Worksheet, StrToFolder2 As String, lr As Long
    Dim oRng As Range, sPath As String, oChart As ChartObject

    Set Ws = ActiveSheet
    Application.ScreenUpdating = False
    StrToFolder2 = "D:\pic\"
    MakeSureDirectoryPathExists StrToFolder2
    sPath = StrToFolder2 & Ws.Range("a1").Value & "." & "jpg"
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    Set oRng = Ws.Range("A2:E" & lr)
    oRng.CopyPicture xlScreen, xlPicture
    Set oChart = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=oRng.Width * 1, Height:=oRng.Height * 1)
    With oChart
        .Activate
        .Chart.Paste
        .Chart.Export Filename:=sPath
        .Delete
    End With
    Application.ScreenUpdating = True
End Sub

بالتوفيق

[Bayan20]

تمام شكرا للمجهود الرائع زادكم الله من علمه وانفع بكم الكثيرين