CD/PC Actual Thematic 25: Programming/pc_actual_25.iso/Delphi/PolarDraw/data1.cab/Samples/Visual_Basic/AnalizeWebSite/AnalizeWebSite.frm

Visual Basic Form | 2001-08-31 | 12.3 KB | 362 lines

VERSION 5.00
Object = "{52DE3A21-0A3F-11D4-B9D2-008048FD54E6}#2.0#0"; "POLARDraw20.ocx"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmAnalyseWeb
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Analyse Web"
   ClientHeight    =   8760
   ClientLeft      =   150
   ClientTop       =   435
   ClientWidth     =   10695
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   8760
   ScaleWidth      =   10695
   Begin ComctlLib.Slider sldZoom
      Height          =   360
      Left            =   0
      TabIndex        =   7
      Top             =   8250
      Width           =   2355
      _ExtentX        =   4154
      _ExtentY        =   635
      _Version        =   327682
      Min             =   10
      Max             =   500
      SelStart        =   10
      TickStyle       =   3
      Value           =   10
   End
   Begin VB.DirListBox Dir1
      Height          =   2340
      Left            =   15
      TabIndex        =   3
      Top             =   2520
      Width           =   2055
   End
   Begin VB.FileListBox File1
      Height          =   2820
      Left            =   15
      Pattern         =   "*.htm"
      TabIndex        =   2
      Top             =   4905
      Width           =   2085
   End
   Begin VB.DriveListBox Drive1
      Height          =   315
      Left            =   15
      TabIndex        =   1
      Top             =   2190
      Width           =   2055
   End
   Begin POLARDRAW20Lib.POLARDraw POLARDraw1
      Height          =   8655
      Left            =   2445
      TabIndex        =   0
      Top             =   30
      Width           =   8205
      _Version        =   131072
      _ExtentX        =   14473
      _ExtentY        =   15266
      _StockProps     =   224
      Appearance      =   1
      PaperShadowColor=   0
      PaperOutlinecolor=   22899756
      CurrentShapeType=   10000
      DrawPaper       =   0   'False
      DrawPaperOutline=   -1  'True
      DrawPaperShadow =   -1  'True
      PaperShadowOffset=   0
      ViewportOriginX =   22899756
      ViewportOriginY =   22873116
      PageOriginX     =   1
      PageOriginY     =   82384101
      HorizontalGrid  =   567
      VerticalGrid    =   567
      ShowVerticalRuler=   0   'False
      ShowHorizontalRuler=   0   'False
      SelectionCount  =   22740992
      ShapeCount      =   22742704
      MeasurementUnits=   2
      RulerMeasurementUnits=   2
      CanvasWidth     =   536873485
      CanvasHeight    =   0
      AllowSelect     =   0   'False
      AllowRotate     =   0   'False
      AllowDelete     =   0   'False
      AllowResize     =   0   'False
      AllowMove       =   0   'False
      AllowEditPoints =   0   'False
      AllowDragSelect =   0   'False
      ShowSelection   =   0   'False
      AllowWheel      =   0   'False
   End
   Begin VB.Label Label2
      Caption         =   "Click left mouse button to follow the link, or the right mouse button just to see the location to follow"
      Height          =   825
      Left            =   45
      TabIndex        =   6
      Top             =   1140
      Width           =   2265
   End
   Begin VB.Label lblZoom
      Caption         =   "Label2"
      Height          =   315
      Left            =   0
      TabIndex        =   5
      Top             =   7875
      Width           =   2220
   End
   Begin VB.Label Label1
      Caption         =   "Choose the HTML page. Polar Draw will show you all links this page contains."
      Height          =   750
      Left            =   60
      TabIndex        =   4
      Top             =   285
      Width           =   2295
   End
   Begin VB.Menu mnuPopup
      Caption         =   ""
      Visible         =   0   'False
      Begin VB.Menu mnuAddressInfo
         Caption         =   ""
      End
   End
