Otomatik Mail Gönderme Makro Hatası

[ozgurpeh]

Merhaba,
Ekteki uygulamayı yurt dışı kaynaklı bir siteden indirdim, fakat mail ekini incelerseniz hatalı işlem yaptığını göreceksiniz. Sebebi sizce ne olabilir ?

http://bit.ly/AutoEmailWkDl

 

[ozgurpeh]

Konu gunceldir

 

[Korhan Ayhan]

Aldığınız hata nedir?

Siz ne yapmak istiyorsunuz?

 

[ozgurpeh]

Aldığınız hata nedir?

Siz ne yapmak istiyorsunuz?

Calıştırınca sizde göreceksiniz ek boş beyaz olarak geliyor,


Tapatalk kullanarak iPhone aracılığıyla gönderildi

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub EmailAuto_CreateSend()

Dim OutApp, OutMail As Object
Dim LastRow, CustRow, LastApptDays, ZoomLev As Long '
Dim FirstNm, LastNm, Problem, LastApptText, Subj, Mesg, BirthPicLoc As String
Dim BdDate, BdFrDate, BdToDate, TodDate, LastApptDt As Date
Dim PicRng As Range
Dim ChartPic As Object

With Sheet2
LastRow = Sheet1.Range("E9999").End(xlUp).Row  'Last Row
TodDate = .Range("B4").Value 'Todays Date

