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

[mahmoud nasr alhasany]

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

الرجاء المساعدة فى عمل كود طباعة  بواسطة 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

[mahmoud nasr alhasany]

احسنت ا/ محمد هشام انت رائع