Pegasus 5/Pegasus_Vol_5_CD2.iso/lotus/extras/dbases/surfnet.apr/SCRIPT/A007ApprGlobObj897.s

Null Bytes Alternating | 1996-09-13 | 16KB | 259 lines

'++LotusScript Development Environment:2:5:(Options):0:74
Option Public


'++LotusScript Development Environment:2:5:(Forward):0:1
Declare Sub CallGNN
Declare Function ReplaceStr (S As String, O As String, R As String) As String
Declare Sub Initialize
Declare Sub ParseNetscapeBookmark

'++LotusScript Development Environment:2:5:(Declarations):0:10
Declare Public Function GetPrivateProfileString Lib"Kernel" (Byval lpName As String, Byval lpKey As Any, Byval lpDefault As String, Byval lpReturn As String, Byval nSize As Integer, Byval lpFile As String) As Integer
Declare Public Function RegOpenKeyExA Lib "advapi32" Alias "RegOpenKeyExA" (Byval HKEY As Long,Byval lpszSubKey As String,Byval dwreserved As Integer,Byval samDesired As Long, keyresult As Long) As Long
Declare Public Function RegQueryValueExA Lib "advapi32" Alias "RegQueryValueExA" (Byval HKEY As Long,Byval lpszValueName As String,Byval dwreserved As Integer, lpdwtype As Long, Byval lpData As String, readbytes As Long) As Long
Declare Public Function RegCloseKey Lib "advapi32" Alias "RegCloseKey" (Byval HKEY As Long) As Long
Declare Public Function GetPrivateProfileStringA Lib "kernel32" Alias "GetPrivateProfileStringA"(Byval AppName As String,Byval KName As Any, Byval Def As String, Byval RStr As String, Byval nSize As Integer, Byval FName As String) As Integer

Dim strURL As String
Dim strPageTitle As String

Dim iMoreInfo As Integer   'Tracks 'more info' on the Found Set Report

'++LotusScript Development Environment:2:2:CallGNN:1:8
Sub CallGNN


    Dim happkey As Long
    Dim HKEY_LOCAL_MACHINE As Long
    Dim KEY_READ As Long
    Dim HKEY_CURRENT_USER As Long
    Dim HKEY_CLASSES_ROOT As Long
    Dim ValueType As Long
    Dim ReturnedKeyContents As String * 255
    Dim readbytes As Long
    Dim ReturnString As String * 255
    MaxBytes%=Len(ReturnString$)
    IniFileName$ = "Win.Ini"
    ReturnedKeycontents$=String$(255,Chr$(32))

    HKEY_CLASSES_ROOT= &H80000000
    HKEY_CURRENT_USER= &H80000001
    HKEY_LOCAL_MACHINE= &H80000002

    KEY_QUERY_VALUE=1
    KEY_ENUMERATE_SUBKEYS=8
    KEY_NOTIFY=16
    KEY_READ=KEY_QUERY_VALUE Or KEY_ENUMERATE_SUBKEYS Or KEY_NOTIFY

    KeyName$="http\shell\open\command"
    URL$= "http://"+currentview.body.url.text

    GNNStat = GetPrivateProfileStringA("GNNWorks","AppPath","NA",ReturnString$,MaxBytes%,IniFileName$)
    AppPath$=Left$(ReturnString$,GNNStat)

    If AppPath$="NA" Then ' did not find 16 bit GNN works
        ValueName$=""
        lstat=RegOpenKeyExA(HKEY_CLASSES_ROOT,KeyName$,0,KEY_READ,happkey)
        ReadBytes=255
        lstat=RegQueryValueExA(happkey,ValueName$,0,valueType, ReturnedKeyContents$,ReadBytes)
        regclosekey(happkey)
        If Trim$(ReturnedKeyContents$)="" Then
            Messagebox("Approach can't determine if a WWW browser is installed, script aborted.")
            Exit Sub
        End If
        BrowserPath$=Left$(ReturnedKeyContents$,ReadBytes-1)

        ' delete all command line params:
        ExePos=Instr(BrowserPath$,".exe")
        If ExePos<>0 Then
            BrowserPath$=Left$(BrowserPath$,ExePos+4)
        End If

        ' return path without leading quote, if there is one:
        QuotePos=Instr(BrowserPath$,Chr$(34))
        If QuotePos<>0 Then
            BrowserPath$=Mid$(BrowserPath$,QuotePos+1)
        End If
    Else
        ' found GNN Works
        BrowserPath$ = Left(AppPath$,GNNStat) & "\IW.EXE"
    End If

    LaunchPath$=BrowserPath$+" "+URL$
    Err=0
    On Error Resume Next
    stat = Shell(LaunchPath$, 1)
    On Error Goto 0
    If Err<>0 Then
        Messagebox "Error launching web browser, please check installation and try again.", MB_OK, "Error"
    End If
End Sub
'++LotusScript Development Environment:2:1:ReplaceStr:1:8
Function ReplaceStr (S As String, O As String, R As String) As String
' S is the input string, O is the old string, R is the replacement string
    If (S = "") Then
        ReplaceStr = ""
    Else
        n = Instr(S,O)
        While (n > 0)
            Mid(S,n) = R
            n = Instr(S,O)
        Wend
        ReplaceStr = S
    End If
