Тестирование полезных кодов и примеров

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub Djek() 'одна страница
Dim Lex(1 To 10000) As String, s1$, ii&, s$
'Путь по которому сохраняем скачанную страницу
s1 = Environ("temp") & "\Temp_2.log"
'URL страницы
s = "http://nato-ukr.narod.ru"
'загружаем страницу
URLDownloadToFile 0, s, s1, 0, 0
    fi% = FreeFile
    'удаляем тэги
    Open s1 For Binary Access Read As #fi%
      LF& = LOF(fi%)
      Buf$ = Space$(LF&)
      Get #fi%, , Buf$
    Close #fi%
    Parse Buf$, Lex$, n%
    For i% = 1 To n%
      'выводим строки длинной более трёх символов .  
      If Len(Lex(i%)) > 3 Then
        ii = ii + 1
        'выводим в окно отладки
        Debug.Print Lex(i%)
      End If
    Next i%
Kill s1
End Sub
 
Sub Parse(Buf As String, Lex() As String, ptr As Integer)
'функция очистки от тэгов написаная уважаемым Catstail
Tmp$ = ""
ptr = 0
For i& = 1 To Len(Buf)
  s$ = Mid$(Buf, i&, 1)
  Select Case (s$)
  Case Chr$(10), Chr$(13)
    Case ">"
      Tmp$ = Trim$(Tmp$)
      If (Left$(Tmp$, 1) <> "<") And _
         (Left$(Tmp$, 1) <> "/") And _
         (Left$(Tmp$, 1) <> ">") And _
         Len(Tmp$) > 0 Then
         ptr% = ptr% + 1
         Lex(ptr%) = Tmp$
      End If
      Tmp$ = ""
    Case "<"
      Tmp$ = Trim$(Tmp$)
      If (Left$(Tmp$, 1) <> "<") And _
         (Left$(Tmp$, 1) <> "/") And _
         (Left$(Tmp$, 1) <> ">") And _
         Len(Tmp$) > 0 Then
         ptr% = ptr% + 1
         Lex(ptr%) = Tmp$
      End If
      Tmp$ = "<"
    Case Else
      Tmp$ = Tmp$ + s$
  End Select
Next i&
End Sub

Private Function I_PI()
Dim s, ss$, s1$, i&, sx$, ii&, sa$
s1 = Environ("temp") & "\Aut_22.txt"
s = "http://www.softholm.com/services/address_ip.php"
URLDownloadToFile 0, s, s1, 0, 0
ss = "Ваш IP адрес: <b>"
Open s1 For Input As #1
  While Not EOF(1)
    Line Input #1, s
    If InStr(s, ss) > 0 Then
      i = InStr(s, ss) + Len(ss)
      ii = i
      Do
        sa = Mid(s, ii, 1)
        ii = ii + 1
        sx = sx & sa
        Debug.Print i
      Loop Until sa = "<"
      sx = Mid(sx, 1, Len(sx) - 1)
      GoTo xren  
    End If 
  Wend
xren:
Close #1
Kill s1
msgbox sx
I_PI = sx
End Function

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
    Sub main()
       s = I_PI
   End Sub 
 
   Private Function I_PI()
     Dim s, ss$, s1$, i&, sx$, ii&, sa$
      s1 = Environ("temp") & "\Aut_22.txt"
      s = "http://www.softholm.com/services/address_ip.php"
      URLDownloadToFile 0, s, s1, 0, 0
      ss = "Ваш IP адрес: <b>"
       Open s1 For Input As #1
         While Not EOF(1)
           Line Input #1, s
           If InStr(s, ss) > 0 Then
             i = InStr(s, ss) + Len(ss)
             ii = i
               Do
                sa = Mid(s, ii, 1)
                ii = ii + 1
                sx = sx & sa
               Loop Until sa = "<"
             sx = Mid(sx, 1, Len(sx) - 1)
             GoTo xren
           End If
        Wend
xren:
      Close #1
      Kill s1
      MsgBox sx
        ' Копируем Ваш IP адрес в буфер обмена
         With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
           .SetText sx
           .PutInClipboard
        End With
 
      I_PI = sx
   End Function