frmworkname.frm

金算盘软件代码

VERSION 5.00
Object = "{F42BDC2B-FC9B-11D1-9ABD-444553540000}#4.0#0"; "ATLEDIT.OCX"
Begin VB.Form frmWorkName 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "新增职务 "
   ClientHeight    =   1515
   ClientLeft      =   2400
   ClientTop       =   2490
   ClientWidth     =   4545
   HelpContextID   =   10241
   Icon            =   "frmWorkName.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form2"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1515
   ScaleWidth      =   4545
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin AtlEdit.TEdit txtWorkName 
      Height          =   285
      Left            =   330
      TabIndex        =   1
      Top             =   600
      Width           =   2535
      _ExtentX        =   4471
      _ExtentY        =   503
      maxchar         =   20
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Text            =   ""
   End
   Begin VB.CommandButton cmdOk 
      Height          =   350
      Index           =   2
      Left            =   3240
      Style           =   1  'Graphical
      TabIndex        =   4
      Tag             =   "1009"
      Top             =   900
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Height          =   350
      Index           =   1
      Left            =   3240
      Style           =   1  'Graphical
      TabIndex        =   3
      Tag             =   "1002"
      Top             =   510
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Height          =   350
      Index           =   0
      Left            =   3240
      Style           =   1  'Graphical
      TabIndex        =   2
      Tag             =   "1001"
      Top             =   120
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.Label lblWorkName 
      Caption         =   "职务名称(&N)"
      Height          =   195
      Left            =   360
      TabIndex        =   0
      Top             =   360
      Width           =   1035
   End
End
Attribute VB_Name = "frmWorkName"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                 功能:      完成职务的增、删、改。                              '
'                 卡片接口:             EditCard 参数: lngID 记录的ID号                        '
'                 作用:                          LNGID为零是增加记录、其它为编辑记录           '
'                                       DelCard 参数: lngID 记录的ID号                         '
'                 作用:                          删除ID号为LNGID的记录                         '
'                 作者：     苏涛                                                                            '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit

Private mblnIsInit As Boolean
Private mblnIsList As Boolean
Private mlngTitleID As Long
Private mlngDTitleID As Long                                   '合并目的ID
Private mblnIsNew As Boolean
Private mstrWorkName As String
Private mblnIsChanged As Boolean

Public Property Get getID() As Long
    getID = mlngTitleID
End Property

Public Function DelCard(lngID As Long, Optional lnghWnd As Long = 0) As Boolean
    Dim recTemp As rdoResultset
    Dim strSql As String, strTitle As String
    
    DelCard = False
    strSql = "SELECT  * FROM Title WHERE lngTitleID= " & lngID
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTemp.EOF = True Then
        DelCard = True
        recTemp.Close
        Exit Function
    Else
        strTitle = recTemp!strTitleName
    End If
    recTemp.Close
    
    If CodeIsUsed(lngID) Then
        ShowMsg lnghWnd, "“" & strTitle & "”职务已经有业务发生,不能删除！", vbExclamation + MB_TASKMODAL, "删除职务"
        Exit Function
    End If
  
    If ShowMsg(lnghWnd, "你确实要删除“" & strTitle & "”职务吗？", vbQuestion + vbYesNo + MB_TASKMODAL + vbDefaultButton2, _
        "删除职务") = vbNo Then Exit Function
    strSql = "DELETE FROM Title WHERE lngTitleID=" & lngID
    DelCard = gclsBase.ExecSQL(strSql)
    gclsSys.SendMessage CStr(Me.hwnd), Message.msgTitle
End Function

Private Sub cmdOk_Click(Index As Integer)
    
    If Index = 0 Then
        If Not SaveCard Then Exit Sub
    ElseIf Index = 2 Then
        If SaveCard Then
'            mlngTitleID = 0
            mblnIsNew = True
            mblnIsChanged = True
            InitCard
            txtWorkName.SetFocus
        End If
        Exit Sub
    End If
    Unload Me
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
'  txtWorkName.SetFocus
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If mblnIsList Then
        mblnIsList = False
        Exit Sub
    End If
    If KeyAscii = vbKeyReturn Then
        BKKEY Me.ActiveControl.hwnd, vbKeyTab
    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
    ElseIf KeyCode = vbKeyEscape Then
        KeyCode = 0
        cmdOk(1).Value = True
    End If
End Sub

Private Sub Form_Load()
    Dim edtErrReturn As ErrDealType
    
    On Error GoTo ErrHandle
'    SetHelpID hwnd, 10241
    Utility.LoadFormResPicture Me
'    SendKeys "%{N}"
    Exit Sub
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub
 
Public Function AddCard(Optional strName As String = "", Optional ByVal intModal As Integer = 0, _
    Optional ByVal IsList As Boolean = False) As Long
    mlngTitleID = 0
    mblnIsNew = True
    mblnIsChanged = True
    mblnIsList = IsList
    InitCard strName
    Show intModal
    AddCard = mlngTitleID
End Function

Public Sub EditCard(ByVal lngID As Long, Optional intModal As Integer = 0, _
    Optional strTitle As String)
    Dim strMess As String
    
    If Not CheckIDUsed("Title", "lngTitleID", lngID) Then
        If Trim(strTitle) <> "" Then
            strMess = "“" & strTitle & "”"
        Else
            strMess = "该"
        End If
        ShowMsg 0, strMess & "职务不存在,不能进行修改！", vbExclamation + MB_TASKMODAL, "修改职务"
        Unload Me
    Else
        mlngTitleID = lngID
        mblnIsNew = False
        InitCard
        Caption = "修改职务"
        cmdOk(2).Visible = False
        Show intModal
    End If
