• DİKKAT

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

Mail kodlarında hata mesajı

A

atillaciftci

Katılım
14 Haziran 2006
Mesajlar
129
Aşağıdaki kodda msg yazan yer hata veriyor burayı nasıl doğru yazabilirim..



Sub is_list_mail_gonder()
Dim Email_Subject, Email_Send_From, Email_Send_To, Email_Cc, Email_Bcc, Email_Body, strLines As String
Dim Mail_Object, Mail_Single As Variant
Dim mailBody As String
Dim i As Long, _
j As Integer, _
d, _
Adet As Integer, _
msg As String, _
cc As String, _
HLink As String, _
Recipient As String, _
Subj As String


For i = 18 To Cells(Rows.Count, "E").End(3).Row
If Cells(i, "B") Like "EVET" Then

msg = Range(i, "D18").Copy & Sheets("Work Order").Select & Range("L2").Select & ActiveSheet.Paste & Sheets("İş Listesi").Select

d = Split(Cells(i, "N"), ";")
For j = 0 To UBound(d)
Recipient = d(j)
Email_Send_To = Recipient
Email_Subject = "Email konusu"
Email_Send_From = ""
Email_Cc = "aaa@aaa.com;bbb@bbb.com"
Email_Bcc = ""
Email_Body = msg

Next j

On Error GoTo debugs
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body
.Display
Application.Wait (Now + TimeValue("00:00:02"))
Application.SendKeys "%e", True
End With
Adet = Adet + 1
Set Mail_Object = Nothing
Set Mail_Single = Nothing
Application.Wait (Now + TimeValue("00:00:01"))
debugs:
If Err.Description <> "" Then
MsgBox Err.Description

End If
End If

Next
MsgBox Adet & " Adet Mail Gönderilmiştir....", vbInformation, "ATİLLA ÇİFTÇİ"
End Sub
 
Merhaba,

msg satırındaki amaçınız nedir.?
 
Mail olarak göndermek istiyorum

Genel olarak yapmak istediğimi açıklayayım 1.sayfaya bilgileri giricem ve o sayfada evet yazdığım satırlardaki sıra numarasını alacak sayfa2 de istediğim yere yazacak ve sayfa2 yi mail atacak.
Sonra sayfa1 e dönecek başka satırada evet yazmışsam o satırda da aynı işlemi yapacak döngü evetler bitene kadar devam edecek.

Örnek dosya ekledim ilginize teşekkürler..

önceki mesajımda msg ile sayfa2 den istediğim bilgileri kopyalar maile yapıştırırım diye düşünmüştüm ama bu işime yaramıyor Sayfa2 yi ek olarak eklemesi gerekiyor.

Örnek dosyada ki kodlarda düzenleme yaparsanız sevinirim..
 

Ekli dosyalar

Kodları aşağıdakilerle değiştirin.

Mail kodlarıyla ilgili detaylı bilgi için linki inceleyiniz.

http://www.excel.web.tr/f48/makroyla-email-gonderme-t2119.html

Kod: 
 Sub Mail_ActiveSheet()
 
    Dim FileExtStr As String, FileFormatNum As Long, Sourcewb As Workbook
    Dim Destwb As Workbook, TempFilePath As String, TempFileName As String
    Dim OutApp As Object, OutMail As Object, sat As Long, i As Long
    Dim j As Integer, kime As String
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Sheets("İş Listesi").Select
    Sheets("Work Order").Range("C2:L" & Rows.Count).ClearContents
    
    sat = 2
    For i = 18 To Cells(Rows.Count, "E").End(xlUp).Row
        If Cells(i, "B") Like "EVET" Then
            Range("D" & i & ":M" & i).Copy Sheets("Work Order").Range("C" & sat)
            sat = sat + 1
            kime = Cells(i, "N") & ";" & kime
        End If
    Next i
    
    Sheets("Work Order").Select
    
    Set Sourcewb = ActiveWorkbook
    
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
    With Destwb
        If Val(Application.Version) < 12 Then
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            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 If
    End With
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = kime
            .cc = "[EMAIL="aaa@aaa.com;bbb@bbb.com"]aaa@aaa.com;bbb@bbb.com[/EMAIL]"
            .BCC = ""
            .Subject = "Email konusu"
            .Body = "Sayfa2"
            .Attachments.Add Destwb.FullName
            .Display   ' .Send
        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
.
 
Yazdığınız kodlar çok işime yaradı teşekkürler ama istediğimi tam karşılamıyor. İstediğim 1.sayfada evet yazanın yanındaki iş nosunu alıp 2.sayfada "L2" ye yazsın sayfa 2 yi mail atsın sonra 1.sayfa da başka evet olan varsa bunu alsın "L2" ye yazsın bunuda mail atsın sadece burası yanlış anlaşılmış gerisi mükemmel olmuş bunuda düzeltirsek süper olur...
 
Bu şekilde deneyin.

Kod: 
Sub Mail_ActiveSheet()
 
    Dim FileExtStr As String, FileFormatNum As Long, Sourcewb As Workbook
    Dim Destwb As Workbook, TempFilePath As String, TempFileName As String
    Dim OutApp As Object, OutMail As Object, sat As Long, i As Long
    Dim j As Integer, kime As String
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Sheets("İş Listesi").Select
    Sheets("Work Order").Range("C2:L" & Rows.Count).ClearContents
    
    sat = 2
    For i = 18 To Cells(Rows.Count, "E").End(xlUp).Row
        If Cells(i, "B") = "EVET" Then
            Range("D" & i & ":M" & i).Copy Sheets("Work Order").Range("C2")
            kime = Cells(i, "N")
   
           Sheets("Work Order").Select
           
           Set Sourcewb = ActiveWorkbook
           
           ActiveSheet.Copy
           Set Destwb = ActiveWorkbook
           With Destwb
               If Val(Application.Version) < 12 Then
                   FileExtStr = ".xls": FileFormatNum = -4143
               Else
                   If Sourcewb.Name = .Name Then
                       With Application
                           .ScreenUpdating = True
                           .EnableEvents = True
                       End With
                       MsgBox "Your answer is NO in the security dialog"
                       Exit Sub
                   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 If
           End With
           
           TempFilePath = Environ$("temp") & "\"
           TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
           
           Set OutApp = CreateObject("Outlook.Application")
           OutApp.Session.Logon
           Set OutMail = OutApp.CreateItem(0)
           
           With Destwb
               .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
               On Error Resume Next
               With OutMail
                   .To = kime
                   .cc = "[EMAIL="aaa@aaa.com;bbb@bbb.com"]aaa@aaa.com;bbb@bbb.com[/EMAIL]"
                   .BCC = ""
                   .Subject = "Email konusu"
                   .Body = "Sayfa2"
                   .Attachments.Add Destwb.FullName
                   .Display   ' .Send
               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 If
        Sheets("İş Listesi").Select
    Next i
    
End Sub
.
 
Konu bütünlüğünü korumak için, farklı konularla ilgili sorularınızı yeni konu başlığı açarak sormanızı rica ederim.
 
Teşekkürler

Yeni konu açtım uyarınız için teşekkürler..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst