mahmoud nasr alhasany قام بنشر يوليو 6 مشاركة قام بنشر يوليو 6 السلام عليكم ورحمة الله وبركاتة الرجاء المساعدة فى عمل كود طباعة بواسطة 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 رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر يوليو 6 أفضل إجابة مشاركة قام بنشر يوليو 6 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 2 رابط هذا التعليق شارك More sharing options...
mahmoud nasr alhasany قام بنشر يوليو 6 الكاتب مشاركة قام بنشر يوليو 6 احسنت ا/ محمد هشام انت رائع رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان