White Spam URL WhiteSpamUrl WhiteSpamUrl()
Code:Sub WhiteSpamUrl() ' White Spam URL WhiteSpamUrl WhiteSpamUrl() https://www.excelfox.com/forum/showthread.php/2348-String-text-in-Word-html-Passing-info-between-Word-and-Excel?p=21222&viewfull=1#post21222 https://www.excelfox.com/forum/showthread.php/2824-Tests-Copying-pasting-Cliipboard-issues?p=18376&viewfull=1#post18376 Dim ClipTxt As String: Let ClipTxt = "[url=https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA] [COLOR=white] htt[COLOR=white]p[/COLOR]s:/[COLOR=white]/w[/COLOR]ww.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA [/color] [/url]" & vbCr & vbLf Dim SelText As String Let SelText = Selection.Text Dim RwTxt() As String Let RwTxt() = Split(SelText, vbCr, -1, vbBinaryCompare) Dim RwCnt As Long For RwCnt = LBound(RwTxt()) To UBound(RwTxt()) Dim ClmTxt() As String Let ClmTxt() = Split(RwTxt(RwCnt), " ", -1, vbBinaryCompare) Dim ClmCnt As Long For ClmCnt = LBound(ClmTxt()) To UBound(ClmTxt()) If InStr(1, Trim(ClmTxt(ClmCnt)), "//www.", vbBinaryCompare) > 0 Then Dim URL As String, URL2 As String Let URL = Trim(ClmTxt(ClmCnt)) Let URL2 = Replace(URL, "http", "ht[color=white]tp[/color]", 1, 1, vbBinaryCompare) Let URL2 = Replace(URL2, "//www.", "/[color=white]/ww[/color]w.", 1, 1, vbBinaryCompare) Let ClipTxt = ClipTxt & "[url=" & URL & "] [color=white] " & URL2 & " [/color] [/url]" & vbCr & vbLf Else ' no url End If Next ClmCnt Next RwCnt Let ClipTxt = ClipTxt & "[url=https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA] [COLOR=white] htt[COLOR=white]p[/COLOR]s:/[COLOR=white]/w[/COLOR]ww.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA [/color] [/url]" ' Put the string in the clipboard With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' web.archive.org/web/20200124185244/http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/ .SetText ClipTxt .PutInClipboard End With End Sub




Reply With Quote
Bookmarks