home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1997 November / Pcwk1197.iso / LOTUS / Eng-ins / SMASTERS / APPROACH / SURFNET.MPR / SCRIPT / A007ApprGlobObj897.s (.txt) < prev    next >
Null Bytes Alternating  |  1997-01-09  |  27KB  |  397 lines
  1. '++LotusScript Development Environment:2:5:(Options):0:74
  2. Option Public
  3.  
  4.  
  5. '++LotusScript Development Environment:2:5:(Forward):0:1
  6. Declare Type SECURITY_ATTRIBUTES
  7. Declare Function ReplaceStr (S As String, O As String, R As String) As String
  8. Declare Sub Initialize
  9. Declare Sub ParseNetscapeBookmark
  10. Declare Sub CallDefaultBrowser
  11. Declare Sub SetWebTrekLicenseKey
  12.  
  13. '++LotusScript Development Environment:2:5:(Declarations):0:10
  14. 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
  15. 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
  16. 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
  17. Declare Public Function RegCloseKey Lib "advapi32" Alias "RegCloseKey" (Byval HKEY As Long) As Long
  18. 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
  19.  
  20. Dim strURL As String
  21. Dim strPageTitle As String
  22.  
  23. Dim iMoreInfo As Integer   'Tracks 'more info' on the Found Set Report
  24.  
  25. 'Begin Global BlockTranslated from WebTrek Licensing Source Code
  26.  
  27. Type SECURITY_ATTRIBUTES
  28.     nLength As Long
  29.     lpSecurityDescriptor As Long
  30.     bInheritHandle As Integer
  31. End Type
  32.  
  33. Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (Byval hKey As Long, Byval lpSubKey As String, phkResult As Long) As Long
  34. Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (Byval hKey As Long, Byval lpSubKey As String, phkResult As Long) As Long
  35. Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (Byval hKey As Long, Byval lpSubKey As String, Byval lpValue As String, lpcbValue As Long) As Long
  36. Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (Byval hKey As Long, Byval lpSubKey As String, Byval ulOptions As Long, Byval samDesired As Long, phkResult As Long) As Long
  37. Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (Byval hKey As Long, Byval lpSubKey As String, Byval Reserved As Long, Byval lpClass As String, Byval dwOptions As Long, Byval samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
  38. Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (Byval hKey As Long, Byval lpValueName As String, Byval Reserved As Long, Byval dwType As Long, lpData As Any, Byval cbData As Long) As Long         
  39. Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (Byval hKey As Long, Byval lpSubKey As String, Byval dwType As Long, Byval lpData As String, Byval cbData As Long) As Long
  40.  
  41.  
  42. Public Const MAX_PATH = 32
  43. Public Const ERROR_SUCCESS = 0&
  44. Public Const HKEY_CLASSES_ROOT = &H80000000
  45. Public Const KEY_CREATE_SUB_KEY = &H4
  46. Public Const SYNCHRONIZE = &H100000
  47. Public Const KEY_SET_VALUE = &H2
  48. Public Const READ_CONTROL = &H20000
  49. Public Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
  50. Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
  51. Public Const REG_SZ = 1                         
  52. Public Const REG_OPTION_NON_VOLATILE = 0       
  53.  
  54. 'End Global BlockTranslated from WebTrek Licensing Source Code
  55.  
  56.  
  57.  
  58.  
  59. '++LotusScript Development Environment:2:1:ReplaceStr:1:8
  60. Function ReplaceStr (S As String, O As String, R As String) As String
  61. ' S is the input string, O is the old string, R is the replacement string
  62.     If (S = "") Then
  63.         ReplaceStr = ""
  64.     Else
  65.         n = Instr(S,O)
  66.         While (n > 0)
  67.             Mid(S,n) = R
  68.             n = Instr(S,O)    
  69.         Wend
  70.         ReplaceStr = S
  71.     End If
  72. End Function
  73. '++LotusScript Development Environment:2:2:Initialize:1:10
  74. Sub Initialize
  75.     iMoreInfo = False
  76. End Sub
  77. '++LotusScript Development Environment:2:2:ParseNetscapeBookmark:1:8
  78. Sub ParseNetscapeBookmark
  79.     'Declarations
  80.     Dim strNetPath As String
  81.     Dim  strBookmarkFile As String
  82.     Dim strBookmarks As String
  83.     Dim strType As String    
  84.     Dim strCrntHdr As String
  85.     Dim strSurfnet As String
  86.     Dim strTableName As String
  87.     Dim strCrntURL As String
  88.     Dim strCrntBkmrk As String
  89.     Dim strMsg As String   'Messag for message box.
  90.     
  91.     Dim iFileId As Integer
  92.     Dim rval As Integer   'Return value.
  93.        'Flag (0=quit, 1=quit, 2=go)
  94.     Dim iOK As Integer
  95.     
  96.     Dim lFileLen As Long
  97.     
  98.     Dim Con As New Connection
  99.     Dim Qry As New Query
  100.     Dim RS As New ResultSet
  101.     
  102.     'Array of bookmarks (Title, URL, Category)
  103.     Dim aryBookmarks(10, 10, 10) As String
  104.     
  105.     'Initializations
  106.     iOK = 0
  107.     strMsg = "Incorrect directory or  file" & Chr(10) &  "doesn't exist, try again?"
  108.     On Error Resume Next   'If error occurs, continue.
  109.     
  110.     Do Until (iOK <> 0)
  111.         strNetPath = Inputbox("Enter the name of the Netscape directory.", "Netscape Directory", "C:\PROGRAM FILES\NETSCAPE\NAVIGATOR", 150, 150)
  112.         
  113.         strBookmarkFile = strNetPath & "\BOOKMARK.HTM"
  114.         strTemp = Dir(strBookmarkFile)  'List the file.
  115.         
  116.         If Lcase$(Dir(strBookmarkFile)) <> "bookmark.htm" Then   'If the file doesn't exist...
  117.             If strNetPath = "" Then
  118.                 Exit Sub
  119.             Else
  120.                 rval = 1   'Reset
  121.                 rval = Messagebox(strMsg , 1,  "Warning")
  122.                 If (rval = 1) Then
  123.                     iOK = 0
  124.                 Else
  125.                     iOK = 1
  126.                 End If
  127.             End If
  128.         Else
  129.             iOK = 2
  130.         End If
  131.     Loop
  132.     
  133.     
  134.     
  135.     If (iOK = 2) Then
  136.         lFileLen = Filelen(strBookmarkFile)
  137.         'iFileId = 1
  138.         iFileId = Freefile
  139.         'Open the file.
  140.         Open strBookmarkFile For Input Access Read As iFileId Len = lFileLen
  141.         
  142.         If lFileLen >32000 Then
  143.             rval = Messagebox("The Netscape Bookmark file is too large at "+Trim(Str$(lFileLen))+ " characters.  Please reduce to 32000 characters or less.", 0, "Import Bookmarks")
  144.             Exit Sub            
  145.         End If
  146.         
  147.         strType = "N"
  148.         strTableName = CurrentDocument.Tables(0).FileName
  149.         strSurfnet = CurrentDocument.Path & strTableName
  150.         
  151.         'Use the data object to enter records.
  152.         If (Con.ConnectTo("dBASE IV")) Then
  153.             Set Qry.Connection = Con
  154.             Qry.Tablename = strSurfnet
  155.             Set RS.Query = Qry
  156.             If (RS.Execute = False) Then
  157.                 Messagebox "Couldn't access file for import."
  158.             End If
  159.         Else
  160.             Messagebox "Couldn't access file for import."
  161.         End If
  162.         
  163.         'Put the contents of the file in a variable.
  164.         strBookmarks = Input$(lFileLen, iFileId)
  165.         
  166.         
  167.         For i = 1 To lFileLen
  168.             'Reset the header if the bookmark has none.
  169.             If (Mid$(strBookmarks, i, 8) = "</DL><p>") Then
  170.                 strCrntHdr = ""
  171.             End If
  172.             
  173.             'Find the header.
  174.             If (Mid$(strBookmarks, i, 3) = "<H3") Then
  175.                 'We've found a header.
  176.                 strCrntHdr = ""
  177.                 'Now let's find the header name
  178.                 Do Until (Mid$(strBookmarks, i, 1) = ">")
  179.                     i = i + 1
  180.                 Loop
  181.                 i = i+ 1   'Get next character.
  182.                 'Get the header and put in a variable.
  183.                 strCrntHdr = ""   'Reset variable.
  184.                 Do Until (Mid$(strBookmarks, i, 1) = "<")
  185.                     strCrntHdr = strCrntHdr & Mid$(strBookmarks, i, 1)
  186.                     i = i+ 1
  187.                 Loop
  188.                 
  189.             'Find the bookmark
  190.             Elseif (Mid$(strBookmarks, i, 2) = "<A") Then
  191.             'We've found a bookmark
  192.                 strType = "B"
  193.             'Now let's find the URL
  194.                 Do Until (Mid$(strBookmarks, i, 1) = """")
  195.                     i = i + 1
  196.                 Loop
  197.                 i = i+ 1   'Get next character.
  198.                 
  199.             'Get the URL and put in a variable.
  200.                 Do Until (Mid$(strBookmarks, i, 1) = """")
  201.                     strCrntURL = strCrntURL & Mid$(strBookmarks, i, 1)
  202.                     i = i+ 1
  203.                 Loop
  204.                 
  205.                 'delete all http;// prefix
  206.                 Dim HTTPPos As Integer
  207.                 HTTPPos = Instr(strCrntURL, "http://")
  208.                 If HTTPPos <> 0 Then
  209.                     strCrntURL = Right$(strCrntURL, Len(strCrntURL) - 7)
  210.                 End If
  211.                 
  212.                 
  213.             'Now let's find the bookmark name.
  214.                 Do Until (Mid$(strBookmarks, i, 1) = ">")
  215.                     i = i + 1
  216.                 Loop
  217.                 i = i+ 1   'Get next character.
  218.             'Get the bookmark name  and put in a variable.
  219.                 Do Until (Mid$(strBookmarks, i, 1) = "<")
  220.                     strCrntBkmrk = strCrntBkmrk & Mid$(strBookmarks, i, 1)
  221.                     i = i+ 1
  222.                 Loop
  223.                 
  224.                 If (Mid$(strBookmarks, i, 4) = "</A>") Then
  225.                     'Now let's add the record to the file.
  226.                     RS.AddRow
  227.                     rval = RS.SetValue(2, strCrntBkmrk)
  228.                     rval = RS.SetValue(1, strCrntURL)
  229.                     rval = RS.SetValue(3, strCrntHdr)
  230.                     RS.UpdateRow
  231.                     strCrntURL = ""
  232.                     strCrntBkmrk = ""
  233.                 End If
  234.             End If
  235.         Next
  236.         Close(iFileId)
  237.         RS.Close
  238.         Messagebox "Import" & Chr(10) & "complete.", 0, "Import"
  239.     End If
  240.     
  241. EndImport:
  242. End Sub
  243. '++LotusScript Development Environment:2:2:CallDefaultBrowser:1:8
  244. Sub CallDefaultBrowser
  245.     
  246.     Dim happkey As Long
  247.     Dim HKEY_LOCAL_MACHINE As Long
  248.     Dim KEY_READ As Long
  249.     Dim HKEY_CURRENT_USER As Long
  250.     Dim HKEY_CLASSES_ROOT As Long
  251.     Dim ValueType As Long
  252.     Dim ReturnedKeyContents As String * 255
  253.     Dim readbytes As Long
  254.     Dim ReturnString As String * 255
  255.     MaxBytes%=Len(ReturnString$)
  256.     IniFileName$ = "Win.Ini"
  257.     ReturnedKeycontents$=String$(255,Chr$(32))
  258.     
  259.     HKEY_CLASSES_ROOT= &H80000000
  260.     HKEY_CURRENT_USER= &H80000001
  261.     HKEY_LOCAL_MACHINE= &H80000002
  262.     
  263.     KEY_QUERY_VALUE=1
  264.     KEY_ENUMERATE_SUBKEYS=8
  265.     KEY_NOTIFY=16
  266.     KEY_READ=KEY_QUERY_VALUE Or KEY_ENUMERATE_SUBKEYS Or KEY_NOTIFY
  267.     
  268.     KeyName$="http\shell\open\command"
  269.     URL$= "http://"+currentview.body.url.text
  270.     
  271.     GNNStat = GetPrivateProfileStringA("GNNWorks","AppPath","NA",ReturnString$,MaxBytes%,IniFileName$)
  272.     AppPath$=Left$(ReturnString$,GNNStat)
  273.     
  274.     If AppPath$="NA" Then ' did not find 16 bit GNN works
  275.         ValueName$=""
  276.         lstat=RegOpenKeyExA(HKEY_CLASSES_ROOT,KeyName$,0,KEY_READ,happkey)
  277.         ReadBytes=255
  278.         lstat=RegQueryValueExA(happkey,ValueName$,0,valueType, ReturnedKeyContents$,ReadBytes)
  279.         regclosekey(happkey)
  280.         
  281.         
  282.         TrimmedKeyContents$ = Trim$(ReturnedKeyContents$)
  283.         If TrimmedKeyContents$ ="" Then
  284.             Messagebox("Approach can't determine if a WWW browser is installed, script aborted.")
  285.             Exit Sub
  286.         End If
  287.         
  288.         ' Strip out any Double quotation marks - Internet Explorer adds these into default browser settings whereas Netscape does not.
  289.         
  290.         NewKeyContents$ = ""
  291.         For cnt = 1 To Len(TrimmedKeyContents$)
  292.             If Mid$(TrimmedKeyContents$, cnt, 1) <> """" Then
  293.                 NewKeyContents$ = NewKeyContents$ + Mid$(TrimmedKeyContents$, cnt, 1)
  294.             End If
  295.         Next cnt        
  296.         
  297.         BrowserPath$=Left$(NewKeyContents$,ReadBytes-1)
  298.         
  299.         ' delete all command line params:
  300.         ExePos=Instr(BrowserPath$,".exe")
  301.         If ExePos<>0 Then
  302.             BrowserPath$=Left$(BrowserPath$,ExePos+4)
  303.         End If
  304.         
  305.         ' return path without leading quote, if there is one:
  306.         QuotePos=Instr(BrowserPath$,Chr$(34))
  307.         If QuotePos<>0 Then
  308.             BrowserPath$=Mid$(BrowserPath$,QuotePos+1)
  309.         End If
  310.     Else
  311.         ' found GNN Works
  312.         BrowserPath$ = Left(AppPath$,GNNStat) & "\IW.EXE"
  313.     End If
  314.     
  315.     LaunchPath$=BrowserPath$+" "+URL$
  316.     Err=0
  317.     On Error Resume Next
  318.     stat = Shell(LaunchPath$, 1)
  319.     On Error Goto 0
  320.     If Err<>0 Then
  321.         Messagebox "Error launching web browser, please check installation and try again.", MB_OK, "Error"
  322.     End If 
  323. End Sub
  324. '++LotusScript Development Environment:2:2:SetWebTrekLicenseKey:1:8
  325. Sub SetWebTrekLicenseKey
  326.     Dim stringCLSIDKey As String *255
  327.     Dim stringCLSIDKeyValue As String * 82
  328.     Dim strCLSIDKeyValue As String
  329.     Dim stringCopyrightValue As String 
  330.     
  331.     Dim notused As Long    
  332.     Dim cvLength As Long
  333.     Dim szKey As String
  334.     
  335.     Dim hKeyControl As Long    
  336.     Dim dwLength As Long
  337.     Dim hKeyCLSID As Long
  338.     Dim hKeyMyCLSID As Long
  339.     Dim hKeyCLSIDTree As Long
  340.     Dim  hKeyCopyright As Long
  341.     Dim dwDisposition As Long
  342.     Dim lpSecurityAttributes As SECURITY_ATTRIBUTES
  343.     
  344.     stringCopyrightValue$ = "WebTrek -- Copyright ⌐ 1996 Home Page Software Inc. -- A Webster CodeBase Product"
  345.     dwLength = 255
  346.     
  347.     
  348.     If (RegOpenKey(HKEY_CLASSES_ROOT, "WebTrek.WebsterCtrl.1", hKeyControl) = ERROR_SUCCESS) Then
  349.          '// Have the main entry:
  350.         
  351.           '// Get the class GUID
  352.         
  353.         If (RegOpenKey(hKeyControl, "CLSID", hKeyCLSID) = ERROR_SUCCESS) Then
  354.             notused = RegQueryValue(hKeyCLSID, "", stringCLSIDKeyValue$, dwLength)
  355.             
  356.             strCLSIDKeyValue$ = Left$(stringCLSIDKeyValue$, dwLength - 1)
  357.             
  358.              '// Done
  359.             notused = RegCloseKey(hKeyCLSID)
  360.         End If
  361.         
  362.           '// Get the CLSID entry
  363.         
  364.         If (RegOpenKey(HKEY_CLASSES_ROOT, "CLSID", hKeyCLSIDTree) = ERROR_SUCCESS) Then
  365.              '// In HKEY_CLASSES_ROOT\CLSID tree: open our GUID
  366.             
  367.             If (RegOpenKeyEx(hKeyCLSIDTree, strCLSIDKeyValue$, 0, KEY_WRITE, hKeyMyCLSID) = ERROR_SUCCESS) Then
  368.                 
  369.                 If (RegCreateKeyEx(hKeyMyCLSID, "Copyright", 0, "REG_SZ", REG_OPTION_NON_VOLATILE, KEY_WRITE, lpSecurityAttributes, hKeyCopyright, dwDisposition) = ERROR_SUCCESS) Then
  370.                      '// Created the key or found an existing one:
  371.                     
  372.                        '// Set the license key value value
  373.                     cvLength = Len(stringCopyrightValue$) + 1
  374.                     szKey$ = "CLSID\" & strCLSIDKeyValue$ & "\Copyright"
  375.                     If(RegSetValue(HKEY_CLASSES_ROOT, szKey$, REG_SZ,  stringCopyrightValue$, Clng(cvLength)) <> ERROR_SUCCESS) Then
  376.                         Messagebox "Error Setting Registry Value"
  377.                         
  378.                     End If
  379.                     
  380.                        '// Done
  381.                     notused = RegCloseKey(hKeyCopyright)
  382.                 End If
  383.                 
  384.                   '// Done
  385.                 notused = RegCloseKey(hKeyMyCLSID)
  386.             End If
  387.             
  388.              '// Done
  389.             notused = RegCloseKey(hKeyCLSIDTree)
  390.         End If
  391.         
  392.         '// Done
  393.         notused = RegCloseKey(hKeyControl)
  394.     End If
  395.     
  396.     
  397. End Sub