mainprog.bas

1.系统采用MapxX4.0进行GIS开发

Attribute VB_Name = "mainprog"
Option Explicit
'system captions
Public Const CUSTOMCOMPANYNAME As String = ""
Public Const PROGRAMTITLE As String = "房屋面积计算"
Public Const SYSTEMTITLE As String = CUSTOMCOMPANYNAME + PROGRAMTITLE
Public Const COMPANYNAME As String = ""
Public Const VERSIONTYPE As String = "(单机版)"
Public Const IFQUITTHESYSTEM As String = "您真的要退出本系统吗?" & vbCrLf & "(建议每天整理和备份数据库)"
'about the *.mdb
Public Const BK_COMPLETED As String = "数据库备份完毕，欢迎继续使用本系统。"
Public Const BK_TIDYUP As String = "数据库整理完毕，欢迎继续使用本系统。"
Public Const BK_RECOVERED As String = "数据库已经成功恢复，欢迎继续使用本系统。"
Public Const BK_PROMPT As String = "数据库不存在，请先恢复数据库。"
Public Const BK_SYSRECOVERED As String = "数据库已经成功恢复，欢迎继续使用本系统。"

'API
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

'used in SetWindowPos
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const HWND_TOPMOST = -1
'-----------------------------------
Public Const PI_IN_MATH = 3.14159265
Public Const OFFSET_OUT = 1 '向外偏移
Public Const OFFSET_IN = 0 '向内偏移
'global variable
Global fMainForm As frmMain '主窗口
Global sysLog As SYSTEMLOG '系统日志变量
Global MAP_CONN As ADODB.Connection '数据库连接
'use this type to record the WorkArea
Public Type rect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Type POINTAPI
    x As Long
    y As Long
End Type
'------------------------
'UPoint:是指Map坐标
'--------------------------
Public Type UPoint
    x As Double
    y As Double
End Type
'----------------------------
'SCPoint：是指Screen坐标
'-----------------------------
Public Type SCPoint
    x As Single
    y As Single
End Type

'use this type to record system log
Public Type SYSTEMLOG
    DateTime As String
    ComputerName As String
    IPAddress As String
    User As String
    SoftwareName As String
    SysInformation As String
End Type
'about the system.log
Global SYSTEM_LOG_PATH As String
'数据库路径及数据库、连接字符串
Global DATABASE_PATH As String '总的数据库目录
Global BK_PATH As String '数据库备份目录
Global DATABASE_STRING As String '数据库连接字符串
'------------------
Global Const DATABASE_PROVIDER As String = "Microsoft.Jet.OLEDB.3.51"
Global Const DATABASE_FILENAME As String = "housedb.mdb" '数据库名
Global Const DATABASE_PREFACE As String = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source="
'--------table path
Global TABLE_PATH As String '--------table path
Global CURRENT_LAYER As String
Global REGION_LAYER As String
Global LINE_LAYER As String
'Global LAYER_CURNAME As String

'---------------------------------
'作者：高飞
'日期：2000.11.20
'-----------------------------------
Sub Main()
    On Error GoTo ErrHandler
    Dim i As Long
    Dim frm As Form
    Dim curPath As String
    Dim begtt
    Dim fs As Scripting.FileSystemObject
   
    '--------------------------------
    '1:显示splash
    '-----------------------------------
    Screen.MousePointer = 11
    Set frm = New frmSplash
    DoEvents '加速显示
    Load frm
    frm.Refresh '加速显示
    frm.Show
    DoEvents '加速显示
    begtt = Timer '记录当前时间
    '--------------------------------------
    '2:连接数据库等信息
    '------------------------------------------
    '设置数据库路径
    curPath = App.path
    If Right(curPath, 1) <> "\" Then
        curPath = curPath & "\"
    End If
    
    TABLE_PATH = curPath & "tab\" '图表文件存储path
    SYSTEM_LOG_PATH = curPath '日志路径
    BK_PATH = curPath & "backup\" '数据库备份路径
    DATABASE_PATH = curPath & "db\" '真正的数据库路径
    
    Set fs = New Scripting.FileSystemObject
    If Not fs.FolderExists(TABLE_PATH) Then
        fs.CreateFolder (TABLE_PATH)
    End If
    If Not fs.FolderExists(BK_PATH) Then
        fs.CreateFolder (BK_PATH)
    End If
    If Not fs.FolderExists(DATABASE_PATH) Then
        fs.CreateFolder (DATABASE_PATH)
    End If
    
    Set fs = Nothing
    '设置数据库连接字符串
    DATABASE_STRING = DATABASE_PREFACE & DATABASE_PATH & DATABASE_FILENAME
    '-----------------------------------------
    '连接数据库----------------
    Set MAP_CONN = New ADODB.Connection
    With MAP_CONN
        .CursorLocation = adUseClient
        .ConnectionString = DATABASE_STRING
        .Open
    End With
    '-------------------------
    '3:获取系统信息
    '--------------------------------------------
    Call GetSystemInformation
    '-------------------------
    '4:显示主窗口
    Set fMainForm = New frmMain
    '设置主窗口的标题
    fMainForm.Caption = SYSTEMTITLE
    Load fMainForm
    fMainForm.Show
    '----------------------------------------------
    '5:测试splash是否显示了2秒，如果没有，则继续显示
    '---------------------------------------------
    Screen.MousePointer = 0
    While Timer < begtt + 1
    Wend
    '--------------------------------------------
    '6:卸载splash
    '-------------------------------------------------
    Unload frm
    '----------------------------
    '记录日志
    WriteToLog ("")
    Screen.MousePointer = 0
    Exit Sub
