home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 25: Programming / pc_actual_25.iso / Basic / GridOne / setup.EXE / BEEGD10.CHM / sample.vbs < prev    next >
Encoding:
Text File  |  2001-09-09  |  15.8 KB  |  479 lines
  1. Option Explicit
  2.  
  3. Const COLORS16_VALUES = "0;8388608;32768;8421376;128;8388736;32896;12632256;8421504;16711680;65280;16776960;255;16711935;65535;16777215"
  4.  
  5. Dim msFullCode
  6. Dim marProcedures
  7.  
  8. Sub ShowCode()
  9.    Dim sHtml, i
  10.  
  11.     On Error Resume Next
  12.    'get source and replace tabs with spaces
  13.    msFullCode = Replace(idMainCode.innerHTML,chr(9),"   ")
  14.  
  15.    For i = 1 To Len(msFullCode)
  16.       If IsCharAlpha(Mid(msFullCode, i, 1)) Then
  17.          msFullCode = Mid(msFullCode, i)
  18.          Exit For
  19.       End If
  20.    Next
  21.    
  22.    'msFullCode = Replace(msFullCode, "_" & chr(13) &  chr(10), "")
  23.  
  24.    msFullCode = Trim(PaintCode(msFullCode))
  25.    'make div
  26.    sHtml = "<p> </p>"
  27.    sHtml = sHtml & "<DIV class=clsExampleGrid>"
  28.    sHtml = sHtml & "<table class= clsExampleTitleBar cellspacing=0>"
  29.    sHtml = sHtml & "<tr>"
  30.    sHtml = sHtml & "<td width=18><img class=clsWinImage src=Class.png></td>"
  31.    sHtml = sHtml & "<td width=100%><b>Sample Code</b></td>"
  32.    sHtml = sHtml & "<td width=18><img class=clsWinImage src=MinWin.png></td>"
  33.    sHtml = sHtml & "<td width=18><img class=clsWinImage src=MaxWin.png></td>"
  34.    sHtml = sHtml & "<td width=18><img class=clsCloseWinImage src=CloseWin.png"
  35.    sHtml = sHtml & " OnClick=" & chr(34) & "window.history.back()" & chr(34) & "></td>"
  36.    sHtml = sHtml & "</tr>"
  37.    sHtml = sHtml & "</table><br>"
  38.    
  39.    sHtml = sHtml & "<select size=1 name=cmbObject valign=Top style=" & chr(34) 
  40.    sHtml = sHtml & "position: relative; width: 48%; top: -7" & chr(34) 
  41.    sHtml = sHtml & " OnChange=" & chr(34) & "SetCurrentObject()" & chr(34) & ">"
  42.    'sHtml = sHtml & "<option value=General selected>General</option>"
  43.    sHtml = sHtml & "</select>  "
  44.    sHtml = sHtml & "<select size=1 name=cmbProcedures valign=Top style=" & chr(34)
  45.    sHtml = sHtml & "position: relative; width: 48%; top: -7" & chr(34)
  46.    sHtml = sHtml & " OnChange=" & chr(34) & "ShowProc()" & chr(34) & ">"
  47.    'sHtml = sHtml & "<option value=Declarations selected>Declarations</option>"
  48.    sHtml = sHtml & "</select>"
  49.    sHtml = sHtml & "<div id=idCodeWindow class=clsExampleCode>"
  50.    'sHtml = sHtml & "<PRE><CODE>" & msFullCode & "</PRE></CODE>"
  51.    sHtml = sHtml & "</div></div>"      
  52.  
  53.    idShowCode.innerHTML = sHtml
  54.    
  55.    LoadProcedures 
  56.    window.navigate "#bkSourcecode"
  57.       
  58. End Sub
  59.  
  60. Private Sub LoadProcedures()
  61.    Dim arLines, i, iPos
  62.    Dim sProcs, oOption
  63.    Dim cmb, sTmp, sTmpList
  64.  
  65.    Set cmb = cmbObject
  66.       
  67.    arLines = Split(msFullCode, Chr(13))
  68.    sProcs = "General_Declarations;"
  69.  
  70.    For i = 0 To Ubound(arLines)
  71.       arLines(i) = ClearTags(arLines(i)) 
  72.       arLines(i) = Replace(arLines(i), Chr(13), "")
  73.       arLines(i) = Replace(arLines(i), Chr(10), "")
  74.       arLines(i) = Replace(arLines(i), Chr(8),"")    
  75.  
  76.       If IsLineProcStart(arLines(i)) Then
  77.          iPos = InStr(arLines(i), "(")
  78.          If iPos = 0 Then             
  79.             If Right(arLines(i), 1) = "_" Then     
  80.                arLines(i) = Left(arLines(i), Len(arLines(i)) - 1)
  81.                arLines(i) = Trim(arLines(i))
  82.                iPos = Len(arLines(i)) + 1
  83.             End If
  84.          End If
  85.          If iPos > 0 Then
  86.             arLines(i) = Left(arLines(i), iPos - 1)
  87.             iPos = InStrRev(arLines(i), " ")
  88.             If iPos > 0 Then
  89.                arLines(i) = Trim(Mid(arLines(i), iPos + 1))
  90.                iPos = InStr(arLines(i), "_")
  91.                If iPos > 0 Then
  92.                   sProcs = sProcs & arLines(i) & ";"
  93.                Else
  94.                   sProcs = sProcs & "General_" & arLines(i) & ";"
  95.                End If
  96.             End If
  97.          End If
  98.       End If   
  99.    Next   
  100.  
  101.    marProcedures = Split(sProcs, ";")
  102.    sTmpList = "0"
  103.  
  104.     for i = 0 to Ubound(marProcedures) - 1
  105.       sTmp = Left(marProcedures(i),InStr(marProcedures(i), "_") - 1)        
  106.       If InStr(sTmpList, "(" & sTmp & ")") = 0 Then
  107.          sTmpList = sTmpList & "(" & sTmp & ")"
  108.            set oOption= document.createElement("OPTION")
  109.            cmb.options.add oOption        
  110.    
  111.          oOption.Text = sTmp
  112.          oOption.Value = sTmp
  113.       End If   
  114.     Next
  115.  
  116.    SetCurrentObject
  117. End Sub
  118.  
  119. Sub SetCurrentObject()
  120.    Dim cmb, sObject, i, sTmp, oOption
  121.  
  122.    Set cmb = cmbProcedures
  123.  
  124.    For i=0 To cmb.children.length - 1
  125.       cmb.removeChild cmb.children(0)
  126.    next
  127.  
  128.    sObject = cmbObject.Value
  129.  
  130.     for i = 0 to Ubound(marProcedures) - 1
  131.       sTmp = Left(marProcedures(i),InStr(marProcedures(i), "_") - 1)
  132.       If sTmp = sObject Then
  133.           
  134.            set oOption= document.createElement("OPTION")
  135.            cmb.options.add oOption        
  136.    
  137.          oOption.Text = Mid(marProcedures(i),InStr(marProcedures(i), "_") + 1)
  138.          oOption.Value = marProcedures(i)
  139.       End If
  140.     Next
  141.  
  142.    ShowProc
  143. End Sub
  144.  
  145. Sub ShowProc()
  146.    Dim iPos, sName, sCode
  147.    Dim iEndPos
  148.  
  149.    sName = cmbProcedures.Value
  150.    
  151.    iPos = GetProcStart(sName)
  152.  
  153.    If iPos > 0 Then
  154.       iPos = InStrRev(msFullCode, Chr(10), iPos)
  155.       sCode = Mid(msFullCode, iPos + 1) 
  156.       iEndPos = GetProcEnd(sCode)
  157.       sCode = Left(sCode, iEndPos)
  158.       idCodeWindow.innerHTML = "<PRE><CODE>" & sCode & "</PRE></CODE>"
  159.    Else
  160.       idCodeWindow.innerHTML = "<PRE><CODE>" & msFullCode & "</PRE></CODE>"
  161.    End If
  162.       
  163. End Sub
  164.  
  165. Function IsLineProcStart(sLine)
  166.    Const TAXT_COMP = 1
  167.  
  168.    IsLineProcStart = False
  169.   
  170.    If StrComp(Left(sLine,4),"Sub ", TAXT_COMP) = 0 Then
  171.       IsLineProcStart = True
  172.    ElseIf StrComp(Left(sLine,9),"Function ", TAXT_COMP) = 0 Then
  173.       IsLineProcStart = True
  174.    ElseIf StrComp(Left(sLine,12),"Private Sub ", TAXT_COMP) = 0 Then
  175.       IsLineProcStart = True
  176.    ElseIf StrComp(Left(sLine,17),"Private Function ", TAXT_COMP) = 0 Then
  177.       IsLineProcStart = True
  178.    End If
  179.  
  180. End Function
  181.  
  182. Function GetProcStart(sName)
  183.    Dim iPos, sLine
  184.  
  185.    sName = " " & Replace(sName, "General_", "")
  186.  
  187.    iPos = InStr(msFullCode, sName)
  188.  
  189.    Do Until iPos = 0
  190.       sLine = GetCodeLine(msFullCode, iPos)
  191.       sLine = ClearTags(sLine)
  192.       If IsLineProcStart(sLine) Then Exit Do
  193.       iPos = InStr(iPos + 1, msFullCode, sName)
  194.    Loop
  195.    
  196.    iPos = GetProcCommentBlock(iPos)
  197.  
  198.    GetProcStart = iPos
  199. End Function
  200.  
  201. Function GetProcCommentBlock(iPos)
  202.    Dim sPrevLine, iPrevPos, bComment
  203.  
  204.    GetProcCommentBlock = iPos
  205.    If iPos < 3 Then Exit Function
  206.    
  207.    iPrevPos = iPos - 2
  208.  
  209.    Do
  210.       iPrevPos = InStrRev(msFullCode, Chr(13), iPrevPos - 2)
  211.       sPrevLine = GetCodeLine(msFullCode, iPrevPos)
  212.       sPrevLine = ClearTags(sPrevLine)
  213.       If Len(sPrevLine) = 0 Then
  214.          If bComment Then  
  215.             iPrevPos = InStr(iPrevPos + 1, msFullCode, Chr(13))
  216.             Exit Do
  217.          End If
  218.       Else
  219.          If Left(sPrevLine, 1) = "'" Then
  220.             bComment = True
  221.          Else
  222.             If bComment = True Then
  223.                Exit Do
  224.             Else
  225.                GetProcCommentBlock = iPos
  226.                Exit Function
  227.             End If
  228.          End If
  229.       End If
  230.    Loop While iPrevPos > 3
  231.  
  232.    GetProcCommentBlock = iPrevPos
  233. End Function
  234.  
  235. Function GetProcEnd(sCode)
  236.    Dim iPosSub, iPosFunc
  237.    Dim iPos, iEndLine
  238.    
  239.    iPosSub = Instr(1, sCode, "End Sub", 1)
  240.    iPosFunc = Instr(1, sCode, "End Function", 1)
  241.  
  242.    If iPosSub > iPosFunc Then
  243.       iPos = iPosFunc
  244.    Else
  245.       iPos = iPosSub
  246.    End If
  247.    
  248.    If iPos = 0 Then iPos = iPosSub + iPosFunc
  249.  
  250.    If iPos = 0 Then
  251.       iPos = Len(sCode)
  252.    Else
  253.       iEndLine = InStr(iPos, sCode, Chr(13))
  254.       If iEndLine > 0 Then
  255.          iPos = iEndLine
  256.       Else
  257.          iPos = Len(sCode)
  258.       End If
  259.    End If
  260.    
  261.    GetProcEnd = iPos
  262. End Function
  263.  
  264. Function GetCodeLine(sCode, iStartPos)
  265.    Dim sTmp, iPos
  266.  
  267.    sTmp = sCode
  268.  
  269.    If iStartPos = 0 then 
  270.       iPos = 0
  271.    Else
  272.       iPos = InStr(iStartPos, sTmp, Chr(13))
  273.    End If
  274.    
  275.    If iPos > 0 Then sTmp = Left(sTmp , iPos - 1)
  276.    
  277.    iPos = InStrRev(sTmp, Chr(13))
  278.    If iPos > 0 Then sTmp = Mid(sTmp , iPos + 1)
  279.    
  280.    sTmp = Replace(sTmp, Chr(10), "")
  281.    sTmp = Replace(sTmp, Chr(8),"")
  282.    GetCodeLine = Trim(sTmp)
  283. End Function
  284.  
  285. Function ClearTags(sLine)
  286.    Dim sTmp, sTmpEnd, iPos, iEndPos
  287.  
  288.    sTmp = sLine
  289.  
  290.    iPos = InStr(sTmp, "<")
  291.    
  292.    Do Until iPos = 0
  293.       iEndPos = InStr(iPos + 1,sTmp, ">")
  294.       If iEndPos = 0 Then Exit Do
  295.       sTmpEnd = Mid(sTmp, iEndPos + 1)
  296.       sTmp = Left(sTmp, iPos - 1) & sTmpEnd
  297.       iPos = InStr(sTmp, "<")
  298.    Loop
  299.  
  300.    ClearTags = Trim(sTmp)
  301. End Function
  302.  
  303. Function PaintCode(sCode)
  304.    Dim sChar, sWord , i
  305.    Dim bSkip, bComment
  306.    Const StartTag = "<font color=#000080>"
  307.    Const CommentTag = "<font color=#008000>"
  308.    Const EndTag = "</font>"
  309.    
  310.    On Error Resume Next
  311.    
  312.    sCode = sCode & " "
  313.  
  314.    Do Until i >= Len(sCode)
  315.       i = i + 1
  316.       sChar = Mid(sCode, i, 1)
  317.       If IsCharAlpha(sChar) Then
  318.          sWord = sWord & sChar
  319.       Else
  320.          If Asc(sChar) = 39 And Not bSkip And Not bComment Then
  321.             bComment = True
  322.             sCode = Left(sCode, i - 1) & CommentTag & Mid(sCode, i)
  323.             i = i + Len(CommentTag)
  324.          End If
  325.          
  326.          If Not bSkip And Not bComment And Len(sWord) > 0 Then
  327.             If GetKeyWord(sWord) Then
  328.                sCode = Left(sCode, i - Len(sWord) - 1) & StartTag & sWord & EndTag & Mid(sCode, i)
  329.                i = i + Len(StartTag) + Len(EndTag)
  330.             End If
  331.          End If
  332.          
  333.          If Asc(sChar) = 13 And bComment Then
  334.             bComment = False
  335.             sCode = Left(sCode, i - 1) & EndTag & Mid(sCode, i)
  336.             i = i + Len(EndTag)
  337.          End If
  338.  
  339.          If Asc(sChar) = 34 Then bSkip = Not bSkip
  340.  
  341.          sWord = ""
  342.       End If
  343.    Loop
  344.    
  345.    sCode = Replace(sCode, EndTag & " " & StartTag, " ")
  346.    sCode = Replace(sCode, EndTag & StartTag, " ")
  347.    PaintCode = Left(sCode, Len(sCode) - 1)
  348. End Function
  349.  
  350.  
  351. Private Sub SetScriptColors()
  352.    Dim sText, i
  353.    Dim sChar, sWord
  354.    Const StartTag = "<font color=#000080>"
  355.    Const EndTag = "</font>"
  356.    
  357.    On Error Resume Next
  358.      
  359.    Do Until i >= Len(sText)
  360.       i = i + 1
  361.       sChar = Mid(sText, i, 1)
  362.       If IsCharAlpha(sChar) Then
  363.          sWord = sWord & sChar
  364.       Else
  365.          If GetKeyWord(sWord) Then
  366.             sText = Left(sText, i - Len(sWord)) & StartTag & sWord & EndTag & Mid(sText, i + 1)
  367.             i = i + Len(StartTag) + Len(EndTag)
  368.          End If
  369.          sWord = ""
  370.       End If
  371.    Loop
  372.    
  373.    sText = Replace(sText, EndTag & StartTag, " ")
  374.    
  375. '   Do Until i = 0
  376. '      i = InStr(i, sText, "'")
  377. '      If i = 0 Then Exit Do
  378. '      rtf.SelStart = i - 1
  379. '      rtf.Span Chr(13), True, True
  380. '      rtf.SelColor = QBColor(2)
  381. '      i = i + Len(rtf.SelText) + 1
  382. '   Loop
  383.    
  384. End Sub
  385.  
  386. Private Function GetKeyWord(sWord)
  387.    Dim iPos
  388.    Const KeyWords = ";Abs;And;As;Asc;Atn;Call;Case;CCur;CDbl;Chr;CInt;CLng;Const;Cos;CSng;CStr;CVar;CVDate;End;DateAdd;DateDiff;DatePart;DateSerial;DateValue;Day;Dim;Do;Else;ElseIf;EndIf;Eqv;Erase;Err;Error;Exit;Exp;Explicit;False;Fix;For;Format;Function;GetObject;GoTo;Hex;Hour;If;Imp;Input;InputBox;InStr;Int;Is;IsDate;IsEmpty;IsNull;IsNumeric;LBound;LCase;Left;Len;Let;Like;LoadPicture;Log;Loop;LTrim;Mid;Minute;Mod;Month;MsgBox;New;Next;Not;Nothing;Now;Null;Oct;On;Option;Or;Preserve;Private;Random;Randomize;ReDim;Rem;Resume;RGB;Right;Rnd;RTrim;Second;Select;Set;Sgn;Sin;Space;Spc;Sqr;Static;Stop;Str;StrComp;Sub;Tan;Then;Time;Timer;TimeSerial;TimeValue;To;Trim;True;Type;TypeOf;UBound;UCase;Until;Val;VarType;Weekday;Wend;While;Xor;Year;CDate;FormatDateTime;Each;Split;"
  389.  
  390.    iPos = InStr(1, KeyWords, ";" & sWord & ";",vbTextCompare)
  391.  
  392.    If iPos > 0 Then
  393.       sWord = Mid(KeyWords, iPos + 1, Len(sWord))
  394.       GetKeyWord = True
  395.    End If
  396. End Function
  397.  
  398. Private Function IsCharAlpha(sChar)
  399.    Dim iKey
  400.    
  401.    iKey = Asc(UCase(sChar))
  402.    
  403.    If iKey > 64 And iKey < 91 Then    'key is char
  404.       IsCharAlpha = True
  405.    End If
  406. End Function
  407.  
  408. Sub FillColorCombo(combo,lDefault)
  409.     dim i,oOption
  410.     dim arColors,arColorValues
  411.  
  412. Const WEB_COLORS = "Aliceblue#16775408;Antiquewhite#14150650;Aqua#16776960;Aquamarine#13959039;Azure#16777200;Beige#14480885;Bisque#12903679;Black#0;Blanchedalmond#13495295;Blue#16711680;Blueviolet#14822282;Brown#2763429;Burlywood#8894686;Cadetblue#10526303;Chartreuse#65407;Chocolate#1993170;Coral#5275647;Cornflower#15570276;Cornsilk#14481663;Crimson#3937500;Cyan#16776960;Darkblue#9109504;Darkcyan#9145088;Darkgoldenrod#755384;Darkgray#11119017;Darkgreen#100;Darkkhaki#7059389;Darkmagenta#9109643;Darkolivegreen#3107669;Darkorange#36095;Darkorchid#13382297;Darkred#139;Darksalmon#8034025;Darkseagreen#9157775;Darkslateblue#9125192;Darkslategray#5197615;Darkturquoise#13749760;Darkviolet#148;Deeppink#9639167;Deepskyblue#16760576;Dimgray#6908265;Dodgerblue#16748574;Firebrick#2237106;Floralwhite#15792895;Forestgreen#2263842;Fuchsia#16711935;Gainsboro#14474460;Ghostwhite#16775416;Gold#55295;Goldenrod#2139610;Gray#8421504;Green#128;Greenyellow#3145645;Honeydew#15794160;Hotpink#11823615;Indianred#6053069;Indigo#8519755;Ivory#15794175;Khaki#9234160;Lavender#16443110;Lavenderblush#16118015;Lawngreen#64636;Lemonchiffon#13499135;Lightblue#15128749;Lightcoral#8421616;Lightcyan#16777184;Lightgoldenrodyellow#13826810;Lightgreen#9498256;Lightgray#13882323;Lightpink#12695295;Lightsalmon#8036607;Lightseagreen#11186720;Lightskyblue#16436871;Lightslategray#10061943;Lightsteelblue#14599344;Lightyellow#14745599;Lime#65280;Limegreen#3329330;Linen#15134970;Magenta#16711935;Maroon#128;Mediumaquamarine#11193702;Mediumblue#13434880;Mediumorchid#13850042;Mediumpurple#14381203;Mediumseagreen#7451452;Mediumslateblue#15624315;Mediumspringgreen#10156544;Mediumturquoise#13422920;Mediumvioletred#8721863;Midnightblue#7346457;Mintcream#16449525;Mistyrose#14804223;Moccasin#11920639;Navajowhite#11394815;Navy#32896;Oldlace#15136253;Olive#32896;Olivedrab#2330219;Orange#42495;Orangered#17919;Orchid#14053594;Palegoldenrod#11200750;Palegreen#10025880;Paleturquoise#15658671;Palevioletred#9662683;Papayawhip#14020607;Peachpuff#12180223;Peru#4163021;Pink#13353215;Plum#14524637;Powderblue#15130800;Purple#8388736;Red#255;Rosybrown#9408444;Royalblue#9464129;Saddlebrown#1262987;Salmon#7504122;Sandybrown#6333684;Seagreen#5737262;Seashell#15660543;Sienna#2970272;Silver#12632256;Skyblue#15453831;Slateblue#13458026;Slategray#9470064;Snow#16448255;Springgreen#8388352;Steelblue#11829830;Tan#9221330;Teal#8421504;Thistle#14204888;Tomato#4678655;Turquoise#13688896;Violet#15631086;Wheat#11788021;White#16777215;Whitesmoke#16119285;Yellow#65535;Yellowgreen#3329434"
  413.  
  414.    On Error Resume Next
  415.     
  416.    arColors=Split(WEB_COLORS,";")
  417.  
  418.    If lDefault <> -1 Then
  419.       set oOption= document.createElement("OPTION")
  420.       combo.options.add oOption
  421.    
  422.       oOption.Text = "Default"
  423.        oOption.Value = lDefault
  424.    End If
  425.    
  426.     for i=0 to Ubound(arColors)
  427.         set oOption= document.createElement("OPTION")
  428.         combo.options.add oOption
  429.         
  430.       arColorValues = Split(arColors(i),"#")
  431.  
  432.       oOption.Text = arColorValues(0)
  433.         oOption.Value = arColorValues(1)
  434.     Next
  435. End Sub
  436.  
  437. Sub ShowApplyTo(sFileName)
  438.     dim sStream , PopUp
  439.  
  440.    Set PopUp = document.all("idMembersList")
  441.  
  442.    If PopUp.style.visibility = "hidden" Then
  443.       ShowAtPoint PopUp         
  444.    Else
  445.       PopUp.style.visibility = "hidden"
  446.    End If
  447. End Sub
  448.  
  449. Sub ShowAtPoint(oPopUp)
  450.    Dim elm, ieX, ieY
  451.  
  452.     set elm = window.event.srcElement
  453.     
  454.     window.event.returnValue = false
  455.     window.event.cancelBubble = true
  456.  
  457.     if elm is nothing then
  458.         ieX = window.event.clientX
  459.         ieY = window.event.clientY + document.body.scrollTop
  460.     else    
  461.         ieX = elm.offsetLeft
  462.         ieY = ((elm.offsetTop) + (elm.offsetHeight) + 1)
  463.     end if
  464.     
  465.     oPopUp.style.top = ieY 
  466.     oPopUp.style.left = ieX
  467.    
  468.    oPopUp.style.visibility = "visible"
  469.  
  470.    set elm = Nothing
  471. End Sub
  472.  
  473. Sub HideApplyTo()
  474.    On Error resume next
  475.  
  476.    document.all("idMembersList").style.visibility = "hidden"
  477.     document.all("sapop").className = "clsMenuText"
  478. End Sub
  479.