VERSION 5.00 Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX" Begin VB.Form monitor_demographics AutoRedraw = -1 'True Caption = "Demographics" ClientHeight = 3855 ClientLeft = 60 ClientTop = 630 ClientWidth = 4650 LinkTopic = "Form1" MaxButton = 0 'False MDIChild = -1 'True ScaleHeight = 3855 ScaleWidth = 4650 Tag = "0" Visible = 0 'False Begin VB.CheckBox chkPlot Caption = "Plot" Height = 195 Left = 60 TabIndex = 4 ToolTipText = "Show miniplot (select column)" Top = 60 Width = 795 End Begin VB.PictureBox Picture1 AutoRedraw = -1 'True Height = 1275 Left = 840 OLEDragMode = 1 'Automatic OLEDropMode = 2 'Automatic ScaleHeight = 1215 ScaleWidth = 1335 TabIndex = 3 Top = 2160 Width = 1395 End Begin VB.TextBox Text1 Height = 315 Left = 3720 TabIndex = 1 Top = 1080 Width = 795 Visible = 0 'False End Begin ComctlLib.ListView lv1 Height = 1755 Left = 0 TabIndex = 0 Top = 300 Width = 5235 _ExtentX = 9234 _ExtentY = 3096 View = 3 LabelWrap = -1 'True HideSelection = -1 'True _Version = 327682 ForeColor = -2147483640 BackColor = -2147483643 BorderStyle = 1 Appearance = 1 NumItems = 0 End Begin VB.Label lblStat Height = 195 Left = 0 TabIndex = 2 Top = 1860 Width = 855 End Begin VB.Menu menuClear Caption = "&Clear" End Begin VB.Menu menucopytolog Caption = "Copy to &editor" End End Attribute VB_Name = "monitor_demographics" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Option Base 1 Dim last_model_time As Integer Private Sub Form_Load() Me.Height = 2550 Me.Width = 4800 lv1.Width = Me.Width - 200 lv1.Height = (Me.Height - 300) - 400 lv1.ColumnHeaders.Clear lv1.ColumnHeaders.add , , "Time", 300 lv1.ColumnHeaders.add , , "Count", 550 lv1.ColumnHeaders.add , , "Born", 500 lv1.ColumnHeaders.add , , "Dead", 500 lv1.ColumnHeaders.add , , "Migr", 500 lv1.ColumnHeaders.add , , "Incr", 500 lv1.ListItems.Clear Call stat_dem End Sub
Private Sub Form_Resize() If WindowState = vbMinimized Then Exit Sub If chkPlot.Value = 0 Then Picture1.Visible = False lblStat.Visible = False lv1.Width = Me.Width - 200 lv1.Height = (Me.Height - 300) - 400 Else Picture1.Visible = True lblStat.Visible = True lv1.Width = maxi(200, Me.Width - 200) lv1.Height = maxi(200, Me.Height / 1.7 - 300 - 400) Picture1.Top = lv1.Top + lv1.Height + 100 lblStat.Top = Picture1.Top Picture1.Height = maxi(200, Me.Height - lv1.Top - lv1.Height - 600) Picture1.Width = Me.Width - Picture1.Left - 200 Call plotnew(0) End If End Sub
Private Sub chkPlot_Click() If chkPlot.Value = 1 Then Me.Height = Me.Height * 1.7 Else Me.Height = Me.Height / 1.7 End If End Sub
Private Sub Form_Terminate() ' MsgBox "term" End Sub
Private Sub Form_Unload(Cancel As Integer) coll_view.Remove "mdem" controlcenter.cmdDemo.enabled = True End Sub
Private Sub menuClear_Click() lv1.ListItems.Clear End Sub
Private Sub menuCopytolog_Click() Dim i As Integer Dim j As Integer Dim txt As String txt = frmEditor.rtbLog.text txt = txt + vbCrLf For i = 1 To lv1.ColumnHeaders.count txt = txt + fspace(lv1.ColumnHeaders(i), 10) Next txt = txt + vbCrLf For i = 1 To lv1.ListItems.count txt = txt + fspace(lv1.ListItems(i), 10) For j = 1 To lv1.ColumnHeaders.count - 1 txt = txt + fspace(lv1.ListItems.Item(i).SubItems(j), 10) Next txt = txt + vbCrLf Next frmEditor.rtbLog.text = txt ' Copy txt also to clipboard Clipboard.Clear Clipboard.SetText txt End Sub
Private Function fspace(txt, bredd) fspace = txt & Space(bredd - Len(txt)) End Function
Private Sub Text1_Change() If Text1.text = "Clear" Then Call menuClear_Click Exit Sub End If If model_time = last_model_time Then Exit Sub last_model_time = model_time Call stat_dem Call plotnew(0) End Sub
Private Sub stat_dem() Dim m Dim i As Long, counter(4) As Long Dim n As Integer Dim sum As Double, totalcount As Double totalcount = (m_icount - I_SUMVEC(i_abroad(1), UBound(i_abroad))) * m_weight Set m = lv1.ListItems.add() m.text = CStr(base_year + model_time) m.SubItems(1) = totalcount m.SubItems(2) = m_born m.SubItems(3) = m_dead m.SubItems(4) = m_netmigration m.SubItems(5) = (m_born - m_dead + m_netmigration) n = lv1.ListItems.count Set lv1.SelectedItem = lv1.ListItems(n) End Sub
Private Sub lv1_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader) Dim i As Integer For i = 1 To lv1.ColumnHeaders.count If lv1.ColumnHeaders(i) = ColumnHeader Then Exit For Next If i > 1 Then Call plotnew(i) End If End Sub
Private Sub plotnew(colnr As Integer) Dim n As Integer, i As Integer Dim y() As Double, miny As Double, maxy As Double Static oldcolnr As Integer ' If no items - exit n = lv1.ListItems.count If n = 0 Then Exit Sub ' If colnr=0 - redraw If colnr = 0 And oldcolnr = 0 Then Exit Sub If colnr = 0 Then colnr = oldcolnr oldcolnr = colnr ' Fill plot-vector with values and compute max and min ReDim y(1 To n) maxy = -999999999 miny = 999999999 For i = 1 To n ' Exit if there are no values If IsNumeric(lv1.ListItems(i).SubItems(colnr - 1)) = False Then Exit Sub ' y(i) = CDbl(lv1.ListItems(i).SubItems(colnr - 1)) y(i) = val(lv1.ListItems(i).SubItems(colnr - 1)) If y(i) > maxy Then maxy = y(i) If y(i) < miny Then miny = y(i) Next miny = miny * 0.95 maxy = maxy * 1.05 If miny = maxy Then miny = miny - 1 maxy = maxy + 1 End If If n = 1 Then n = 2 ReDim Preserve y(1 To n) y(2) = y(1) End If ' Set scale for upper-left and lower-right Picture1.Cls Picture1.Scale (1, maxy)-(n, miny) For i = 2 To n Picture1.Line (i - 1, y(i - 1))-(i, y(i)), QBColor(0) Next lblStat.Caption = lv1.ColumnHeaders(colnr) End Sub