其他数据库

开发平台：
Visual Basic

frmDetail.frm：源码内容
							VERSION 5.00
Begin VB.Form frmDetail 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "具体排班"
   ClientHeight    =   6150
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   10440
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   12
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmDetail.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6150
   ScaleWidth      =   10440
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.Frame fraCmd 
      Appearance      =   0  'Flat
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   600
      Left            =   4440
      TabIndex        =   13
      Top             =   5400
      Width           =   3000
      Begin VB.CommandButton cmdPlan 
         Caption         =   "保存(&S)"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   525
         Index           =   0
         Left            =   0
         TabIndex        =   15
         Top             =   0
         Width           =   1275
      End
      Begin VB.CommandButton cmdPlan 
         Caption         =   "返回(&R)"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   525
         Index           =   1
         Left            =   1688
         TabIndex        =   14
         Top             =   0
         Width           =   1275
      End
   End
   Begin VB.Frame fraPlan 
      Caption         =   "排班表"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   4185
      Left            =   315
      TabIndex        =   3
      Top             =   830
      Width           =   5490
      Begin VB.Image imgTemp 
         Height          =   630
         Left            =   1935
         Top             =   4035
         Visible         =   0   'False
         Width           =   720
      End
      Begin VB.Label lblWeek 
         AutoSize        =   -1  'True
         BackColor       =   &H00C0C0C0&
         BackStyle       =   0  'Transparent
         Caption         =   "日"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00808000&
         Height          =   240
         Index           =   0
         Left            =   300
         TabIndex        =   12
         Top             =   1425
         Width           =   270
      End
      Begin VB.Label lblWeek 
         AutoSize        =   -1  'True
         BackColor       =   &H00C0C0C0&
         BackStyle       =   0  'Transparent
         Caption         =   "一"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00808000&
         Height          =   240
         Index           =   1
         Left            =   1050
         TabIndex        =   11
         Top             =   1425
         Width           =   270
      End
      Begin VB.Label lblWeek 
         AutoSize        =   -1  'True
         BackColor       =   &H00C0C0C0&
         BackStyle       =   0  'Transparent
         Caption         =   "二"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00808000&
         Height          =   240
         Index           =   2
         Left            =   1800
         TabIndex        =   10
         Top             =   1425
         Width           =   270
      End
      Begin VB.Label lblWeek 
         AutoSize        =   -1  'True
         BackColor       =   &H00C0C0C0&
         BackStyle       =   0  'Transparent
         Caption         =   "三"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00808000&
         Height          =   240
         Index           =   3
         Left            =   2550
         TabIndex        =   9
         Top             =   1425
         Width           =   270
      End
      Begin VB.Label lblWeek 
         AutoSize        =   -1  'True
         BackColor       =   &H00C0C0C0&
         BackStyle       =   0  'Transparent
         Caption         =   "四"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00808000&
         Height          =   240
         Index           =   4
         Left            =   3300
         TabIndex        =   8
         Top             =   1425
         Width           =   270
      End
      Begin VB.Label lblWeek 
         AutoSize        =   -1  'True
         BackColor       =   &H00C0C0C0&
         BackStyle       =   0  'Transparent
         Caption         =   "五"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00808000&
         Height          =   240
         Index           =   5
         Left            =   4050
         TabIndex        =   7
         Top             =   1425
         Width           =   270
      End
      Begin VB.Label lblWeek 
         AutoSize        =   -1  'True
         BackColor       =   &H00C0C0C0&
         BackStyle       =   0  'Transparent
         Caption         =   "六"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   12
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00808000&
         Height          =   240
         Index           =   6
         Left            =   4800
         TabIndex        =   6
         Top             =   1425
         Width           =   270
      End
      Begin VB.Label lblShift 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "*"
         ForeColor       =   &H00FF0000&
         Height          =   240
         Index           =   0
         Left            =   345
         TabIndex        =   5
         Top             =   615
         Width           =   120
      End
      Begin VB.Label lblDay 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "1"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H000000C0&
         Height          =   210
         Index           =   0
         Left            =   345
         TabIndex        =   4
         Top             =   360
         Width           =   135
      End
      Begin VB.Image imgPlan 
         Height          =   660
         Index           =   0
         Left            =   75
         Picture         =   "frmDetail.frx":000C
         Top             =   225
         Visible         =   0   'False
         Width           =   705
      End
   End
   Begin VB.Frame fraShift 
      Caption         =   "请选择班次"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   4320
      Left            =   6435
      TabIndex        =   1
      Top             =   830
      Width           =   3705
      Begin VB.OptionButton optShift 
         BackColor       =   &H00C0C0C0&
         Caption         =   "J"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   450
         Index           =   0
         Left            =   240
         Style           =   1  'Graphical
         TabIndex        =   2
         Top             =   330
         Width           =   500
      End
   End
   Begin VB.Image imgNotSel 
      Height          =   660
      Left            =   3060
      Picture         =   "frmDetail.frx":044E
      Top             =   6120
      Visible         =   0   'False
      Width           =   705
   End
   Begin VB.Image imgSel 
      Height          =   660
      Left            =   3930
      Picture         =   "frmDetail.frx":0890
      Top             =   6105
      Visible         =   0   'False
      Width           =   705
   End
   Begin VB.Label lblTitle 
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "2000年5月排班情况"
      ForeColor       =   &H000040C0&
      Height          =   240
      Left            =   3840
      TabIndex        =   0
      Top             =   210
      Width           =   2040
   End
