企业管理

开发平台：
Visual Basic

Module1.bas：源码内容
							Attribute VB_Name = "modMain"
Option Explicit
Public dbConnection As Connection
Public cntMIS As ADODB.Connection
Public QueryItem As Integer          '查询数据判定变量
Public ConnWZ As New 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
Type ConnectInfo
    UID As String
    Pwd As String
    DataBase As String
    Server As String
End Type
Type t_User
    UserCode As String
    UserName As String
    Pwd As String
    QX As Integer
    BeiZhu As String
End Type
Public db As New ADODB.Connection
Public db1 As New ADODB.Connection
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public uConnect As ConnectInfo
Public DSNCONNECTION As String
Public UserInfo As t_User
Public Function InitAdoConnection() As Boolean
With uConnect
        DSNCONNECTION = "Provider=SQLOLEDB;Integrated Security=SSPI;Persist Security Info=False;" _
            & " Initial Catalog= " & .DataBase & ";Data Source=" & .Server
End With
On Error GoTo hErr
 
With ConnWZ
    If .State = adStateOpen Then GoTo lNext
    '.Provider = "SQLOLEDB"
    .CursorLocation = adUseClient
    .ConnectionString = DSNCONNECTION
    .Mode = adModeReadWrite
    .ConnectionTimeout = 45
    .CommandTimeout = 45
    .Properties("Prompt") = adPromptNever
    .Open
End With
lNext:
InitAdoConnection = True
On Error GoTo 0
Exit Function
hErr:
    MsgBox Err.Description, vbInformation, "提示信息"
    InitAdoConnection = False
End Function
Sub Main()
  Dim strSql As String
'  If App.PrevInstance Then
'        MsgBox "此应用程序已经运行", vbExclamation Or vbOKOnly, App.Title & "(系统错误)"
'        Exit Sub
'  End If
  On Error GoTo LogoError
    Open App.Path & "RS.dll" For Input As #1
    Input #1, strSql
        uConnect.UID = strSql
    Input #1, strSql
        uConnect.Pwd = strSql
    Input #1, strSql
        uConnect.Server = strSql
    Input #1, strSql
        uConnect.DataBase = strSql
    Close #1
    On Error GoTo 0
  frmFrash.Show vbModal
  
  If Not InitAdoConnection Then
     MsgBox "网络故障或没有与网络进行连接，请检查计算机的网络连接或与网络管理员联系。", vbOKOnly + vbQuestion, "信息管理系统"
     End
  Else
     frmLogin.Show vbModal
  End If
  
  Call iniConnect(db)
  Call iniConnect(db1)
  MsgTitle = "提示"
  MsgTitle = "提示"
  
  'RSGL.Show
  
LogoOK:
     Exit Sub
LogoError:
    frmODBCLogon.Show
     'Beep
     'MsgBox "网络故障或没有与网络进行连接，请检查计算机的网络连接或与网络管理员联系。", vbOKOnly + vbQuestion, "信息管理系统"
End Sub
Public Sub iniConnect(iCon As ADODB.Connection)
On Error GoTo hErr
    DSNCONNECTION = "Provider=MSDataShape; Data " & DSNCONNECTION
With iCon
    If .State = adStateOpen Then GoTo lNext
    '.Provider = "SQLOLEDB"
    .CursorLocation = adUseClient
    .ConnectionString = DSNCONNECTION
    .Mode = adModeReadWrite
    .ConnectionTimeout = 45
    .CommandTimeout = 45
    .Properties("Prompt") = adPromptNever
    .Open
End With
On Error GoTo 0
lNext:
Exit Sub
hErr:
    MsgBox Err.Description, vbInformation, "提示信息"
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

						