简体   繁体   English

使用VBA在电子邮件的超链接内的单元格中插入文本

[英]Insert text from cell within Hyperlink in a email using VBA

I am fairly new to VBA and I am trying to understand how it really works. 我对VBA还是很陌生,我想了解它的工作原理。

So currently I have an excel sheet with items that have due dates.I was able to look online and send out emails to certain people with their respective due dates. 因此,目前我有一个Excel工作表,其中包含到期日的项目。我能够在线查找并向某些人发送电子邮件,并注明其到期日。 Each email has a link to the excel file thats on a network drive. 每封电子邮件都有指向网络驱动器上excel文件的链接。

However, now I am required to link to somewhere else where each item has a folder. 但是,现在我需要链接到每个项目都有一个文件夹的其他位置。 The trick to this is that there is a directory where each item is placed in this directory. 诀窍是在每个目录中都放置一个目录。 They are all within in 1 folder. 它们都在1个文件夹中。 The folders have the same name as in the text in the excel sheet. 这些文件夹与excel工作表中的文本具有相同的名称。

I was wondering if there is a way to take the text from the cell respective to each item and place it in the hyperlink? 我想知道是否有一种方法可以将文本从相应的单元格提取到每个项目并将其放在超链接中? So depending on the item and when its due. 因此,取决于项目及其到期时间。 The hyperlink will change every time so it goes to the specific folder. 超链接每次都会更改,因此会转到特定的文件夹。 Here is the example of the structure. 这是结构的示例。 Y:\\Main Directory\\Folder 1 and another one would be Y:\\Main Directory\\Folder 3. I placed the name of each folder next to each item within the excel sheet. Y:\\ Main Directory \\ Folder 1,另一个将是Y:\\ Main Directory \\ Folder3。我将每个文件夹的名称放在excel工作表中每个项目的旁边。 Also the column with the name of each folder is in column "B". 同样,每个文件夹的名称列也在“ B”列中。 How would I go about this? 我将如何处理? Thank you! 谢谢! Much appreciated! 非常感激!

Here is the code: 这是代码:

 Option Explicit



    Public Sub CheckAndSendMail()
     Dim lRow As Long
     Dim lstRow As Long
     Dim toDate As Date
     Dim toList As String
     Dim ccList As String
     Dim bccList As String
     Dim eSubject As String
     Dim EBody As String
     Dim vbCrLf As String





     Dim ws As Worksheet

     With Application
     .ScreenUpdating = True
     .EnableEvents = True
     .DisplayAlerts = True


     End With

     Set ws = Sheets(1)
     ws.Select

     lstRow = WorksheetFunction.Max(3, ws.Cells(Rows.Count, "R").End(xlUp).Row)

     For lRow = 3 To lstRow

     toDate = CDate(Cells(lRow, "R").Value)


     If Left(Cells(lRow, "R"), 4) <> "Mail" And toDate - Date <= 7 Then
     vbCrLf = "<br><br>"



     toList = Cells(lRow, "F") 'gets the recipient from col F
     eSubject = "Text " & Cells(lRow, "C") & " is due on " & Cells(lRow, "R").Value
        EBody = "<HTML><BODY>"
        EBody = EBody & "Dear " & Cells(lRow, "F").Value & vbCrLf
        EBody = EBody & "Text" & Cells(lRow, "C") & vbCrLf
        EBody = EBody & "Text" & vbCrLf
        EBody = EBody & "Link to the Document:"
        EBody = EBody & "<A href='Hyperlink to Document'>Description of Document </A>" & vbCrLf
        'Line below is where the hyperlink to the folder directory and the different folder names
        EBody = EBody & "Text" & "<A href= 'Link to folder Directory\Variable based on                text'>Description </A>"
        EBody = EBody & "</BODY></HTML>"




     MailData msgSubject:=eSubject, msgBody:=EBody, Sendto:=toList

     'Cells(lRow, "W").Value = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column W"


     End If
     Next lRow


     ActiveWorkbook.Save


     With Application
     .ScreenUpdating = True
     .EnableEvents = True
     .DisplayAlerts = True

     End With

     End Sub



     Function MailData(msgSubject As String, msgBody As String, Sendto As String, _
     Optional CCto As String, Optional BCCto As String, Optional fAttach As String)

     Dim app As Object, Itm As Variant
     Set app = CreateObject("Outlook.Application")
     Set Itm = app.CreateItem(0)
     With Itm
     .Subject = msgSubject
     .To = Sendto
     If Not IsMissing(CCto) Then .Cc = CCto
     If Len(Trim(BCCto)) > 0 Then
     .Bcc = BCCto
     End If
     .HTMLBody = msgBody
     .BodyFormat = 2 '1=Plain text, 2=HTML 3=RichText -- ISSUE: this does not keep HTML formatting -- converts all text
     'On Error Resume Next
     If Len(Trim(fAttach)) > 0 Then .Attachments.Add (fAttach) ' Must be complete path'and filename if you require an attachment to be included
     'Err.Clear
     'On Error GoTo 0
     .Save ' This property is used when you want to saves mail to the Concept folder
     .Display ' This property is used when you want to display before sending
     '.Send ' This property is used if you want to send without verification
     End With
     Set app = Nothing
     Set Itm = Nothing
     End Function 
"<A href=" & chr(34) & "J:\Main Directory\" & Range("B" & lRow).Value & chr(34) & ">Description of Document </A>"

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM