حفظ نطاق معين كصورة

[ابوعلي الحبيب]

السلام عليكم

الاساتذه الكرام
امل المساعدة

لدي كود اخذ صورة من نطاق معين وحفظها

وكان يعمل بشكل ممتاز ثم توقف 

لا ادري لماذا
 

مرفق ملف

ولكم كل الشكر والتقدير

 

كود اخذ صورة وحفظها.xlsb

[أبوأحـمـد]

وعليكم السلام

هذا كود أنا مستخدمه في أداة التقويم الدراسي

يحفظ الصورة في سطح المكتب عدل فيه حسب احتياجك

Sub ExportScreenshot()

Dim Path As String
    Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "Capture.jpg"
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("ورقة1").Range("D2:AR34")

Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 800
.Height = PicTemp.Height + 350
End With
ChTemp.Export Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "تقويم اكسل.jpg", Filtername:="jpg"

MsgBox "تم حفظ صورة للتقوم على سطح المكتب" & vbNewLine & "تقويم اكسل.jpg" & vbNewLine & " يمكن الاستفادة منها لتكون خلفية لسطح المكتب" & vbNewLine & "لايقاف الرسال أو منع حفظ الصورة حدد الخيار من تبويب صفحة حول", , "التقويم"

Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[ابوعلي الحبيب]

شكرا لتفاعلك اخ أبوأحـمـد
والكود جميل ولكن

كيف اجعل الكود ياخذ اسم الصورة من خليلة محددة
وكذلك

وكذلك حفظ الصورة في مجلد في D

جزاك الله خير

[أبوأحـمـد]

جرب هذا 

Sub ExportScreenshot()

Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim wbA As Workbook
Dim ChTemp As Chart
Dim PicTemp As Picture
Dim name_jpg As String
Dim strPath As String
Dim strPathFile As String
Dim myFile As Variant

Set ShTemp = ActiveSheet
Set wbA = ActiveWorkbook

Application.ScreenUpdating = False
'تحديد النطاق المطلوب أخذ صورة له
Set pic_rng = ShTemp.Range("D2:AR34")

Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 800
.Height = PicTemp.Height + 350
End With

On Error GoTo errHandler

'الحصول على اسم الصورة من الخلية A1
name_jpg = Range("A1").Value & ".jpg"

'الحصول على مجلد المصنف النشط 
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
strPathFile = strPath & name_jpg

' حدد مجلدًا للملف
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="jpg Files (*.jpg), *.jpg", _
        Title:="حدد المجلد واسم الملف للحفظ")


'التصدير إلى صورة إذا تم تحديد مجلد
If myFile <> "False" Then
ChTemp.Export Filename:=myFile, FilterName:="jpg"
        
    'رسالة تأكيد الحفظ مع معلومات الملف
    MsgBox "تم حفظ الصورة: " _
      & vbCrLf _
      & myFile
End If
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

exitHandler:
    Exit Sub
errHandler:
    MsgBox "تعذر حفظ الصورة"
    Resume exitHandler
    

End Sub

 

[ابوعلي الحبيب]

الاخ أبوأحـمـد اكرر شكري لك على تفاعلك 

ولكن للاسف لم تنجح الطريقة

جزاك الله خير

[أبوأحـمـد]

12 ساعات مضت, ابوعلي الحبيب said:

لم تنجح الطريقة

وضح أكثر ..
ما المشكلة في الكود؟

[حسونة حسين]

وعليكم السلام ورحمه الله وبركاته

اخي @ابوعلي الحبيب

الكود الخاص بك في المشاركه الاولي ليس به اي مشكله  لكن تأكد ان المسار الذي تحفظ به الصورة موجود

 

وهذا كود اخر بسيط سوف يقوم بإنشاء المسار ان لم يكن موجود ويحفظ الصورة

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
    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"
    Set oRng = Ws.Range("A3:H17")
    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

 

 

[ابوعلي الحبيب]

 الاستاذ الفاضل

حسونة حسين

 

تسلم  هذا هو المطلوب

لك مني كل الشكر والتقدير 

ولكل من تفاعل معي

ﷲ يجزاكم خير ويسعدكك