تحويل نطاق متغير الى صورة pdf

**أنس دروبي** · يونيو 25, 2015

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

أساتذتي الكرام يوجد في الملف المرفق كود يقوم بحفظ النطاق المحدد في الكود الى صورة (pdf)

الذي نريده هو جعل أن النطاق المطلوب للتحويل هو نطاق متغير فيه زيادة ونقصان في الصفوف

ارجو ان يكون المطلوب مفهوم

نرجو الحل وعرض الفكرة

وشكراً

أخوكم أنس دروبي

تحويل نطاق متغير الى صورة.rar

**مختار حسين محمود** · يونيو 26, 2015

السلام عليكم

جرب تتغيير السطر التالى فى الكود convert_pdf

Set Rng = Range("a1:f17")

بالسطر التالى

Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6))

الاعتماد هنا على النطاق المتاح من الخلية A1 حتى آخر خلية بها بيانات فى العمود 6

دون الاعتماد على الخليتين P2,P3 اعتبرهم مش موجودين ولا علاقة لهما بالكود تحياتى

الميساني · يونيو 26, 2015

الاخ العزيز

Creation World

لقد جربت الكود الخاص بملف و لكن لا اعرف كيف يتم الحفظ بصيغة ملف pdf و ماهو اسم الملف و مسار الملف بعد التحويل الى pdf؟؟؟ حيث تظهر رسالة فقط بعد الضغط على زر1 !!!

فهل لك ان توضح ذلك لتعم الفائدة

**مختار حسين محمود** · يونيو 26, 2015

الأستاذ الميسانى الملف هتلاقيه فى الــــ Documents

الميساني · يونيو 26, 2015

شكرا جزيلا استاذ مختار على الاجابة

هل يمكن تعديل الكود بحيث يمكن للمستخدم تحديد موقع حفظ الملف بحيث يظهر مربع حوار لحفظ الملف

وهل يمكن اضافة سطر لغرض فتح الملف بعد تحويله الى ملف pdf??

حليم ناصر · يونيو 26, 2015

سلام عليكم

جزاكم الله خيرا علئ هذه المعلومات

ممكن تحدد المسارDocuments بدقة بحثت عنه ولم اجده

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

ياسر خليل أبو البراء · يونيو 26, 2015

الأخ الكريم Creation

يرجى تغيير اسم الظهور للغة العربية

الأخ الحبيب مختار

بارك الله فيك وجزاك الله خير الجزاء

الأخ الكريم الميساني ..

إليك الكود بعد التعديل .. يمكنك من خلال الكود تعديل المسار واسم المللف كما يمكنك فتح الملف بعد التحويل من خلال آخر سطر

تمت إضافة تعليقات على الأسطر التي يمكنك من خلالها التعديل

Sub Convert_PDF()
'في مسار محدد من خلال الكود ثم فتح الملف [PDF] يقوم الكود بتحويل نطاق محدد إلى ملف
'--------------------------------------------------------------------------------
    On Error Resume Next
    Dim FileName As String, MyFileName As String, MS As String
    Dim Rng As Range
    
    If ActiveWindow.SelectedSheets.Count > 1 Then
        MsgBox "There is more then one sheet selected," & vbNewLine & "ungroup the sheets and try the macro again."
    Else
        On Error Resume Next
'[PDF] تعيين النطاق المطلوب تحويله إلى
        Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6))
        If Not Rng Is Nothing Then
            Debug.Print Rng.Address(External:=True)
            Rng.Select
'يمكن تغيير مسار الحفظ واسم الملف من خلال هذا السطر
            MyFileName = "C:\Users\" & Environ("UserName") & "\Desktop\" & ActiveSheet.[A1].Value
            
            FileName = Create_PDF(Selection, MyFileName, True, True)

            If FileName <> MyFileName Then
                MS = MsgBox("تم التحويل والحفظ بنجاح", vbInformation, "منظومة الصرافة")
            Else
                MS = MsgBox("قمت بإلغاء المهمة لذلك لم يتم التحويل", vbCritical, "منظومة الصرافة")
            End If
        End If
    End If
'بعد التحويل [PDF]سطر لفتح ملف الـ
    ActiveWorkbook.FollowHyperlink MyFileName & ".PDF"
End Sub

