اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

مساعدة فى عمل كود الطباعة بواسطة PDF And Word


إذهب إلى أفضل إجابة Solved by محمد هشام.,

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

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

الرجاء المساعدة فى عمل كود طباعة  بواسطة PDF And Word


Private Sub WordView_Click()

End Sub

and

Private Sub PDFConvertor_Click()

End Sub


Private Sub WordView_Click()

End Sub

and

Private Sub PDFConvertor_Click()

End Sub

 

كرت الصنف 2024.xlsm

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

  • أفضل إجابة

 

Private Sub PDFConvertor_Click()
Dim f As Worksheet: Set f = Sheets("Sheet5")
Dim fname As String, filePath As String, folderName As String
Dim sMsg As String, xname As String
fname = f.[E1]
folderName = "PDF ملفات"
filePath = ThisWorkbook.Path & "\" & folderName
  
 xname = " من " & Format(f.[b1], "dd-mm-yyyy") & "  " & _
                "إلى " & " " & Format(f.[b2], "dd-mm-yyyy")
Application.ScreenUpdating = False
Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير بصيغة", vbYesNo, fname)
If Msg <> vbYes Then Exit Sub
    'Call Main
   If Dir(filePath, vbDirectory) = "" Then MkDir filePath
        Set Rng = f.Range("A1").CurrentRegion
        f.PageSetup.PrintArea = Rng.Address
        
f.ExportAsFixedFormat Type:=xlTypePDF, _
    FileName:=filePath & "\" & fname & xname & ".pdf", _
             Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                           IgnorePrintAreas:=False, OpenAfterPublish:=False
        f.PageSetup.PrintArea = ""
        Application.ScreenUpdating = True
    MsgBox "  تم حفظ الملف  بنجاح " & vbCrLf & vbCrLf & xname, vbInformation, "PDF"
End Sub
'**********************************
Private Sub Save_Excel_Click()
Dim sh As Worksheet, NewWb As Workbook
Dim folderName As Variant, FileName As String, fname As String

Set sh = ThisWorkbook.Sheets("Sheet5")
fname = sh.[E1]
folderName = "ملفات Excel"
filePath = ThisWorkbook.Path & "\" & folderName

With Application
.DisplayAlerts = False
.ScreenUpdating = False

    sh.Copy
     Set NewWb = ActiveWorkbook: Set n = NewWb.Sheets(1)
     n.Name = fname
     n.Columns("A").SpecialCells(xlBlanks).EntireRow.Delete
    If Dir(filePath, vbDirectory) = "" Then MkDir filePath
NewWb.SaveAs FileName:=filePath & "\" & fname & ".xlsx", FileFormat:=51
NewWb.Close False
Set NewWb = Nothing

    .DisplayAlerts = True
    .ScreenUpdating = True
    MsgBox "  تم حفظ الملف  بنجاح ", vbInformation, "Excel"

  End With
End Sub
'**************************************************
Private Sub WordView_Click()
Dim lr&, tmp As Word.Document, n As Word.Application
Dim WS As Worksheet: Set WS = Sheets("Sheet5")

lr = WS.Range("A:A").Find("*", _
   searchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Set n = CreateObject("word.application")
n.Visible = True: Const Cnt As Long = 1
    
    xname = "Word ملفات"
    Patch = ThisWorkbook.Path & "\" & xname
    fname = WS.[E1]
    xdate = " من " & Format(WS.[b1], "dd-mm-yyyy") & "  " & _
                "إلى " & " " & Format(WS.[b2], "dd-mm-yyyy")
                   
  Application.ScreenUpdating = False
With WS.Range("A" & Cnt & ":H" & lr).Copy
    Set tmp = n.Documents.Add
      n.Selection.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
       Application.CutCopyMode = False
       n.ActiveDocument.PageSetup.Orientation = wdOrientLandscape
       n.ActiveDocument.PageSetup.PaperSize = WdPaperSize.wdPaperA3
If Dir(Patch, vbDirectory) = "" Then MkDir Patch
     tmp.SaveAs Patch & "\" & fname & xdate & ".docx"
       tmp.Close
    Set tmp = Nothing
        n.Quit
      Set n = Nothing
     End With
    Application.ScreenUpdating = True
    MsgBox "  تم حفظ الملف  بنجاح " & _
         vbCrLf & vbCrLf & xdate, vbInformation, "Word"
End Sub

 

كرت الصنف 2024 V2.xlsm

  • Like 2
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information