طلب التعديل على كود لإرسال شيت عن طريقة الأوت لوك بعد حفظه كـ PDF

[علي الشيخ]

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

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

 

في الشيت المرفق يوجد كودين

الكود الأول Module 1 وهو يعمل على حفظ الصفحة " النطاق المخصص للطباعة فقط " كـ PDF إلى سطح المكتب بنفس اسم ملف الإكسل

 

الكود الثاني Module 2 وهو يعمل على بدء رسالة جديدة في الاوت لوك واخذ بعض المعطيات من نفس الشيت التي تم حفظها سابقا

كموضوع رسالة وبعض السطور لجسم الرسالة

 

المشكلة هنا ان المفروض الكود الثاني يأخذ في المرفق ملف البي دي إف الذي نتج من الكود الأول

ولكن الرسالة تكون بدون مرفق

وأيضا يكون موضوع الرسالة Subject يكون نفس اسم المرفق " ملف البي دي إف"

فأي أفكار أو مساعد يجزاكم الله خيرا

 

pdftest.rar

[علي الشيخ]

تم الحل بفضل الله والكود موجود أدناه للاستفادة لمن يحتاجه

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

ومن ثم يقوم بفتح برنامج الأوت لوك واخذ ملف البي دي إف الناتج كمرفق ويكون موضوع الرسالة هو نفس اسم ملف البي دي اف المرفق

يمكن التعديل على الكود لما يتناسب مع حاجاتكم والله يجزاكم خير

Sub Send_To_Pdf()
Dim PdfPath As String
Dim BoDy As String

BoDy = "Hellom Officena.net"


PdfPath = Save_as_pdf
EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), " ", , , BoDy, 1, PdfPath
End Sub

Public Function Save_as_pdf() As String
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String

Set FSO = CreateObject("Scripting.FileSystemObject")

s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ActiveWorkbook.Name

If FSO.FileExists(ActiveWorkbook.FullName) Then
    '//Change Excel Extension to PDF extension in FilePath
    s(1) = FSO.GetExtensionName(s(0))

    If s(1) <> "" Then
        s(1) = "." & s(1)
        sNewFilePath = Replace(s(0), s(1), ".pdf")

        '//Export to PDF with new File Path
        ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sNewFilePath, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
    End If
Else
    '//Error: file path not found
    MsgBox "Error: this workbook may be unsaved.  Please save and try again."
End If

Set FSO = Nothing

Save_as_pdf = sNewFilePath

End Function


Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String)
  Dim MonOutlook As Object
  Dim MonMessage As Object
  Set MonOutlook = CreateObject("Outlook.Application")
  Set MonMessage = MonOutlook.createitem(0)

  Dim PJ() As String
  PJ() = Split(PjPaths, ";")

  With MonMessage
      .Subject = "P.O #" & Subject     '"Je suis content"
      .To = Destina           '
      .cc = " "            '"chef@machin.com;directeur@chose.com"
      .bcc = CCIdest          '"un.copain@supermail.com;une-amie@hotmail.com"
      .BoDy = "Hello , Officena.net"
        If PjPaths <> "" And NbPJ <> 0 Then
            For i = 0 To NbPJ - 1
                'MsgBox PJ(I)
              .Attachments.Add PJ(i)      '"C:\Mes Documents\Zoulie Image.gif"
            Next i
        End If
      .display
      '.send                        '.Attachments.Add ActiveWorkbook.FullName
  End With                        '?plusieurs?MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb"

  Set MonOutlook = Nothing
End Sub