Function Create_PDF(Myvar As Object, FixedFilePathName As String, OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
           & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            FileFormatstr = "PDF Files (*.jpeg), *.jpeg"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")

            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        On Error GoTo 0

        If Dir(Fname) <> "" Then Create_PDF = Fname
    End If
End Function

كل عام وأنتم بخير

**مختار حسين محمود** · يونيو 26, 2015

أخى وأستاذى الفاضل ياسر خليل نورت الموضوع

هذا الكود البسيط كفيل بتحقيق طلبات الأستاذ الميسانى

الكود بيعمل pdf من النطاق المتاح وأنت تحدد مكان الحفظ فقط مع فتح الـــ pdf

Sub PDFusingdialogbox()


Dim Rng As Range
Dim i As Variant
Dim fName As String

fName = ActiveSheet.[a1].Value
i = Application.GetSaveAsFilename(fName, "PDF Files (*.pdf), *.pdf")
Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6))

 Application.ScreenUpdating = False
   
    Rng.Activate
    Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("ورقة1").Range("A1").Select
    
 Application.ScreenUpdating = True
 
End Sub

تحياتى كل سنة وأنتم أقرب الى الله

هو فين صاحب الموضوع الأخ الكريم Creation !!!!!!!!!!!!!

تم تعديل يونيو 26, 2015 بواسطه مختار حسين محمود

الميساني · يونيو 26, 2015

الأخ الكريم Creation

يرجى تغيير اسم الظهور للغة العربية

الأخ الحبيب مختار

بارك الله فيك وجزاك الله خير الجزاء

الأخ الكريم الميساني ..

إليك الكود بعد التعديل .. يمكنك من خلال الكود تعديل المسار واسم المللف كما يمكنك فتح الملف بعد التحويل من خلال آخر سطر

تمت إضافة تعليقات على الأسطر التي يمكنك من خلالها التعديل

الاخ الكريم ياسر ابو البراء المحترم

شكرا شكرا شكرا على هذا الابداع و التواضع

هل يمكن تعديل الكود بحيث يظهر مربع حوار لحفظ الملف بصيغة pdf تحديدا و فقط هذه الصيغة لا غيرها و يقوم الستخدم بوضع اسم للملف و من ثم يقو الكود بعملية الحفظ و التحويل

الميساني · يونيو 26, 2015

أخى وأستاذى الفاضل ياسر خليل نورت الموضوع

هذا الكود البسيط كفيل بتحقيق طلبات الأستاذ الميسانى

الكود بيعمل pdf من النطاق المتاح وأنت تحدد مكان الحفظ فقط مع فتح الـــ pdf

ما اعرف كيف اشكر والله

يارب يكتب بكل حرف حسنات

الميساني · يونيو 26, 2015

الاخ الكريم مختار حسين محمود

لدي بعض الملاحظات

1- عندما تكون الخلية A1 فارغة وعند ظهور مربع حوار حفظ بصيغةملف PDF و اختيار الامر (الغاء) يتم عرض الملف الناتج مع

رسالة خطا Error loading c:\user\username\desktop\FALSE.pdf كيف يمكن تجنب ذلك؟

2- كيفية اظهار رسالة للمستخدم في حالة حفظ اكثر من ملفين بنفس الاسم ؟ لانه الكود يقوم بعمل Over write

3- كيف يمكن حفظ نطاق محدد اكثر من مرة مثال لنفرض بان لدينا 10 اساتذة و اردنا طباعة السيرة الذاتية لكل واحد بحيث نحصل في النهاية على ملف pdf يحتوي على السيرة الذاتية لكل الاساتذة؟

ولك مني تحية وسلام

الميساني · يونيو 26, 2015

طبعا عمل السيرة الذاتية يتم عن طريق دالة vlookup من شيت ثاني

الميساني · يونيو 26, 2015

اليكم الملف المرفق و المطلوب تطبيق كود حفظ الشهادات لكل الطلاب في ملف pdf واحد يحتوي على كل الشهادات وليس شهادة طالب واحدة في ملف منفصل

BOOKTOPDF.rar

**مختار حسين محمود** · يونيو 26, 2015

الأستاذ الميسانى شىء طبيعى ظهور هذا الخطأ لأن أنت فلتها بنفسك A1 فارغة

طبق الكود على ملف الأخ الكريم Creation

Sub PDFusingdialogbox()

Dim Rng As Range
Dim i As Variant
Dim Fname As String

Fname = "Elmisani"  ' ضع الاسم اللى يعجبك
i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf")
Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6))

 Application.ScreenUpdating = False
   
    Rng.Activate
    Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("ورقة1").Range("A1").Select
    
 Application.ScreenUpdating = True
 
End Sub

هذا بالنسبة للملاحظة الأولى

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

Sub PDFusingdialogbox()

Dim Rng As Range
Dim i As Variant
Dim Fname As String

Fname = Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name, ".", 1) - 1) & "(" & Format(Now, "DD-MM-YYYY-hhmmss") & ").pdf"
i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf")
Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6))

 Application.ScreenUpdating = False
   
    Rng.Activate
    Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("ورقة1").Range("A1").Select
    
 Application.ScreenUpdating = True
 
End Sub

اذا كنت تريد وضع الاسم بنفسك فى الصندوق الحوارى استخدم الكود التالى هو هو بس بنلعب بالاسم زى ما قلت لك

