Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/checkl1g/checklin.frm

Visual Basic Form | 1998-06-30 | 5.1 KB | 178 lines

VERSION 5.00
Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   5820
   ClientTop       =   8445
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   Begin VB.TextBox Text1
      Height          =   1095
      Left            =   120
      MultiLine       =   -1  'True
      TabIndex        =   2
      Text            =   "checklinks.frx":0000
      Top             =   120
      Width           =   3255
   End
   Begin VB.CommandButton Command1
      Caption         =   "Quit"
      Height          =   495
      Index           =   1
      Left            =   3480
      TabIndex        =   1
      Top             =   2640
      Width           =   1095
   End
   Begin VB.CommandButton Command1
      Caption         =   "Start"
      Height          =   495
      Index           =   0
      Left            =   3480
      TabIndex        =   0
      Top             =   1920
      Width           =   1095
   End
   Begin InetCtlsObjects.Inet Inet1
      Left            =   3840
      Top             =   120
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      RequestTimeout  =   120
   End
   Begin VB.Label Label4
      Caption         =   "Label4"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   2880
      Width           =   2895
   End
   Begin VB.Label Label3
      Caption         =   "Label3"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   2400
      Width           =   2775
   End
   Begin VB.Label Label2
      Caption         =   "Label2"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   1920
      Width           =   2655
   End
   Begin VB.Label Label1
      Caption         =   "Label1"
      Height          =   255
      Left            =   120
      TabIndex        =   3
      Top             =   1440
      Width           =   2415
   End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Put the full name and path to your file here.
Const FILENAME = "c:\documents\stamps\links.xls"
Dim XLObj As Excel.Application
Private Sub Command1_Click(Index As Integer)
Select Case Index
    Case 0 'Start
        Command1(0).Enabled = False
        Call CheckLinks
        Command1(0).Enabled = True
    Case 1 ' Quit
        End
End Select
End Sub
Private Sub Form_Load()
' Create the Excel object and open the worksheet.
Set XLObj = CreateObject("Excel.Application")
XLObj.Workbooks.Open FILENAME
Inet1.Protocol = icHTTP
End Sub
Public Sub CheckLinks()
Dim row As Integer, url As String
Dim buf As String, msg As String, fnf As Integer
Dim snf As Integer, tout As Integer, ok As Integer
On Error Resume Next
' Make row equal to the Worksheet row where
' your data starts.
row = 4
tout = 0
fnf = 0
ok = 0
snf = 0
' Minimize the form.
Form1.WindowState = 1
    ' I keep URLs in column 3 (C) of the worksheet.
    url = XLObj.Cells(row, 3)
    ' If it's empty we are done.
    If url = "" Then Exit Do
    ' Try to open the URL.
    Text1.Text = Inet1.OpenURL(url)
    DoEvents
    ' If the URL returned any text, put the
    ' first 50 characters in a buffer. Error
    ' messages will be found here.
    If Len(Text1.Text) > 50 Then
        buf = Left(Text1.Text, 50)
    Else
        buf = Text1.Text
    End If
    ' Catch a time out error.
    If Err = 35761 Then
        msg = "Timed out"
        tout = tout + 1
        Err.Clear
    ' If nothing is returned it usually means
    ' that the server was not found.
    ElseIf Text1.Text = "" Then
        msg = "Server not found"
        snf = snf + 1
    ' If error 404 is returned from the URL
    ' it means the server was found but
    ' the requested file was not present.
    ElseIf InStr(1, buf, "404") Then
        msg = "File not found"
        fnf = fnf + 1
    ' Otherwise the link is OK.
    Else
        msg = "OK"
        ok = ok + 1
    End If
    ' Put the result in column 5 of the worksheet.
    XLObj.Cells(row, 5) = msg
    ' Move to the next row.
    row = row + 1
    ' Display current status on form.
    Form1.Caption = ok + fnf + snf + tout
    Label1.Caption = "OK: " & ok
    Label2.Caption = "File not found: " & fnf
    Label3.Caption = "Server not found: " & snf
    Label4.Caption = "Timed out: " & tout
Loop While True
' When all links checked, restore the form.
Form1.WindowState = 0
' Close the worksheet.
XLObj.Workbooks.Close
' Delete the object.
Set XLObj = Nothing
' Display a summary of results.
buf = "OK: " & ok & vbCrLf
buf = buf & "Server not found: " & snf & vbCrLf
buf = buf + "File not found: " & fnf & vbCrLf
buf = buf & "Timed out: " & tout
MsgBox (buf)
End Sub