PC World Komputer 1999 January/pcwk_01_1999_B.iso/Lotus123/FRENCH/LOTUS023.DSK/ICONS/INETSRCH.LSS

Text File | 1996-10-02 | 9.1 KB | 307 lines

'********************************************************
'*                            *
'*    Internet Search for 123                *
'*    Authored by Darcy Burner            *
'*    updated by Linda Sharar                *
'*                            *
'********************************************************



Option Public
'Option Declare

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


Function GetKey (myKey As String) As String

    Dim HKEY_LOCAL_MACHINE As Long
    Dim KEY_READ As Long
    Dim HKEY_CURRENT_USER As Long
    Dim HKEY_CLASSES_ROOT As Long
    Dim KEY_QUERY_VALUE As Integer
    Dim KEY_ENUMERATE_SUBKEYS As Integer
    Dim KEY_NOTIFY As Integer


    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

    Dim lstat As Long
    Dim KeyVal As Long
    Dim KeyReadBytes As Long
    Dim ValueType As Long
    Dim ValueName As String
    Dim ReturnedKeyContents As String * 255
    ReturnedKeyContents=String$(255,Chr$(32))

    'Open the registry and get the key address (myKey)
    lstat=RegOpenKeyExA(HKEY_CLASSES_ROOT,myKey,0,KEY_READ,KeyVal)
    KeyReadBytes = 255
    'Get the value of the key at that address (ReturnedKeyContents)
    lstat=RegQueryValueExA(KeyVal,ValueName,0,ValueType, _
    ReturnedKeyContents,KeyReadBytes)
    'Close the registry, thank you (you wouldn't want the keys to escape!)
    regclosekey(KeyVal)

    'Get rid of the extra characters in the keystring
    ReturnedKeyContents = Rtrim$(ReturnedKeyContents)
    ReturnedKeyContents = Left$(ReturnedKeyContents,(Len(ReturnedKeyContents)-1))

    GetKey = ReturnedKeyContents
End Function



Sub Main
    %Include "Inistrs.lss"

'****************************************************************
'*     The following section added by Linda Sharar        *
'*            on 10/2/96                 *
'****************************************************************

    On Error Goto RangeError

'****************************************************************
'*     Continue Function as written by Darcy Burner        *
'*                                 *
'****************************************************************

'Select current cell contents

    query$ = Selection.Cell(0,0,0).contents

    If query$ = "" Then
        Beep
        Messagebox NOTEXT, MB_OK, ERRSTR
        Exit Sub
    End If

'****************************************************************
'*     The following section added by Linda Sharar        *
'*            on 9/26/96                 *
'****************************************************************