End
Attribute VB_Name = "frmDetail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public mTitle As String
Public mWorkNo As String
Public mDeptID As String
Public mNeedToRefresh As Boolean
Public mIsToLook As Boolean
Dim mPicNotSel As Picture
Dim mPicSel As Picture
Dim mPicHeight As Integer
Dim mPicWidth As Integer
Const PICSPACE = 45
Const SHIFTPICSPACE = 340 'TOP
Const DAYPICSPACE = 40 'TOP
Const WEEKPICSPACE = 420
Const INILEFT = 135 '450
Const INITOP = 690 '1515
Const COLCOUNT = 7
'*******fraPlan
Const FRATOP = 830
Const FRALEFT = 315
Const FRAWIDTH = 5490
Const FRASPACE = 120
'******optPlan
Const OPTPLANLEFT = 240
Const OPTPLANTOP = 350
Const OPTPLANWIDTH = 500
Const OPTPLANHEIGHT = 450
Const FRASHIFTWIDTH = 3700
Const ShiftCount = 6
Const FRASHIFTPLANSPACE = 630
Const STRPLAN = "排班表"
Const STRYEAR = "年"
Const STRMONTH = "月"
Const STRPLANDETAIL = "具体排班"
Const STRPLANLOOK = "查看排班"
Const FRACMDSPACE = 400
Const mMsg1 = "抱歉,排班保存未成功!"
Const mMsg2 = "恭喜,排班保存成功!"
Private Sub SetPic()
    Set mPicNotSel = imgNotSel.Picture
    Set mPicSel = imgSel.Picture
    mPicHeight = imgNotSel.Height
    mPicWidth = imgNotSel.Width
    Dim I As Integer
    For I = 0 To lblWeek.Count - 1
        With lblWeek(I)
            .Left = INILEFT + (mPicWidth + PICSPACE) * I _
                + (mPicWidth - Me.TextWidth(.Caption)) / 2
            .Top = INITOP - WEEKPICSPACE
        End With
    Next
End Sub
Private Sub cmdPlan_Click(Index As Integer)
    Select Case Index
        Case 0
            If SaveData Then
                mNeedToRefresh = True
                Me.Hide
            End If
        Case 1
            mNeedToRefresh = False
            Me.Hide
    End Select
End Sub
Private Function SaveData() As Boolean
    Dim EmpRst As Recordset
    Dim DeptID As Integer
    Dim Sql As String
    Dim strWorkNo As String
    Dim IsTrans As Boolean
    On Error GoTo SaveErr
    BeginTrans
    IsTrans = True
    If Trim(mDeptID) <> Empty Then
        DeptID = CInt(Val(mDeptID))
        Sql = "select WorkNo from Employee where DeptID=" & DeptID
        Set EmpRst = gDataBase.OpenRecordset(Sql, dbOpenSnapshot)
        While Not EmpRst.EOF
            strWorkNo = Trim(EmpRst!WorkNo)
            If Not SaveDataToDatabase(strWorkNo) Then GoTo SaveErr
            EmpRst.MoveNext
        Wend
        EmpRst.Close
        Set EmpRst = Nothing
    Else
        If Trim(mWorkNo) <> Empty Then
            strWorkNo = Trim(mWorkNo)
            If Not SaveDataToDatabase(strWorkNo) Then GoTo SaveErr
        End If
    End If
    CommitTrans
    IsTrans = False
    SaveData = True
    
    MsgBox mMsg2, vbInformation, gTitle
    Exit Function
