msys.bas

为个人用户开发的车险秘书系统

Attribute VB_Name = "MSys"
Option Explicit

Public conn As New ADODB.Connection
Public rs As New ADODB.Recordset
Public IniFileName As String, aflgdb As Boolean
Public dname As String, uname As String, upw As String
Public Const linkdb = "\data.mdb"
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
Public loginuser As String
Public Const vupw = "greentea_tealion"


Public Const HWND_TOPMOST& = -1
' 将窗口置于列表顶部，并位于任何最顶部窗口的前面
Public Const SWP_NOSIZE& = &H1
' 保持窗口大小
Public Const SWP_NOMOVE& = &H2
' 保持窗口位置

'******************************************
'INI文件操作API

Private Declare Function GetPrivateProfileInt Lib "kernel32" _
Alias "GetPrivateProfileIntA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As String, _
    ByVal nDefault As Long, _
    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 WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As Any, _
    ByVal lpString As Any, _
    ByVal lpFileName As String) As Long
    
Public Function GetiniValue(ByVal lpKeyName As String, ByVal strName As String, ByVal strIniFile As String) As String

    Dim strTmp As String * 255
    
    Call GetPrivateProfileString(lpKeyName, strName, "", _
    strTmp, Len(strTmp), strIniFile)
    GetiniValue = Left$(strTmp, InStr(strTmp, vbNullChar) - 1)
End Function

Public Sub WrtiniValue(ByRef strIniFile As String, ByVal Section As String, ByVal Key As String, ByVal Value As String)
    Dim Buff As String * 256
    Buff = Value + Chr(0)
    Call WritePrivateProfileString(Section, Key, Buff, strIniFile)
End Sub

    
'******************************************


Public Sub FClose()
    Unload MDIFmain
End Sub

'数据库连接
Public Function OpenCn(ByVal pws As String)
On Error GoTo strErrMag
        Set conn = New ADODB.Connection
        Dim itsConnectionString As String
        
        itsConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & linkdb & ";Jet OLEDB:Database Password=" & pws & ";Persist Security Info=False"
        'conn.Open itsConnectionString
        'itsConnectionString = "DSN=" & dbName & ";User ID=" & userName & "; Password=" & pws & ";"
        'MsgBox (itsConnectionString)
        conn.ConnectionString = itsConnectionString
        conn.CursorLocation = adUseClient
        conn.Open
        OpenCn = True
        aflgdb = True
        Exit Function
strErrMag:
        OpenCn = False
        aflgdb = False
        Exit Function
End Function


Public Function ExcSql()
    On Error GoTo errmsg
        Dim gera As Boolean
        
        
        gera = True
        If aflgdb = False Then gera = OpenCn(vupw)
        If gera = True Then
            ExcSql = True
        Else
            GoTo errmsg
        End If
        Exit Function
errmsg:
    ExcSql = False
End Function

Public Sub ExcSqlCZ(ByVal vsql As String)
        Dim gera As Boolean
        gera = True
        If aflgdb = False Then gera = OpenCn(vupw)
        If gera = True Then
            conn.Execute vsql
        End If
End Sub

Public Function StripNulls(Item As String) As String
    Dim pos As Integer
    pos = InStr(Item, Chr$(0))
    If pos Then Item = Left$(Item, pos - 1)
    StripNulls = Item
End Function

Public Sub wfi(ByVal vmsg As String)
    Dim IniFileName As String
    IniFileName = App.Path & "\errorsql.ini"
    
    WrtiniValue IniFileName, "SYSMSG", "sql1", vmsg
End Sub

Public Sub exsql(ByVal vsql As String)
    Dim vdb As Boolean
    
    vdb = ExcSql
    If vdb = True Then
        conn.Execute (vsql)
    End If
End Sub

Public Sub showselcb(ByVal vname As ComboBox, ByVal vtn As String)
    Dim sql As String
    Dim rs As Recordset
    Dim vdb As Boolean
    
    sql = "select 属性 from sys where 类别='" & vtn & "'"
    vdb = ExcSql
    If vdb = True Then
        Set rs = conn.Execute(sql)
        If Not rs.EOF Then
        With vname
            Do While Not rs.EOF
                .AddItem rs("属性")
            rs.MoveNext
            Loop
            .ListIndex = 0
        End With
        End If
        rs.Close
        Set rs = Nothing
    End If
End Sub

'delete public
Public Sub showsel(ByVal vname As OsenXPComboBox, ByVal vtn As String)
    Dim sql As String
    Dim rs As Recordset
    Dim vdb As Boolean
    
    sql = "select 属性 from sys where 类别='" & vtn & "'"
    vdb = ExcSql
    If vdb = True Then
        Set rs = conn.Execute(sql)
        If Not rs.EOF Then
        With vname
            Do While Not rs.EOF
                .AddItem rs("属性")
            rs.MoveNext
            Loop
            .ListIndex = 0
        End With
        End If
        rs.Close
        Set rs = Nothing
    End If
End Sub