apmi0400.frm

ERP中的一个子模块

Private ds_index As Long

Private Type Pglist_Enum
    SubSystem() As String
    PgID() As String
    PgNAME() As String
    AddtoList() As Boolean      ' 0:Not Added,1:Added
End Type
Private Pglist As Pglist_Enum

Private SubSysteminINI() As String


Private Function Code_check(ByVal msgflg As Boolean) As Boolean
On Error GoTo ErrProc
    '操作员数据存在检查
    Dim Wksql As String

    Code_check = False
    
    ' 记录设置傪取得
    Wksql = "SELECT *"
    Wksql = Wksql & " FROM DMQX"
    Wksql = Wksql & " WHERE QXCODE = '" & Trim(TxtCode) & "'"
    Set DMQX = New ADODB.Recordset
    DMQX.MaxRecords = 1                     '取得记录件数
    DMQX.Source = RepSql(Wksql)                     'SQL语句
    DMQX.ActiveConnection = ADOcon          '数据库设定
    DMQX.CursorType = adOpenStatic          '光标类型设定
    DMQX.LockType = adLockReadOnly          '同时实行处理设定
    DMQX.Open
    
    If proc_mode = 1 Then
        '登录模式
        If DMQX.RecordCount > 0 Then
            If msgflg = True Then
                Call MsgDisplay(INS_ZUMI, "")
            End If
            Exit Function
        End If
    Else
        '更新模式
        If DMQX.RecordCount <= 0 Then
            If msgflg = True Then
                Call MsgDisplay(NOT_CODE, "")
            End If
            Exit Function
        End If
    End If
    
    Code_check = True
    Exit Function
    
ErrProc:
    Call errMsgEdit("")
    
End Function


Private Sub CboSubSystem_Click()
'    Call SetInlist
    Call SetNotinlist
End Sub

Private Sub CboSubSystem_GotFocus()
    Set FldOp.ctrl = ActiveControl
    FldOp.gotFocus
End Sub

Private Sub CboSubSystem_KeyPress(KeyAscii As Integer)
    KeyAscii = FldOp.keyPress(KeyAscii)
    If KeyAscii = 0 Then CboSubSystem_LostFocus
End Sub

Private Sub CboSubSystem_LostFocus()
    FldOp.lostFocus
    If ActiveControl.Name = CboSubSystem.Name Then
        FldOp.moveFcs
    End If
End Sub


Private Sub cmdClr_Click()
    If MsgDisplay(CLEAR_OK, "") = vbOK Then
        Call main_proc
        TxtCode.Enabled = True
        cmdGuide.Enabled = True
        TxtCode.SetFocus
    Else
        If proc_mode = 1 Then
            TxtCode.SetFocus
        Else
            TxtName.SetFocus
        End If
    End If
End Sub

Private Sub CmdGuide_Click()
    With FrmDmqx
        .Show vbModal
        If .result = True Then
            TxtCode = .selCd
            Call Code_check(False)
            Call SetSysList
            Call SetInlistfromtable
            proc_mode = 2               '更新?霓傊移行
            CmdEnt.Caption = "更新"
            TxtMode.Caption = "更  新"
            ds_index = 0
            Call SerDataDisplayDetail
            CmdDel.Enabled = True
            cmdClr.Enabled = True
            TxtName.SetFocus
        Else
            TxtCode.SetFocus
        End If
    End With
    Unload FrmDmqx
    Set FrmDmqx = Nothing

End Sub

Private Sub cmddel_Click()
    On Error GoTo ErrProc
    '削除确认消息
    If MsgDisplay(DELETE_OK, "") = vbCancel Then Exit Sub
    ADOcon.BeginTrans
    If delete_db_proc = True Then '削除成功
        ADOcon.CommitTrans
        If proc_mode = 2 Or (proc_mode = 3 And SerMaxCnt = 1) Then   ' 数据１件的时的削除
            Call main_proc
            TxtCode.SetFocus
            Exit Sub
        Else
            Call DmqxSerch
            If SerMaxCnt = 1 Then       ' 数据偑１件偟偐側偄时候
                ds_index = 0
            ElseIf ds_index >= SerMaxCnt - 1 Then    ' 堦个最后的数据傪删除时候
                ds_index = SerMaxCnt - 1
            End If
            Call Move_Point
            Call SerDataDisplayDetail
            Call RecButtonCtl '检索移动按钮使用控制
            TxtName.SetFocus
        End If
    Else
        Call PrtErrMsg
    End If
ErrProc:
    ADOcon.RollbackTrans
End Sub

Private Sub RecButtonCtl()
'检索移动按钮使用控制
    If SerMaxCnt <= 1 Then
        cmdFst.Enabled = False
        cmdPre.Enabled = False
        cmdNxt.Enabled = False
        cmdLas.Enabled = False
    Else
        Select Case ds_index
        Case 0 '先头
            cmdFst.Enabled = False
            cmdPre.Enabled = False
            cmdNxt.Enabled = True
            cmdLas.Enabled = True
        Case SerMaxCnt - 1 '末尾
            cmdFst.Enabled = True
            cmdPre.Enabled = True
            cmdNxt.Enabled = False
            cmdLas.Enabled = False
        Case Else
            cmdFst.Enabled = True
            cmdPre.Enabled = True
            cmdNxt.Enabled = True
            cmdLas.Enabled = True
        End Select
    End If
