Content Supported by Sourcelens Consulting
Attribute VB_Name = "modGeofacts"
Option Explicit
Public appWorld As Excel.Application
Public wbWorld As Excel.Workbook
'
' Public shtWorld As Excel.Worksheet
Sub Setup()
' IMPORTANT: If your machine does not have Excel 97 installed,
' you must change the reference to the Excel 95 Object Library.
' Then, in the Declarations section above, change the variable
' declaration "wbWorld as Workbook" to "shtWorld As Worksheet."
' Then change all references to "wbWorld" to "shtWorld."
On Error Resume Next 'ignore errors
Set appWorld = GetObject(, "Excel.Application") 'look for a running copy of Excel
If Err.Number <> 0 Then 'If Excel is not running then
Set appWorld = CreateObject("Excel.Application") 'run it
End If
Err.Clear ' Clear Err object in case error occurred.
On Error GoTo 0 'Resume normal error processing
Set wbWorld = appWorld.Workbooks.Open(App.Path & "\world.xls")
End Sub
' Set the objects to Nothing.
Sub CleanUp()
' This should force an unload of Microsoft Excel,
' providing no other applications or users have it loaded.
Set appWorld = Nothing
Set wbWorld = Nothing
End Sub
' Fill the Continents combo box with the names
' of the sheets in the workbook.
Sub FillContinentsList()
Dim shtContinent As Excel.Worksheet
' Iterate through the collection of sheets and add
' the name of each sheet to the combo box.
For Each shtContinent In wbWorld.Sheets
frmGeoFacts.cmbContinents.AddItem shtContinent.Name
Next
' Select the first item and display it in the combo box.
frmGeoFacts.cmbContinents.Text = frmGeoFacts.cmbContinents.List(0)
Set shtContinent = Nothing
End Sub
' Fill the Continents combo box with the names
' of the features corresponding to a given continent.
Sub FillFeaturesList()
Dim shtContinent As Excel.Worksheet
Dim rngFeatureList As Excel.Range
Dim intFirstBlankCell As Integer
Dim loop1 As Integer
' Hide the old ranking list.
frmGeoFacts.lstTopRanking.Visible = False
' Get the sheet with the name of the continent selected in the Continents combo box.
Set shtContinent = wbWorld.Sheets(frmGeoFacts.cmbContinents.Text)
' Assign the first row of this sheet to an object.
Set rngFeatureList = shtContinent.Rows(1)
' See if it's an empty list.
If (rngFeatureList.Cells(1, 1) = "") Then
intFirstBlankCell = 0
Else
' Search the row for the first blank cell.
intFirstBlankCell = rngFeatureList.Find("").Column
End If
' Empty the previous contents of the features combo box.
frmGeoFacts.cmbFeatures.Clear
' Add the items to the features combo box.
For loop1 = 1 To intFirstBlankCell
frmGeoFacts.cmbFeatures.AddItem rngFeatureList.Cells(1, loop1)
Next
' Select the first item and display it in the combo box.
frmGeoFacts.cmbFeatures.Text = frmGeoFacts.cmbFeatures.List(0)
' Clean up.
Set shtContinent = Nothing
Set rngFeatureList = Nothing
End Sub
' Fill the list of ranking items.
Sub FillTopRankingList()
Dim shtContinent As Excel.Worksheet
Dim intColumOfFeature As Integer
Dim rngRankedList As Excel.Range
Dim intFirstBlankCell As Integer
Dim loop1 As Integer
' Get the sheet with the name of the continent selected in the Continents combo box.
Set shtContinent = wbWorld.Sheets(frmGeoFacts.cmbContinents.Text)
' Empty the previous contents of the ranking list box.
frmGeoFacts.lstTopRanking.Clear
' If the feature selection is blank, do nothing.
If (frmGeoFacts.cmbFeatures <> "") Then
' Look up the column of the selected feature in the first row of the spreadsheet.
intColumOfFeature = shtContinent.Rows(1).Find(frmGeoFacts.cmbFeatures.Text).Column
' Assign the column to an object.
Set rngRankedList = shtContinent.Columns(intColumOfFeature)
' See if it's a blank list.
If (rngRankedList.Cells(1, 1) = "") Then
intFirstBlankCell = 0
Else
' Search the row for the first blank cell.
intFirstBlankCell = rngRankedList.Find("").Row
End If
' Add the items to the TopRanking ListBox.
For loop1 = 2 To intFirstBlankCell
frmGeoFacts.lstTopRanking.AddItem rngRankedList.Cells(loop1, 1)
Next
' Show the new ranking list.
frmGeoFacts.lstTopRanking.Visible = True
End If
' Clean up.
Set shtContinent = Nothing
Set rngRankedList = Nothing
End Sub