frmfront.frm

一个交通专用的gis-T系统

VERSION 5.00
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "tabctl32.ocx"
Begin VB.Form frmFront 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "开始..."
   ClientHeight    =   3675
   ClientLeft      =   1425
   ClientTop       =   2175
   ClientWidth     =   5385
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3675
   ScaleWidth      =   5385
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command5 
      Caption         =   "关闭(&C)"
      Height          =   375
      Left            =   4320
      TabIndex        =   17
      Top             =   3240
      Width           =   975
   End
   Begin TabDlg.SSTab SSTab1 
      Height          =   3015
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   5175
      _ExtentX        =   9128
      _ExtentY        =   5318
      _Version        =   393216
      TabHeight       =   520
      TabCaption(0)   =   "新建项目"
      TabPicture(0)   =   "frmFront.frx":0000
      Tab(0).ControlEnabled=   -1  'True
      Tab(0).Control(0)=   "Label3"
      Tab(0).Control(0).Enabled=   0   'False
      Tab(0).Control(1)=   "Label2"
      Tab(0).Control(1).Enabled=   0   'False
      Tab(0).Control(2)=   "Label4"
      Tab(0).Control(2).Enabled=   0   'False
      Tab(0).Control(3)=   "cmdFAQ"
      Tab(0).Control(3).Enabled=   0   'False
      Tab(0).Control(4)=   "cmdFeedBack"
      Tab(0).Control(4).Enabled=   0   'False
      Tab(0).Control(5)=   "cmdBlank"
      Tab(0).Control(5).Enabled=   0   'False
      Tab(0).ControlCount=   6
      TabCaption(1)   =   "打开项目"
      TabPicture(1)   =   "frmFront.frx":001C
      Tab(1).ControlEnabled=   0   'False
      Tab(1).Control(0)=   "Command2"
      Tab(1).Control(1)=   "Command1"
      Tab(1).Control(2)=   "txtFileName"
      Tab(1).Control(3)=   "filFileName"
      Tab(1).Control(3).Enabled=   0   'False
      Tab(1).Control(4)=   "DirDirectory"
      Tab(1).Control(4).Enabled=   0   'False
      Tab(1).Control(5)=   "drvDrive"
      Tab(1).Control(5).Enabled=   0   'False
      Tab(1).Control(6)=   "Label1"
      Tab(1).ControlCount=   7
      TabCaption(2)   =   "最近..."
      TabPicture(2)   =   "frmFront.frx":0038
      Tab(2).ControlEnabled=   0   'False
      Tab(2).Control(0)=   "RecentFiles"
      Tab(2).Control(1)=   "Command4"
      Tab(2).Control(2)=   "Command3"
      Tab(2).ControlCount=   3
      Begin VB.ListBox RecentFiles 
         Height          =   1680
         Left            =   -74880
         TabIndex        =   13
         Top             =   480
         Width           =   4935
      End
      Begin VB.CommandButton Command4 
         Caption         =   "取消(&C)"
         Height          =   375
         Left            =   -70800
         TabIndex        =   12
         Top             =   2520
         Width           =   855
      End
      Begin VB.CommandButton Command3 
         Caption         =   "打开(&O)"
         Height          =   375
         Left            =   -71880
         TabIndex        =   11
         Top             =   2520
         Width           =   975
      End
      Begin VB.CommandButton Command2 
         Caption         =   "取消(&C)"
         Height          =   375
         Left            =   -70800
         TabIndex        =   10
         Top             =   2480
         Width           =   855
      End
      Begin VB.CommandButton Command1 
         Caption         =   "打开(&O)"
         Height          =   375
         Left            =   -71760
         TabIndex        =   9
         Top             =   2480
         Width           =   855
      End
      Begin VB.TextBox txtFileName 
         Height          =   285
         Left            =   -74160
         TabIndex        =   8
         Top             =   2520
         Width           =   2295
      End
      Begin VB.FileListBox filFileName 
         Height          =   1710
         Left            =   -72960
         Pattern         =   "*.mdb"
         TabIndex        =   6
         TabStop         =   0   'False
         Top             =   480
         Width           =   3015
      End
      Begin VB.DirListBox DirDirectory 
         Height          =   1440
         Left            =   -74880
         TabIndex        =   5
         TabStop         =   0   'False
         Top             =   840
         Width           =   1815
      End
      Begin VB.DriveListBox drvDrive 
         Height          =   315
         Left            =   -74880
         TabIndex        =   4
         TabStop         =   0   'False
         Top             =   480
         Width           =   1815
      End
      Begin VB.CommandButton cmdBlank 
         BackColor       =   &H80000009&
         Caption         =   "新建路网"
         Height          =   855
         Left            =   360
         MaskColor       =   &H00FFFFFF&
         Picture         =   "frmFront.frx":0054
         Style           =   1  'Graphical
         TabIndex        =   3
         ToolTipText     =   "Blank Page"
         Top             =   1800
         Width           =   975
      End
      Begin VB.CommandButton cmdFeedBack 
         BackColor       =   &H80000009&
         Caption         =   "导入路网"
         Height          =   855
         Left            =   2040
         MaskColor       =   &H00FFFFFF&
         Picture         =   "frmFront.frx":0496
         Style           =   1  'Graphical
         TabIndex        =   2
         ToolTipText     =   "Feed Back Template"
         Top             =   1800
         Width           =   975
      End
      Begin VB.CommandButton cmdFAQ 
         BackColor       =   &H80000009&
         Caption         =   "在线帮助"
         Height          =   855
         Left            =   3720
         MaskColor       =   &H00FFFFFF&
         Picture         =   "frmFront.frx":08D8
         Style           =   1  'Graphical
         TabIndex        =   1
         ToolTipText     =   "Frequent Asked Questions Template"
         Top             =   1800
         Width           =   975
      End
      Begin VB.Label Label4 
         BackStyle       =   0  'Transparent
         Caption         =   "欢迎使用GIS-T Interface！"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   15
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   240
         TabIndex        =   16
         Top             =   600
         Width           =   4335
      End
      Begin VB.Label Label2 
         BackStyle       =   0  'Transparent
         Caption         =   $"frmFront.frx":0D1A
         Height          =   735
         Left            =   240
         TabIndex        =   14
         Top             =   1080
         Width           =   4695
      End
      Begin VB.Label Label1 
         Caption         =   "文件名："
         Height          =   255
         Left            =   -74880
         TabIndex        =   7
         Top             =   2560
         Width           =   975
      End
      Begin VB.Label Label3 
         BackColor       =   &H00FFFFFF&
         BorderStyle     =   1  'Fixed Single
         Height          =   2415
         Left            =   120
         TabIndex        =   15
         Top             =   480
         Width           =   4935
      End
   End
