home *** CD-ROM | disk | FTP | other *** search
VERSION 4.00 Begin VB.Form Indexer Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Stock Indexer" ClientHeight = 4905 ClientLeft = 1095 ClientTop = 1785 ClientWidth = 8565 BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 5595 Left = 1035 LinkTopic = "Form1" ScaleHeight = 4905 ScaleWidth = 8565 Top = 1155 Width = 8685 Begin VB.Timer tmr_Background Enabled = 0 'False Interval = 2 Left = 8040 Top = 2640 End Begin VB.CommandButton cmd_Draw Appearance = 0 'Flat BackColor = &H80000005& Caption = "Draw" Height = 435 Left = 6780 TabIndex = 14 Top = 2640 Width = 1035 End Begin VB.Frame Frame1 Appearance = 0 'Flat BackColor = &H00FFFF00& Caption = "Display Characteristic" ForeColor = &H80000008& Height = 1635 Left = 4740 TabIndex = 11 Top = 3240 Width = 3735 Begin VB.Label lbl_DisplayState Appearance = 0 'Flat BackColor = &H80000005& BackStyle = 0 'Transparent Caption = "State Machine Off" ForeColor = &H80000008& Height = 615 Left = 60 TabIndex = 13 Top = 960 Width = 3615 End Begin VB.Label lbl_DisplayChar Appearance = 0 'Flat BackColor = &H00FFFF00& ForeColor = &H80000008& Height = 555 Left = 60 TabIndex = 12 Top = 300 Width = 3615 End End Begin VB.ListBox lst_Companies Appearance = 0 'Flat Height = 2370 Left = 6240 MultiSelect = 2 'Extended TabIndex = 10 Top = 180 Width = 2115 End Begin VB.OptionButton opt_CurIndex Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Index8" ForeColor = &H00FFFFFF& Height = 315 Index = 7 Left = 4740 TabIndex = 2 Top = 2700 Width = 1335 End Begin VB.OptionButton opt_CurIndex Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Index7" ForeColor = &H00FFFFFF& Height = 315 Index = 6 Left = 4740 TabIndex = 9 Top = 2340 Width = 1335 End Begin VB.OptionButton opt_CurIndex Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Index6" ForeColor = &H00FFFFFF& Height = 315 Index = 5 Left = 4740 TabIndex = 8 Top = 1980 Width = 1335 End Begin VB.OptionButton opt_CurIndex Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Index5" ForeColor = &H00FFFFFF& Height = 315 Index = 4 Left = 4740 TabIndex = 7 Top = 1620 Width = 1335 End Begin VB.OptionButton opt_CurIndex Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Index4" ForeColor = &H00FFFFFF& Height = 315 Index = 3 Left = 4740 TabIndex = 6 Top = 1260 Width = 1335 End Begin VB.OptionButton opt_CurIndex Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Index3" ForeColor = &H00FFFFFF& Height = 315 Index = 2 Left = 4740 TabIndex = 5 Top = 900 Width = 1335 End Begin VB.OptionButton opt_CurIndex Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Index2" ForeColor = &H00FFFFFF& Height = 315 Index = 1 Left = 4740 TabIndex = 4 Top = 540 Width = 1335 End Begin VB.OptionButton opt_CurIndex Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Index1" ForeColor = &H00FFFFFF& Height = 315 Index = 0 Left = 4740 TabIndex = 3 Top = 180 Value = -1 'True Width = 1335 End Begin VB.PictureBox pic_Display Appearance = 0 'Flat BackColor = &H80000005& ForeColor = &H80000008& Height = 4515 Left = 60 ScaleHeight = 4485 ScaleMode = 0 'User ScaleWidth = 4485 TabIndex = 0 Top = 360 Width = 4515 End Begin VB.Label Label1 Appearance = 0 'Flat BackColor = &H80000005& BackStyle = 0 'Transparent Caption = "Historical Data" ForeColor = &H80000008& Height = 195 Left = 60 TabIndex = 1 Top = 60 Width = 2475 End Begin VB.Menu mnu_Behave Caption = "Category" Begin VB.Menu mnu_Category Caption = "Non-Interruptable" Checked = -1 'True Index = 0 End Begin VB.Menu mnu_Category Caption = "Background Display Only" Index = 1 End Begin VB.Menu mnu_Category Caption = "Background Display and Scaling" Index = 2 End End Attribute VB_Name = "Indexer" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Dim CurrentStateMachine% ' Indicates which state machine is currently selected. ' 0 = Non-interruptable ' 1 = Background display ' 2 = Background display and scaling Dim CurrentSelectedIndex% ' Index that is currently selected for editing. Dim Sheet As Object ' Object will refer to Excel sheet ' containing stock prices. Dim Companies As Object ' Object refers to an Excel range ' containing the list of companies. Dim period As Object ' Object refers to an Excel range ' containing the periods for which ' we have data. Dim HighRange As Object, LowRange As Object ' Range information Dim DataTable As Object ' Object refers to an Excel range ' containing all of the data for all ' of the companies. Dim IndexList$() ' Brute force array of companies in ' each index. ' Used for fast listbox update Const WM_USER = &H400 #If Win32 Then Private Const LB_FINDSTRINGEXACT = &H1A2 Private Const LB_SELITEMRANGE = &H19B Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function SendMessageBynum Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long #Else Const LB_FINDSTRINGEXACT = (WM_USER + 35) Const LB_SELITEMRANGE = (WM_USER + 28) Private Declare Function SendMessage& Lib "User" (ByVal hwnd%, ByVal wMsg%, ByVal wParam%, lParam As Any) Private Declare Function SendMessageBynum& Lib "User" Alias "SendMessage" (ByVal hwnd%, ByVal wMsg%, ByVal wParam%, ByVal lParam&) Private Declare Function SendMessageByString& Lib "User" Alias "SendMessage" (ByVal hwnd%, ByVal wMsg%, ByVal wParam%, ByVal lParam$) #End If Private Sub cmd_Draw_Click() Dim i%, di% pic_Display.Cls LoadIndexFromList CurrentSelectedIndex For i% = 0 To 7 di% = DrawIndex(i%, True) Next i% End Sub ' This function draws the historical chart of an entire index. ' restart% is set to True to clear the current operation ' Returns True if the operation is completed, 0 if the function ' needs to be called again. ' See article text for additional information on this function Private Function DrawIndex%(IndexNum%, restart%) Dim CurEntry% Dim IVal# Dim PrevVal# Static StateCurEntry%(7) Static StatePrevVal#(7) If restart% Then StateCurEntry%(IndexNum%) = 1 If CurrentStateMachine% <> 0 Then ' We defined the function to always return ' immediately on reset. DrawIndex = False Exit Function End If End If If IndexList$(IndexNum%, 0) = "" Then ' Exit if no entries for this index DrawIndex% = True Exit Function End If Select Case CurrentStateMachine% Case 0 ' - Non interruptable - VERY SLOW For CurEntry% = 1 To period.Columns.Count IVal# = GetIndexVal(IndexNum%, CurEntry%) ' Don't draw the first entry If CurEntry% <> 1 Then pic_Display.Line (CurEntry% - 1, PrevVal#)-(CurEntry%, IVal#), opt_CurIndex(IndexNum%).BackColor PrevVal# = IVal# Next CurEntry% DrawIndex% = True Case 1 To 2 ' Interruptable If StateCurEntry%(IndexNum%) > period.Columns.Count Then DrawIndex% = True Exit Function End If IVal# = GetIndexVal(IndexNum%, StateCurEntry%(IndexNum%)) ' Don't draw the first entry If StateCurEntry%(IndexNum%) <> 1 Then pic_Display.Line (StateCurEntry%(IndexNum%) - 1, StatePrevVal#(IndexNum%))-(StateCurEntry%(IndexNum%), IVal#), opt_CurIndex(IndexNum%).BackColor StatePrevVal#(IndexNum%) = IVal# StateCurEntry%(IndexNum%) = StateCurEntry%(IndexNum%) + 1 DrawIndex% = False End Select End Function Private Sub Form_Load() Dim col%, usecol& Dim rcount% Dim di% Screen.MousePointer = 11 ' Initialize the background colors to indicate which ' option button corresponds to each index. For col% = 0 To 7 Select Case col% Case 0 To 6 usecol& = QBColor(col%) Case 7 ' We're drawing on a white background usecol& = QBColor(8) End Select opt_CurIndex(col%).BackColor = usecol& Next col% mnu_Category_Click (0) ' Initialize menu ' Initialize OLE Automation objects Set Sheet = GetObject(App.Path & "\Stocks.XLS") Set Companies = Sheet.Range("companies") Set period = Sheet.Range("period") Set HighRange = Sheet.Range("highprice") Set LowRange = Sheet.Range("lowprice") Set DataTable = Sheet.Range("StockData") ' Now load listbox lst_Companies with a list of all ' available companies. Note that this particular stock ' database is entirely ficitional. For rcount% = 1 To Companies.Rows.Count lst_Companies.AddItem Companies.Cells(rcount%, 1).Text Next rcount% ' Redimension list to hold all companies if necessary ReDim IndexList$(8, Companies.Rows.Count - 1) CurrentSelectedIndex% = 0 ' Track current index Screen.MousePointer = 0 StateMachineInput "FormLoaded" End Sub ' Retreives the value of an index. It searches through all ' of the companies that comprise the index and takes the ' average of their prices (Note that real stock indexes ' often use different formulas). Private Function GetIndexVal#(ByVal IndexNum%, Entrynum%) Dim CurVal% Dim Comp$ Dim dl& Dim TotalPrice# Do Comp$ = IndexList$(IndexNum%, CurVal%) If Comp$ <> "" Then ' Find the offset to the company dl& = SendMessageByString(lst_Companies.hwnd, LB_FINDSTRINGEXACT, -1, Comp$) If dl& < 0 Then Exit Do ' Should never happen ' Now get the data for the specified entry TotalPrice# = TotalPrice# + DataTable.Value(dl& + 1, Entrynum%) CurVal% = CurVal% + 1 End If Loop While Comp$ <> "" If CurVal% > 0 Then GetIndexVal# = TotalPrice# / CurVal% End Function ' Retrieves the low and high range for a particular company Private Sub GetPeriodLimit(ByVal Company$, LowPrice#, HighPrice#) Dim quote As Object Dim dl& dl& = SendMessageByString(lst_Companies.hwnd, LB_FINDSTRINGEXACT, -1, Company$) If dl& >= 0 Then ' We found it, now select it HighPrice# = HighRange.Value(dl& + 1) LowPrice# = LowRange.Value(dl& + 1) End If End Sub ' Loads the company list for an index from the list box Private Sub LoadIndexFromList(idxnum%) Dim c%, CurEntry% For c% = 0 To lst_Companies.ListCount - 1 If lst_Companies.Selected(c%) Then IndexList$(idxnum%, CurEntry%) = lst_Companies.List(c%) CurEntry% = CurEntry% + 1 End If Next c% ' Clear the rest of the entries While CurEntry% < UBound(IndexList$, 1) IndexList$(idxnum%, CurEntry%) = "" CurEntry% = CurEntry% + 1 Wend End Sub ' Loads the company list box from an index list Private Sub LoadListFromIndex(idxnum%) Dim dl& Dim c% Dim rng& ' First clear all existing selections rng& = lst_Companies.ListCount - 1 rng& = rng * &H10000 ' Shift to high word dl& = SendMessageBynum(lst_Companies.hwnd, LB_SELITEMRANGE, 0, rng) ' Now loop through the list For c% = 0 To UBound(IndexList, 1) If IndexList$(idxnum%, c%) = "" Then Exit For ' We're done dl& = SendMessageByString(lst_Companies.hwnd, LB_FINDSTRINGEXACT, -1, IndexList(idxnum%, c%)) If dl& >= 0 Then ' We found it, now select it lst_Companies.Selected(dl&) = True End If Next c% End Sub Private Sub lst_Companies_Click() StateMachineInput "ListClicked" End Sub Private Sub mnu_Category_Click(Index As Integer) Dim lbl$ Dim midx% For midx% = 0 To 1 ' Uncheck the other categories If midx% <> Index Then mnu_Category(midx%).Checked = False Else mnu_Category(midx%).Checked = True Next midx% Select Case Index Case 0 ' Display is non-interruptable ' This represents the category of task that ' must not allow any user interaction or changes ' by other applications. It also represents ' non-event driven design. lbl$ = "Non-interruptable: Characteristic of non-event driven design." ' We need a command button to provide any ' sort of decent performance cmd_Draw.Visible = True Case 1 ' Display takes place in the background ' Display is retriggered on click on option button cmd_Draw.Visible = False lbl$ = "Background display: Reset on option click" CurrentStateMachine% = 1 Case 2 cmd_Draw.Visible = False lbl$ = "Background display and scale: Reset on option click" CurrentStateMachine% = 2 End Select lbl_DisplayChar = lbl$ StateMachineInput "MenuClick" End Sub Private Sub opt_CurIndex_Click(Index As Integer) ' Exit if no change to index If CurrentSelectedIndex% = Index Then Exit Sub ' Save previous index information LoadIndexFromList CurrentSelectedIndex LoadListFromIndex Index CurrentSelectedIndex% = Index ' Now trigger any background operations that ' may be necessary StateMachineInput "OptionClicked" End Sub ' Sets the scale of the display area to match the period ' range and the low and high price ' restart% is set to True to reset the operation ' Returns -1 if the operation was completed, 0 if the ' function needs to be called again. Private Function SetDisplayScales%(restart%) Dim LowPrice#, HighPrice# Dim LowestPrice#, HighestPrice# Static StateLowestPrice#, StateHighestPrice# Static StateC% ' The period width is easy: We'll use a coordinate ' system corresponding to the number of periods ' The vertical ($) axis is scaled from the lowest ' price to the highest. How we do this depends on ' the selected Category Select Case CurrentStateMachine% ' - Non interruptable - VERY SLOW!!! Case 0, 1 ' Machine # 1 does this non-interruptable also Dim c% For c% = 0 To lst_Companies.ListCount - 1 GetPeriodLimit ByVal lst_Companies.List(c%), LowPrice#, HighPrice# If c% = 0 Then LowestPrice# = LowPrice# HighestPrice# = HighPrice# Else If LowPrice# < LowestPrice# Then LowestPrice# = LowPrice# If HighPrice# > HighestPrice# Then HighestPrice# = HighPrice# End If Next c% pic_Display.Scale (0, HighestPrice#)-(period.Columns.Count, LowestPrice#) ' Using this algorithm we are always done SetDisplayScales% = True Case 2 ' Machine # 2 does this interruptable also If restart% Then StateC% = 0 SetDisplayScales% = False Exit Function End If If StateC% > lst_Companies.ListCount - 1 Then pic_Display.Scale (0, StateHighestPrice#)-(period.Columns.Count, StateLowestPrice#) ' Using this algorithm we are always done SetDisplayScales% = True Exit Function End If GetPeriodLimit ByVal lst_Companies.List(StateC%), LowPrice#, HighPrice# If StateC% = 0 Then StateLowestPrice# = LowPrice# StateHighestPrice# = HighPrice# Else If LowPrice# < StateLowestPrice# Then StateLowestPrice# = LowPrice# If HighPrice# > StateHighestPrice# Then StateHighestPrice# = HighPrice# End If StateC% = StateC% + 1 End Select End Function ' This is the control function that decides what should ' be happening at any given time. ' We're using a string to describe the event for illustration ' purposes. A real program would use an integer for efficiency. ' This is the state machine function that is the heart ' of the background processing capability. Private Sub StateMachineInput(OutsideEvent$) Static InternalState% ' Indicates the current state ' 0 - State machine off ' 1 - Machine is idle ' 2 - State machine is ready to start drawing ' 3 - State machine is drawing index InternalIndex% ' 4 - State machine is setting scale mode Static InternalIndex% ' Current index being drawn (Machine 1) Dim result% ' Each of these cases defines a different state ' machine. Select Case CurrentStateMachine% Case 0 ' Non-interruptable. This is not really ' a state machine - it just performs ' the specified operation immediately Select Case OutsideEvent$ Case "FormLoaded" result% = SetDisplayScales(True) Case "MenuClicked" ' Turn off the state machine tmr_Background.Enabled = False cmd_Draw_Click InternalState% = 0 lbl_DisplayState.Caption = "State Machine Off" pic_Display.Cls End Select Case 1 ' Background display only (No state 4) If OutsideEvent$ = "FormLoaded" Then ' We're not handling display as part of ' the machine at this point result% = SetDisplayScales(True) End If Select Case InternalState% Case 0 ' Always turn on the machine tmr_Background.Enabled = True InternalState% = 2 lbl_DisplayState.Caption = "Start Drawing" pic_Display.Cls Case 1 ' Idle Select Case OutsideEvent$ Case "OptionClicked" InternalState% = 2 lbl_DisplayState.Caption = "Start Drawing" End Select Case 2 ' Start drawing here InternalIndex% = 0 pic_Display.Cls result% = DrawIndex(InternalIndex%, True) InternalState% = 3 lbl_DisplayState.Caption = "Drawing in Progress" Case 3 Select Case OutsideEvent$ Case "OptionClicked" ' Restart InternalState% = 2 lbl_DisplayState.Caption = "Start Drawing" Case "Timer" result% = DrawIndex(InternalIndex%, False) If result% Then ' End of index If InternalIndex% >= 7 Then InternalState% = 1 ' Goto idle lbl_DisplayState.Caption = "Idle" Else InternalIndex% = InternalIndex + 1 result% = DrawIndex(InternalIndex%, True) End If End If End Select End Select Case 2 ' Background display and Scale Mode Select Case InternalState% Case 0 ' Always turn on the machine tmr_Background.Enabled = True InternalState% = 4 result% = SetDisplayScales(True) lbl_DisplayState.Caption = "Setting Display Scale" pic_Display.Cls Case 1 ' Idle Select Case OutsideEvent$ Case "OptionClicked" InternalState% = 2 lbl_DisplayState.Caption = "Start Drawing" End Select Case 2 ' Start drawing here InternalIndex% = 0 pic_Display.Cls ' We've also changed the drawing algorithm For InternalIndex% = 0 To 7 result% = DrawIndex(InternalIndex%, True) Next InternalIndex% InternalState% = 3 lbl_DisplayState.Caption = "Drawing in Progress" Case 3 Select Case OutsideEvent$ Case "OptionClicked" ' Restart InternalState% = 2 lbl_DisplayState.Caption = "Start Drawing" Case "Timer" result% = True For InternalIndex% = 0 To 7 ' Look for all of them to finish result% = result% And DrawIndex(InternalIndex%, False) Next InternalIndex% If result% Then ' End of index InternalState% = 1 ' Goto idle lbl_DisplayState.Caption = "Idle" End If End Select Case 4 ' Note that the only way to exit this state is ' through completion, or if you change state machines ' using the menu result% = SetDisplayScales(False) If result% Then ' Lets start a drawing operation InternalState% = 2 lbl_DisplayState.Caption = "Start Drawing" tmr_Background.Interval = 2 End If End Select End Select End Sub Private Sub tmr_Background_Timer() StateMachineInput "Timer" End Sub 
(.txt)