Çözüldü Excel Çalışma Kitabındaki Sayfanın xlsx Uzantılı Olarak Microsoft Outlook Programına Giden Maile Ek Olarak Eklenmesi Hk.

[skaan]

Merhaba;
Aşağıdaki kodlar ile özetle excel çalışma kitabindakı "Proforma" isimli sayfadaki fatura görüntüsünü belirlediğim bir dosyaya pdf uzantılı olarak kayıt edebiliyorum.
Ben bu kodların çalışmasını bozmadan yine aynı makro ile bu kodlara ek olarak excel çalışma kitabında bulunan "Sayfa1" isimli sayfanın "xlsx"uzantılı olarak Microsoft Outlook Programına gönderilmek üzere ek olarak eklenmesini istiyorum. Giden sayfası açılınca to: cc: konu : kısımları boş kalacak
sadece mail açıklamasında " Ekli Dosyayı Sisteme İşleyelim Lütfen" açıklaması yazmalı. Sonuc olarak makro çalışınca hem pdf kayıt tarafı hemde xlsx uzantılı excel dosyası outlook ek olarak eklenmeli.. Kodlar pdf kaydında çalışıyor sorun yok ancak; bu kodlara outlook giden mail ek ıle ılgılı kısmı eklememde yardımcı olmanızı rica ediyorum.Kodları nasıl ekleme ve düzenleme yapılabilinir.. Örnek dosyam ektedir.. Yardımcı olmanızı rica ediyorum..Tşk.

Saygılarımla;
SKaan


Sub KaydetPDF()
Dim YazdirmaAlani As Range
Dim DosyaAdi As String
Dim DosyaYolu As String
Dim TamDosyaAdi As String
Dim DosyaVar As Boolean
Dim KlasorYolu As Variant
Dim FaturaListe As Worksheet
Dim Proforma As Worksheet

' Aktif sayfanın adını kontrol et
If ActiveSheet.Name <> "Proforma" Then
MsgBox "Bu işlem sadece 'Proforma' adlı sayfada kullanılabilir.", vbExclamation
Exit Sub
End If

' Yazdırma alanını belirleyin
Set YazdirmaAlani = ActiveSheet.UsedRange ' Kaydedilecek yazdırma alanını otomatik olarak alın

' Referans sayfalarını tanımla
Set FaturaListe = ThisWorkbook.Sheets("FaturaListe")
Set Proforma = ThisWorkbook.Sheets("Proforma")

' Yazdırma alanlarını belirle
Dim Bilgi1 As String
Bilgi1 = Proforma.Range("AP9").Value
Dim Bilgi2 As String
Bilgi2 = Proforma.Range("F8").Value
Dim Bilgi3 As String
Bilgi3 = Proforma.Range("AN32").Value
Dim Bilgi4 As String
Bilgi4 = Proforma.Range("AF14").Value

' Kaydedilecek dosyanın adını kullanıcıdan alın
DosyaAdi = InputBox("PDF dosyasının adını girin", "Dosya Adı")

' Dosya adının boş olmadığından emin olun
If DosyaAdi <> "" Then
Do
DosyaVar = False ' Dosya adı çakışmasını kontrol etmek için bayrağı sıfırla

' Kaydedilecek dosyanın tam yolunu belirle
If KlasorYolu = "" Then
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Kaydedilecek klasörü seçin"
.Show
If .SelectedItems.Count > 0 Then
KlasorYolu = .SelectedItems(1)
Else
Exit Sub ' Kullanıcı bir klasör seçmezse işlemi sonlandır
End If
End With
End If

DosyaYolu = KlasorYolu & "\"
TamDosyaAdi = DosyaYolu & DosyaAdi & ".pdf"

' Dosyanın daha önce kaydedilip kaydedilmediğini kontrol et
If Dir(TamDosyaAdi) <> "" Then
' Dosya zaten varsa, dosya adını değiştirmek için kullanıcıdan yeni bir dosya adı iste
DosyaAdi = InputBox("Belirtilen dosya adıyla aynı isimde bir dosya zaten mevcut. Yeni dosya adını girin", "Dosya Adı")
DosyaVar = True ' Dosya adı çakışması olduğunu belirtmek için bayrağı ayarla
End If
Loop While DosyaVar = True ' Dosya adı çakışması olduğu sürece döngüyü tekrarla

' Belirli hücrelere değerleri yaz
Dim Satir1 As Long
Satir1 = FaturaListe.Range("B" & FaturaListe.Rows.Count).End(xlUp).Row + 1
FaturaListe.Range("B" & Satir1).Value = Bilgi1

Dim Satir2 As Long
Satir2 = FaturaListe.Range("C" & FaturaListe.Rows.Count).End(xlUp).Row + 1
FaturaListe.Range("C" & Satir2).Value = Bilgi2

Dim Satir3 As Long
Satir3 = FaturaListe.Range("D" & FaturaListe.Rows.Count).End(xlUp).Row + 1
FaturaListe.Range("D" & Satir3).Value = Bilgi3

Dim Satir4 As Long
Satir4 = FaturaListe.Range("E" & FaturaListe.Rows.Count).End(xlUp).Row + 1
FaturaListe.Range("E" & Satir4).Value = Bilgi4

' Yazdırma alanını belirle ve PDF olarak kaydet
With Proforma
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TamDosyaAdi, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
End With

' Bilgi mesajını görüntüle
MsgBox "Pdf Dosyanız Belirlediğiniz Klasöre Eklenmiştir.", vbInformation
End If
End Sub

 

[skaan]

Üstadlar yardımcı olabilecekmisiniz acaba ?
Destek rica ediyorum..

Saygılarımla;
SKaan

 

[tahsinanarat]

Sn. @skaan Aşağıdaki kodu kendinize uyarlayıp deneyiniz.

Sub Mail_ActiveSheet()
    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

    'Copy the ActiveSheet to a new workbook
    Sayfa1.Copy
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            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 = "Part of " & Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    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 = "This is the Subject line"
            .Body = "Gövde açıklamasını buraya yazınız"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            .Attachments.Add ("C:\Perform_pdf\Proforma_dosyaadi.pdf")
            .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Proforma faturanızıda belirli bir adrese kaydetmek isterseniz de;

Sub farklıkaydetPDF2()
dosya_adı = "Proforma_dosyaadi"
If dosya_adı = "" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
Kaynak = "C:\Perform_pdf\"
If Right(Kaynak, 1) <> "\" Then
End If
yer = Kaynak & dosya_adı

Range("A1:AU48").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yer, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

adres yollarını kendinize göre düzenleyerek kullanabilirsiniz.

 

[tahsinanarat]

Örnek dosyanız ekte, farklıkaydetPDF2 makrosunu çalıştırdığınızda istediğiniz gibi mail ekine her iki dosyanızı da ekliyor.
Not: Kodlar daha evvel bu siteden temin ettiğim kodlarla düzenlenmiştir.
Kaloy Gelsin.

 

[skaan]

Sayın tahsinanarat;
Hata ile karşılaşıyorum..

Saygılarımla;
Skaan

 

[tahsinanarat]

Sn. @skaan
.Attachments.Add ("C:\Perform_pdf\Proforma_dosyaadi.pdf")
Kaynak = "C:\Perform_pdf\"
Kaynak Dosyanın kayıt yerini kendine göre değiştirmiş miydiniz.

 

[skaan]

Merhaba;
Kaynak Dosyanın kayıt yeriniden kaynaklanıyormuş..
Yardımlarınız için teşekkürler..

Saygılar..
Skaan