تعديل كود ارسال الشيت الفعال بيانات اميل الخاص ب ( ياسر ابو البراء )

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

الساده الكرام  ..

ارجو المساعده فى تعديل كود لاخ الجليل ياسر ابو البراء .. جذاه الله كل الخير والتقدير

الكود يقو على ارسال نسخه بيانات وليس المعاادلان من الشيت الفعال اميل

- المطلوب

تغير  الشيت الفعال  الى اسم شيت وليكن شيت  a&b   

اى نسخ الشيت a & b   بيانات وارساله اميل  واختيار ايضا اسم المصنف الجديد الذى يتم ارساله اميل ... يتم كتابته داخل الكود

هلى يمكن المساعده فى ذلك

Option Explicit
Sub Mail_ActiveSheet_Using_Outlook()
    Dim fileExtStr          As String
    Dim fileFormatNum       As Long
    Dim sourceWb            As Workbook
    Dim destWb              As Workbook
    Dim tempFilePath        As String
    Dim tempFileName        As String
    Dim outApp              As Object
    Dim outMail             As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
        Set sourceWb = ActiveWorkbook
        ActiveSheet.Copy
        Set destWb = ActiveWorkbook
        With destWb
            If Val(Application.Version) < 12 Then
                fileExtStr = ".xls": fileFormatNum = -4143
            Else
                Select Case sourceWb.FileFormat
                    Case 51: fileExtStr = ".xlsx": fileFormatNum = 51
                    Case 52:
                        If .HasVBProject Then
                            fileExtStr = ".xlsm": fileFormatNum = 52
                        Else
                            fileExtStr = ".xlsx": fileFormatNum = 51
                        End If
                    Case 56: fileExtStr = ".xls": fileFormatNum = 56
                    Case Else: fileExtStr = ".xlsb": fileFormatNum = 50
                End Select
            End If
        End With
    
        'Change All Cells In The Worksheet To Values If You Want
        With destWb.Sheets(1).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
        '======================================
        'Save The New Workbook/Mail It/Delete It
        tempFilePath = Environ$("temp") & "\"
        tempFileName = Replace(sourceWb.Name, ".xlsm", "")
    
        Set outApp = CreateObject("Outlook.Application")
        Set outMail = outApp.CreateItem(0)
    
        With destWb
            .SaveAs tempFilePath & tempFileName & fileExtStr, FileFormat:=fileFormatNum
            On Error Resume Next
                With outMail
                    .To = "aaa@.com"   'Change Email
                    .CC = "aaa@.com"
                    .BCC = "aaa@.com"
                    .Subject = "بدلات "
                    .Body = " مع تحيات ..إدارة الشئون الادارية  )- 8240"
                    .Attachments.Add destWb.FullName
                    .Send
                End With
            On Error GoTo 0
            .Close savechanges:=False
        End With
    
        'Delete The File You Have Sent
        Kill tempFilePath & tempFileName & fileExtStr
    
        Set outMail = Nothing
        Set outApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[ياسر خليل أبو البراء]

وعليكم السلام

يرجى وضع الملف الذي توصلت إليه ووضع الرابط ليستفيد الجميع

تقبل تحياتي