'Attribute VB_Name = "McRitchie_MakeHTML_link"
Option Explicit
'Designed for personal use to obtain one of
'   href for Google Groups form  message-id line
'   news: ...   from same message-id line
'   gather together a link that split to multiple lines
'     and may have message rely character (>> as well.
'The icon I use on my Excel toolbar is an [H] with turquoise background
'Mentioned in http://www.mvps.org/dmcritchie/excel/...
'  barhopper.htm, buildtoc.htm, copyvba.htm, excel.htm, navigation.htm, toolbars.htm,
'  and in xlnews.htm which has related material.
'Content of this macro was former in buildtoc.txt and is now found in
'  http://www.mvps.org/dmcritchie/excel/code/makehtml_link.txt
 

Sub MakeHTML_Link()
' David McRitchie 2001-03-22  HTML links
' Dana DeLouis 2001-03-19 misc, using an
' Idea From: Chip Pearson
'  http://www.cpearson.com/excel/clipboar.htm
'= = = = = = = = =
' VBA Lib.Ref.: Microsoft Forms 2.0 object lib.
' Excel 2000 due to Replace() Function.
'= = = = = = = = =
'The following might become related to this
'  http://www.screaminet.com/~tswirsky/transurl.htm#DLArea
' TransURL - URL Translation Utility
'= = = = = = = = =
  Dim MyDataObj As New DataObject
  MyDataObj.GetFromClipboard
  Dim slnk As String, pLnk As String
  Dim hLnk As String, vLnk As String
 ' MsgBox pLnk
  Dim Skip3 As String
  Skip3 = vbCr & vbCr & vbCr
  slnk = MyDataObj.GetText
 ' sLnk = Replace(MyDataObj.GetText, _
     vbCr, vbNullString)
 ' MyDataObj.SetText ""
 ' On Error Resume Next
 ' MyDataObj.PutInClipboard  'Clear Clipboard
 ' On Error GoTo 0
  slnk = Replace(slnk, vbCr, vbNullString)
  slnk = Replace(slnk, vbLf, vbNullString)
  slnk = Replace(slnk, vbLf, vbNullString)
  slnk = Replace(slnk, ">", vbNullString)
  slnk = Replace(slnk, "<", vbNullString)
  slnk = Replace(slnk, " ", vbNullString)
  slnk = Replace(slnk, Chr(160), vbNullString)
  slnk = Replace(slnk, "Message-ID:", "news:")
  slnk = Replace(slnk, "References:", "news:")
  If LCase(Left(slnk, 1)) = "q" Then
     pLnk = MSKBQ(slnk)
     If pLnk <> slnk Then
        pLnk = "<a href=""" & pLnk & """>" & slnk & " -- </a>"
        GoTo Both_ready
     End If
  End If
  If LCase(Left(slnk, 7)) = "http://" Then GoTo ready
  If LCase(Left(slnk, 5)) = "news:" Then
    slnk = Mid(slnk, 6, Len(slnk) - 5)
    GoTo Google_Ready
  ElseIf Left(slnk, 1) = "<" Then
    If Right(slnk, 1) = ">" Then
       slnk = Mid(slnk, 2, Len(slnk) - 2)
       GoTo Google_Ready
    Else
       slnk = Mid(slnk, 2, Len(slnk) - 1)
       GoTo Google_Ready
    End If
  ElseIf InStr(1, slnk, "@") And Mid(slnk, Len(slnk) - 3, 1) = "." Then
    slnk = "mailto:" & slnk
  ElseIf InStr(1, slnk, "@") Then
    GoTo Google_Ready
  Else
    slnk = "http://" & slnk
  End If
  GoTo ready
Google_Ready:
  slnk = Replace(slnk, "...", vbNullString)
  vLnk = Replace(Replace(Replace(slnk, "#", "%23"), "$", "%24"), "@", "%40")
  pLnk = "http://groups.google.com/groups" & _
      "?threadm=" & _
      Replace(Replace(Replace(slnk, "#", "%23"), "$", "%24"), "@", "%40")  '-- use threadm=  instead of as_umsgid=
  pLnk = InputBox("Your Google URL for Message-ID:" _
      & vbCr & slnk & vbCr & vbCr & vbCr & vbCr _
      & "news://msnews.microsoft.com/" & vLnk & vbCr _
      & "converted to:" & vbCr & vLnk _
      & vbCr & "is:" & vbCr, "Google Ready:", pLnk)
  If pLnk = "" Then GoTo done
  hLnk = InputBox("Your newslink for Message-ID:" _
      & vbCr & slnk & vbCr & vbCr & vbCr & vbCr, , _
      "news://msnews.microsoft.com/" & vLnk)
  If hLnk = "" Then GoTo done
  hLnk = "<a href=""" & pLnk & """>news:" & slnk & "</a>"
  hLnk = InputBox("Your Google Reference for HTML is:" _
      & vbCr, "HTML Reference to Google", hLnk)
  If hLnk = "" Then GoTo done
  GoTo TakeTheLink
Both_ready:
  slnk = InputBox("Both references part1" & Skip3 & slnk, , slnk)
  If slnk = "" Then GoTo done
  pLnk = InputBox("Both references part2" & Skip3 & pLnk, , pLnk)
  If pLnk = "" Then GoTo done
  GoTo TakeTheLink
ready:
  slnk = InputBox("reference inside only" & Skip3 & slnk, , slnk)
  If slnk = "" Then GoTo done
  pLnk = "<A href=""" & slnk & """>" & slnk & "</a>"
  pLnk = InputBox("reference full hyperlink" & Skip3 & pLnk, , pLnk)
  If pLnk = "" Then GoTo done
TakeTheLink:
  If LCase(Left(slnk, 7)) = "mailto:" Then GoTo done
  On Error GoTo failure
  MyDataObj.SetText pLnk
  On Error Resume Next
  MyDataObj.PutInClipboard
  If Err.number <> 0 Then GoTo failure
  vLnk = MyDataObj.GetText
  If Err.number <> 0 Or vLnk <> pLnk Then
    pLnk = InputBox("mission control, we've " _
    & "lost the paste: " & vLnk & Chr(13) & pLnk, "Reference", pLnk)
  End If
  Set MyDataObj = Nothing
  On Error GoTo failure
  ActiveWorkbook.FollowHyperlink _
     Address:=slnk, NewWindow:=True
  'Can you find the error, if you don't actually have a link???
  MsgBox "according to Excel VBA you should have taken a link"
done:
  Beep
  Exit Sub
failure:
  On Error GoTo 0
  slnk = InputBox("Failed to get to link, please extract your link" _
     & "from here: " & vLnk & Chr(13) & pLnk, "Reference", slnk)
End Sub