Attribute VB_Name = "frmAnalyseWeb"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim pd_shapes As POLARDRAW20Lib.Shapes
Dim pd_page As POLARDRAW20Lib.Page
Dim pd_shape0 As POLARDRAW20Lib.Shape
Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
End Sub
Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub
Private Sub File1_Click()
'When user chooses the file, Polar Draw dispalys that file as a shape and
'creates a diagram showing all references to other pages that this HTML
'page contains
    Dim nameLink As String
    nameLink = File1.FileName
    POLARDraw1.EnableRendering = False
    pd_shapes.Delete
    Dim pd_hyper As POLARDRAW20Lib.Hyperlink
    Set pd_shape0 = pd_shapes.Add(polRoundRectangle, 0, 0, 30, 8)
    With pd_shape0
      .Fill.Type = polSolidColor
      .Fill.Color = RGB(224, 82, 56)
      .Line.Color = .Fill.Color
      .IsFilled = True
    End With
    Set pd_hyper = pd_shape0.AddHyperlink
    With pd_hyper
        .ShowHandCursor = True

        If Dir1.Path = "C:\" Or Dir1.Path = "c:\" Then
          POLARDraw1.HyperlinkBase = Dir1.Path
          .Address = Dir1.Path + File1.FileName
        Else
          POLARDraw1.HyperlinkBase = Dir1.Path + "\"
          .Address = Dir1.Path + "\" + File1.FileName
        End If
    End With
    Set_Font (pd_shape0.ID)
    pd_shape0.Text.Plain = nameLink
    List
    pd_shapes.SelectAll
    POLARDraw1.ActiveWindow.FitTo polFitToSelection
    POLARDraw1.Zoom = 100
    RefreshZoomSlider
    POLARDraw1.EnableRendering = True
    POLARDraw1.Render
    Set pd_hyper = Nothing
End Sub
Private Sub Form_Load()
    Set pd_shapes = POLARDraw1.ActivePage.Shapes
    POLARDraw1.ActiveWindow.CenterPage
    POLARDraw1.MeasurementUnits = polUnitsMilimeter
    RefreshZoomSlider
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Set pd_shapes = Nothing
    Set pd_page = Nothing
    Set pd_shape0 = Nothing
End Sub
Private Sub POLARDraw1_HyperlinkClicked(ByVal lShapeID As Long, ByVal nButton As Integer, ByVal nMask As Integer)
    If pd_shapes.ItemFromID(lShapeID).Hyperlink Is Nothing Then MsgBox "Error: Not a hyperlink!!!"
    If pd_shapes.ItemFromID(lShapeID).IsLink = True Then Exit Sub
    Select Case nButton
      Case vbRightButton
         'just show the location
         mnuAddressInfo.Caption = POLARDraw1.HyperlinkBase + pd_shapes.ItemFromID(lShapeID).Hyperlink.Address
         Me.PopupMenu mnuPopup

      Case vbLeftButton
         'follow hyperlink
         With pd_shapes.ItemFromID(lShapeID)
            .Hyperlink.Follow
            'formatting to 'visited' color
            .Fill.Color = RGB(244, 155, 173)
            .Line.Color = .Fill.Color
         End With
   End Select
End Sub
Private Sub List()
'This function searches through the main shape, findes
'references to other pages and displays them as shapes
If pd_shape0.Hyperlink Is Nothing Then Exit Sub
Dim pathHtml, newLink As String
Dim tsLine As String
Dim numLine, numEndAHref As Integer
Dim numLink, recID As Long
Dim numAHref As Variant
Const endLink = ">"
Const beginLink = "a href"
Dim Dist As Long  'distance between shapes
Dist = pd_shape0.Height / 4
Dim lLeft As Long, lRight As Long, lTop As Long, lBottom As Long
Dim lSgn As Integer
lSgn = 1
numLink = 0
pathHtml = pd_shape0.Hyperlink.Address
Dim fso As New FileSystemObject
Dim theFile As TextStream
'creating FS object - HTML file that will be searched
Set fso = CreateObject("Scripting.FileSystemObject")
Set theFile = fso.OpenTextFile(pathHtml, ForReading, False)
Dim lWarningsCount As Long
lWarningsCount = 0
'MergeStrings flag will be used to merge previous and next line
'in case the link <a href = ".....">....</a> wasn't completed in one line
Dim tempStr As String
Dim MergeStrings As Boolean
tempStr = ""
MergeStrings = False
Dim counter As Long
counter = 0
Do While theFile.AtEndOfStream <> True
'we are taking just one line and search through it
    tsLine = theFile.ReadLine
    If MergeStrings Then tsLine = tsLine + tempStr
    numAHref = InStr(1, tsLine, beginLink, vbTextCompare)
    While numAHref <> 0
      'search through one line until any reference to another page is found
      Dim posLinkStart As Long
      posLinkStart = 0
      posLinkStart = InStr(numAHref, tsLine, "=", vbTextCompare) + 1

      If posLinkStart < numAHref Then
         posLinkStart = numAHref
      End If

      numEndAHref = InStr(posLinkStart, tsLine, endLink, vbTextCompare) - 1

      If numEndAHref = -1 Then
         'in case that line doesn't contain whole link
         tempStr = Mid(tsLine, numAHref)
         MergeStrings = True
         numAHref = 0


      Else
         newLink = Mid$(tsLine, posLinkStart, numEndAHref - posLinkStart)
         Dim lWidth As Long
         lWidth = Calculate(newLink)
         MergeStrings = False
         tempStr = ""

         counter = counter + 1
         lSgn = -lSgn
         lLeft = pd_shape0.Right + 4 * Dist
         lRight = lLeft + lWidth
         lTop = pd_shape0.Top + lSgn * ((counter / 2) * (pd_shape0.Height + Dist))
         lBottom = lTop + pd_shape0.Height

         Rectangle newLink, lLeft, lTop, lRight, lBottom
         tsLine = Mid(tsLine, numEndAHref)
         numAHref = InStr(1, tsLine, beginLink, vbTextCompare)

         lWarningsCount = lWarningsCount + 1
         If lWarningsCount > 19 Then
            POLARDraw1.EnableRendering = True
            POLARDraw1.Render
            POLARDraw1.EnableRendering = False

            If MsgBox("There are more than " + CStr(counter) + " links on this page! If you want to continue, please press OK.", vbOKCancel) = vbOK Then
               lWarningsCount = 0
            Else
               Exit Do
            End If
         End If
      End If
    Wend
 Loop
