frmempcardnew.frm

金算盘软件代码

'        txtEmployee(5).top = 3180
'        txtEmployee(1).Left = 3570
'        txtEmployee(1).top = 270
'        lstText(0).Left = 3570
'        lstText(0).top = 755
'        lstText(2).Left = 3570
'        lstText(2).top = 1240
'        dtmEmployee(0).Left = 3570
'        dtmEmployee(0).top = 1725
'        dtmEmployee(0).width = 1875
'        dtmEmployee(2).Left = 3570
'        dtmEmployee(2).top = 2210
'        dtmEmployee(2).width = 1875
'        txtEmployee(3).Left = 3570
'        txtEmployee(3).top = 2695
'        txtEmployee(6).Left = 3570
'        txtEmployee(6).top = 3180
'        lblNote(7).Visible = False
'        txtEmployee(2).Visible = False
'        lblNote(11).Visible = False
'        chkStop(1).Visible = False
'        lblNote(14).Visible = False
'        lstText(4).Visible = False
'    Case 16
'        Me.Height = 4770
'        SetControl lblNote(0), 150, 300, 0
'        SetControl txtEmployee(0), 1140, 270, 1
'        SetControl lblNote(2), 2580, 300, 2
'        SetControl txtEmployee(1), 3570, 270, 3
'        SetControl lblNote(1), 150, 660, 4
'        SetControl cboSex, 1140, 636, 5
'        SetControl lblNote(3), 2580, 660, 6
'        SetControl lstText(0), 3570, 598, 7
'        SetControl lblNote(5), 150, 1020, 8
'        SetControl lstText(2), 1140, 960, 9
'        SetControl lblNote(4), 2580, 1020, 10
'        SetControl lstText(1), 3570, 1002, 11
'        SetControl lblNote(6), 150, 1380, 12
'        SetControl lstText(3), 1140, 1368, 13
'        SetControl lblNote(11), 2580, 1380, 14
'        SetControl txtEmployee(7), 3570, 1320, 15
'        SetControl lblNote(8), 150, 1734, 16
'        SetControl txtEmployee(3), 1140, 1734, 17
'        SetControl chkStop(1), 2730, 1830, 18
'        SetControl lblNote(14), 2700, 2160, 19
'        SetControl lstText(4), 3720, 2160, 20
'        SetControl lblNote(13), 150, 2100, 21
'        SetControl txtEmployee(4), 1140, 2100, 22
'        SetControl lblNote(9), 150, 2466, 23
'        SetControl dtmEmployee(0), 1140, 2466, 24
'        SetControl lblNote(10), 150, 2832, 25
'        SetControl dtmEmployee(1), 1140, 2832, 26
'        SetControl chkStop(2), 2730, 2820, 27
'        SetControl lblNote(17), 2700, 3180, 28
'        SetControl lstText(5), 3720, 3120, 29
'        SetControl lblNote(7), 2700, 3500, 30
'        SetControl txtEmployee(2), 3720, 3420, 31
'        SetControl lblNote(12), 150, 3198, 32
'        SetControl dtmEmployee(2), 1140, 3198, 33
'        SetControl lblNote(15), 150, 3567, 34
'        SetControl txtEmployee(5), 1140, 3564, 35
'        SetControl lblNote(16), 150, 3930, 36
'        txtEmployee(3).width = txtEmployee(4).width
'        SetControl txtEmployee(6), 1140, 3930, 37
'        txtEmployee(6).width = 4365
'        SetControl chkStop(0), 5700, 3990, 38
'        txtEmployee(7).Visible = True
'        chkStop(2).Visible = True
'        lstText(5).Visible = True
'        lblNote(17).Visible = True
'        lblNote(11).Caption = "身份证(&D)"
'        txtEmployee(2).BackColor = &H80000004
'        txtEmployee(2).width = lstText(5).width
'        txtEmployee(2).Left = lstText(5).Left
'        txtEmployee(2).Enabled = False
'        cmdOK(0).TabIndex = 39
'        cmdOK(1).TabIndex = 40
'        cmdOK(2).TabIndex = 41
'        cmdOK(4).TabIndex = 42
'    End Select
End Sub

Private Sub SetControl(conX As Control, lLeft As Long, lTop As Long, iTab As Integer)
    conX.Left = lLeft
    conX.top = lTop
    conX.TabIndex = iTab
End Sub

