module1.bas

非常不错的人事管理软件

Attribute VB_Name = "Module1"
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 YGXM As String
Global YJBM As String
Global EJBM As String
Global PDMC As String
Global RKPDZPH As String
Global YHM As String
Global SBBH As String
Global RKWH As String
Global FLAGBH As String
Global FlagBMTZ As String
Global TKDCZ As Integer
Global FFLAG As Integer
Global RKPDBH As String
Global CKPDBH As String
Global CKPDRQ As String
Global CKPDBGY As String
Global CKPDWTJ As String
Global CXTJ As String
Global LYWZMC As String
Global LYWZRQ As String
Global RKRQBegin As Date
Global RKRQEnd As Date
Global KCCXSPBH As String
Global flag As Integer
Global FLAGLY As Integer
Global RKBGY As String
Global BLCPH As String
Global GLHTBH As String
Global GLHTMC  As String
Global MsgTitle As String

Public db As Connection
Public db1 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=RS;"
    ConnWZ.CursorLocation = adUseClient
    
    Set db = New Connection
  db.CursorLocation = adUseClient
  db.Open "DSN=RS;"
    
 '二维表的数据库连接
  Set db1 = New Connection
  db1.CursorLocation = adUseClient
  db1.Open "PROVIDER=MSDataShape;DSN=RS;"
    
  MsgTitle = "提示"
  
  RSGL.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 SetButtons(bVal As Boolean)
  'SZBGL.ActiveForm.cmdCancel.Visible = bVal
  'SZBGL.ActiveForm.cmdClose.Visible = bVal
  'SZBGL.ActiveForm.cmdNext.Enabled = bVal
  'SZBGL.ActiveForm.cmdFirst.Enabled = bVal
  'SZBGL.ActiveForm.cmdLast.Enabled = bVal
  'SZBGL.ActiveForm.cmdPrevious.Enabled = bVal
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