module1.bas

物业管理

Attribute VB_Name = "Module1"
Public fMainForm As frmmain
Public Username   As String
Public UserGrade  As String
Declare Sub RtlmoveMemory Lib "kernel32" (ipvdest As Any, ipvsource As Any, ByVal cbcopy As Long)
Option Explicit
Public dbConnection As Connection
Public cntMIS As ADODB.Connection
Public QueryItem As Integer          '查询数据判定变量

Public ConnWZ As ADODB.Connection
'全局变量
'Global pdbh As String
Global KL As String
Global GANGWEI As String
Global LLDBH As String
'Global STRLLDKQYF As String

Global MsgTitle As String

Public db As Connection

Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Sub Main()
  On Error GoTo LogoError
  Set ConnWZ = New ADODB.Connection
    ConnWZ.Open "DSN=数据库;"
    ConnWZ.CursorLocation = adUseClient
    
    Set db = New Connection
  db.CursorLocation = adUseClient
  db.Open "DSN=数据库;"
   MsgTitle = "提示"
  Dim fLogin As New frmLogin
    fLogin.Show vbModal
    If Not fLogin.OK Then
        'Login Failed so exit app
        End
    End If
    Unload fLogin

    frmmain.Show
LogoOK:
            Exit Sub
LogoError:
            Beep
            MsgBox "数据库连接错误，请联系管理员", vbOKOnly + vbQuestion, "信息管理系统"
End Sub

Sub LoadResStrings(frm As Form)
    On Error Resume Next
    Dim ctl As Control
    Dim obj As Object
    Dim fnt As Object
    Dim sCtlType As String
    Dim nVal As Integer
    'set the form's caption
    frm.Caption = LoadResString(CInt(frm.Tag))
    'set the font
    Set fnt = frm.Font
    fnt.Name = LoadResString(20)
    fnt.Size = CInt(LoadResString(21))
    'set the controls' captions using the caption
    'property for menu items and the Tag property
    'for all other controls
    For Each ctl In frm.Controls
        Set ctl.Font = fnt
        sCtlType = TypeName(ctl)
        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
        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
    Next


End Sub
Sub EnterToNext(KeyCode As Integer)
On Error GoTo EnterError
If KeyCode = 13 Then SendKeys "{TAB}"
EnterOK:
  Exit Sub
EnterError:
  MsgBox "请正确操作！", vbOKOnly, "提示"
  Resume Next
End Sub
Sub GotoFirst(adoPrimaryRS As ADODB.Recordset, ByRef mbDataChanged)
  On Error GoTo GoFirstError
  adoPrimaryRS.MoveFirst
  mbDataChanged = False
  Exit Sub
GoFirstError:
  MsgBox "请正确操作！", vbOKOnly, MsgTitle
End Sub
Sub GotoLast(adoPrimaryRS As ADODB.Recordset, ByRef mbDataChanged)
  On Error GoTo GoLastError
  adoPrimaryRS.MoveLast
  mbDataChanged = False

  Exit Sub
GoLastError:
  MsgBox "请正确操作！", vbOKOnly, MsgTitle
End Sub

Sub GotoNext(adoPrimaryRS As ADODB.Recordset, ByRef mbDataChanged)
  On Error GoTo GoNextError
  If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext
  If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
     'moved off the end so go back
    adoPrimaryRS.MoveLast
  End If
  'show the current record
  mbDataChanged = False

  Exit Sub
GoNextError:
  MsgBox "请正确操作！", vbOKOnly, MsgTitle
End Sub

Sub GotoPrevious(adoPrimaryRS As ADODB.Recordset, ByRef mbDataChanged)
  On Error GoTo GoPrevError

  If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious
  If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
    'moved off the end so go back
    adoPrimaryRS.MoveFirst
  End If
  'show the current record
  mbDataChanged = False

  Exit Sub

GoPrevError:
  MsgBox "请正确操作！", vbOKOnly, MsgTitle
End Sub



Sub InitGrid(adoPrimaryRS As ADODB.Recordset, MSFlexGrid As MSFlexGrid)
    MSFlexGrid.Clear
    With MSFlexGrid
       .Rows = 1
       .Cols = adoPrimaryRS.Fields.Count
       .FixedCols = adoPrimaryRS.Fields.Count - 1
       If adoPrimaryRS.BOF Or adoPrimaryRS.EOF Then
            Exit Sub
        End If
       adoPrimaryRS.MoveFirst
       While Not adoPrimaryRS.EOF
          .AddItem Trim(adoPrimaryRS(0)) & vbTab & Trim(adoPrimaryRS(1)) + "   （" + Trim(adoPrimaryRS(2)) + "）"
          adoPrimaryRS.MoveNext
       Wend
       .TextArray(0) = adoPrimaryRS(0).Name
       .TextArray(1) = adoPrimaryRS(1).Name
       .TextArray(2) = "数据"
       .RowHeight(0) = 600
       .Row = 0
       .Col = .Cols - 1
       .CellForeColor = vbBlue
       .CellAlignment = vbAlignRight
       .Col = .Cols - 2
       .CellForeColor = vbBlue
       .CellAlignment = vbAlignRight
       .ColWidth(0) = 0
       .ColWidth(1) = 3200
       .ColWidth(2) = 2000
    End With
End Sub
Sub RefreshGrid(Grid As MSFlexGrid, adoRS As Recordset, ID As String)
    Dim i As Integer
    Dim ItemIndex As Integer
    Dim adoRsBackup As Recordset
    Dim strItem As String
    Dim GridRow As Integer
    Set adoRsBackup = adoRS.Clone
     With Grid
         .Clear
         .Rows = 1
         .Cols = adoRS.Fields.Count + 1
         .TextArray(0) = "序号"
         .ColWidth(0) = 800
         .ColAlignment(0) = flexAlignCenterCenter
         For i = 1 To .Cols - 1
             .TextArray(i) = adoRS.Fields(i - 1).Name
             .ColWidth(i) = 2000
         Next i
         If adoRsBackup.RecordCount = 0 Then
            adoRsBackup.Close
            Exit Sub
         Else
            adoRsBackup.MoveFirst
            ItemIndex = 1
            While Not adoRsBackup.EOF
               strItem = ItemIndex
               For i = 0 To adoRsBackup.Fields.Count - 1
                   strItem = strItem & vbTab & adoRsBackup.Fields(i)
               Next i
               If Trim(adoRsBackup.Fields(0)) = Trim(ID) Then GridRow = ItemIndex
               .AddItem strItem
               ItemIndex = ItemIndex + 1
               adoRsBackup.MoveNext
            Wend
            .Row = GridRow
            adoRsBackup.Close
         End If
    End With
End Sub