Sub PDFusingdialogbox222()

Dim Rng As Range
Dim i As Variant
Dim Fname As String

Fname = ""
i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf")
Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6))

 Application.ScreenUpdating = False
   
    Rng.Activate
    Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("ورقة1").Range("A1").Select
    
 Application.ScreenUpdating = True
 
End Sub

بالنسبة للمرفق أعتذر الليلة للصلاة كل سنة وأنتم جميعا أقرب لله

تم تعديل يونيو 26, 2015 بواسطه مختار حسين محمود

ياسر خليل أبو البراء · يونيو 26, 2015

بسم الله ما شاء الله أخي الحبيب الغالي المتمكن مختار

ايه الجمال ده ... صراحة في منتهى الروعة والابداع والاختصار

أنا صراحة اشتغلت على الكود الموجود وعدلت طبقاً لما طلبه الاخوة من مسار الحفظ وفتح الملف بعد التحويل ..

بس كودك هو الأفضل والأيسر بلاشك

**أنس دروبي** · يونيو 27, 2015

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

أخي وأستاذي مختار حسين محمود

اشكرك جزيل الشكر على هذه الفكرة الرائعة في المشاركة الاولى نفذت المطلوب بكل ماتقوله من معنى

وأشكرك مرة أخرى على تعديل مسار الحفظ لملف pdf في المشاركة رقم 2 و9

أخي وأستاذي الكريم ياسر خليل أبو البراء

شكراً على هذا التعديل الرائع والأحترافي في الكود في المشاركة رقم 8

ملاحظة

ولكن خلينا نضيف فكرة جديدة بالنسبة لمسار الملف

هل نستطيع أن نجعل المسار دنميكي بحيث يكون الملف المحفوظ الذي هو بصيغة pdf

أن يقوم بالحفظ في المسار الذي موجود فيه ملف أكسل الأساسي

يعني إذا وجد الملف الأساسي في القرص (D) يكون الحفظ فيه

وعذراً عن التأخير كان يوجد لدي مشكلة في الانترنت عندي....

وشكرأ

أخوكم أنس دروبي

تم تعديل يونيو 27, 2015 بواسطه Creation World

**مختار حسين محمود** · يونيو 27, 2015

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

آخى وحبيبى فى الله وأستاذى ياسر خليل

كله بفضل من الله ثم تشجيعك لى جازاكم الله خيرا

الأخ الكريم أنس دروبي بارك الله فيك

اذا كنت تريد حفظ الــ pdf فى نفس مسار ملف الاكسل استخدم الكود بالشكل التالى

Sub PDFusingdialogbox()

Dim Rng As Range
Dim i As Variant
Dim Fname As String

Fname = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name, ".", 1) - 1) & "(" & Format(Now, "DD-MM-YYYY") & ").pdf"
i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf")
Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6))

 Application.ScreenUpdating = False
   
    Rng.Activate
    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=i, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("ورقة1").Range("A1").Select
    
 Application.ScreenUpdating = True
 
End Sub

**مختار حسين محمود** · يونيو 27, 2015

الأخ الكريم الميسانى على الرغم من أن طلبك حيرنى إلا إنى طلعت منه بكود أعتقد أنه جميل وظريف

هذا الكود هيخليك تتعلم سواقة العربيات بدرى بدرى لذلك سميته كود الفتيس على غرارعصا الفتيس فى العربيات

عملت لك تعديلات وتنسيقات كان لابد منها فى الملف لتحقيق مطلبك اللى صدمنى من أول وهله أشوفه

3 اكواد فى الملف

كود عمل pdf

Sub PDFusingdialogbox()
'by mokhtar hussien
'27/6/2015
Dim Rng As Range
Dim i As Variant
Dim Fname As String

Fname = ""
i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf")
Set Rng = Sheets("ورقة3").Range(Cells(1, 1), Cells(Rows.Count, 8))

 Application.ScreenUpdating = False
   
    Rng.Activate
    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=i, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("ورقة3").Range("A1").Select
    
 Application.ScreenUpdating = True
 
End Sub

كود الفتيس وهو مسؤل عن نقل النطاق المتاح فى الورقة 2 الى الورقة 3 مع كل غيار تاخده بعصا الفتيس ( الـ Spinner )

الـ Spinner هنا أصبح ليه وظيفين تغيير البيانات فى الورقة 2 + يعمل عمل عصا الفتيس وده مش هتلاقيه فى أى حته فى العالم إلا عندنا فى الصعيد