Private Sub dtmEmployee_KeyPress(Index As Integer, KeyAscii As Integer, bCancel As Long)
    If KeyAscii = vbKeySpace Then
        dtmEmployee(Index).DropDownPanel
    End If
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
    SetTabIndex
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim i As Integer
    
    mblnIsRefer = False
    If KeyCode = vbKeyEscape Or KeyCode = vbKeyReturn Then
        For i = 0 To 5
            If lstText(i).ReferVisible Then mblnIsRefer = True
        Next i
    End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    
    On Error Resume Next
    If mblnIsList Then
        mblnIsList = False
        Exit Sub
    End If
    If KeyAscii = vbKeyReturn Then
        If Not mblnIsRefer Then
            If Me.ActiveControl.Name = "dtmEmployee" Then
                BKKEY Me.ActiveControl.Window, vbKeyTab
            Else
                BKKEY Me.ActiveControl.hwnd, vbKeyTab
            End If
        End If
    ElseIf KeyAscii = vbKeyEscape Then
        cmdOK(1).Value = Not mblnIsRefer
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn And Shift = 2 Then
        cmdOK(0).Value = True
    End If
End Sub

Private Sub Form_Load()
    Dim i As Integer
    Dim edtErrReturn As ErrDealType
    
    On Error GoTo ErrHandle
'    SetHelpID hwnd, 30010
    Utility.LoadFormResPicture Me
'    frmEmployeeList.IsShowCard(1) = True
    For i = 0 To 5
        mblnIsFirst(i) = True
    Next
'    #If conVersionType = 8 Then
'        SetForm 8
'    #ElseIf conVersionType = 16 Then
'        SetForm 16
'    #Else
'        SetForm 16
'    #End If
    #If conVersionType = 16 Then
        #If conHos = 1 Then
            chkStop(1).Enabled = False
            chkStop(2).Enabled = False
        #End If
        If gclsBase.ControlAccount Then
            chkActive(6).Visible = False
            chkActive(7).Visible = False
        Else
            For i = 1 To 7
                chkActive(i).Visible = False
            Next i
        End If
    #End If
    mblnIsNext = False
'    SendKeys "%{C}"
    Exit Sub
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_Paint()
'    #If conVersionType = 8 Then
'        FrameBox Me.hwnd, 60, 150, 5595, 3525
'    #ElseIf conVersionType = 16 Then
'        FrameBox Me.hwnd, 60, 120, 60 + 5565, 120 + 4215
'        FrameBox Me.hwnd, 2580, 1710, 2580 + 2870, 1710 + 885
'        FrameBox Me.hwnd, 2580, 2700, 2580 + 2900, 2700 + 1155
'    #Else
'        FrameBox Me.hwnd, 60, 120, 60 + 5565, 120 + 4215
'        FrameBox Me.hwnd, 2580, 1710, 2580 + 2870, 1710 + 885
'        FrameBox Me.hwnd, 2580, 2700, 2580 + 2900, 2700 + 1155
''        FrameBox Me.hwnd, 2580, 2220, 5445, 3135
'    #End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim intMsgReturn As Integer, strMess As String
    
    If UnloadMode <> vbFormControlMenu Then Exit Sub
    If Trim(txtEmployee(0).Text & txtEmployee(1).Text) = "" Then Exit Sub
    If mblnIsChanged Then
        If mblnIsNew Then
            strMess = "您要保存新增的职员"
            If txtEmployee(0).Text <> "" Then
                strMess = strMess & "“" & txtEmployee(0).Text & "”"
            End If
            If txtEmployee(1).Text <> "" Then
                strMess = strMess & "“" & txtEmployee(1).Text & "”"
            End If
            strMess = strMess & "吗？"
        Else
            strMess = "“" & txtEmployee(0).Text & "”" & " " _
                & "“" & txtEmployee(1).Text & "”职员已被修改，是否保存？"
        End If
        intMsgReturn = ShowMsg(hwnd, strMess, vbQuestion + vbYesNoCancel, Caption)
        If intMsgReturn = vbYes Then
            Cancel = Not SaveCard
        ElseIf intMsgReturn = vbCancel Then
            Cancel = True
        End If
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Unload frmDepartmentCard
    Unload frmEmployeeType
    Unload frmEducation
    Unload frmWorkName
    Unload frmTax
    Unload frmBankcard
    Utility.UnLoadFormResPicture Me
    mblnIsChanged = False
End Sub

Private Sub GetLstValue()
    Dim i As Integer
    
    For i = 0 To 4
        If Trim(lstText(i).Text) = "" Then mlngLstID(i) = 0
    Next i
End Sub