SaveErr:
    If IsTrans Then Rollback
    MsgBox mMsg1 & vbCrLf & Err.Description, vbCritical, gTitle
    Err.Clear
    SaveData = False
End Function
Private Function SaveDataToDatabase(strWorkNo As String) As Boolean
    Dim Sql As String
    Dim I As Integer
    Dim IntShift As Integer
    Dim intDay As Integer
    On Error GoTo SaveDataErr
    For I = 0 To lblDay.Count - 1
        intDay = CInt(Val(lblDay(I)))
        IntShift = CInt(Val(lblShift(I).Tag))
        Sql = "Update " & gPlanTableName & " set F_Shift=" & IntShift _
            & " where WorkNo='" & strWorkNo & "' and F_Day=" & intDay
        gDataBase.Execute Sql
    Next
    SaveDataToDatabase = True
    Exit Function
SaveDataErr:
    Err.Clear
    SaveDataToDatabase = False
    'Resume Next
End Function
Private Sub Form_Load()
'    Dim Str As String
'    Str = App.Path + "datakq.mdb"
'    Set gDataBase = Workspaces(0).OpenDatabase(Str, False, False, ";pwd=wsh2000")
    
    fraPlan.Caption = Year(Date) & STRYEAR _
        & Format(Month(Date), "00") & STRMONTH _
        & Space(0) & STRPLAN
    SetPic
    SetDesk
    
    SetlblTitle
    SetCaption
End Sub
Private Sub SetCaption()
    Dim Str As String
    If mIsToLook Then
        Str = STRPLANLOOK
    Else
        Str = STRPLANDETAIL
    End If
    Me.Caption = Str
End Sub
Private Sub SetlblTitle()
    With lblTitle
        .Caption = mTitle
        .Left = (Me.Width - Me.TextWidth(Trim(.Caption))) / 2
    End With
End Sub
Private Sub ClearImages()
    Dim Count As Integer
    Count = imgPlan.Count
    While Count <> 1
        Unload imgPlan(Count - 1)
        Unload lblShift(Count - 1)
        Unload lblDay(Count - 1)
        Count = imgPlan.Count
    Wend
    Count = optShift.Count
    While Count <> 1
        Unload optShift(Count - 1)
    Wend
End Sub
Private Sub SetDesk()
    Dim I As Integer
    Dim DayRow As Integer
    Dim DayCol As Integer
