mod_main.bas

用VB开发的巡检系统基于MAPINFo用VB开发的巡检系统基于MAPINFo很好的

Attribute VB_Name = "mod_main"
Option Explicit
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Global g_InitWorkSpace As String '初始化工作空间文件路径
Global g_Buffer As Single '缓冲半径

Global g_Com As Integer
Global g_BTL As Long

Global gblCn As ADODB.Connection

Global gblRs As ADODB.Recordset

'##################刘登杰
Public gramgps As Boolean '由于共用一个临时文件，限制一次只能运行一个处理

Public bchuli As Boolean ''是否正确处理文件

'##################刘登杰


'//系统运行
Public Sub Main()
    If App.PrevInstance Then
        MsgBox "系统已经运行，请退出后再重新登录！", vbInformation, "提示"
        End
    Else
        '获取配置参数
        g_InitWorkSpace = reIni("Project", "WorkPath")
        g_Buffer = reIni("Project", "Buffer")
        
        g_Com = reIni("GPS", "Com")
        g_BTL = reIni("GPS", "BTL")
        
        '初始化数据库
        InitializeDatabase
        
        frmSplash.Show
'        DoEvents
'        Set fMainForm = New MDIFrmMain
'        fMainForm.Show
    End If
End Sub


'初始化数据库
Sub InitializeDatabase()
    Dim strCurDir As String
    On Error GoTo err_lab
    strCurDir = App.Path + "\系统数据库\ProXJXT_DB.mdb"
    Set gblCn = New ADODB.Connection
    With gblCn
        .CursorLocation = adUseClient
        .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
            & strCurDir & ";Persist Security Info=False"
        .ConnectionTimeout = 30
        .Open
    End With
    Set gblRs = New ADODB.Recordset
    Exit Sub
err_lab:
    MsgBox Err.Number + ":" + Err.Description, vbOKOnly + vbCritical, "提示"
End Sub


'//读取系统资源文件
Public Sub LoadResStrings(ByVal frm As Form)
      Dim objCtrl As Control
      Dim obj As Object
      Dim fnt As Object
      Dim sCtlType As String
      Dim nVal As Integer
      Dim I As Integer
      
      'On Error Resume Next
      If frm.Tag <> "" Then
            frm.Caption = LoadResString(CInt(frm.Tag))
      End If
      
      'MDI窗体没有Font属性
      If frm.Name <> "MDIFrmMain" Then
            Set fnt = frm.Font
            '根据不同系统设置不同的字体
            fnt.Name = "宋体"
            fnt.Size = 8
      End If
      '装入各控件的资源串和设置字体
      For Each objCtrl In frm.Controls
        sCtlType = TypeName(objCtrl)
        'objCtrl.Font = fnt            '设各控件的字体与窗体一样
        If sCtlType = "Label" Then
              'objCtrl.Caption = LoadResString(CInt(objCtrl.Tag))
        ElseIf sCtlType = "Menu" Then
            If objCtrl.Caption <> "-" Then
                  objCtrl.Caption = LoadResString(CInt(objCtrl.Caption))
            End If
        ElseIf sCtlType = "TabStrip" Then
            'For Each obj In objCtrl.Tabs
            '    obj.Caption = LoadResString(CInt(obj.Tag))
            '    obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
            'Next
        ElseIf sCtlType = "SSTab" Then
            'For i = 0 To objCtrl.Tabs - 1
            '    objCtrl.TabCaption(i) = LoadResString(CInt(objCtrl.TabCaption(i)))
            'Next
        ElseIf sCtlType = "Toolbar" Then
            'For Each obj In objCtrl.Buttons
            '    obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
            '    obj.Description = obj.ToolTipText
            '    For i = 1 To obj.ButtonMenus.Count
            '        obj.ButtonMenus(i).Text = LoadResString(CInt(obj.ButtonMenus(i).Tag))
            '    Next
            'Next
        ElseIf sCtlType = "ListView" Then
            'For Each obj In objCtrl.ColumnHeaders
            '    obj.Text = LoadResString(CInt(obj.Tag))
            'Next
        ElseIf sCtlType = "TreeView" Then
            'For Each obj In objCtrl.ColumnHeaders
            '    obj.Text = LoadResString(CInt(obj.Tag))
            'Next
        Else
            'nVal = 0
            'nVal = Val(objCtrl.Tag)
            'If nVal > 0 Then objCtrl.Caption = LoadResString(nVal)
            'nVal = 0
            'nVal = Val(objCtrl.ToolTipText)
            'If nVal > 0 Then objCtrl.ToolTipText = LoadResString(nVal)
        End If
      Next
End Sub


'//wcs
'//函数：读取系统配置文件
Function reIni(AppName As String, KeyName As String) As String
    Dim rc As Long
    Dim re As String
    re = String(100, " ")
    rc = GetPrivateProfileString(ByVal AppName, ByVal KeyName, ByVal "0", ByVal re, ByVal 100, ByVal App.Path + "\ProCFG.INI")
    reIni = DropNull(re)
    'Debug.Print reINI
End Function

'==========================================
'函数功能：写入配置文件
'输入参数：段名、关键名、写入值、文件路径
'输出参数：返回写入值是否成功标志
'//设 计 者：wcs
'==========================================
Public Function Set_ProfileStringINI(ByVal strSectName As String, ByVal strKeyName As String, ByVal strValue As String, ByVal strFilePath As String) As Boolean
    If Dir$(strFilePath, vbDirectory) = "" Then
        Exit Function
    End If
    Dim lg As Long
    lg = WritePrivateProfileString(strSectName, strKeyName, strValue, strFilePath) '//如果没有节，则系统自动写入节、关键字、值
    Set_ProfileStringINI = True
    Exit Function
End Function

Function DropNull(str1 As String) As String
    Dim n As String
    n = InStr(1, str1, Chr(0))
    DropNull = Mid$(str1, 1, n - 1)
End Function

'解析GPS数据包(根据","解析串)
'源字符串、制定从第几位","号开始记数
Function ReadString_GPS_Package(ByVal sT As String, ByVal iPos As Integer) As String
    Dim m As Integer, s As String, leng As Integer, K As Integer, w As Integer, z As Integer, bl As Boolean
    Dim tmp As String
    leng = Len(sT)
    For m = 1 To leng
        s = Mid$(sT, m, 1)
        'Debug.Print s
        If s = "," Then
            K = K + 1
            If K = iPos Then
                w = w + 1
                bl = True
                'Debug.Print Mid$(sT, 1, w)
            ElseIf K = iPos + 1 Then
                tmp = Mid$(sT, w + 1, z)
                'Debug.Print tmp
                Exit For
            Else
                w = w + 1
            End If
        Else
            If bl Then
                z = z + 1
            Else
                w = w + 1
            End If
        End If
    Next
    ReadString_GPS_Package = tmp
End Function