VBA Create Email Links

[EvonS]

So the table below spans columns A-G

Situation	Date	Originating Agency	Lead	Assisting	Summary	Email List
1	Jan 1	TCHC	ODSP	TPS	Summary goes here	emai1@email.com
2	Jan 1	TESS	EMS	TCHC	Summary goes here	emails@emails.com

<tbody>
</tbody>

I have a button that creates email links in column H containing the info in each line of the table so that I can send an email to the people in the email list. I accomplish this, using this code

Sub insertVeryLongHyperlinkv2()


    Dim curCell As Range
    Dim longHyperlink As Variant
    Dim x As Integer
    Dim situation As Variant
    Dim emails As Variant
    Dim tdate As Integer
    Dim sdate As Integer
    Dim EmailBody As String


    x = 2
    
    Do
     
            situation = Cells(x, 1)
            emails = Cells(x, 7)
            EmailBody = "&body=Please use this email thread to communicate situation updates and next steps." & "%0A%0A" & "Confidential identifying information should be sent to those requiring the information in a separate email or via other means" & "%0A%0A" & "Date: " & Cells(x, 2) & "%0A%0A" & "Originating Agency: " & Cells(x, 3) & "%0A%0A" & "Lead Agency: " & Cells(x, 4) & "%0A%0A" & "Assisting Agencies: " & Cells(x, 5) & "%0A%0A" & "Situation Information: " & Cells(x, 6)
            Set curCell = Range("H" & x) ' or use any cell-reference
            longHyperlink = "mailto:" & emails & [H1] & "?subject=" & situation & " Thread" & EmailBody ' Or a Cell reference like [C1]
        
            curCell.Hyperlinks.Add Anchor:=curCell, _
                            Address:=longHyperlink, _
                            SubAddress:="", _
                            ScreenTip:=" - Click here to create email thread", _
                            TextToDisplay:="Create " & situation & " Email Thread"
      
      
            x = x + 1
    Loop Until Cells(x, 7) = 0




End Sub

The code creates the first link just fine but gives me a "Run-time error '1004' Application or object-defined error" error before it creates the second link. Debug highlights this entire section:

curCell.Hyperlinks.Add Anchor:=curCell, _
                            Address:=longHyperlink, _
                            SubAddress:="", _
                            ScreenTip:=" - Click here to create email thread", _
                            TextToDisplay:="Create " & situation & " Email Thread"

Debug also has an arrow at the "TextToDisplay:" line.

Your help would really be appreciated.


Thanks,

Evon

 

[Kenneth Hobson]

ActiveSheet.Hyperlinks.Add Anchor:=curCell, Address:=longHyperlink, _
   SubAddress:="", ScreenTip:=" - Click here to create email thread", _
    TextToDisplay:="Create " & situation & " Email Thread"

 

[EvonS]

Thanks for the reply. That code yields the exact same error.

 

[Kenneth Hobson]

It ran ok for me using your sample data. Maybe you had some locked cells?

Sub insertVeryLongHyperlinkv2()
  Dim curCell As Range
  Dim longHyperlink As String
  Dim x As Long
  Dim situation As Variant
  Dim emails As Variant
  'Dim tdate As Integer
  'Dim sdate As Integer
  Dim EmailBody As String

  x = 2
    
  Do
    situation = Cells(x, 1)
    emails = Cells(x, "G")  'Cells(x, 7)
    EmailBody = "&body=Please use this email thread to communicate situation updates and next steps." & _
      "%0A%0A" & "Confidential identifying information should be sent to those requiring the " & _
      "information in a separate email or via other means" & "%0A%0A" & "Date: " & Cells(x, 2) & _
      "%0A%0A" & "Originating Agency: " & Cells(x, 3) & "%0A%0A" & "Lead Agency: " & Cells(x, 4) & _
      "%0A%0A" & "Assisting Agencies: " & Cells(x, 5) & "%0A%0A" & "Situation Information: " & Cells(x, 6)
    Set curCell = Range("H" & x) ' or use any cell-reference
    longHyperlink = "mailto:" & emails & [H1] & "?subject=" & situation & " Thread" & EmailBody ' Or a Cell reference like [C1]
  
    curCell.Hyperlinks.Add Anchor:=curCell, _
      Address:=longHyperlink, _
      SubAddress:="", _
      ScreenTip:=" - Click here to create email thread", _
      TextToDisplay:="Create " & situation & " Email Thread"
  
    x = x + 1
  Loop Until Cells(x, 7) = 0
End Sub

 

[EvonS]

Thanks for taking the time to help me. There are no locked cells in my sheet. I've even tried changing where the links are created but the same thing happens. Do you have any other troubleshooting tips?

 

[Kenneth Hobson]

I guess something is going on that I don't see. You can try my example. https://www.dropbox.com/s/s99urn1wzrstxz8/1081492-vba-create-email-links.xlsm?dl=0

 

[EvonS]

So I used your code and I get the same error in the same place. I guess there's something up with my sheet but I have no idea what. Any suggestions?

 

[EvonS]

So I figured out the issue. When I use the code l my actual worksheet, an error occurs whenever it tries to create an email that has too many characters. Thanks for the help.