End Sub

Private Sub CmdEnd_Click()
    ' 结束确认
    Unload Me
End Sub
Private Sub CmdEnt_Click()
    On Error GoTo ErrProc
    '输入检查
    ADOcon.BeginTrans
    If False = update_check Then Exit Sub
'    If proc_mode = 1 Then '追加模式側傜
        If delete_db_proc = True Then '削除成功
            If insert_db_proc = True Then
                ADOcon.CommitTrans
                Call main_proc
                TxtCode.SetFocus
            End If
        End If
'    Else                             '追加模式偱側偗傟偽
'        If update_db_proc = True Then '更新成功的时候
'            ADOcon.CommitTrans
'            Select Case proc_mode
'            Case 1 '登录模式的时候
'            Case 2 '更新模式的时候
'                Call main_proc
'                TxtCode.SetFocus
'            Case 3 '检索模式的时候
'                Call DmqxSerch
'                Call Move_Point
'                TxtName.SetFocus
'            End Select
'        Else
'            '更新失败的时候
'            Call PrtErrMsg
'        End If
'    End If
    Exit Sub
ErrProc:
    ADOcon.RollbackTrans
End Sub

Private Sub cmdFst_Click()
    DmqxSer.MoveFirst
    Call SerDataDisplayDetail
    ds_index = 0
    Call RecButtonCtl
    TxtName.SetFocus
End Sub
Private Sub cmdLas_Click()
    DmqxSer.MoveLast
    Call SerDataDisplayDetail
    ds_index = SerMaxCnt - 1
    Call RecButtonCtl
    TxtName.SetFocus
End Sub

Private Sub cmdNxt_Click()
    DmqxSer.MoveNext
    Call SerDataDisplayDetail
    ds_index = ds_index + 1
    Call RecButtonCtl
    TxtName.SetFocus
End Sub

Private Sub cmdPre_Click()
    DmqxSer.MovePrevious
    Call SerDataDisplayDetail
    ds_index = ds_index - 1
    Call RecButtonCtl
    TxtName.SetFocus
End Sub
Private Function delete_db_proc() As Boolean
    Dim Wksql As String
    Dim acCmd As New ADODB.Command
    Dim acLock As New ADODB.Command
    Dim wkWhere As String
    
On Error GoTo ErrProc

    delete_db_proc = False

'    ADOcon.BeginTrans

    '条件文的设定
    wkWhere = " WHERE qxCODE = '" & Trim(TxtCode) & "'"
    
    '记录偵锁定傪偐偗傞
    Wksql = "SELECT QXCODE FROM DMQX"
    Wksql = Wksql & wkWhere
    With acLock
        .ActiveConnection = ADOcon
        .CommandText = RepSql(Wksql)
        .CommandType = adCmdText
    End With
    If ADORecordLock(acLock) = False Then GoTo ErrProc
    
    
    '削除
    Wksql = "DELETE FROM DMQX"
    Wksql = Wksql & wkWhere
    With acCmd
        .ActiveConnection = ADOcon
        .CommandText = RepSql(Wksql)
        .CommandType = adCmdText
        .Execute
    End With
'    ADOcon.CommitTrans

    Set acCmd = Nothing
    Set acLock = Nothing
    
    delete_db_proc = True
    Exit Function

ErrProc:
'    Call SetErrMsg("")
    Set acCmd = Nothing
    Set acLock = Nothing
    
'    ADOcon.RollbackTrans
    If Err.Number <> 0 Then Err.Clear
End Function

Private Function DmqxSerch() As Boolean
On Error GoTo ErrProc
    Dim wh As String
    Dim Wksql As String
    
    If serchData(0) <> "" Then
        wh = " QXCODE >= '" & serchData(0) & "'"
    End If
    If serchData(1) <> "" Then
        If wh <> "" Then wh = wh & " AND "
        wh = wh & " QXCODE <= '" & serchData(1) & "'"
    End If
    If wh <> "" Then wh = " WHERE " & wh
    
'addition 2001/01/22 T.Uchino ------------------------------>
    Dim Rec As New ADODB.Recordset
    Wksql = "SELECT * FROM DMQX" & wh
    With Rec
        .MaxRecords = 1                 '取得记录件数
        .Source = CntSql(Wksql)         'SQL语句
        .ActiveConnection = ADOcon      '数据库设定
        .Open
        If .RecordCount <= 0 Then   ' 数据无
            Call MsgDisplay(SERCH_NO_DATA, "")
            .Close
            Set Rec = Nothing
            Exit Function
        End If
        .Close
    End With
    Set Rec = Nothing
