أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
EM_ACC مجدى يونس-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة بحاجة الى كود ترحيل اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





تعديل كود تصدير الاسماء المعرفة الي صور في مجلد

السلام عليكم ورحمة الله وبركاته..... لدي كود يعمل على تصدير كل الاسماء المعرفة لدي (جداول) الي صور في مجلد محدد، ولكن اح ..



16-04-2020 01:04 صباحا
jjebril
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-09-2017
رقم العضوية : 334
المشاركات : 90
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 1-1-1973
يتابعهم : 6
يتابعونه : 1
قوة السمعة : 170
 offline 

السلام عليكم ورحمة الله وبركاته.....
لدي كود يعمل على تصدير كل الاسماء المعرفة لدي (جداول) الي صور في مجلد محدد، ولكن احيانا يتم تصدير بعض الجداول الي صور بدون اقتصاص ، يعني فيه زيادة بيضاء في الصورة المستخرجة
الكود : بداخل الملف مع صورة للتوضيح

شكرا لكم جميعا ، ،،،
kCDun_جدول_تكاليف_اجهزة_ومعدات_اخرى
 
 
  سؤال في اكاديمية صقر للتدريب.rar   تحميل rar مرات التحميل :(15)
الحجم :(66.12) KB


16-04-2020 01:43 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif تعديل كود تصدير الاسماء المعرفة الي صور في مجلد
جرب الكود التالي لعله يفي بالغرض
قم بتعديل الشروط بنفسك في الكود لتقوم بتصدير الجداول التي تريدها
Sub Test()
    Dim oFldr       As String
    Dim nm          As Name
    Dim rng         As Range

    oFldr = GetFolder(ActiveWorkbook.Path)
    
    If oFldr = "" Then
        MsgBox "Cancelled", vbExclamation
    Else
        For Each nm In ActiveWorkbook.Names
        On Error Resume Next
            'If Left(nm.Name, 1) = "P" And Not InStr(1, nm.RefersTo, "#REF!") > 0 Then
                Set rng = Range(nm.RefersTo)
                rng.Parent.Activate
                ActiveWindow.View = xlNormalView
                Call ExportRangeAsPictureFile(rng, oFldr & "\" & nm.Name & ".jpg")
                ActiveWindow.View = xlPageBreakPreview
                Set rng = Nothing
                On Error GoTo 0
            'End If
        Next nm
    End If
End Sub

Function GetFolder(strPath As String) As String
    Dim fldr        As FileDialog
    Dim sItem       As String

    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select Folder To Export All Of The Figures To"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show = True Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function

Function ExportRangeAsPictureFile(rExport As Range, sExport As String) As Boolean
    Dim dh          As Double
    Dim dw          As Double

    dh = 1: dw = 1
    
    On Error Resume Next
        Kill sExport
    On Error GoTo 0

    If rExport Is Nothing Then GoTo exit_Func
    rExport.CopyPicture appearance:=xlScreen, Format:=xlBitmap

    With ActiveSheet.ChartObjects.Add(Left:=rExport.Left, Top:=rExport.Top, Width:=rExport.Width + dw, Height:=rExport.Height + dh)
        DoEvents
        With .Chart
            Do Until .Pictures.Count = 1
                DoEvents: .Paste
            Loop
            .ChartArea.Format.Line.Visible = msoFalse
            .Export sExport
            ExportRangeAsPictureFile = True
        End With
        .Delete
    End With

exit_Func:
End Function

16-04-2020 02:33 مساء
مشاهدة مشاركة منفردة [2]
jjebril
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-09-2017
رقم العضوية : 334
المشاركات : 90
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 1-1-1973
يتابعهم : 6
يتابعونه : 1
قوة السمعة : 170
 offline 
look/images/icons/i1.gif تعديل كود تصدير الاسماء المعرفة الي صور في مجلد
بارك الله فيك اخي ياسر ، شكرا للرد والاهتمام
جربت هذا الكود ولكن من كثرة الجداول لدي يحدث مشكلة ، وخاصة في الذاكرة ، ولذلك فهل يمكن لصق الجدول في ورقة جديدة ثم يتم تصدير الصورة الي المجلد ، ثم حذف هذه الورقة.
فانا احاول اجرب هذا الكود ، فهو ياخذ نسخة من الجدول ثم فتح ورقة جديدة ثم يتم اللصق فيها ، ولكن لا يتم تصدير الصورة للاسف ، يمكن التعديل على هذا الكود من فضلك:
===============
======================================================================================================
Sub ExportScreenshot2()
Application.ScreenUpdating = False
    Application.CutCopyMode = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

Application.Calculation = xlManual
Application.Calculation = xlCalculationManual

ActiveWindow.View = xlNormalView
ActiveWindow.Zoom = 100


Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture

Dim oFldr As String
Dim nm As Name

For Each nm In ActiveWorkbook.Names
Next

oFldr = GetFolder(ActiveWorkbook.Path)

If oFldr = "" Then
MsgBox "Cancelled", vbExclamation
Else
For Each nm In ActiveWorkbook.Names
If Left(nm.Name, 1) = "ج" Or Left(nm.Name, 1) = "ص" And Not InStr(1, nm.RefersTo, "#REF!") > 0 Then
On Error Resume Next
Set pic_rng = Range(nm.RefersTo)
pic_rng.Parent.Activate
pic_rng.Select
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set ShTemp = Worksheets.Add '.Add

pic_rng.Paste
Selection.Paste '.Copy
    ActiveSheet.Pictures.Paste.Select


DoEvents
On Error Resume Next
ActiveSheet.Pictures oFldr & "" & nm.Name & ".jpg"
Application.DisplayAlerts = False
ShTemp.Delete

Application.DisplayAlerts = True
Application.ScreenUpdating = True

Set rng = Nothing
End If
Next nm
End If
Application.ScreenUpdating = True
    Application.CutCopyMode = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True

Application.Calculation = xlCalculationAutomatic ' = xlManual


Prompt = "The procedure is now completed."
    Title = "Procedure Completion"
    MsgBox Prompt, vbOKOnly + vbInformation, Title
    
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select Folder To Export All Of The Figures To"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show = True Then sItem = .SelectedItems(1)
End With
GetFolder = sItem
Set fldr = Nothing
End Function

16-04-2020 03:46 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif تعديل كود تصدير الاسماء المعرفة الي صور في مجلد
لم يعمل الكود الخاص بك معي بشكل طبيعي .. بينما يعمل الكود الذي أرفقته
ربما يكون السبب اختلاف نسخ الأوفيس
سأترك الموضوع لبقية الأعضاء للمساهمة فيه لأنني أتذكر أن هناك موضوع قديم بنفس الفكرة ولم يكن يعمل الكود لديك أيضاً ـ فحتى لا نضيع الوقت ننتظر مشاركات الأخوة الأعضاء.

16-04-2020 04:35 مساء
مشاهدة مشاركة منفردة [4]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif تعديل كود تصدير الاسماء المعرفة الي صور في مجلد
يمكنك بشكل يدوي إنشاء ورقة عمل وسمها Temp و في الكود استخدم الإشارة لورقة العمل الجديدة Temp بدلاً من ActiveSheet

16-04-2020 06:45 مساء
مشاهدة مشاركة منفردة [5]
jjebril
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-09-2017
رقم العضوية : 334
المشاركات : 90
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 1-1-1973
يتابعهم : 6
يتابعونه : 1
قوة السمعة : 170
 offline 
look/images/icons/i1.gif تعديل كود تصدير الاسماء المعرفة الي صور في مجلد
اريد انشاء ورقة عمل ثم اللصق فيها وبعد انتهاء حذفها

16-04-2020 06:52 مساء
مشاهدة مشاركة منفردة [6]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif تعديل كود تصدير الاسماء المعرفة الي صور في مجلد
يمكن إنشاء وتسمية ورقة عمل بسطر واحد بهذا الشكل
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp"

والحذف تشير لورقة العمل المراد حذفها وتستخدم Delete ..




الكلمات الدلالية
تعديل ، تصدير ، الاسماء ، المعرفة ، مجلد ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 06:59 صباحا