ErrHandler:
    ErrMessageBox "Main()", "启动过程出错"
    'close all sub forms
    For i = Forms.Count - 1 To 1 Step -1
        Unload Forms(i)
    Next
    '
    End
End Sub
'错误处理函数
Public Sub ErrMessageBox(ByVal sPrompt As String, ByVal sTitle As String)
    Dim msg As String
    Dim ErrMsg As String
    '报告错误
    ErrMsg = "错误#" & CStr(Err.Number) & "：" & Err.Description
    msg = sPrompt & vbCrLf & ErrMsg
    MsgBox msg, vbOKOnly + vbExclamation, sTitle
    
    msg = sPrompt & vbCrLf & ErrMsg
    '将错误记录添加入系统日志
    Call WriteToLog(msg)
    
    '清除错误记录
    Err.Clear
End Sub
'判断一个对象是否Valid
Public Function IsInvalidObject(Obj As Variant) As Boolean
    If IsNull(Obj) = True Or IsEmpty(Obj) = True Or TypeName(Obj) = "Nothing" Then
        IsInvalidObject = True
    Else
        IsInvalidObject = False
    End If
End Function
'this function get the workarea of windows in spite of the taskbar
Public Function GetWorkArea() As rect
    Dim theArea As rect
    Dim tmpVal As Long
    
    tmpVal = SystemParametersInfo(48, 0, theArea, 0)
    GetWorkArea = theArea
End Function
' Returns true if lyr is the current insertion layer
Public Function IsInsertionLayer(Lyr As Layer, MapCtl As Map) As Boolean
    If IsInvalidObject(MapCtl.Layers.InsertionLayer) Then
        IsInsertionLayer = False
    ElseIf Lyr = MapCtl.Layers.InsertionLayer Then
        IsInsertionLayer = True
    Else
        IsInsertionLayer = False
    End If
End Function
' Return true if the layer is permanent. We do this by seeing if the layer has a
' .tab extension. If it's a temporary layer, it'll have a ".tmp" extension.
Public Function IsPermanent(Lyr As Layer) As Boolean
    If LCase$(Right$(Lyr.Filespec, 3)) = "tab" Then
        IsPermanent = True
    Else
        IsPermanent = False
    End If
End Function
'获取系统信息
Private Sub GetSystemInformation()
    Dim cjd As CJDFun.CFunction
    
    On Error GoTo ErrHandler
    Set cjd = New CJDFun.CFunction
    sysLog.IPAddress = cjd.GetComputerIP()
    sysLog.ComputerName = cjd.GetComputerNm()
    sysLog.SoftwareName = SYSTEMTITLE
    '使用者的代码还需添加
    sysLog.User = ""
    If Not cjd Is Nothing Then
        Set cjd = Nothing
    End If
    Exit Sub
ErrHandler:
    If Not cjd Is Nothing Then
        Set cjd = Nothing
    End If
End Sub
'日志记录函数
Public Sub WriteToLog(Information As String)
    On Error GoTo ErrHandler
    '记录日期、时间、计算机名称、登录者、登录信息、软件系统名称
    Dim dt As String
    Dim info As String
    Dim sysfo As String
    
    dt = Format(Date, "Long Date") & Format(Time, "Long Time")
    sysLog.DateTime = dt
    sysfo = sysLog.DateTime & _
          "——机器名#" & sysLog.ComputerName & _
          "——IP地址#" & sysLog.IPAddress & _
          "——系统名#" & sysLog.SoftwareName & _
          "——登录者#" & sysLog.User & _
          Information & vbCrLf & vbCrLf
    'write to the system.log
    'first:判断制定路径的文件是否存在
    Dim fs As Scripting.FileSystemObject
    Dim FileName As String
    Dim EXEPath As String
    Dim FileNum As Integer
    
    EXEPath = App.path & "\" & "system.log"
    FileName = SYSTEM_LOG_PATH & "system.log"
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    '如果数据库服务器上没有日志文件，则判断工作站是否存在该文件，如果存在，则
    'copy一份过去
    If Not fs.FileExists(FileName) Then
        If fs.FileExists(EXEPath) Then
            fs.CopyFile EXEPath, FileName
        End If
    End If
    
    'second:采用二进制格式打开文件
    FileNum = FreeFile()
    Open FileName For Binary Access Write Lock Write As #FileNum
    
    Put #FileNum, LOF(FileNum) + 1, sysfo
    
    'close the filename
    Close #FileNum
    Set fs = Nothing
    
    Exit Sub
ErrHandler:
    Close #FileNum
    MsgBox "Public WriteToLog()" & vbCrLf & _
           "错误#" & Err.Number & ":" & Err.Description, vbOKOnly + vbExclamation, SYSTEMTITLE
End Sub
Public Function ReadFromLog() As String
    On Error GoTo ErrHandler
    'Read from "system.log"
    'first:判断制定路径的文件是否存在
    Dim fs As Scripting.FileSystemObject
    Dim FileName As String
    Dim EXEPath As String
    Dim FileNum As Integer
    
    EXEPath = App.path & "\" & "system.log"
    FileName = SYSTEM_LOG_PATH & "system.log"
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    '如果数据库服务器上没有日志文件，则判断工作站是否存在该文件，如果存在，则
    'copy一份过去
    If Not fs.FileExists(FileName) Then
        If fs.FileExists(EXEPath) Then
            fs.CopyFile EXEPath, FileName
        End If