range 2 jpeg by mohtar

[مختار حسين محمود]

اخوانى وأحبابى السلام عليكم

 

اليوم أقدم لكم  كيفية     عمل صورة    من مدى معين تحدده     مع حفظ الصورة فى مسار تحدده أيضاً

 

الكود المستخدم فى الموضوع مديول عادى :

Sub make_jpeg()
Dim i  As Integer
Dim intCount As Integer
Dim objPic As Shape
Dim objChart As Chart

'نسخ المدى كصوره
Call Sheet1.Range("A1:f13").CopyPicture(xlScreen, xlPicture)

'مسح أى أشكال من شيت 2
intCount = Sheet2.Shapes.Count
For i = 1 To intCount
    Sheet2.Shapes.Item(1).Delete
Next i
'عمل جدول فى شيت 2
Sheet2.Shapes.AddChart
'تنشيط شيت 2
Sheet2.Activate
'تحديد الجدول الذى يوجد فى شيت 2
Sheet2.Shapes.Item(1).Select
Set objChart = ActiveChart
'لصق المدى اللى نسخناه فى هذا الجدول
Sheet2.Shapes.Item(1).Width = Range("A1:f13").Width
Sheet2.Shapes.Item(1).Height = Range("A1:f13").Height
objChart.Paste
'حفظ الجدول كصورة فى المسار التالى
objChart.Export ("D:\photo\mokhtar.Jpeg")
End Sub

وتفضلوا المرفق واعلموا أن لا أريد كلمات المدح أو الثناء

 

ولكن كل ما أريده من حضراتكم دعوة بسيطة بظهر الغيب للمرحوم أبى  .   كل سنة وأنتم أقرب الى اللـــــه عز وجل

 

range 2 jpeg by mohtar.rar

[Akram Galal]

الله يرحمة

ويرحم جميع المسلمين

[Akram Galal]

أخي مختار

هل ممكن تظهر رسالة نختار منها مكان الفولدر كتابة اسمه

ثم كتابة اسم الملف

جزاك الله خيرا

[ibn_egypt]

اخى الفاضل أ.مختار

 

جزاك الله كل خير أخي الكريم وجعل عملك في ميزان حسناتك ... فكرة جميلة ورائعة 

 

تسلم ايدك ورحم الله والدك ووالدي وجميع موتانا وموتي المسلمين .. وبارك الله لك في أبنائك وجعلهم قرة عين لك

 

ولكن

 

ايه رايك نضيف اضافة بسيطة على الكود بحيث نجعل انه ليس من الضرورى الحفظ في ال D بل يتم الحفظ في نفس مسار ملف الاكسل

 

كما يتم حفظ الصورة بالتاريخ والوقت الذي التقطت فيه حتى لا يتم استبدال الصورة الجديدة بالصورة الموجودة سابقا

 

هذا الكود بعد الاضافة البسيطة

Sub make_jpeg()
Dim i  As Integer
Dim intCount As Integer
Dim objPic As Shape
Dim objChart As Chart
Dim savedate
savedate = Date
Dim savetime
savetime = Time
Dim formattime As String
formattime = Format(savetime, "hh.mm.ss")
Dim formatdate As String
formatdate = Format(savedate, "DD-MM-YYYY")

'نسخ المدى كصوره
Call Sheet1.Range("A1:f13").CopyPicture(xlScreen, xlPicture)

'مسح أى أشكال من شيت 2
intCount = Sheet2.Shapes.Count
For i = 1 To intCount
    Sheet2.Shapes.Item(1).Delete
Next i
'عمل جدول فى شيت 2
Sheet2.Shapes.AddChart
'تنشيط شيت 2
Sheet2.Activate
'تحديد الجدول الذى يوجد فى شيت 2
Sheet2.Shapes.Item(1).Select
Set objChart = ActiveChart
'لصق المدى اللى نسخناه فى هذا الجدول
Sheet2.Shapes.Item(1).Width = Range("A1:f13").Width
Sheet2.Shapes.Item(1).Height = Range("A1:f13").Height
objChart.Paste
'حفظ الجدول كصورة فى المسار التالى
objChart.Export Filename:=ThisWorkbook.Path & "\" & "Mokhtar" & formatdate & " " & formattime & ".jpg"
End Sub

ومرفق الملف للتوضيح

 

تحياتي  

range 2 jpeg.rar