Sub Export_1st_2nd_Top_Students_To_JPG()
Dim sh As Worksheet
Dim rng As Range
Dim objPic As Shape
Dim ObjChart As Chart
Dim Path As String
Dim fn As String
On Error Resume Next
ansr = MsgBox("هـل تـريـد تـصـديـر الـطـلاب الأوائـل كـمـلـف صـورة", 64 + vbMsgBoxRight + vbYesNo, "")
If ansr = vbNo Then Exit Sub
' انشاء مجلد باسم "الصف والسنة" فى نفس مسار الملف الاصلي
MkDir ThisWorkbook.Path & "\" & Sheets("Main data").[Y2] _
& " " & Sheets("Main data").[Z2]
' "انشاء مجلد باسم "نصف العام" داخل مجلد "الصف والسنة
MkDir ThisWorkbook.Path & "\" & Sheets("Main data").[Y2] _
& " " & Sheets("Main data").[Z2] & "\" & ActiveSheet.[EE4]
' مسار الملف الذي سيتم الحفظ فيه
Path = ThisWorkbook.Path & "\" & Sheets("Main data").[Y2] _
& " " & Sheets("Main data").[Z2] & "\" & ActiveSheet.[EE4]
' اسم الملف داخل مسار الحفظ
fn = Path & "\" & ActiveSheet.[EE3]
Set sh = ActiveSheet
Set rng = Range("$B$7:$H$45")
Application.DisplayAlerts = 0
Application.ScreenUpdating = 0
Application.EnableEvents = 0
rng.CopyPicture xlScreen, xlPicture
Sheets.Add , Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Shapes.AddChart
.Activate
.Shapes.Item(1).Select
Set ObjChart = ActiveChart
.Shapes.Item(1).Width = rng.Width
.Shapes.Item(1).Height = rng.Height
ObjChart.Paste
ObjChart.Export (fn & ".jpg")
.Delete
End With
sh.Activate
MsgBox "تم حفظ" & " ( " & ActiveSheet.[EE3] & " ) " & "كملف صورة " & _
" ، فى المسـارالتالي" & vbCrLf & Path, vbInformation + vbMsgBoxRight, ""
CreateObject("Shell.Application").Open (Path & "\" & ActiveSheet.[EE3] & ".jpg")
Application.DisplayAlerts = 1
Application.ScreenUpdating = 1
Application.EnableEvents = 1
End Sub
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