'<--------------------------------------- 2001/01/22 T.Uchino
    
    '前回使用偟偨Recordset傪开放
    If DmqxSer.State <> adStateClosed Then DmqxSer.Close
    Set DmqxSer = Nothing
    
    Wksql = "SELECT DISTINCT QXCODE"
    Wksql = Wksql & " FROM DMQX"
    Wksql = Wksql & wh
    Wksql = Wksql & " ORDER BY QXCODE"
    ' 记录设置傪取得
    Set DmqxSer = New ADODB.Recordset
    DmqxSer.MaxRecords = APL_DTL_MAXCNT        '取得记录件数
    DmqxSer.Source = RepSql(Wksql)                     'SQL语句
    DmqxSer.ActiveConnection = ADOcon          '数据库设定
    DmqxSer.CursorType = adOpenStatic          '光标类型设定
    DmqxSer.LockType = adLockReadOnly          '同时实行处理设定
    DmqxSer.Open

    SerMaxCnt = DmqxSer.RecordCount
    If SerMaxCnt <= 0 Then
        Call MsgDisplay(SERCH_NO_DATA, "")
        Exit Function
    Else
        TxtFldCnt.Caption = Format(SerMaxCnt, "######0")
        DmqxSerch = True
    End If

ErrProc:
    Call errMsgEdit("")
End Function


Private Function insert_db_proc() As Boolean
    Dim i As Integer
    Dim HaveInsert As Boolean
    HaveInsert = False
    For i = 0 To UBound(Pglist.PgID) - 1
        If Pglist.AddtoList(i) = True Then
            If insert_db_procOnly(Str(i)) = False Then
                insert_db_proc = False
                Exit Function
            End If
            HaveInsert = True
        End If
    Next
    If HaveInsert = False Then
        If insert_db_procOnly("NotInsert") = False Then
            insert_db_proc = False
            Exit Function
        End If
    End If
    insert_db_proc = True
End Function


Private Function insert_db_procOnly(i As String) As Boolean
    On Error GoTo ErrProc
    
    '操作员数据登录处理
    Dim qx As AdoOp

    insert_db_procOnly = False

    Set qx = initDMQX
    
    qx.data(QXCODE) = Trim(TxtCode)             '操作员编号
    qx.data(QXNAME) = Trim(TxtName)             '操作员名称
    qx.data(QXREMK) = Trim(TxtRemk)             '备注
    If i = "NotInsert" Then
        qx.data(QXSUBSYSTEM) = Trim("")        '子系统名称
        qx.data(QXPGID) = Trim("")                  '程序编号
        qx.data(QXPGNM) = Trim("")                  '程序名称
    Else
        qx.data(QXSUBSYSTEM) = Trim(Pglist.SubSystem(i))        '子系统名称
        qx.data(QXPGID) = Trim(Pglist.PgID(i))                  '程序编号
        qx.data(QXPGNM) = Trim(Pglist.PgNAME(i))                '程序名称
    End If
    If False = qx.InsDB Then GoTo ErrProc:

    insert_db_procOnly = True
    Exit Function

ErrProc:
    Call SetErrMsg("")
    If Err.Number <> 0 Then Err.Clear
End Function

Private Sub main_proc()

    TxtMode = "登  录"
    CmdEnt.Caption = "登录"
    proc_mode = 1               '?霓 = 登录

    TxtCode = ""    '分类编号
    TxtName = ""    '名称
    TxtRemk = ""    '备注
    
    CboSubSystem.Clear
    LstPrg(0).Clear
    LstPrg(1).Clear
    Call ClearData
    
    TxtFldCnt = ""
    SerMaxCnt = 0
    
    Call RecButtonCtl

    TxtCode.Enabled = True
    cmdGuide.Enabled = True

    CmdDel.Enabled = False
    cmdClr.Enabled = False
End Sub

Private Sub SerDataDisplay()
    proc_mode = 3
    TxtMode = "更  新"
    CmdEnt.Caption = "更新"
    CmdDel.Enabled = True

    Call SerDataDisplayDetail
    ds_index = 0
    Call RecButtonCtl
    TxtName.SetFocus
End Sub
Private Sub SerDataDisplayDetail()
'数据表示处理
'   婡  擻：选择偟偨数据的画面表示处理
'   参数：无
'   返回值：无
    Dim rst As ADODB.Recordset

    If proc_mode = 3 Then
        Set rst = DmqxSer
    Else
        Set rst = DMQX
    End If

    TxtCode = NoNull(rst!QXCODE)                       '操作员编号
    Dim remk As String
    TxtName = GetName(NoNull(rst!QXCODE), remk)                      '名称
    TxtRemk = Trim(remk)                       '备注
    If proc_mode = 3 Then
        Call ClearData
        Call SetSysList3
    Else
        Call SetSysList
    End If
    TxtCode.Enabled = False
    cmdGuide.Enabled = False
End Sub


Private Function GetName(code As String, remk As String) As String
    Dim Wksql As String
    Dim qx As New ADODB.Recordset
    Wksql = "select qxremk,qxname from dmqx"
    Wksql = Wksql & " where qxcode ='" & code & "' "
    With qx
        .ActiveConnection = ADOcon
        .Source = Wksql
        .Open