End Sub

Private Sub InitCard(Optional strName As String = "")
   Dim recWorkName As rdoResultset, strSql As String
   
   mblnIsInit = True
   mlngDTitleID = 0
   If Not mblnIsNew Then
        strSql = "SELECT * FROM Title WHERE lngTitleID=" & mlngTitleID
        Set recWorkName = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        mstrWorkName = recWorkName!strTitleName
        txtWorkName.Text = mstrWorkName
        recWorkName.Close
    Else
        txtWorkName.Text = Trim(strName)
    End If
    mblnIsInit = False
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 120, 120, 3070, 1320
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(txtWorkName.Text) = "" Then Exit Sub
    If mblnIsChanged Then
        If mblnIsNew Then
            strMess = "您要保存新增的职务“" & txtWorkName.Text & "”吗？"
        Else
            strMess = "“" & txtWorkName.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
    mblnIsChanged = False
    Utility.UnLoadFormResPicture Me
End Sub

Private Sub txtWorkName_Change()
    If ContainErrorChar(txtWorkName.Text) Then BKKEY txtWorkName.hwnd
    If Not mblnIsInit Then mblnIsChanged = True
End Sub

Private Function CodeCheck() As Boolean
    Dim recTitle As rdoResultset, strSql As String
    
    strSql = "SELECT * FROM Title WHERE strTitleName= '" & txtWorkName.Text _
        & "' AND lngTitleID<>" & IIf(mblnIsNew, 0, mlngTitleID)
    Set recTitle = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTitle.EOF Then
        CodeCheck = True
    Else
        CodeCheck = False
        mlngDTitleID = recTitle!lngTitleID
    End If
    recTitle.Close
End Function

Private Function MergeCode() As Boolean
    
    MergeCode = False
    If Not DisplaceActivity("Business", "lngTitleID", mlngDTitleID, mlngTitleID) Then Exit Function
    If Not DisplaceActivity("BusinessAddress", "lngTitleID", mlngDTitleID, mlngTitleID) Then Exit Function
    If Not DisplaceActivity("Customer", "lngTitleID", mlngDTitleID, mlngTitleID) Then Exit Function
    If Not DisplaceActivity("CustomerAddress", "lngTitleID", mlngDTitleID, mlngTitleID) Then Exit Function
    If Not DisplaceActivity("Employee", "lngTitleID", mlngDTitleID, mlngTitleID) Then Exit Function
    MergeCode = True
End Function

Private Function SaveCard() As Boolean
    Dim recTitle As rdoResultset, strSql As String
    
    SaveCard = False
    If Not mblnIsChanged Then
        SaveCard = True
        Exit Function
    End If
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    
    If txtWorkName.Text = "" Then
        ShowMsg hwnd, "职务不能为空！", vbExclamation + MB_TASKMODAL, Caption
        GoTo ErrHandle
    End If
     
    If CodeCheck Then
        If mblnIsNew Then
            mlngTitleID = GetNewID("Title")
            strSql = "INSERT INTO Title(lngTitleID,strTitleName) VALUES(" _
                & mlngTitleID & ",'" & Trim(txtWorkName.Text) & "')"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
'            strSql = "SELECT * FROM Title WHERE strTitleName='" _
'                & Trim(txtWorkName.Text) & "'"
'            Set recTitle = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'            mlngTitleID = recTitle!lngTitleID
'            recTitle.Close
        Else
            strSql = "UPDATE Title SET strTitleName='" & Trim(txtWorkName.Text) _
                & "' WHERE lngTitleID=" & mlngTitleID
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        End If
    Else
        If mblnIsNew Then
            ShowMsg hwnd, "职务“" & txtWorkName.Text & "”已经存在，请重新录入！", _
                vbExclamation + MB_TASKMODAL, Caption
            GoTo ErrHandle
        Else
            If ShowMsg(hwnd, "是否将职务“" & mstrWorkName & "”与“" & txtWorkName.Text _
                & "”进行合并？", vbQuestion + vbYesNo + MB_TASKMODAL, Caption) = vbNo Then
                GoTo ErrHandle
            Else
                If Not MergeCode Then GoTo ErrHandle
                strSql = "DELETE FROM Title WHERE lngTitleID=" & mlngTitleID
                If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            End If
        End If
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    mblnIsChanged = False
    Exit Function
    gclsSys.SendMessage CStr(Me.hwnd), Message.msgTitle
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
End Function

Private Function CodeIsUsed(ByVal lngID As Long) As Boolean
    
    CodeIsUsed = True
    If CheckIDUsed("Business", "lngTitleID", lngID) Then Exit Function
    If CheckIDUsed("BusinessAddress", "lngTitleID", lngID) Then Exit Function
    If CheckIDUsed("Customer", "lngTitleID", lngID) Then Exit Function
    If CheckIDUsed("CustomerAddress", "lngTitleID", lngID) Then Exit Function
    If CheckIDUsed("Employee", "lngTitleID", lngID) Then Exit Function
    CodeIsUsed = False
End Function

Private Sub txtWorkName_KeyPress(KeyAscii As Integer)
    If InStr("`~!@#$%^&*=+' "";:,./?|\", Chr(KeyAscii)) > 0 Then KeyAscii = 0
End Sub