Outlook resim'e link köprü ekleme

[ozgurpeh]

Merhaba,

Aşağıdaki kod ile hergün farklı tarihte doğan kişiler için otomatik mail gidiyor. Excelde bir resim mail body sinde mesaj olarak ulaşıyor. Ben bu resim üzerine mailde tıklanabilecek herkes için ayrı bir link eklemek istiyorum ( metin kutusu denedim olmadı ) P sütununda herkes için belirlenmiş linkler var . Bu koda bunu nasıl ekleyebilirim. Desteğinize ihtiyacım var.

Şimdiden teşekkürler

"No = Sheet1.Range("P" & CustRow).Value"

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, No, 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
            LastNm = Sheet1.Range("E" & CustRow).Value
            Problem = Sheet1.Range("H" & CustRow).Value
            No = Sheet1.Range("P" & CustRow).Value
            LastApptDt = Sheet1.Range("G" & CustRow).Value
            .Range("B5").Value = FirstNm & " " & LastNm
            .Range("B3").Value = FirstNm
            .Range("B1").Value = No
            .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) & " hafta"
               Case 43 To 365
               LastApptText = Round(LastApptDays / 30, 0) & " ay"
               Case Is > 365
               LastApptText = Round(LastApptDays / 365, 0) & " yil"
            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(Replace(Mesg, "#LastName#", LastNm), "#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("E22:H30")
            Sheet2.Range("G23").Value = Replace(Replace(Replace(Replace(Replace(Replace(Mesg, "#LastName#", LastNm), "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
            Sheet2.Range("G50").Value = Replace(Replace(Replace(Replace(Replace(Replace(Mesg, "#LastName#", LastNm), "#FirstName#", FirstNm), "#LastApptDt#", LastApptDt), "#BirthDate#", Format(BdDate, "mmmm dd")), "#LastApptText#", LastApptText), "#Problem#", Problem)
            Fname = ThisWorkbook.Path & "\Resim.PNG"
        
            PicRng.CopyPicture
            
            Set chartpic = Sheet2.ChartObjects.Add(0, 0, PicRng.Width * ZoomLev, PicRng.Height * ZoomLev)
            chartpic.Activate
            chartpic.Chart.Paste
            chartpic.Chart.Export Fname, "PNG"
            chartpic.Delete
    
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
    
            With OutMail
                .SentOnBehalfOfName = ""
                .To = Sheet1.Range("N" & CustRow).Value
                .BCC = ""
                .Subject = Subj
                .Attachments.Add Fname
                .HTMLBody = "<html><img src=""Resim.png""></html>" & "</Font>" & .HTMLBody
                .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
         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
ActiveWorkbook.Save
'Application.Quit
End Sub