basemodule.bas

一个为公安系统接警中心控制软件,不错哦.

Attribute VB_Name = "BaseModule"
Option Explicit
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
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 SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SCREENSAVERRUNNING = 97

Sub SetForm(frm As Form, FntSize As Integer)
    On Error Resume Next
    Dim ctl As Control
    Dim obj As Object, fnt As Object
    Dim sCtlType As String, nVal As Integer
    
'    frm.Caption = LoadResString(CInt(frm.Tag))
    For Each ctl In frm.Controls
        sCtlType = TypeName(ctl)
        If ctl.Font.Size < FntSize Then
            ctl.Font.Name = "宋体"    '= fnt
            ctl.Font.Size = FntSize
            If sCtlType = "Label" Then
                ctl.Caption = LoadResString(CInt(ctl.Tag))
            ElseIf sCtlType = "Menu" Then
                ctl.Caption = LoadResString(CInt(ctl.Caption))
            ElseIf sCtlType = "TabStrip" Then
                For Each obj In ctl.Tabs
                    obj.Caption = LoadResString(CInt(obj.Tag))
                    obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
                Next
            ElseIf sCtlType = "Toolbar" Then
                For Each obj In ctl.Buttons
                    obj.ToolTipText = LoadResString(CInt(obj.ToolTipText))
                Next
            ElseIf sCtlType = "ListView" Then
                For Each obj In ctl.ColumnHeaders
                    obj.Text = LoadResString(CInt(obj.Tag))
                Next
            ElseIf sCtlType = "DBGrid" Or sCtlType = "DataGrid" Then
                Set ctl.HeadFont.Name = "宋体"
                ctl.HeadFont.Size = FntSize
            Else
                nVal = 0
                nVal = Val(ctl.Tag)
                If nVal > 0 Then ctl.Caption = LoadResString(nVal)
                nVal = 0
                nVal = Val(ctl.ToolTipText)
                If nVal > 0 Then ctl.ToolTipText = LoadResString(nVal)
            End If
        End If
    Next
End Sub

Public Sub SetColumnWidth(ByRef WidthString As String, ByRef Mycolumn As Object, nDefault As Integer)
    Dim CommaPos As Integer

    CommaPos = InStr(1, WidthString, ",")
    If CommaPos > 0 Then
        Mycolumn.Width = Val(Mid(WidthString, 1, CommaPos - 1))
        WidthString = Mid(WidthString, CommaPos + 1)
        Exit Sub
    Else
        If WidthString = "" Then
            Mycolumn.Width = nDefault
            Exit Sub
        Else
            Mycolumn.Width = Val(WidthString)
            WidthString = ""
            Exit Sub
        End If
    End If
End Sub

Sub SaveGridColWidth(sSection As String, ByRef Grd As Object)
    Dim i As Integer
    Dim grdWidth As String
    
    grdWidth = ""
    With Grd
        For i = 0 To Grd.Columns.Count - 1
            If Grd.Columns(i).Visible = False Then
                PutString grdWidth, 0
            ElseIf Grd.Columns(i).Width <= 60 Then
                PutString grdWidth, 60
            Else
                PutString grdWidth, Grd.Columns(i).Width
            End If
        Next
    End With
    SavePrivateSetting sSection, "GrdWidth", grdWidth
End Sub

Sub PutString(ByRef WidthString As String, nWidth As Integer)
    If WidthString = "" Then
        WidthString = WidthString & nWidth
    Else
        WidthString = WidthString & "," & nWidth
    End If
End Sub

'///////////////////////////////////////
'//若缺省ini文件名, 则默认与EXE文件同名
'///////////////////////////////////////
Function SavePrivateSetting(Section As String, Item As String, Setting As Variant, Optional sIniFile As String)
    If sIniFile = vbNullString Then
        sIniFile = App.Path & "\" & App.EXEName & ".INI"
    End If
    
    Dim SettingStr As String
    Dim X As Integer
    SettingStr = Setting
    X = WritePrivateProfileString(Section, Item, SettingStr, sIniFile)
End Function

