home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 October A / Pcwk10a98.iso / Lotus / LOTUS / FLG / INETSRCH.LSS < prev    next >
Text File  |  1996-10-02  |  7KB  |  223 lines
  1. Option Public
  2. 'Option Declare
  3.  
  4. 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
  5. Declare Public Function RegQueryValueExA Lib "advapi32" _
  6.     Alias "RegQueryValueExA" _
  7.     (Byval HKEY As Long,_
  8.     Byval lpszValueName As String,_
  9.     Byval dwreserved As Integer, _
  10.     lpdwtype As Long, _
  11.     Byval lpData As String, _
  12.     readbytes As Long) As Long
  13. Declare Public Function RegCloseKey Lib "advapi32" _
  14.     Alias "RegCloseKey" (Byval HKEY As Long) As Long
  15. Declare Public Function GetPrivateProfileStringA Lib "kernel32" _
  16.     Alias "GetPrivateProfileStringA"_
  17.     (Byval AppName As String,_
  18.     Byval KName As Any, _
  19.     Byval Def As String, _
  20.     Byval RStr As String, _
  21.     Byval nSize As Integer, _
  22.     Byval FName As String) As Integer
  23.  
  24.  
  25. Function GetKey (myKey As String) As String
  26.     
  27.     Dim HKEY_LOCAL_MACHINE As Long
  28.     Dim KEY_READ As Long
  29.     Dim HKEY_CURRENT_USER As Long
  30.     Dim HKEY_CLASSES_ROOT As Long
  31.     Dim KEY_QUERY_VALUE As Integer
  32.     Dim KEY_ENUMERATE_SUBKEYS As Integer
  33.     Dim KEY_NOTIFY As Integer
  34.     
  35.     
  36.     HKEY_CLASSES_ROOT= &H80000000
  37.     HKEY_CURRENT_USER= &H80000001
  38.     HKEY_LOCAL_MACHINE= &H80000002
  39.     
  40.     KEY_QUERY_VALUE=1
  41.     KEY_ENUMERATE_SUBKEYS=8
  42.     KEY_NOTIFY=16
  43.     KEY_READ=KEY_QUERY_VALUE Or KEY_ENUMERATE_SUBKEYS Or KEY_NOTIFY
  44.     
  45.     Dim lstat As Long    
  46.     Dim KeyVal As Long
  47.     Dim KeyReadBytes As Long
  48.     Dim ValueType As Long
  49.     Dim ValueName As String
  50.     Dim ReturnedKeyContents As String * 255
  51.     ReturnedKeyContents=String$(255,Chr$(32))
  52.     
  53.     'Open the registry and get the key address (myKey)
  54.     lstat=RegOpenKeyExA(HKEY_CLASSES_ROOT,myKey,0,KEY_READ,KeyVal)
  55.     KeyReadBytes = 255
  56.     'Get the value of the key at that address (ReturnedKeyContents)
  57.     lstat=RegQueryValueExA(KeyVal,ValueName,0,ValueType, _
  58.     ReturnedKeyContents,KeyReadBytes)
  59.     'Close the registry, thank you (you wouldn't want the keys to escape!)
  60.     regclosekey(KeyVal)
  61.     
  62.     'Get rid of the extra characters in the keystring
  63.     ReturnedKeyContents = Rtrim$(ReturnedKeyContents)
  64.     ReturnedKeyContents = Left$(ReturnedKeyContents,(Len(ReturnedKeyContents)-1))
  65.     
  66.     GetKey = ReturnedKeyContents
  67. End Function
  68.  
  69.  
  70.  
  71. Sub Main
  72. %Include "inistrs.lss"
  73.  
  74. '****************************************************************
  75. '*     The following section added by Linda Sharar        *
  76. '*            on 9/26/96                 *
  77. '***************************************************************** 
  78.     On Error Goto RangeError
  79.     
  80. 'Select current cell contents
  81.  
  82.   query$ = Selection.TextBlock.Text
  83.   If query$ = "" Then
  84.         Beep
  85.         Messagebox NOTEXT, MB_OK, ERRSTR
  86.         Exit Sub
  87.   End If
  88.  
  89. 'Begin trimming and parsing string for query 
  90.  
  91. query$= Trim$(query$)    
  92.     Dim querylen As Integer    
  93.     
  94. 'Strip away spaces on left and right    
  95.     query$= Trim$(query$)    
  96.     
  97. 'Locate Internal Spaces and replace with addition symbols
  98.     contents$=query$    
  99.     firstspace$ = " "
  100.     spaceposition = Instr(contents$, firstspace$)    
  101.     While spaceposition<>"0"
  102.         Mid$(contents$, spaceposition, 1) = "+"
  103.         oldspaceposition=spaceposition
  104.         spaceposition = Instr(contents$, firstspace$)
  105.         While spaceposition=oldspaceposition+1
  106.             leftcontents$=Left(contents$, spaceposition-1)
  107.             contentlen=Len(contents$)                        
  108.             rightcontents$=Right(contents$,contentlen-spaceposition)
  109.             contents$ = Leftcontents$+Rightcontents$
  110.             spaceposition = Instr(contents$, firstspace$)            
  111.         Wend
  112.     Wend
  113.     query$=contents$
  114.     
  115.     
  116. '****************************************************************
  117. '*     Continue Function as written by Darcy Burner        *
  118. '*                                 *
  119. '**************************************************************** 
  120.     
  121.  
  122.     Dim URL As String
  123.     URL$ = "http://search.yahoo.com/bin/search?p="& query$
  124.     
  125.     ' ** Define the search key list **
  126.     ' ********************************
  127.     Dim strKeylist(3) As String
  128.     strKeylist(0) = "http"    'http
  129.     strKeylist(1) = "htmlfile"    'htmlfile
  130.     strKeylist(2) = ".htm"    '.htm
  131.     strKeylist(3) = ".html"    '.html
  132.     
  133.     ' ** Declare the variables needed **
  134.     ' ****************************************
  135.     Dim ReturnedKey As String * 255
  136.     'Dim DDEAppKey As String
  137.     'Dim DDETopicKey As String
  138.     'Dim ReturnedDDEAppKey As String
  139.     'Dim ReturnedDDETopicKey As String
  140.     Dim strSKey As String
  141.     Dim SeekKey As String
  142.     Dim BrowserPath As String
  143.     Dim LaunchPath As String
  144.     Dim stat As Variant
  145.     
  146.     Dim QuotePos As Integer
  147.     Dim ExePos As Integer
  148.     
  149.     
  150.     ' ** Iterate through the list of keyvalues until a valid one is found **
  151.     ' **********************************************************************
  152.     Forall strPKey In strKeylist
  153.         ReturnedKey = GetKey(strPKey)        
  154.         If ReturnedKey<>"" Then
  155.             'We got something.  Were we looking for a file extension...?
  156.             If Left$(strPKey, 1) = "." Then
  157.                 'Set the DDE command to nothing
  158.                 SeekKey = Trim$(ReturnedKey)
  159.                 'Strip out excess nulls
  160.                 While InStr(SeekKey, Chr$(0)) > 0
  161.                     SeekKey=Left$(SeekKey, InStr(SeekKey, Chr$(0)) -1)
  162.                 Wend
  163.             Else
  164.                 'We weren't looking for a file extension, so get DDE keys (to
  165.                 'send message to app if running) and command key (to launch app
  166.                 'if not already running)
  167.                 'DDEAppKey = strPKey+"\shell\open\ddeexec\Application"
  168.                 'DDETopicKey = strPKey+"\shell\open\ddeexec\Topic"
  169.                 'ReturnedDDEAppKey = GetKey (DDEAppKey)
  170.                 'ReturnedDDETopicKey = GetKey (DDETopicKey)
  171.                 SeekKey = strPKey
  172.             End If    
  173.             'Get the app key pointed to
  174.             strSKey= SeekKey+"\shell\open\command"
  175.             'Get the browser path
  176.             BrowserPath = GetKey (strSKey)
  177.              'Delete all command line params:
  178.             ExePos=Instr(1,BrowserPath,".exe",1)
  179.             If ExePos<>0 Then
  180.                 BrowserPath=Left$(BrowserPath,ExePos+4)
  181.             End If
  182.             'Return path without leading quote, if there is one:
  183.             QuotePos=Instr(BrowserPath,Chr$(34))
  184.             If QuotePos<>0 Then
  185.                 BrowserPath=Mid$(BrowserPath,QuotePos+1)
  186.                 QuotePos=Instr(BrowserPath, CHR$(34))
  187.                 If QuotePos<>0 Then
  188.                     Mid$(BrowserPath,QuotePos)=" "
  189.                 End If
  190.             End If
  191.             'Create the command to send to the shell
  192.             LaunchPath=BrowserPath+" "+URL
  193.             Err=0
  194.             On Error Resume Next
  195.             
  196.             ' ** Send the appropriate commands to the shell **
  197.             ' *********************************************************
  198.             'Send the command to application to change to a new URL
  199.             '(Hah!  Wishful thinking, that I could send a DDE command from Script.  Oh well.)
  200.  
  201.             'Send the command to the shell to launch a new browser
  202.             stat=Shell(LaunchPath, 1)
  203.             'If you successfully launched, you're done
  204.             If stat = 33 Then
  205.                 Exit Sub
  206.             End If
  207.             On Error Goto 0
  208.         End If    
  209.     End Forall
  210.  
  211. 'None of the registry keys pointed to valid browsers, so send an error
  212.     Msgbox NOBROWSER
  213.     Exit Sub
  214.     
  215. 'New Error control by Linda Sharar    
  216.     RangeError:
  217.         Beep
  218.         Messagebox NOTEXT, MB_OK, ERRSTR
  219.     Exit Sub    
  220. End Sub
  221.  
  222.  
  223.