End
Attribute VB_Name = "frmFront"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*********************************************************************
'*
'*                本源码完全免费，共交通同仁学习参考                 *
'*                      www.tranbbs.com                              *
'*                   Developed by Yang Ming                          *
'*       Nanjing Institute of City Transportation Planning           *
'*                 请保留本版权信息，谢谢合作                        *
'*                      中国交通技术论坛                             *
'*                                                                   *
'*                                                                   *
'*********************************************************************
Option Explicit
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hWnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
'See Module1.bas for global variable declarations
Private Declare Function HtmlHelpA Lib "hhctrl.ocx" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long




Private Sub cmdBlank_Click()
    Load FrmNewProject
    FrmNewProject.Show
    Unload Me
End Sub


Private Sub cmdFAQ_Click()
    Unload Me
    Dim tempstr
    tempstr = App.Path & "\HELP.CHM::/html/newproject.htm"
    HtmlHelpA Main.hWnd, tempstr, 0, 0
End Sub

Private Sub cmdFeedBack_Click()
    Load Frmwizard
    Frmwizard.Show
    Unload Me
End Sub

Private Sub Command1_Click()
    Dim sFile, sDir
    Dim RespErr
    
    On Error GoTo MapErr
    sFile = txtFileName.Text
    
    If sFile <> "" Then
        Set mDbBiblio = DBEngine.Workspaces(0).OpenDatabase(sFile)
    
        Dim FilePlace
        FilePlace = InStrRev(sFile, "\")
            
        sDir = Left(sFile, FilePlace)
        Dim Lyr As mapxlib.Layer
        ProjectPath = sDir
        MDBPath = sFile
        
        Main.Mapshow.Layers.Add sDir & "link.tab"
        Main.Mapshow.Layers.Add sDir & "node.tab"
        Set Lyr = Main.Mapshow.Layers("Link")
        Main.Mapshow.Bounds = Lyr.Bounds
        
        
        
        Open ProjectPath & "setup.ini" For Input As #1
        Do While Not EOF(1)
        Input #1, NodeRadius, NodeColor, LinkWidth, LinkColor
        Loop
        Close #1
        Call MnuControl
        
        Open app_path & "\setup\recent.dat" For Append As #1
        Print #1, sFile
        Close #1
        
    Else
    
        Me.Hide
        RespErr = MsgBox("打开项目错误，请选择有效的项目文件！", vbExclamation, "项目打开错误！")
        Me.Show
        Exit Sub
        
    End If
    
    Unload Me
    Exit Sub
    
MapErr:
    Me.Hide
    RespErr = MsgBox("打开项目错误，请检查项目文件是否完整！", vbExclamation, "项目打开错误！")
    Me.Show
    Close #1
    
    
End Sub

Private Sub Command2_Click()
    Unload Me
    
End Sub

Private Sub Command3_Click()
Dim sFile, sDir
Dim RespErr
sFile = RecentFiles.Text

On Error GoTo MapErr
If sFile <> "" Then
        Set mDbBiblio = DBEngine.Workspaces(0).OpenDatabase(sFile)
    
        Dim FilePlace
        FilePlace = InStrRev(sFile, "\")
            
        sDir = Left(sFile, FilePlace)
        Dim Lyr As mapxlib.Layer
        ProjectPath = sDir
        MDBPath = sFile
        
        Main.Mapshow.Layers.Add sDir & "link.tab"
        Main.Mapshow.Layers.Add sDir & "node.tab"
        Set Lyr = Main.Mapshow.Layers("Link")
        Main.Mapshow.Bounds = Lyr.Bounds
        
        
        
        Open ProjectPath & "setup.ini" For Input As #1
        Do While Not EOF(1)
        Input #1, NodeRadius, NodeColor, LinkWidth, LinkColor
        Loop
        Close #1
        Call MnuControl
        
        Open app_path & "\setup\recent.dat" For Append As #1
        Print #1, sFile
        Close #1
        
    Else
    
        Me.Hide
        RespErr = MsgBox("打开项目错误，请选择有效的项目文件！", vbExclamation, "项目打开错误！")
        Me.Show
        Exit Sub
        
    End If
    
    Unload Me
    Exit Sub
    
MapErr:
    Me.Hide
    RespErr = MsgBox("打开项目错误，请检查项目文件是否完整！", vbExclamation, "项目打开错误！")
    Me.Show
    Close #1
    
    
End Sub

Private Sub Command4_Click()
    Unload Me
End Sub

Private Sub Command5_Click()
    Unload Me
End Sub

Private Sub DirDirectory_Change()
filFileName.Path = DirDirectory.Path
End Sub

Private Sub drvDrive_Change()
DirDirectory.Path = drvDrive.Drive
End Sub

Private Sub filFileName_Click()
Dim intFileNum As Integer
Dim strTextLine As String, strFileName As String
If Right(DirDirectory.Path, 1) = "\" Then
strFileName = filFileName.Path & filFileName.FileName
Else
strFileName = filFileName.Path & "\" & filFileName.FileName
End If
txtFileName.Text = ""
txtFileName.Text = strFileName
End Sub

Function app_path() As String
'this will tell us where is the ME located.
    Dim x As String
    x = App.Path
    If Right$(x, 1) <> "\" Then x = x + "\"
    app_path = UCase$(x)
    
End Function

Private Sub Form_Load()
' Stay on top.
Call KeepOnTop(Me)
' for recent files
Dim intFileNum As Integer
Dim strTextLine As String, strFileName As String
intFileNum = FreeFile
Open app_path & "\setup\recent.dat" For Input As #intFileNum
Do While Not EOF(intFileNum)
Line Input #intFileNum, strTextLine
RecentFiles.AddItem strTextLine
Loop
Close #intFileNum

End Sub

Private Sub Picture2_Click()

End Sub

Private Sub RecentFiles_DblClick()
Dim sFile, sDir
Dim RespErr
sFile = RecentFiles.Text

On Error GoTo MapErr
If sFile <> "" Then
        Set mDbBiblio = DBEngine.Workspaces(0).OpenDatabase(sFile)
    
        Dim FilePlace
        FilePlace = InStrRev(sFile, "\")
            
        sDir = Left(sFile, FilePlace)
        Dim Lyr As mapxlib.Layer
        ProjectPath = sDir
        MDBPath = sFile
        
        Main.Mapshow.Layers.Add sDir & "link.tab"
        Main.Mapshow.Layers.Add sDir & "node.tab"
        Set Lyr = Main.Mapshow.Layers("Link")
        Main.Mapshow.Bounds = Lyr.Bounds
        
        
        
        Open ProjectPath & "setup.ini" For Input As #1
        Do While Not EOF(1)
        Input #1, NodeRadius, NodeColor, LinkWidth, LinkColor
        Loop
        Close #1
        Call MnuControl
        
        Open app_path & "\setup\recent.dat" For Append As #1
        Print #1, sFile
        Close #1
        
    Else
    
        Me.Hide
        RespErr = MsgBox("打开项目错误，请选择有效的项目文件！", vbExclamation, "项目打开错误！")
        Me.Show
        Exit Sub
        
    End If
    
    Unload Me
    Exit Sub
    
MapErr:
    Me.Hide
    
    RespErr = MsgBox("打开项目错误，请检查项目文件是否完整！", vbExclamation, "项目打开错误！")
    Me.Show
    Close #1

End Sub