'///////////////////////////////////////
'//若缺省ini文件名, 则默认与EXE文件同名
'///////////////////////////////////////
Function GetPrivateSetting(Section As String, Item As String, Default As Variant, Optional sIniFile As String) As Variant
    If sIniFile = vbNullString Then
        sIniFile = App.Path & "\" & App.EXEName & ".INI"
    End If
    
    Dim X As Long
    Dim sBuffer As String
    sBuffer = Space(32767)
    
    X = GetPrivateProfileString(Section, Item, Default, sBuffer, Len(sBuffer), sIniFile)
    GetPrivateSetting = DelNullChar(Trim(sBuffer))
    If GetPrivateSetting = "" Then
        GetPrivateSetting = Default
    End If
End Function

Function DelNullChar(Str) As String
    Dim nPos As Integer, sTemp As String
    nPos = InStr(1, Str, Chr(0))
    If nPos > 0 Then
        sTemp = Left(Str, nPos - 1)
    Else
        sTemp = Str
    End If
    DelNullChar = sTemp
End Function

''/////////////////////////////////////////////////////////////////////////////////
''//nMode 代表关键字段属性：=0, 表示字符编码性质；=1, 表示数值型；=2, 表示一般文字性质
''/////////////////////////////////////////////////////////////////////////////////
Function GetFilterString(sText As String, sKeyField As String, nMode As Integer) As String
    sText = Trim(sText)
    If sText = "" Then
        GetFilterString = ""
        Exit Function
    End If
    
    Dim sFilter As String, nWordLen As Integer
    Dim nPos As Integer, nCommaPos As Integer
    nWordLen = Len("字")
    
    If nMode = 0 Or nMode = 1 Then      '按字符编码或数值检索
        Dim sTemp As String, sChar As String, i As Integer, j As Integer
        Dim arFlag() As String, nFlagNum As Integer

        sText = UCase(sText)
        Do            '全角逗号替换为半角逗号, 剔除空格
            nCommaPos = InStr(1, sText, "，")
            If nCommaPos > 0 Then
                sText = Trim(Left(sText, nCommaPos - 1)) + "," + Trim(Mid(sText, nCommaPos + nWordLen))
            End If
            
            nPos = InStr(1, sText, " ")
            If nPos > 0 Then
                sText = Trim(Left(sText, nPos - 1)) + "," + Trim(Mid(sText, nPos + 1))
            End If
        Loop While nPos > 0 Or nCommaPos > 0
        
        sTemp = ""
        nPos = -1
        nCommaPos = -1
        nFlagNum = 0
        For i = 1 To Len(sText)         '剔除多余的","、"-"
            sChar = Mid(sText, i, 1)
            If sChar = "," Then         '保证","不与前一个","、"-"紧相连
                If Not (i = nCommaPos + 1 Or i = nPos + 1) Then
                    sTemp = sTemp + sChar
                    nFlagNum = nFlagNum + 1
                End If
                nCommaPos = i
            ElseIf sChar = "-" Then     '保证"-"不与前一个","、"-"紧相连
                If Not (i = nCommaPos + 1 Or i = nPos + 1) Then
                    If nPos > nCommaPos Then    '最前一个分格符是"-", 强行把当前"-"改为","
                        sChar = ","
                    End If
                    sTemp = sTemp + sChar
                    nFlagNum = nFlagNum + 1
                End If
                nPos = i
            Else
                sTemp = sTemp + sChar
            End If
        Next
        
        '便于下一步处理,末尾和开头固定有一个","
        If Right(sTemp, 1) = "-" Then
            sTemp = Left(sTemp, Len(sTemp) - 1) + ","
        ElseIf Not Right(sTemp, 1) = "," Then
            sTemp = sTemp + ","
            nFlagNum = nFlagNum + 1
        End If
        
        If Left(sTemp, 1) = "-" Then
            sTemp = "," + Right(sTemp, Len(sTemp) - 1)
        ElseIf Not Left(sTemp, 1) = "," Then
            sTemp = "," + sTemp
            nFlagNum = nFlagNum + 1
        End If
        sText = sTemp
        
        'arFlag记录","、"-"在字符串中的绝对位置
        ReDim Preserve arFlag(nFlagNum, 2)
        j = 0
        For i = 1 To Len(sText)
            sChar = Mid(sText, i, 1)
            If sChar = "," Or sChar = "-" Then
                arFlag(j, 0) = i
                arFlag(j, 1) = sChar
                j = j + 1
            End If
        Next
        
        Dim nPrevPos As Integer, sTempStr As String
        nPrevPos = 1        '第一个","在字符串中的位置
        sFilter = ""
        For i = 1 To nFlagNum - 1   '第一个数组元属不处理
            sTemp = Mid(sText, nPrevPos + 1, arFlag(i, 0) - nPrevPos - 1)
            If sFilter <> "" Then
                If arFlag(i - 1, 1) = "-" Then
                    sFilter = sFilter + " AND "
                Else
                    sFilter = sFilter + " OR "
                End If
            End If
            
            If arFlag(i, 1) = "," Then
                If arFlag(i - 1, 1) = "-" Then  '前一分隔符是"-"
                    sTempStr = " <= " & IIf(nMode = 0, "'" & sTemp & "'", Val(sTemp))
                Else
                   sTempStr = IIf(nMode = 0, " LIKE '" & sTemp & "%'", " = " & Val(sTemp))
                End If
            Else        ' = "-"
                sTempStr = " >= " & IIf(nMode = 0, "'" & sTemp & "'", Val(sTemp))
            End If
            sFilter = sFilter + sKeyField + sTempStr
            nPrevPos = arFlag(i, 0)
        Next
    Else        ''按一般文字检索
        Do While InStr(1, sText, "，") > 0
            nPos = InStr(1, sText, "，")
            sText = Trim(Left(sText, nPos - 1)) + "," + Trim(Mid(sText, nPos + nWordLen))
        Loop
        
        sFilter = ""
        Do While InStr(1, sText, ",") > 0
            nPos = InStr(1, sText, ",")
            If nPos > 1 Then
                If sFilter <> "" Then
                    sFilter = sFilter + " OR "
                End If
                
                sFilter = sFilter + " Instr(" + sKeyField + ",'" & Trim(Left(sText, nPos - 1)) & "')>0 "
            End If
            sText = Trim(Mid(sText, nPos + 1))
        Loop
        
        If sText <> "" Then
            If sFilter <> "" Then
                sFilter = sFilter + " OR "
            End If
            
            sFilter = sFilter + " Instr(" + sKeyField + ",'" & sText & "')>0"
        End If
    End If
    If sFilter <> "" Then
       sFilter = "(" + sFilter + ")"
    End If
    GetFilterString = sFilter