End Sub
Private Sub Set_Font(lShapeID As Long)
   Dim fnt As POLARDRAW20Lib.Font
   Set fnt = pd_shapes.ItemFromID(lShapeID).Text.Font
   With fnt
       .Size = 8
       .Bold = False
       .Underline = True
       .Name = "Arial"
   End With
   Set fnt = Nothing
End Sub
Private Sub Rectangle(Link As String, Left As Long, ByVal Top As Long, Right As Long, ByVal Bottom As Long)
 'This Sub creates new shapes which represent reference to other shapes
   Dim pd_shape1 As POLARDRAW20Lib.Shape  'new shape
   Dim pd_shape_line As POLARDRAW20Lib.Shape 'link between shape0 and others
   Dim pd_hyper As POLARDRAW20Lib.Hyperlink  'hyperlink of the new shape
   Set pd_shape1 = pd_shapes.Add(polRoundRectangle, Left, Top, Right, Bottom)
   Set_Font (pd_shape1.ID)
   pd_shape1.Text.Plain = Link
   Set pd_hyper = pd_shape1.AddHyperlink
   With pd_hyper
        .Address = Link
        .ShowHandCursor = True
   End With
   Select Case Link
    Case ""
        pd_shape1.Hyperlink.Address = Dir1.Path + "\" + Link
    Case "\"
        pd_shape1.Hyperlink.Address = Dir1.Path + Link
    Case "http"
        pd_shape1.Hyperlink.Address = Link
   End Select
   Set pd_shape_line = pd_shapes.AddConnection(pd_shape0.ID, pd_shape1.ID)
   With pd_shape_line.Connection

      .SourceConnect pd_shape0.ID, 4
      .DestinationConnect pd_shape1.ID, 8
   End With

   pd_shape_line.ZOrder polSendToBack
   RefreshZoomSlider
   Set pd_shape1 = Nothing
   Set pd_shape_line = Nothing
   Set pd_hyper = Nothing
End Sub
Private Sub sldZoom_Scroll()
    'Changing slider value affects directly to Zoom property, so changes can be visible to the user
    POLARDraw1.Zoom = sldZoom.Value
    lblZoom = "Zoom: " + CStr(POLARDraw1.Zoom) + "%"
End Sub
Private Sub RefreshZoomSlider()
   sldZoom.Value = POLARDraw1.Zoom
   lblZoom = "Zoom: " + CStr(POLARDraw1.Zoom) + "%"
End Sub
Private Function Calculate(ByRef str As String) As Long
'This function formats string that will appear in shape (link name)
'and returns width of the shape, depending on the string length
'(approcsimate 2mm per character)
    str = Replace(str, Chr(34), " ", 1, -1, vbTextCompare)
    str = Trim(str)
    Calculate = 2 * Len(str)
End Function