For CustRow = 5 To LastRow
Subj = .Range("F3").Value 'Subject
Mesg = .Range("F4").Value 'Message

    .Range("B5:B7").ClearContents
    BdDate = Sheet1.Range("M" & CustRow).Value
    BdFrDate = DateSerial(Year(TodDate), Month(BdDate), Day(BdDate))
    BdToDate = TodDate + .Range("B10").Value - 1
    
    If BdFrDate >= TodDate And BdFrDate <= BdToDate Then
        If Sheet1.Range("Q" & CustRow).Value = Empty Or Year(TodDate) <> Year(Sheet1.Range("Q" & CustRow).Value) Then
            FirstNm = Sheet1.Range("F" & CustRow).Value
            Problem = Sheet1.Range("H" & CustRow).Value
            LastApptDt = Sheet1.Range("G" & CustRow).Value
            .Range("B5").Value = FirstNm
            .Range("B6").Value = Sheet1.Range("E" & CustRow).Value 'Last Name
            .Range("B7").Value = LastApptDt
            .Calculate
            LastApptDays = .Range("B8").Value 'Days since last appt
            
            Select Case LastApptDays
              Case 1 To 14
               LastApptText = LastApptDays & " Days"
               Case 15 To 42
               LastApptText = Round(LastApptDays / 7, 0) & " Weeks"
               Case 43 To 365
               LastApptText = Round(LastApptDays / 30, 0) & " Months"
               Case Is > 365
               LastApptText = Round(LastApptDays / 365, 0) & " Year(s)"
            End Select
                
        Subj = Replace(Replace(Replace(Replace(Replace(Subj, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
        Mesg = Replace(Replace(Replace(Replace(Replace(Mesg, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
        
    BirthPicLoc = ActiveWorkbook.Path & "\" & FirstNm & "'s Birthday Gift.png"
            Sheet2.Activate
            ZoomLev = 100 / Sheet2.Parent.Windows(1).Zoom
            Set PicRng = Sheet2.Range("E17:H34")
            PicRng.CopyPicture xlPrinter
            Set ChartPic = Sheet2.ChartObjects.Add(0, 0, PicRng.Width * ZoomLev, PicRng.Height * ZoomLev)
            ChartPic.Activate
            ChartPic.Chart.Paste
            ChartPic.Chart.Export BirthPicLoc, "png"
            ChartPic.Delete
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
    
                    With OutMail
                        .To = Sheet1.Range("N" & CustRow).Value
                        .attachments.Add BirthPicLoc
                        .Subject = Subj
                        .Body = Mesg
                        .Display 'Change to .Send to Send emails without displaying them first
                    End With
                    On Error GoTo 0
                    Set OutMail = Nothing
                    
        Sheet1.Range("Q" & CustRow).Value = TodDate
        Kill (BirthPicLoc) 'Delete Temp Picture
         End If
    End If
 Next CustRow
End With
'ThisWorkbook.Save ' Use these two lines if you want to save and close the workbook when the macro is done
'ThisWorkbook.Close
End Sub

 

[ozgurpeh]

teşekkürler işe yaradı

 

[ozgurpeh]

Deneyiniz.

Option Explicit

Sub EmailAuto_CreateSend()

Dim OutApp, OutMail As Object
Dim LastRow, CustRow, LastApptDays, ZoomLev As Long '
Dim FirstNm, LastNm, Problem, LastApptText, Subj, Mesg, BirthPicLoc As String
Dim BdDate, BdFrDate, BdToDate, TodDate, LastApptDt As Date
Dim PicRng As Range
Dim ChartPic As Object

With Sheet2
LastRow = Sheet1.Range("E9999").End(xlUp).Row  'Last Row
TodDate = .Range("B4").Value 'Todays Date

For CustRow = 5 To LastRow
Subj = .Range("F3").Value 'Subject
Mesg = .Range("F4").Value 'Message

    .Range("B5:B7").ClearContents
    BdDate = Sheet1.Range("M" & CustRow).Value
    BdFrDate = DateSerial(Year(TodDate), Month(BdDate), Day(BdDate))
    BdToDate = TodDate + .Range("B10").Value - 1
   
    If BdFrDate >= TodDate And BdFrDate <= BdToDate Then
        If Sheet1.Range("Q" & CustRow).Value = Empty Or Year(TodDate) <> Year(Sheet1.Range("Q" & CustRow).Value) Then
            FirstNm = Sheet1.Range("F" & CustRow).Value
            Problem = Sheet1.Range("H" & CustRow).Value
            LastApptDt = Sheet1.Range("G" & CustRow).Value
            .Range("B5").Value = FirstNm
            .Range("B6").Value = Sheet1.Range("E" & CustRow).Value 'Last Name
            .Range("B7").Value = LastApptDt
            .Calculate
            LastApptDays = .Range("B8").Value 'Days since last appt
           
            Select Case LastApptDays
              Case 1 To 14
               LastApptText = LastApptDays & " Days"
               Case 15 To 42
               LastApptText = Round(LastApptDays / 7, 0) & " Weeks"
               Case 43 To 365
               LastApptText = Round(LastApptDays / 30, 0) & " Months"
               Case Is > 365
               LastApptText = Round(LastApptDays / 365, 0) & " Year(s)"
            End Select
               
        Subj = Replace(Replace(Replace(Replace(Replace(Subj, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
        Mesg = Replace(Replace(Replace(Replace(Replace(Mesg, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
       
    BirthPicLoc = ActiveWorkbook.Path & "\" & FirstNm & "'s Birthday Gift.png"
            Sheet2.Activate
            ZoomLev = 100 / Sheet2.Parent.Windows(1).Zoom
            Set PicRng = Sheet2.Range("E17:H34")
            PicRng.CopyPicture xlPrinter
            Set ChartPic = Sheet2.ChartObjects.Add(0, 0, PicRng.Width * ZoomLev, PicRng.Height * ZoomLev)
            ChartPic.Activate
            ChartPic.Chart.Paste
            ChartPic.Chart.Export BirthPicLoc, "png"
            ChartPic.Delete
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
   
                    With OutMail
                        .To = Sheet1.Range("N" & CustRow).Value
                        .attachments.Add BirthPicLoc
                        .Subject = Subj
                        .Body = Mesg
                        .Display 'Change to .Send to Send emails without displaying them first
                    End With
                    On Error GoTo 0
                    Set OutMail = Nothing
                   
        Sheet1.Range("Q" & CustRow).Value = TodDate
        Kill (BirthPicLoc) 'Delete Temp Picture
         End If
    End If
Next CustRow
End With
'ThisWorkbook.Save ' Use these two lines if you want to save and close the workbook when the macro is done
'ThisWorkbook.Close
End Sub

Korhan bey, son bir sorum daha olacak size. Resim alanının ek değilde metnin altında mail body alanında göstermek için kod nasıl olmalı ?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub EmailAuto_CreateSend()

Dim OutApp, OutMail As Object, chartpic As Object
Dim LastRow, CustRow, LastApptDays, ZoomLev As Long, Fname As String
Dim FirstNm, LastNm, Problem, LastApptText, Subj, Mesg, BirthPicLoc As String
Dim BdDate, BdFrDate, BdToDate, TodDate, LastApptDt As Date, PicRng As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheet2
LastRow = Sheet1.Range("E9999").End(xlUp).Row  'Last Row
TodDate = .Range("B4").Value 'Todays Date

For CustRow = 5 To LastRow
Subj = .Range("F3").Value 'Subject
Mesg = .Range("F4").Value 'Message

    .Range("B5:B7").ClearContents
    BdDate = Sheet1.Range("M" & CustRow).Value
    BdFrDate = DateSerial(Year(TodDate), Month(BdDate), Day(BdDate))
    BdToDate = TodDate + .Range("B10").Value - 1
    
    If BdFrDate >= TodDate And BdFrDate <= BdToDate Then
        If Sheet1.Range("Q" & CustRow).Value = Empty Or Year(TodDate) <> Year(Sheet1.Range("Q" & CustRow).Value) Then
            FirstNm = Sheet1.Range("F" & CustRow).Value
            Problem = Sheet1.Range("H" & CustRow).Value
            LastApptDt = Sheet1.Range("G" & CustRow).Value
            .Range("B5").Value = FirstNm
            .Range("B6").Value = Sheet1.Range("E" & CustRow).Value 'Last Name
            .Range("B7").Value = LastApptDt
            .Calculate
            LastApptDays = .Range("B8").Value 'Days since last appt
            
            Select Case LastApptDays
              Case 1 To 14
               LastApptText = LastApptDays & " Days"
               Case 15 To 42
               LastApptText = Round(LastApptDays / 7, 0) & " Weeks"
               Case 43 To 365
               LastApptText = Round(LastApptDays / 30, 0) & " Months"
               Case Is > 365
               LastApptText = Round(LastApptDays / 365, 0) & " Year(s)"
            End Select
                
            Subj = Replace(Replace(Replace(Replace(Replace(Subj, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
            Mesg = Replace(Replace(Replace(Replace(Replace(Mesg, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
        
            Sheet2.Activate
            ZoomLev = 100 / Sheet2.Parent.Windows(1).Zoom
            Set PicRng = Sheet2.Range("E17:H34")
            
            Fname = ThisWorkbook.Path & "\Resim.jpg"
        
            PicRng.CopyPicture
            
            Set chartpic = Sheet2.ChartObjects.Add(0, 0, PicRng.Width * ZoomLev, PicRng.Height * ZoomLev)
            chartpic.Activate
            chartpic.Chart.Paste
            chartpic.Chart.Export Fname, "JPG"
            chartpic.Delete
    
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
    
            With OutMail
                .Display 'Change to .Send to Send emails without displaying them first
                .To = Sheet1.Range("N" & CustRow).Value
                .Subject = Subj
                .Attachments.Add Fname
                .HTMLBody = "<font style=""font-family: Calibri; font-size: 11pt;""/font>" & Mesg & "<Br><Br>" & _
                            "<html><img src=""cid:Resim.jpg""></html>" & "</Font>" & .HTMLBody
            End With
            On Error GoTo 0
            Set OutMail = Nothing
                    
            Sheet1.Range("Q" & CustRow).Value = TodDate
         End If
    End If
 Next CustRow
End With
'ThisWorkbook.Save ' Use these two lines if you want to save and close the workbook when the macro is done
'ThisWorkbook.Close
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[ozgurpeh]

Option Explicit Sub EmailAuto_CreateSend() Dim OutApp, OutMail As Object, chartpic As Object Dim LastRow, CustRow, LastApptDays, ZoomLev As Long, Fname As String Dim FirstNm, LastNm, Problem, LastApptText, Subj, Mesg, BirthPicLoc As String Dim BdDate, BdFrDate, BdToDate, TodDate, LastApptDt As Date, PicRng As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Sheet2 LastRow = Sheet1.Range("E9999").End(xlUp).Row 'Last Row TodDate = .Range("B4").Value 'Todays Date For CustRow = 5 To LastRow Subj = .Range("F3").Value 'Subject Mesg = .Range("F4").Value 'Message .Range("B5:B7").ClearContents BdDate = Sheet1.Range("M" & CustRow).Value BdFrDate = DateSerial(Year(TodDate), Month(BdDate), Day(BdDate)) BdToDate = TodDate + .Range("B10").Value - 1 If BdFrDate >= TodDate And BdFrDate <= BdToDate Then If Sheet1.Range("Q" & CustRow).Value = Empty Or Year(TodDate) <> Year(Sheet1.Range("Q" & CustRow).Value) Then FirstNm = Sheet1.Range("F" & CustRow).Value Problem = Sheet1.Range("H" & CustRow).Value LastApptDt = Sheet1.Range("G" & CustRow).Value .Range("B5").Value = FirstNm .Range("B6").Value = Sheet1.Range("E" & CustRow).Value 'Last Name .Range("B7").Value = LastApptDt .Calculate LastApptDays = .Range("B8").Value 'Days since last appt Select Case LastApptDays Case 1 To 14 LastApptText = LastApptDays & " Days" Case 15 To 42 LastApptText = Round(LastApptDays / 7, 0) & " Weeks" Case 43 To 365 LastApptText = Round(LastApptDays / 30, 0) & " Months" Case Is > 365 LastApptText = Round(LastApptDays / 365, 0) & " Year(s)" End Select Subj = Replace(Replace(Replace(Replace(Replace(Subj, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem) Mesg = Replace(Replace(Replace(Replace(Replace(Mesg, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem) Sheet2.Activate ZoomLev = 100 / Sheet2.Parent.Windows(1).Zoom Set PicRng = Sheet2.Range("E17:H34") Fname = ThisWorkbook.Path & "\Resim.jpg" PicRng.CopyPicture Set chartpic = Sheet2.ChartObjects.Add(0, 0, PicRng.Width * ZoomLev, PicRng.Height * ZoomLev) chartpic.Activate chartpic.Chart.Paste chartpic.Chart.Export Fname, "JPG" chartpic.Delete Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With OutMail .Display 'Change to .Send to Send emails without displaying them first .To = Sheet1.Range("N" & CustRow).Value .Subject = Subj .Attachments.Add Fname .HTMLBody = "<font style=""font-family: Calibri; font-size: 11pt;""/font>" & Mesg & "<Br><Br>" & _ "<html><img src=""cid:Resim.jpg""></html>" & "</Font>" & .HTMLBody End With On Error GoTo 0 Set OutMail = Nothing Sheet1.Range("Q" & CustRow).Value = TodDate End If End If Next CustRow End With 'ThisWorkbook.Save ' Use these two lines if you want to save and close the workbook when the macro is done 'ThisWorkbook.Close Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

Teşekkürler, oldu fakat aşağıdaki güvenlik onayı verilmeden ilerlemiyor. Bunu aşabiliyor muyuz ?

 

[Korhan Ayhan]

Linki inceleyiniz.

http://www.excel.web.tr/f48/outlook-uzerinden-mesaj-gonderirken-guvenlik-uyarysy-t135090.html

 

[ozgurpeh]

Linki inceleyiniz.

http://www.excel.web.tr/f48/outlook-uzerinden-mesaj-gonderirken-guvenlik-uyarysy-t135090.html

Tüm soruların cevabı için teşekkür ederim. Çok yardımcı oldunuz.

 

[ozgurpeh]

Deneyiniz.

Option Explicit

Sub EmailAuto_CreateSend()

Dim OutApp, OutMail As Object, chartpic As Object
Dim LastRow, CustRow, LastApptDays, ZoomLev As Long, Fname As String
Dim FirstNm, LastNm, Problem, LastApptText, Subj, Mesg, BirthPicLoc As String
Dim BdDate, BdFrDate, BdToDate, TodDate, LastApptDt As Date, PicRng As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheet2
LastRow = Sheet1.Range("E9999").End(xlUp).Row  'Last Row
TodDate = .Range("B4").Value 'Todays Date

For CustRow = 5 To LastRow
Subj = .Range("F3").Value 'Subject
Mesg = .Range("F4").Value 'Message

    .Range("B5:B7").ClearContents
    BdDate = Sheet1.Range("M" & CustRow).Value
    BdFrDate = DateSerial(Year(TodDate), Month(BdDate), Day(BdDate))
    BdToDate = TodDate + .Range("B10").Value - 1
  
    If BdFrDate >= TodDate And BdFrDate <= BdToDate Then
        If Sheet1.Range("Q" & CustRow).Value = Empty Or Year(TodDate) <> Year(Sheet1.Range("Q" & CustRow).Value) Then
            FirstNm = Sheet1.Range("F" & CustRow).Value
            Problem = Sheet1.Range("H" & CustRow).Value
            LastApptDt = Sheet1.Range("G" & CustRow).Value
            .Range("B5").Value = FirstNm
            .Range("B6").Value = Sheet1.Range("E" & CustRow).Value 'Last Name
            .Range("B7").Value = LastApptDt
            .Calculate
            LastApptDays = .Range("B8").Value 'Days since last appt
          
            Select Case LastApptDays
              Case 1 To 14
               LastApptText = LastApptDays & " Days"
               Case 15 To 42
               LastApptText = Round(LastApptDays / 7, 0) & " Weeks"
               Case 43 To 365
               LastApptText = Round(LastApptDays / 30, 0) & " Months"
               Case Is > 365
               LastApptText = Round(LastApptDays / 365, 0) & " Year(s)"
            End Select
              
            Subj = Replace(Replace(Replace(Replace(Replace(Subj, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
            Mesg = Replace(Replace(Replace(Replace(Replace(Mesg, "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
      
            Sheet2.Activate
            ZoomLev = 100 / Sheet2.Parent.Windows(1).Zoom
            Set PicRng = Sheet2.Range("E17:H34")
          
            Fname = ThisWorkbook.Path & "\Resim.jpg"
      
            PicRng.CopyPicture
          
            Set chartpic = Sheet2.ChartObjects.Add(0, 0, PicRng.Width * ZoomLev, PicRng.Height * ZoomLev)
            chartpic.Activate
            chartpic.Chart.Paste
            chartpic.Chart.Export Fname, "JPG"
            chartpic.Delete
  
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
  
            With OutMail
                .Display 'Change to .Send to Send emails without displaying them first
                .To = Sheet1.Range("N" & CustRow).Value
                .Subject = Subj
                .Attachments.Add Fname
                .HTMLBody = "<font style=""font-family: Calibri; font-size: 11pt;""/font>" & Mesg & "<Br><Br>" & _
                            "<html><img src=""cid:Resim.jpg""></html>" & "</Font>" & .HTMLBody
            End With
            On Error GoTo 0
            Set OutMail = Nothing
                  
            Sheet1.Range("Q" & CustRow).Value = TodDate
         End If
    End If
Next CustRow
End With
'ThisWorkbook.Save ' Use these two lines if you want to save and close the workbook when the macro is done
'ThisWorkbook.Close
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Tşkler