'    Dim Row As Integer
    Dim Cols As Integer
    Dim FirstWeekDay As Integer
    
    ClearImages
    
    For I = 1 To gMaxDay - 1
        Load imgPlan(I)
        Load lblShift(I)
        Load lblDay(I)
    Next
    
    GetShift
    
    FirstWeekDay = Weekday(DateSerial(Year(Date), Month(Date), 1))
    DayRow = 0
    Cols = FirstWeekDay - 1
    For I = 0 To gMaxDay - 1
        DayCol = Cols Mod COLCOUNT
        DayRow = Cols  COLCOUNT
        imgPlan(I).Left = INILEFT + (mPicWidth + PICSPACE) * DayCol
        imgPlan(I).Top = INITOP + (mPicHeight + PICSPACE) * DayRow
        imgPlan(I).Visible = True
        Cols = Cols + 1
        
        With lblDay(I)
            .Caption = I + 1
            .Left = imgPlan(I).Left + (mPicWidth - Me.TextWidth(.Caption)) / 2
            .Top = imgPlan(I).Top + DAYPICSPACE
            .Visible = True
            .ZOrder 0
        End With
        
        With lblShift(I)
            .Left = imgPlan(I).Left + (mPicWidth - Me.TextWidth("A")) / 2
            .Top = imgPlan(I).Top + SHIFTPICSPACE
            .Visible = True
            .ZOrder 0
        End With
    Next
    
    If Not mIsToLook Then
        Dim Rst As Recordset
        Set Rst = gDataBase.OpenRecordset("select ID,ShiftName " _
            & "from Shift   where ID<>" & gNoShift _
            & " order by ID", dbOpenSnapshot)
        For I = 1 To Rst.RecordCount '- 1
            Load optShift(I)
        Next
        'SHIFTCOUNT
        
        I = 0
        DayRow = 0
        Cols = 0
        Dim H As Integer
        While Not Rst.EOF
            DayCol = Cols Mod ShiftCount
            DayRow = Cols  ShiftCount
            With optShift(I)
                .Caption = Trim(Rst!ShiftName)
                .Tag = CStr(Rst!ID)
                If Rst!ID <= UBound(aInnerShift) Then
                    For H = 1 To UBound(aInnerShift)
                        If Rst!ID = aInnerShift(H).ID Then
                            .ToolTipText = aInnerShift(H).Note
                            Exit For
                        End If
                    Next
                End If
                If I = 0 Then
                    .Left = OPTPLANLEFT
                    .Top = OPTPLANTOP
                Else
                    .Left = OPTPLANLEFT + (OPTPLANWIDTH + PICSPACE) * DayCol 'optShift(0).Width
                    .Top = OPTPLANTOP + (OPTPLANHEIGHT + PICSPACE) * DayRow 'optShift(0).Width
                    .Visible = True
                End If
            End With
            I = I + 1
            Cols = I
            Rst.MoveNext
        Wend
        Rst.Close
        Set Rst = Nothing
    End If
    'Next
    
    
    '******fraPlan
    With fraPlan
        .Left = FRALEFT
        .Top = FRATOP
        .Width = FRAWIDTH
        .Height = imgPlan(imgPlan.Count - 1).Top + mPicHeight _
            + PICSPACE + FRASPACE
    End With
    With fraShift
        .Left = fraPlan.Left + fraPlan.Width + FRASHIFTPLANSPACE
        If mIsToLook Then
            Me.Width = .Left - 200
        End If
        .Top = fraPlan.Top
        .Height = fraPlan.Height
        .Width = FRASHIFTWIDTH
    End With
    
    With fraCmd
        .Top = fraPlan.Top + fraPlan.Height + FRACMDSPACE
        .Left = (Me.Width - .Width) / 2
        Me.Height = .Top + .Height + FRACMDSPACE + 200
        cmdPlan(0).Visible = Not mIsToLook
        If mIsToLook Then
            cmdPlan(1).Left = (.Width - cmdPlan(1).Width) / 2
        End If
    End With
End Sub
Private Sub GetShift()
    If mWorkNo = Empty Then Exit Sub
    Dim Rst As Recordset
    Dim Sql As String
    Dim I As Integer
    Sql = "select ShiftName,ID from " & gPlanQryName _
        & " where WorkNo='" & mWorkNo & "'" _
        & " order by F_Day"
    Set Rst = gDataBase.OpenRecordset(Sql, dbOpenSnapshot)
    I = 0
    While Not Rst.EOF
        With lblShift(I)
            .Caption = IIf(IsNull(Rst!ShiftName), "", Trim(Rst!ShiftName))
            .Tag = IIf(IsNull(Rst!ID), gNoShift, CStr(Rst!ID))
        End With
        Rst.MoveNext
        I = I + 1
    Wend
    Rst.Close
    Set Rst = Nothing
End Sub
Private Function GetPicture(isSel As Boolean) As Picture
    If isSel Then
        Set GetPicture = mPicSel
    Else
        Set GetPicture = mPicNotSel
    End If
End Function
Private Sub imgPlan_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    With imgTemp
        Set imgTemp = GetPicture(True)
        .Left = imgPlan(Index).Left
        .Top = imgPlan(Index).Top
        .Width = imgPlan(Index).Width
        .Height = imgPlan(Index).Height
        .Tag = Index
        If Not .Visible Then .Visible = True
    End With
    
    If Not mIsToLook Then
        Dim I As Integer
        Dim intIndex As Integer
        For I = 0 To optShift.Count - 1
            If optShift(I).Value Then
                intIndex = I
                Exit For
            End If
        Next
        With lblShift(Index)
            .Caption = optShift(intIndex).Caption
            .Tag = optShift(intIndex).Tag
        End With
    End If
End Sub
Private Sub lblDay_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    imgPlan_MouseDown Index, Button, Shift, X, Y
End Sub
Private Sub lblShift_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    imgPlan_MouseDown Index, Button, Shift, X, Y
End Sub

						