home *** CD-ROM | disk | FTP | other *** search
VERSION 5.00 Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "comctl32.ocx" Begin VB.Form frmMain Caption = "WorldView" ClientHeight = 5430 ClientLeft = 60 ClientTop = 600 ClientWidth = 9780 HelpContextID = 10 Icon = "Main.frx":0000 KeyPreview = -1 'True LinkTopic = "Form1" ScaleHeight = 5430 ScaleWidth = 9780 StartUpPosition = 2 'CenterScreen Begin VB.PictureBox picPicture BorderStyle = 0 'None Height = 1335 Left = 3960 ScaleHeight = 1335 ScaleWidth = 1935 TabIndex = 4 TabStop = 0 'False Top = 2520 Visible = 0 'False Width = 1935 Begin VB.Image imgPicture BorderStyle = 1 'Fixed Single Height = 855 Left = 120 Stretch = -1 'True Top = 120 Width = 1215 End End Begin ComctlLib.ProgressBar ProgressBar1 Align = 2 'Align Bottom Height = 255 Left = 0 TabIndex = 3 Top = 5175 Width = 9780 _ExtentX = 17251 _ExtentY = 450 _Version = 327682 Appearance = 1 End Begin ComctlLib.ListView lvwInfo Height = 1095 Left = 3360 TabIndex = 2 Top = 720 Width = 1815 _ExtentX = 3201 _ExtentY = 1931 View = 3 LabelEdit = 1 LabelWrap = -1 'True HideSelection = 0 'False _Version = 327682 Icons = "ImageList1" SmallIcons = "ImageList1" ForeColor = -2147483640 BackColor = -2147483643 BorderStyle = 1 Appearance = 1 NumItems = 2 BeginProperty ColumnHeader(1) {0713E8C7-850A-101B-AFC0-4210102A8DA7} Key = "" Object.Tag = "" Text = "Field" Object.Width = 2540 EndProperty BeginProperty ColumnHeader(2) {0713E8C7-850A-101B-AFC0-4210102A8DA7} SubItemIndex = 1 Key = "" Object.Tag = "" Text = "Value" Object.Width = 2540 EndProperty End Begin ComctlLib.TreeView tvwCountry Height = 4935 Left = 0 TabIndex = 0 Top = 0 Width = 3135 _ExtentX = 5530 _ExtentY = 8705 _Version = 327682 HideSelection = 0 'False Indentation = 529 LabelEdit = 1 Style = 7 ImageList = "ImageList1" Appearance = 1 End Begin ComctlLib.TabStrip TabStrip1 Height = 2535 Left = 4920 TabIndex = 1 Top = 0 Width = 4815 _ExtentX = 8493 _ExtentY = 4471 MultiRow = -1 'True _Version = 327682 BeginProperty Tabs {0713E432-850A-101B-AFC0-4210102A8DA7} NumTabs = 3 BeginProperty Tab1 {0713F341-850A-101B-AFC0-4210102A8DA7} Caption = "Tab 1" Key = "" Object.Tag = "" ImageVarType = 2 EndProperty BeginProperty Tab2 {0713F341-850A-101B-AFC0-4210102A8DA7} Caption = "Tab 2" Key = "" Object.Tag = "" ImageVarType = 2 EndProperty BeginProperty Tab3 {0713F341-850A-101B-AFC0-4210102A8DA7} Caption = "Tab 3" Key = "" Object.Tag = "" ImageVarType = 2 EndProperty EndProperty End Begin ComctlLib.ImageList ImageList1 Left = 3000 Top = 4680 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 ImageWidth = 14 ImageHeight = 14 MaskColor = 12632256 _Version = 327682 BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} NumListImages = 4 BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Main.frx":0442 Key = "world" EndProperty BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Main.frx":075C Key = "info" EndProperty BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Main.frx":0A76 Key = "right" EndProperty BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "Main.frx":0D90 Key = "down" EndProperty EndProperty End Begin VB.Menu mnuFile Caption = "&File" Begin VB.Menu mnuFileProperties Caption = "P&roperties" End Begin VB.Menu mnuSep1 Caption = "-" End Begin VB.Menu mnuFileExit Caption = "E&xit" End End Begin VB.Menu mnuHelp Caption = "&Help" Begin VB.Menu mnuHelpCredits Caption = "&Credits" End Begin VB.Menu mnuSep2 Caption = "-" End Begin VB.Menu mnuHelpAbout Caption = "&About" End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Dim objTabs As New clsItemCol Private Sub LoadCountries() On Error GoTo ErrHandler 'Dim db As ADODB.Connection 'Dim rs As ADODB.Recordset Dim db As Database Dim rs As Recordset Dim sName As String Dim NewNode As Node 'db.ConnectionString = GetConnectString & AppPath & "worldview.mdb" 'db.Open 'Set rs = New ADODB.Recordset 'Set rs = db.Execute("select Id, CountryNameShort, CountryNameLong from tbl_Country order by CountryNameShort") Set db = OpenDatabase(GetDatabaseName) Set rs = db.OpenRecordset("select Id, CountryNameShort, CountryNameLong from tbl_Country order by CountryNameShort") tvwCountry.Nodes.Clear While Not rs.EOF sName = rs!CountryNameShort & "" If StrComp(sName, "none", vbTextCompare) = 0 Then sName = rs!CountryNameLong & "" End If If sName <> "" Then Set NewNode = tvwCountry.Nodes.Add(, , , sName, "world") NewNode.Tag = rs!Id End If rs.MoveNext Wend 'Close Everything rs.Close db.Close EndSub: Exit Sub ErrHandler: Call SetErr(Err, Err.Description, Me.Name & ".LoadCountries") GoTo EndSub Resume End Sub Private Sub LoadCountry(ByVal CountryId As Long) On Error GoTo ErrHandler 'Dim db As New ADODB.Connection 'Dim rs As ADODB.Recordset Dim db As Database Dim rs As Recordset Dim i As Integer Dim j As Integer Dim sFieldName As String Dim NewItem As ListItem Dim lCount As Long Screen.MousePointer = vbHourglass 'Set db = New ADODB.Connection 'db.ConnectionString = GetConnectString & AppPath & "worldview.mdb" 'db.Open 'Set rs = New ADODB.Recordset 'Set rs = db.Execute("select * from tbl_Country where Id = " & CountryId) Set db = OpenDatabase(GetDatabaseName) Set rs = db.OpenRecordset("select * from tbl_Country where Id = " & CountryId) 'Load the information if not EOF lvwInfo.ListItems.Clear If Not rs.EOF Then 'The last tab is the MAP If Me.TabStrip1.SelectedItem.Index = Me.TabStrip1.Tabs.Count Then If FileExists(AppPath & rs!picname) Then Set imgPicture.Picture = LoadPicture(AppPath & rs!picname) Else Set imgPicture.Picture = LoadPicture("") End If Me.lvwInfo.Visible = False picPicture.Visible = True Else Set imgPicture.Picture = LoadPicture("") Me.lvwInfo.Visible = True picPicture.Visible = False End If lCount = objTabs(Me.TabStrip1.SelectedItem.Index).Fields.Count For i = 1 To lCount sFieldName = objTabs(Me.TabStrip1.SelectedItem.Index).Fields(i).Name Set NewItem = lvwInfo.ListItems.Add(, , sFieldName, , "right") 'If this item has subitems 'then display them 'else just display the value of this item If objTabs(Me.TabStrip1.SelectedItem.Index).Fields(i).Fields.Count > 0 Then NewItem.SmallIcon = "down" For j = 1 To objTabs(Me.TabStrip1.SelectedItem.Index).Fields(i).Fields.Count sFieldName = objTabs(Me.TabStrip1.SelectedItem.Index).Fields(i).Fields(j).Name Set NewItem = lvwInfo.ListItems.Add(, , " " & sFieldName, , "info") 'Load the Value Call SetItemValue(NewItem, rs(sFieldName).Type, rs(sFieldName) & "", objTabs(Me.TabStrip1.SelectedItem.Index).Fields(i).Fields(j)) Next j Else 'Load the Value Call SetItemValue(NewItem, rs(sFieldName).Type, rs(sFieldName) & "", objTabs(Me.TabStrip1.SelectedItem.Index).Fields(i)) End If ProgressBar1.Value = (CLng(i) * 100) \ lCount Next i End If ProgressBar1.Value = 0 'Close Everything rs.Close db.Close EndSub: Screen.MousePointer = vbDefault SetCaption Exit Sub ErrHandler: Call SetErr(Err, Err.Description, Me.Name & ".LoadCountry") GoTo EndSub Resume End Sub Private Sub SetCaption() Dim sText As String If (tvwCountry.SelectedItem Is Nothing) Then sText = "<None>" Else sText = "[" & tvwCountry.SelectedItem.Text & "]" End If Me.Caption = App.CompanyName & " " & App.Title & " - " & sText End Sub Private Sub SetItemValue(ByVal NewItem As ListItem, ByVal lFieldType As Long, ByVal sFieldValue As String, ByVal objField As clsFieldEl) On Error GoTo ErrHandler Dim sFormat As String If Val(sFieldValue) = -1 Then sFieldValue = "NA" End If 'Put the precision on it if necessary sFormat = String(objField.Precision, "0") If Len(sFormat) > 0 Then sFormat = "." & sFormat sFormat = "###,###,###,###,##0" & sFormat Select Case lFieldType Case dbCurrency: sFieldValue = "$" & Format(sFieldValue, sFormat) 'Case adDecimal, adDouble, adInteger, adNumeric, adSingle, adSmallInt, adTinyInt, adUnsigneadigInt, adUnsignedInt, adUnsignedSmallInt, adUnsignedTinyInt: Case dbDouble, dbInteger, dbSingle: sFieldValue = Format(sFieldValue, sFormat) End Select NewItem.SubItems(1) = sFieldValue & " " & objField.Trailer EndSub: Exit Sub ErrHandler: Call SetErr(Err, Err.Description, Me.Name & ".SetItemValue") GoTo EndSub Resume End Sub Private Sub LoadTemplate() On Error GoTo ErrHandler 'This gets the Sections (tabs) from the template file Dim fle As Integer Dim sLineItem As String Dim sFieldName As String Dim sTrailer As String Dim sPrecision As String Dim lCount As Long Dim NewTab As clsItemEl Dim NewFieldCol As clsFieldCol Dim NewField As clsFieldEl Dim lIdx As Long objTabs.Clear fle = FreeFile Open AppPath & "template.txt" For Input As fle While Not EOF(fle) 'The line number lCount = lCount + 1 'Now find the next line Line Input #fle, sLineItem 'We are entering a new section, soes not apply to this program If Left(sLineItem, 1) = "!" Then Set NewTab = objTabs.Add(Trim(Right(sLineItem, Len(sLineItem) - 1)), lCount) GoTo LineProcessed End If 'We are entering Sub-Categories, so this header must exists first If Left(sLineItem, 1) = "~" Then 'Set the field to the current fields collection Set NewFieldCol = NewTab.Fields.Add(Trim(Right(sLineItem, Len(sLineItem) - 1)), "", 0).Fields GoTo LineProcessed End If If sLineItem = "" Then 'Set back to the tabs fields Set NewFieldCol = NewTab.Fields GoTo LineProcessed End If 'Parse the LineItem and get the information out of it lIdx = InStr(1, sLineItem, "|") If lIdx > 0 Then 'Get the Group Database fieldname sFieldName = Left(sLineItem, lIdx - 1) 'Get the Precision if this is a number sLineItem = Right(sLineItem, Len(sLineItem) - Len(sFieldName) - 1) lIdx = InStr(1, sLineItem, "|") sPrecision = Mid(sLineItem, 1, lIdx - 1) 'Get the Trailer that is the unit this value is in (km, in, etc...) sLineItem = Right(sLineItem, Len(sLineItem) - Len(sPrecision) - 1) lIdx = InStr(1, sLineItem, "|") sTrailer = Mid(sLineItem, 1, lIdx - 1) End If Call NewFieldCol.Add(sFieldName, sTrailer, Val(sPrecision)) LineProcessed: Wend EndSub: Close fle Set NewTab = Nothing Exit Sub ErrHandler: Call SetErr(Err, Err.Description, Me.Name & ".LoadTemplate") GoTo EndSub Resume End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyF5 Then LoadCountries End If End Sub Private Sub Form_Load() On Error GoTo ErrHandler Dim i As Integer If Not IsDataAware Then End Me.Width = Screen.Width * 0.6 Me.Height = Screen.Height * 0.6 Call SetCaption Call LoadTemplate lvwInfo.ColumnHeaders(1).Width = 2500 lvwInfo.ColumnHeaders(2).Width = 6000 'Load the TabStrip TabStrip1.Tabs.Clear For i = 1 To objTabs.Count Call TabStrip1.Tabs.Add(, , objTabs(i).FieldName) Next i EndSub: LoadCountries Exit Sub ErrHandler: Call SetErr(Err, Err.Description, Me.Name & ".Form_Load") GoTo EndSub Resume End Sub Private Function IsDataAware() As Boolean ' If GetConnectString = "" Then ' IsDataAware = False ' Call MsgBox("This application requires Microsoft's DCOM and ADO. They must be installed in this order as well." & vbCrLf & "These components can be download from our website at http://www.gravitybox.com", vbInformation, "Application Terminated") ' Else ' IsDataAware = True ' End If IsDataAware = True End Function Private Sub Form_Resize() On Error Resume Next tvwCountry.Move 0, 0, tvwCountry.Width, Me.ScaleHeight - ProgressBar1.Height TabStrip1.Move tvwCountry.Width, 0, Me.ScaleWidth - tvwCountry.Width, Me.ScaleHeight - ProgressBar1.Height lvwInfo.Move TabStrip1.Left + 120, (TabStrip1.Height - TabStrip1.ClientHeight), TabStrip1.Width - 240, Me.ScaleHeight - (TabStrip1.Height - TabStrip1.ClientHeight) - ProgressBar1.Height - 120 picPicture.Move lvwInfo.Left, lvwInfo.Top, lvwInfo.Width, lvwInfo.Height End Sub Private Sub imgPicture_DblClick() If imgPicture.Picture <> 0 Then Load frmFullPic Set frmFullPic.Image1.Picture = imgPicture.Picture frmFullPic.Caption = Me.tvwCountry.SelectedItem.Text frmFullPic.Width = frmFullPic.Image1.Width + (frmFullPic.Width - frmFullPic.ScaleWidth) frmFullPic.Height = frmFullPic.Image1.Height + (frmFullPic.Height - frmFullPic.ScaleHeight) frmFullPic.Show vbModal End If End Sub Private Sub lvwInfo_DblClick() If Not (lvwInfo.SelectedItem Is Nothing) Then Load frmSupp frmSupp.Caption = lvwInfo.SelectedItem.Text frmSupp.Text1.Text = lvwInfo.SelectedItem.SubItems(1) frmSupp.Show vbModal End If End Sub Private Sub lvwInfo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim NewItem As ListItem Set NewItem = lvwInfo.HitTest(X, Y) If (NewItem Is Nothing) Then lvwInfo.ToolTipText = "" Else lvwInfo.ToolTipText = NewItem.SubItems(1) Set lvwInfo.SelectedItem = NewItem End If End Sub Private Sub mnuFileExit_Click() Unload Me End Sub Private Sub mnuFileProperties_Click() Call MsgBox("Country Count: " & Me.tvwCountry.Nodes.Count, vbInformation) End Sub Private Sub mnuHelpAbout_Click() Set gAboutIcon = Me.Icon frmAbout.Show vbModal Set gAboutIcon = Nothing End Sub Private Sub mnuHelpCredits_Click() Dim sMsg As String sMsg = "The information contained in this program was taken off the CIA World FactBook Site. This site can be found at the following internet address:" & vbCrLf & vbCrLf & _ "http://www.odci.gov/cia/publications/factbook/" & vbCrLf & vbCrLf & _ "All information contained within is property of the CIA and all accuracy is a direct result of CIA compilation of this information. GravityBox Software has only built this application to better display the given information. Neither this program nor its information content is for sale." Call MsgBox(sMsg, vbInformation) End Sub Private Sub picPicture_Resize() On Error Resume Next imgPicture.Move 0, 0, picPicture.Width, picPicture.Height End Sub Private Sub TabStrip1_Click() If Not (tvwCountry.SelectedItem Is Nothing) Then Call LoadCountry(tvwCountry.SelectedItem.Tag) End If End Sub Private Sub tvwCountry_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim NewNode As Node Set NewNode = tvwCountry.HitTest(X, Y) If (NewNode Is Nothing) Then tvwCountry.ToolTipText = "" Else tvwCountry.ToolTipText = NewNode.Text End If End Sub Private Sub tvwCountry_NodeClick(ByVal Node As ComctlLib.Node) Call LoadCountry(Node.Tag) End Sub 
(.txt)