Sub Spinner6_Change()
 'fetace code
 'by mokhtar hussien
 '27/6/2015

 Dim Rng As Range
 Set Rng = Sheets("ورقة2").Range("A1:H39")
 
 Application.ScreenUpdating = False

 Rng.Copy
 
 With ActiveWorkbook.Sheets("ورقة3").Cells(Rows.Count, "A").End(xlUp)

 .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

 End With

 Application.CutCopyMode = False
 Application.ScreenUpdating = True
 
End Sub

كود مسح البيانات من الورقة 3 اذا أخطأت فى التعامل مع عصا الفيس مش سايبك أنا أهه

Sub del()
'by mokhtar hussien
'27/6/2015

   Application.ScreenUpdating = False
 
    Columns("A:H").Select
    With Selection
    .ClearContents
    .Borders.LineStyle = xlNone
    End With
    Range("a1").Select
    
   Application.ScreenUpdating = True
  
End Sub

المرفق :fff:

used range as pdf using dialog box 2 by mokhtar .rar

تم تعديل يونيو 27, 2015 بواسطه مختار حسين محمود

**أنس دروبي** · يونيو 27, 2015

السلام عليكم ورحمة الله

اخي وأستاذي الكريم مختار حسين محمود

جزاك الله كل خير على هذا الكود المتميز والأكثر من رائع

ولكن الذي أريده هو حفظ المسار في الكود الأول نفسه في المشاركة الأولى

لا أريد ان تظهر لي نافذة حفظ الملف بأسم

نريد مباشرة حفظه بناء على الخلية (a1)

=======================================================

وطلب آخر منذ زمن بعيد كنت قد عرضت فكرة أنه نريد ان نحول النطاق الى ملف صورة بصيغة(jpeg)

فكانت أغلب الأجوبة كودات تقوم بحفظ النطاق صورة ولكن داخل الملف

نريد نفس المطلوب بدال صيغة pdf تكون صيغة صورة

وشكراً

تم تعديل يونيو 27, 2015 بواسطه Creation World

**۩◊۩ أبو حنين ۩◊۩** · يونيو 27, 2015

السلام عليكم

الاخ الكريم

مرفق ملف اقتباس من اعمال الاخ ياسر والاخ مختار

المسار محدد سابقا فى الكود \D

يتم حفظ الملف باسم الموجود فى الخليه a1

لعله المطلوب

PDF1.rar

**مختار حسين محمود** · يونيو 27, 2015

الأخ الحبيب أبو حنين بارك الله فيكم

الأخ الحبيب Creation World بالله عليك غير اسم الظهور

الكود التالى للحفظ بناء على A1 وفى نفس مسا ر ملف الاكسل ومن غير مربع حوارى

Sub PDF()

Dim Rng As Range
Dim fName As String

fName = ThisWorkbook.Path & "\" & ActiveSheet.[a1].Value

Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6))

Application.ScreenUpdating = False
  
    Rng.Activate
    Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=fName, Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Sheets("ورقة1").Range("A1").Select
   
Application.ScreenUpdating = True

End Sub

بالنسبة لطلبك الثانى الخاص بالصورة اعمل موضوع جديد لتعم الفائدة

ومؤقتا شوف الموضوع ده http://www.officena.net/ib/index.php?showtopic=58031

تم تعديل يونيو 27, 2015 بواسطه مختار حسين محمود

**۩◊۩ أبو حنين ۩◊۩** · يونيو 27, 2015

الاستاذ ياسر

تقبل الله منا ومنك خير الاعمال

اخى الحبيب

هل يمكن اضافه

عند خلو الخليه a1 من البيانات

تظهر رساله تنبية برجاء املاء الخليه a1

ياسر خليل أبو البراء · يونيو 27, 2015

الأخ الغالي أبو حنين

إليك هذا السطر يمكن إضافته في بدايات الكود بعد تعريف المتغيرات بحيث لو كانت الخلية فارغة يتم إظهار رسالة ثم الخروج من الإجراء

If IsEmpty(Range("A1")) Then MsgBox "الخلية فارغة يرجى كتابة بيان بها", vbInformation: Exit Sub

تقبل تحياتي

**۩◊۩ أبو حنين ۩◊۩** · يونيو 27, 2015

الأخ الغالي ... ياسر أبو البراء

جزاك الله كل الخير ... منور المنتدى

**أنس دروبي** · يونيو 27, 2015

الله يباركم جميعاً على هذه الأفكار الرائعة

وأن شاء الله أستاذ مختار أغير اسم الظهور الى اللغة العربية

علماً هذا الاسم منذ خمس سنوات في المواقع

بالنسبة لموضوع حفظ النطاق بصيغة صورة

سوف اذكره في موضوع لوحده لكي تعم الفائدة وتكثر الأراء

تمت الأجابة في هذا الموضوع على طلبي وجزاكم الله خيراً مرة اخرى

تسجيل الدخول

تحويل نطاق متغير الى صورة pdf

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information