Imports System.Net
 
Public Class Form1
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Me.TextBox1.Text = "http://catcut.net/3adB "
    End Sub
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        On Error GoTo 1
        Dim WC As New WebClient
        Dim str As String
        Dim cc As String
        Dim i As Integer = 0
 
        'для теста http://catcut.net/Dj8B
 
        cc = Me.TextBox1.Text
        Me.TextBox1.Enabled = False
 
        WC.Proxy = New System.Net.WebProxy
        WC.Encoding = System.Text.Encoding.UTF8
        str = WC.DownloadString(cc)
        WC.Dispose()
 
        Dim rezult() As String = ParseAll(str, "var go_url = decodeURIComponent('", "'")
        'Threading.Thread.Sleep(15000) ' при слепе программа намертво висит пока не обработает все ссылки
        For i = 0 To UBound(rezult)
            rezult(i) = Replace(rezult(i), "%25", "%")
            rezult(i) = Replace(rezult(i), "%26", "&")
            rezult(i) = Replace(rezult(i), "%2A", "*")
            rezult(i) = Replace(rezult(i), "%2F", "/")
            rezult(i) = Replace(rezult(i), "%3A", ":")
            rezult(i) = Replace(rezult(i), "%3B", ";")
            rezult(i) = Replace(rezult(i), "%3D", "=")
            rezult(i) = Replace(rezult(i), "%3F", "?")
 
            MsgBox(rezult(i) & vbNewLine & "Если подождать 15 секунд и закрыть месагу," & vbNewLine & "то получим нашу короткую ссылку.")
 
            WC.Proxy = New System.Net.WebProxy
            WC.Encoding = System.Text.Encoding.UTF8
            rezult(i) = WC.DownloadString(rezult(i))
            WC.Dispose()
  
            rezult(i) = Replace(rezult(i), "%2F", "/")
            rezult(i) = Replace(rezult(i), "%3A", ":")
 
            MsgBox("Наш результат ↓" & vbNewLine & rezult(i))
        Next i
        Exit Sub
1:
        MsgBox(Err.Number & vbNewLine & Err.Description)
    End Sub

Public Function ParseAll(ByVal str As String, ByVal str1 As String, ByVal str2 As String) As String()
        Dim i As Integer = 0
        Dim len1 As Integer = str1.Length
        Dim len2 As Integer = str2.Length
        Dim rezult As New List(Of String)
        Do While i < str.Length
            Dim i1 As Integer = str.IndexOf(str1, i, StringComparison.OrdinalIgnoreCase)
            Dim i2 As Integer = str.IndexOf(str2, i1 + len1)
            If i1 = -1 OrElse i2 = -1 Then
                Exit Do
            End If
            rezult.Add(str.Substring(i1 + len1, i2 - (i1 + len1)))
            i = i2 + len2
        Loop
        Return rezult.ToArray()
    End Function