'Set Variables for String Indicators
    singlequote$= "'"
    doublequote$= """"
    carat$= "^"

'Test to see if selected cell contains a text string
    If Instr(1,query$, singlequote$)=1 Then
        IsText="Yes"
    End If
    If Instr(1,query$, doublequote$)=1 Then
        IsText="Yes"
    End If
    If Instr(1,query$, carat$)=1 Then
        IsText="Yes"
    End If

'If cell does not contain text, give error and exit subroutine
    If IsText <> "Yes" Then
        Beep
        Messagebox NOTEXT, MB_OK, ERRSTR
        Exit Sub
    End If

'Assuming cell contains text, begin trimming and parsing string for query

    query$= Trim$(query$)
    Dim symbolposition As Integer
    Dim querylen As Integer

'First strip away any excess single quotation marks
    symbol$ = singlequote$
    symbolposition = Instr(1, query$, symbol$)
    While symbolposition <> 0
        querylen=Len(query$)
        leftquery$=Left(query$, symbolposition-1)
        rightquery$=Right(query$,querylen-symbolposition)
        query$= leftquery$+rightquery$
        symbolposition = Instr(1, query$, symbol$)
    Wend

'Strip away any excess carat marks
    symbol$ = carat$
    symbolposition = Instr(1, query$, symbol$)
    While symbolposition <> 0
        querylen=Len(query$)
        leftquery$=Left(query$, symbolposition-1)
        rightquery$=Right(query$,querylen-symbolposition)
        query$= leftquery$+rightquery$
        symbolposition = Instr(1, query$, symbol$)
    Wend

'Strip away any excess double quotation marks
    symbol$ = doublequote$
    symbolposition = Instr(1, query$, symbol$)
    While symbolposition <> 0
        querylen=Len(query$)
        leftquery$=Left(query$, symbolposition-1)
        rightquery$=Right(query$,querylen-symbolposition)
        query$= leftquery$+rightquery$
        symbolposition = Instr(1, query$, symbol$)
    Wend

'Strip away spaces on left and right
    query$= Trim$(query$)

'Locate Internal Spaces and replace with addition symbols
    contents$=query$
    firstspace$ = " "
    spaceposition = Instr(contents$, firstspace$)
    While spaceposition<>"0"
        Mid$(contents$, spaceposition, 1) = "+"
        oldspaceposition=spaceposition
        spaceposition = Instr(contents$, firstspace$)
        While spaceposition=oldspaceposition+1
            leftcontents$=Left(contents$, spaceposition-1)
            contentlen=Len(contents$)
            rightcontents$=Right(contents$,contentlen-spaceposition)
            contents$ = Leftcontents$+Rightcontents$
            spaceposition = Instr(contents$, firstspace$)
        Wend
    Wend
    query$=contents$


'****************************************************************
'*     Continue Function as written by Darcy Burner        *
'*                                 *
'****************************************************************

    Dim URL As String
    URL$ = "http://search.yahoo.com/bin/search?p="& query$

    ' ** Define the search key list **
    ' ********************************
    Dim strKeylist(3) As String
    strKeylist(0) = "http"    'http
    strKeylist(1) = "htmlfile"    'htmlfile
    strKeylist(2) = ".htm"    '.htm
    strKeylist(3) = ".html"    '.html

    ' ** Declare the variables needed **
    ' ****************************************
    Dim ReturnedKey As String * 255
    'Dim DDEAppKey As String
    'Dim DDETopicKey As String
    'Dim ReturnedDDEAppKey As String
    'Dim ReturnedDDETopicKey As String
    Dim strSKey As String
    Dim SeekKey As String
    Dim BrowserPath As String
    Dim LaunchPath As String
    Dim stat As Variant

    Dim QuotePos As Integer
    Dim ExePos As Integer


    ' ** Iterate through the list of keyvalues until a valid one is found **
    ' **********************************************************************
    Forall strPKey In strKeylist
        ReturnedKey = GetKey(strPKey)
        If ReturnedKey<>"" Then
            'We got something.  Were we looking for a file extension...?
            If Left$(strPKey, 1) = "." Then
                'Set the DDE command to nothing
                SeekKey = Trim$(ReturnedKey)
                'Strip out excess nulls
                While InStr(SeekKey, Chr$(0)) > 0
                    SeekKey=Left$(SeekKey, InStr(SeekKey, Chr$(0)) -1)
                Wend
            Else
                'We weren't looking for a file extension, so get DDE keys (to
                'send message to app if running) and command key (to launch app
                'if not already running)
                'DDEAppKey = strPKey+"\shell\open\ddeexec\Application"
                'DDETopicKey = strPKey+"\shell\open\ddeexec\Topic"
                'ReturnedDDEAppKey = GetKey (DDEAppKey)
                'ReturnedDDETopicKey = GetKey (DDETopicKey)
                SeekKey = strPKey
            End If
            'Get the app key pointed to
            strSKey= SeekKey+"\shell\open\command"
            'Get the browser path
            BrowserPath = GetKey (strSKey)
             'Delete all command line params:
            ExePos=Instr(1,BrowserPath,".exe",1)
            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)
                QuotePos=Instr(BrowserPath, CHR$(34))
                If QuotePos<>0 Then
                    Mid$(BrowserPath,QuotePos)=" "
                End If
            End If            'Create the command to send to the shell
            LaunchPath=BrowserPath+" "+URL
            Err=0
            On Error Resume Next

            ' ** Send the appropriate commands to the shell **
            ' *********************************************************
            'Send the command to application to change to a new URL
            '(Hah!  Wishful thinking, that I could send a DDE command from Script.  Oh well.)

            'Send the command to the shell to launch a new browser
            stat=Shell(LaunchPath, 1)
            'If you successfully launched, you're done
            If stat = 33 Then
                Exit Sub
            End If
            On Error Goto 0
        End If
    End Forall
    'None of the registry keys pointed to valid browsers, so send an error
    Msgbox NOBROWSER
    Exit Sub

'****************************************************************
'*     The following section added by Linda Sharar        *
'*            on 10/2/96                 *
'****************************************************************

'New Error control by Linda Sharar
    RangeError:
        Beep
        Messagebox NOTEXT, MB_OK, ERRSTR
    Exit Sub

End Sub