• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

makro ile mail gönderme

Merhaba,
Sayfa üzerinde yazdırma alanı belirlenmiş bir alan var bu alana pdf ye çevir diye bir buton kodlaması yazdım ve çeviriyor çevirirken yazdırma alanı içerisindeki D6 hücresinden dosya kaydı yapacağı müşterinin adını otomatik çekiyor..Buraya kadar herşey normal bir buton kodlaması daha yaptım yine d12 deki mail adresine göre yazdırma sayfası içindeki kayıtlı olan dosyayı mail atmak istiyorum fakat Attachment yapacağım yerde dosya yolunu yazmam gerek ben yine müşteri adından çeksin istiyorum umarım anlatabilmişimdir…Cevabınızı bekliyorum teşekkürler..
 
sukruyilmaz' Alıntı:
bende aşağıdaki kodu kullanarak mail gönderme butonu yapmıştım. kodu yazan forumdaki üstadlarımdır...

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
Set rng = Nothing
On Error GoTo 0


With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Attachments.Add ""
.HTMLBody = ""
.Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing

End Sub
Genişletmek için tıkla ...

Mükemmel çalışıyor. Yapanın eline ve emeğine sağlık.
 
yeni bir konu açmadan sorumu buraya yazmaya karar verdim inşallah cevap alırım.
Sorum şu,aşağıdaki kodda d41 hücresindeki sayıyı çekemiyorum mailin konusuna diğerleri geliyor bu gelmiyor,d41 hücresindeki değer başka hücredede olsa yine olmuyor,kodda bir hatamı var,yardımcı olabilirmisiniz?
.Subject = "FİŞ" + Range("D41").Value + "-" + Range("D35").Value

Kod: 
Option Explicit

Private Sub CommandButton2_Click()
ActiveSheet.PageSetup.PrintArea = "A1:I31"
Application.Dialogs(xlDialogPrint).Show
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("D35:D37:H35")) Is Nothing Then Exit Sub
Target.Font.Size = 16
End Sub
Private Sub CommandButton1_Click()
Dim Sayfa As Worksheet
    Dim Alan As Range
    Dim daralan As Range
    
    ' mailin gönderileceği kişi girilmemişse HATA'ya git
    If Range("D36").Value = "" Then GoTo HATA

    On Error GoTo HATA

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    ' mail ile gönderilecek alanı ayarla
    Set Sayfa = ActiveSheet
    Set Alan = ActiveSheet.Range("A1:I30")
   
    With Alan

        .Parent.Select
        Set daralan = ActiveCell

        .Select
        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

                        With .Item
                .To = Range("D36").Value
                .CC = Range("D37").Value
                .Subject = "FİŞ" + Range("D41").Value + "-" + Range("D35").Value
                .Send
            End With

        End With

        daralan.Select
    End With
    
    Sayfa.Select

HATA:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
   ActiveSheet.PageSetup.PrintArea = "A1:I31"
Application.Dialogs(xlDialogPrint).Show

End Sub
 
kendi sorumu kendim cevaplayayım,artılardan(+) kurtardık sorun çözüldü.
.Subject = "FİŞ" & Range("D41").Value & "-" & Range("D35").Value
 
Arkadaşlar merhaba "to" kısmında birden fazla kişiye nasıl mail atılır.
 
Mail atma makrosu

Merhabalar,
taze üye olarak hepinize selamlar.konuda incelediğim üzere ihtiyacımı büyük oranda karşılayan makroları inceledim.fakat ekte bulabileceğiniz dosyamda farklı sekmelerde ucus raporlarım var.maddeler halinde asağıda belirtiyorum;
1.çalıştığım sayfayı mail atsın
2.formülle oluşan hücrelerin sadece değerini alsın(formul olmasın)
3.mailde oluşacak excelin konu başlığını hücrelerden belirli bir sırayla makro ile alsın(hücreleri ben secebilirim)
uslup hatası varsa affediniz.eğer yardımcı olabilirseniz sayenizde hızıma hız katacağım :) tesekkurler.
 

Ekli dosyalar

merhaba, yardımınızı rica ederim
 
Son düzenleme:
ya da kolaylık olsun diye aşağıda atacağım makroyu belirteceğim maddelere göre düzenleyebilir misiniz?
1.sadece çalıştığım sayfayı alsın
2.gönderimi yapmasın sadece maile eklesin ben göndereceğim kişileri ve imzamı manuel ekleyeceğim.
3.maile eklenecek excelin ismini hücrelerden belirli bir sırayla makro ile alsın(hücreleri ben secebilirim)
4.alt tarafta buton yine çıkıyor onun olmaması lazım.
5.sadece values olarak alsın formuller olmasın.
 
Son düzenleme:
Sub Mail_ActiveSheet()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010
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

' Next, copy the sheet to a new workbook.
' You can also use the following line, instead of using the ActiveSheet object,
' if you know the name of the sheet you want to mail :
' Sheets("Sheet5").Copy
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

' Determine the Excel version, and file extension and format.
With Destwb
If Val(Application.Version) < 12 Then
' For Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
' For Excel 2007-2010, exit the subroutine if you answer
' NO in the security dialog that is displayed when you copy
' a sheet from an .xlsm file with macros disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You answered NO in the security dialog."
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsx": 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 If
End With

' You can use the following statements to change all cells in the
' worksheet to values.
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False

' Save the new workbook, mail, and then 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
' Change the mail address and subject in the macro before
' running the procedure.
With OutMail
.To = "selcukdogru@hotmail.com.tr"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hello World!"
.Attachments.Add Destwb.FullName
' You can add other files by uncommenting the following statement.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

' Delete the file after sending.
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

Ekli dosyalar

arkadaşlar konuyu bilen kimse yok mu forumda? sıfırdan bir şey yapılmayacak olana müdahale edilecek ?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst