AccessTr.neT

Sub MailActiveSheet()



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

Dim i As Integer



i = ActiveCell.Row '<=========== Eklenen Satır i ile aktif satır belirlenip ona göre kopyalama yapılır

With Application

    .ScreenUpdating = False

    .EnableEvents = False

End With



Set Sourcewb = ThisWorkbook



ActiveSheet.Copy

Set Destwb = ActiveWorkbook



With Destwb

    FileExtStr = ".xlsb": FileFormatNum = 50

End With



TempFilePath = Environ$("temp") & "\"

TempFileName = " " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")



'================>Eklenen<==========================================

Range(i & ":" & i).Copy Destwb.Worksheets("W.O KAYIT").Range("4:4")   '<=========== Eklenen Satır sadece seçtiğiniz satırı kopyalar

Destwb.Worksheets("W.O KAYIT").Range("A5:Z993").Clear                 '<=========== Eklenen Satır Geriye kalanı siler

'================>Eklenen BİTTİ<==========================================



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 = ""

        .CC = ""

        .BCC = ""

        .Subject = "C&I BAKIM WORK ORDER"

        .Body = "Sayın İlgililer" & vbNewLine & vbNewLine & "IT ile ilgili yeni oluşturulan iş emrini ekte görebilirsiniz." & vbNewLine & vbNewLine & "İyi Çalışmalar"

        .Attachments.Add Destwb.FullName

        '.Send

        .Display

    End With

    On Error GoTo 0

    .Close savechanges:=False

End With



Kill TempFilePath & TempFileName & FileExtStr



Set OutMail = Nothing

Set OutApp = Nothing



With Application

    .ScreenUpdating = True

    .EnableEvents = True

End With

End Sub

(10/05/2019, 04:21)haliliyas yazdı: [ -> ]bu arada kodlar da kopyalanıyor sayfayla beraber yeni kitap-->yeni sayfa-->sadece 3-4 satırı kopyala yapsak daha hızlı ve kolay olmaz mı? diğerlerinin arka planda çalışan kodlara ihtiyacı var mı? 
not: önerim sadece teorik nasıl yapılır bilmiyorum )

dilerim işinize yarar

Sub MailActiveSheet()



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

Dim i As Integer



i = ActiveCell.Row '<=========== Eklenen Satır i ile aktif satır belirlenip ona göre kopyalama yapılır

With Application

    .ScreenUpdating = False

    .EnableEvents = False

End With



Set Sourcewb = ThisWorkbook



ActiveSheet.Copy

Set Destwb = ActiveWorkbook



With Destwb

    FileExtStr = ".xlsb": FileFormatNum = 50

End With



TempFilePath = Environ$("temp") & "\"

TempFileName = " " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")



'================>Eklenen<==========================================

Range(i & ":" & i).Copy Destwb.Worksheets("W.O KAYIT").Range("4:4")   '<=========== Eklenen Satır sadece seçtiğiniz satırı kopyalar

Destwb.Worksheets("W.O KAYIT").Range("A5:Z993").Clear                 '<=========== Eklenen Satır Geriye kalanı siler

'================>Eklenen BİTTİ<==========================================



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 = ""

        .CC = ""

        .BCC = ""

        .Subject = "C&I BAKIM WORK ORDER"

        .Body = "Sayın İlgililer" & vbNewLine & vbNewLine & "IT ile ilgili yeni oluşturulan iş emrini ekte görebilirsiniz." & vbNewLine & vbNewLine & "İyi Çalışmalar"

        .Attachments.Add Destwb.FullName

        '.Send

        .Display

    End With

    On Error GoTo 0

    .Close savechanges:=False

End With



Kill TempFilePath & TempFileName & FileExtStr



Set OutMail = Nothing

Set OutApp = Nothing



With Application

    .ScreenUpdating = True

    .EnableEvents = True

End With

End Sub

(10/05/2019, 16:54)ertus35 yazdı: [ -> ]resim geldi mi acaba. Yükleyemedim sanırım resmi.

(10/05/2019, 18:22)haliliyas yazdı: [ -> ]dilerim işinize yarar)

Saygılarımla[img][/img]