Private Function SaveCard(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim blnMergeCode As Boolean
    Dim intResult As Integer    '编码检查结果:1--合法 -1--编码重复 -2--名称重复
    Dim recEmployee As rdoResultset, strSql As String, strCard As String
    Dim strBill As String, strOffice As String, strHome As String
    Dim strPost As String, strAddr As String, strBirthDay As String
    Dim strInDay As String, strOutDay As String, strDEmployee As String
 
  '需要事务处理
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    SaveCard = False
    If mblnIsExist Then GoTo ErrHandle
    If Not blnByAdd Then
        If Not CheckNotEmpty Then GoTo ErrHandle
    End If
    If Not CheckDate(blnByAdd) Then GoTo ErrHandle
    If Not blnByAdd Then GetLstValue
    If Not LstIsValid Then GoTo ErrHandle
    intResult = CheckCode(strDEmployee)
    If intResult = -2 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "职员名称不能为重复,请重新录入！", vbExclamation, Caption
            txtEmployee(1).SetFocus
            txtEmployee(1).SelStart = 0
            txtEmployee(1).SelLength = Len(txtEmployee(1).Text)
        End If
        GoTo ErrHandle
    End If
    If intResult = -1 Then
        If mblnIsNew Then
            If Not blnByAdd Then
                ShowMsg hwnd, "职员编码“" & Trim(txtEmployee(0).Text) _
                    & "”已经存在,请重新录入！", vbExclamation, Caption
                txtEmployee(0).SetFocus
                txtEmployee(0).SelStart = 0
                txtEmployee(0).SelLength = Len(txtEmployee(0).Text)
            End If
            GoTo ErrHandle
        Else
            If ShowMsg(hwnd, "是否将职员“" & mstrEmployee & "”与“" _
                & strDEmployee & "”进行合并?", _
                vbQuestion + vbYesNo, Caption) = vbNo Then
                txtEmployee(0).SetFocus
                txtEmployee(0).SelStart = 0
                txtEmployee(0).SelLength = Len(txtEmployee(0).Text)
                GoTo ErrHandle
            Else
                blnMergeCode = True
            End If
        End If
    End If
    
    strBill = IIf(txtEmployee(2).Text = "", " ", txtEmployee(2).Text)
    strOffice = IIf(txtEmployee(3).Text = "", " ", txtEmployee(3).Text)
    strHome = IIf(txtEmployee(4).Text = "", " ", txtEmployee(4).Text)
    strPost = IIf(txtEmployee(5).Text = "", " ", txtEmployee(5).Text)
    strAddr = IIf(txtEmployee(6).Text = "", " ", txtEmployee(6).Text)
    strCard = IIf(txtEmployee(7).Text = "", " ", txtEmployee(7).Text)
    strBirthDay = IIf(dtmEmployee(0).Text = "", " ", dtmEmployee(0).Text)
    strInDay = IIf(dtmEmployee(1).Text = "", " ", dtmEmployee(1).Text)
    strOutDay = IIf(dtmEmployee(2).Text = "", " ", dtmEmployee(2).Text)
    If mstrNotes = "" Then mstrNotes = " "
    If mblnIsNew Then
        mlngEmployeeID = GetNewID("Employee")
        strSql = "INSERT INTO Employee(lngEmployeeID,strEmployeeCode,strEmployeeName," _
            & "blnIsInActive,blnIsMale,lngDepartmentID,lngEmployeeTypeID," _
            & "lngEducationID,blnIsPersonTax,lngPersonTaxTypeID,strBankCode," _
            & "strInDate,strOutDate,lngTitleID,strAddress,blnIsBank,lngBankID," _
            & "strPostalCode,strOfficePhone,strHomePhone,strCardNO,strBirthdate," _
            & "strNotes,strStartDate,blnAccount,blnAR,blnAP,blnCash,blnPurchase," _
            & "blnSale,blnStock,blnEntrust) VALUES (" & mlngEmployeeID & ",'" _
            & txtEmployee(0).Text & "','" & txtEmployee(1).Text & "'," _
            & chkStop(0).Value & "," & IIf(optSex(0).Value, 1, 0) _
            & "," & mlngLstID(0) & "," & mlngLstID(1) & "," _
            & mlngLstID(2) & "," & chkStop(1).Value _
            & "," & mlngLstID(4) & ",'" & strBill _
            & "','" & strInDay & "','" & strOutDay _
            & "'," & mlngLstID(3) & ",'" & strAddr & "'," & chkStop(2).Value _
            & "," & mlngLstID(5) & ",'" & strPost & "','" & strOffice _
            & "','" & strHome & "','" & strCard & "','" & strBirthDay _
            & "','" & mstrNotes & "','" & Format(gclsBase.BaseDate, "yyyy-mm-dd") & "'," _
            & chkActive(0).Value & "," & chkActive(1).Value & "," _
            & chkActive(2).Value & "," & chkActive(3).Value & "," _
            & chkActive(4).Value & "," & chkActive(5).Value & "," _
            & chkActive(6).Value & "," & chkActive(7).Value & ")"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    Else
        If blnMergeCode Then
            If Not MergeCode Then GoTo ErrHandle
            strSql = "DELETE FROM Employee WHERE lngEmployeeID=" & mlngEmployeeID
        Else
            strSql = "UPDATE Employee SET strEmployeeCode='" & txtEmployee(0).Text _
                & "',strEmployeeName