End Function
'++LotusScript Development Environment:2:2:Initialize:1:10
Sub Initialize
    iMoreInfo = False
End Sub
'++LotusScript Development Environment:2:2:ParseNetscapeBookmark:1:8
Sub ParseNetscapeBookmark
    'Declarations
    Dim strNetPath As String
    Dim strBookmarkFile As String
    Dim strBookmarks As String
    Dim strType As String
    Dim strCrntHdr As String
    Dim strSurfnet As String
    Dim strTableName As String
    Dim strCrntURL As String
    Dim strCrntBkmrk As String
    Dim strMsg As String   'Messag for message box.

    Dim iFileId As Integer
    Dim rval As Integer   'Return value.
       'Flag (0=quit, 1=quit, 2=go)
    Dim iOK As Integer

    Dim lFileLen As Long

    Dim Con As New Connection
    Dim Qry As New Query
    Dim RS As New ResultSet

    'Array of bookmarks (Title, URL, Category)
    Dim aryBookmarks(10, 10, 10) As String

    'Initializations
    iOK = 0
    strMsg = "Incorrect directory or file doesn't exist, try again?"
    On Error Resume Next   'If error occurs, continue.

    Do Until (iOK <> 0)
        strNetPath = Inputbox("Enter the name of the Netscape directory.", "Netscape Directory", "C:\NETSCAPE", 150, 150)
        strBookmarkFile = strNetPath & "\BOOKMARK.HTM"
        strTemp = Dir(strBookmarkFile)  'List the file.
        If (strTemp = "") Then   'If the file doesn't exist...
            rval = 1   'Reset
            rval = Messagebox(strMsg , 1,  "Warning")
            If (rval = 1) Then
                iOK = 0
            Else
                iOK = 1
            End If
        Else
            iOK = 2
        End If
    Loop

    If (iOK = 2) Then
        lFileLen = Filelen(strBookmarkFile)
        iFileId = 1
        'Open the file.
        Open strBookmarkFile For Input Access Read As iFileId Len = lFileLen

        strType = "N"
        strTableName = CurrentDocument.Tables(0).FileName
        strSurfnet = CurrentDocument.Path & strTableName

        'Use the data object to enter records.
        If (Con.ConnectTo("dBASE IV")) Then
            Set Qry.Connection = Con
            Qry.Tablename = strSurfnet
            Set RS.Query = Qry
            If (RS.Execute = False) Then
                Messagebox "Couldn't access file for import."
            End If
        Else
            Messagebox "Couldn't access file for import."
        End If

        'Put the contents of the file in a variable.
        strBookmarks = Input$(lFileLen, iFileId)
        For i = 1 To lFileLen
            'Reset the header if the bookmark has none.
            If (Mid$(strBookmarks, i, 8) = "</DL><p>") Then
                strCrntHdr = ""
            End If

            'Find the header.
            If (Mid$(strBookmarks, i, 3) = "<H3") Then
                'We've found a header.
                strCrntHdr = ""
                'Now let's find the header name
                Do Until (Mid$(strBookmarks, i, 1) = ">")
                    i = i + 1
                Loop
                i = i+ 1   'Get next character.
                'Get the header and put in a variable.
                strCrntHdr = ""   'Reset variable.
                Do Until (Mid$(strBookmarks, i, 1) = "<")
                    strCrntHdr = strCrntHdr & Mid$(strBookmarks, i, 1)
                    i = i+ 1
                Loop

            'Find the bookmark
            Elseif (Mid$(strBookmarks, i, 2) = "<A") Then
            'We've found a bookmark
                strType = "B"
            'Now let's find the URL
                Do Until (Mid$(strBookmarks, i, 1) = """")
                    i = i + 1
                Loop
                i = i+ 1   'Get next character.

            'Get the URL and put in a variable.
                Do Until (Mid$(strBookmarks, i, 1) = """")
                    strCrntURL = strCrntURL & Mid$(strBookmarks, i, 1)
                    i = i+ 1
                Loop

                'delete all http;// prefix
                Dim HTTPPos As Integer
                HTTPPos = Instr(strCrntURL, "http://")
                If HTTPPos <> 0 Then
                    strCrntURL = Right$(strCrntURL, Len(strCrntURL) - 7)
                End If


            'Now let's find the bookmark name.
                Do Until (Mid$(strBookmarks, i, 1) = ">")
                    i = i + 1
                Loop
                i = i+ 1   'Get next character.
            'Get the bookmark name  and put in a variable.
                Do Until (Mid$(strBookmarks, i, 1) = "<")
                    strCrntBkmrk = strCrntBkmrk & Mid$(strBookmarks, i, 1)
                    i = i+ 1
                Loop

                If (Mid$(strBookmarks, i, 4) = "</A>") Then
                    'Now let's add the record to the file.
                    RS.AddRow
                    rval = RS.SetValue(2, strCrntBkmrk)
                    rval = RS.SetValue(1, strCrntURL)
                    rval = RS.SetValue(3, strCrntHdr)
                    RS.UpdateRow
                    strCrntURL = ""
                    strCrntBkmrk = ""
                End If
            End If
        Next
        Close(1)
        RS.Close
        Messagebox "Import complete.", MB_OK, "Import"
    End If

EndImport:
End Sub