End Function

Public Function GetForm(frm As Form) As Form
    Dim i As Integer
    
    For i = 0 To Forms.Count - 1
        If Forms(i) Is frm Then
            Set GetForm = Forms(i)
            Exit Function
        End If
    Next
    Set GetForm = Nothing
End Function

Public Function GetNextCode(LastCode As String) As String
    Dim TempStr As String
    Dim nLength As Integer
    Dim i As Integer
    nLength = Len(LastCode)     'FFFF cause error
    If UCase(LastCode) = String(nLength, "F") Then
         GetNextCode = "1" & String(nLength, "0")
         Exit Function
    End If
    If nLength > 0 Then
        For i = nLength To 1 Step -1
            If UCase(Mid(LastCode, i, 1)) < "F" And UCase(Mid(LastCode, i, 1)) <> "9" Then
                TempStr = Left(LastCode, i - 1) & Chr(Asc(UCase(Mid(LastCode, i, 1))) + 1) & String(nLength - i, "0")
                TempStr = UCase(TempStr)
                Exit For
            ElseIf UCase(Mid(LastCode, i, 1)) = "9" Then
                TempStr = Left(LastCode, i - 1) & "A" & String(nLength - i, "0")
                TempStr = UCase(TempStr)
                Exit For
            End If
        Next i
        GetNextCode = TempStr
    End If
End Function

''///////////////////////////////////////////
''//bMode = True, 使Ctrl+Alt+Del无效
''///////////////////////////////////////////
Function DisableHostReset(bMode As Boolean)
    Dim ret As Integer
    Dim pOld As Boolean
    ret = SystemParametersInfo(SPI_SCREENSAVERRUNNING, bMode, pOld, 0)
End Function