Programming Languages Suite/ProgLangD.iso/Bonus/lotus123rel9/approach/lotcss.lss

Text File | 1998-04-05 | 6.2 KB | 204 lines

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 TranslateEnviron (myKeyValue As String) As String

    ''We need this function for NT5 to find InternetExplorer 4.0 because it registers differently
    'than any other version/operating system combination.

    Dim pos As Integer
    Dim EnvVar As String
    Dim ValueEnvVar As String
    Dim exePos As Integer

    pos = Instr(1, myKeyValue, "%")
        exePos=Instr(1,myKeyValue,".exe",1)  'Must be prior to .exe!
    If ((pos > 0) And (pos < exePos)) Then
        'We've located an environmental variable which needs substitution

        'Remove the leading % from the string
        myKeyValue = Right$(myKeyValue, Len(myKeyValue) - pos)

        'Find the next % so we can extract the Environmental variable for translation
        pos = Instr(1, myKeyValue, "%")

        'Extract the Variable Name
        EnvVar = Left$(myKeyValue, pos - 1)

        'Translate the variable
        ValueEnvVar = Environ(EnvVar)

        'Reassemble the string with the translated value
        myKeyValue = """" & ValueEnvVar & Right$(myKeyValue, Len(myKeyValue) - pos)

    End If

    'Return the new value
    TranslateEnviron = myKeyValue

End Function


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))

    ReturnedKeyContents = TranslateEnviron(ReturnedKeyContents)

    GetKey = ReturnedKeyContents
End Function



Sub Main
    %Include "Inistrs.lss"
Dim URL As String
    URL$=" http://www.support.lotus.com"    'The URL to open

    ' ** 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

            '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

End Sub