apmi0400.frm

ERP中的一个子模块

        If .RecordCount > 0 Then
            GetName = NoNull(!QXNAME)
            remk = NoNull(!QXREMK)
        End If
        .Close
    End With
    Set qx = Nothing
End Function


Private Function update_check() As Boolean
    '登录·更新时数据检查
    Dim wk_data As String
    
    update_check = False
    
    '分类编号
    If Trim(TxtCode) = "" Then
        Call MsgDisplay(NOT_CUT, "")
        TxtCode.SetFocus
        Exit Function
    End If

    If Code_check(True) = False Then
        TxtCode.SetFocus
        Exit Function
    End If
    
    '名称
    If Trim(TxtName) = "" Then
        Call MsgDisplay(NOT_CUT, "")
        TxtName.SetFocus
        Exit Function
    End If
    update_check = True

End Function

Private Function update_db_proc() As Boolean
    Dim acCmd As New ADODB.Command
    Dim acLock As New ADODB.Command
    Dim Wksql As String
    Dim wkWhere As String

    update_db_proc = False

    On Error GoTo ErrProc

    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 = "UPDATE DMQX SET"
    Wksql = Wksql & " QXNAME ='" & Trim(TxtName) & "'"
    Wksql = Wksql & ",QXREMK ='" & Trim(TxtRemk) & "'"
    Wksql = AddUpdateInfo(Wksql)
    Wksql = Wksql & wkWhere
    With acCmd
        .ActiveConnection = ADOcon
        .CommandText = RepSql(Wksql)
        .CommandType = adCmdText
        .Execute
    End With
    ADOcon.CommitTrans

    Set acCmd = Nothing
    Set acLock = Nothing

    update_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 Sub cmdSer_Click()
    
    Dim result As Integer
    
    Dim bkdata(1) As String
    Load FrmMi41
    With FrmMi41
        .Show vbModal    ' 检索条件设定画面表示
        If True = .result Then
            bkdata(0) = serchData(0)
            bkdata(1) = serchData(1)
            ' 检索条件的代入
            serchData(0) = .cd(0)
            serchData(1) = .cd(1)
            result = DmqxSerch     ' 数据库检索
            If result = True Then
                proc_mode = 3
                cmdClr.Enabled = True
                Call SerDataDisplay
            Else
                '数据偑无偐偭偨时候偼前回的条件傪再度存放
                serchData(0) = bkdata(0)
                serchData(1) = bkdata(1)
            End If
        Else
            If proc_mode = 1 Then
                TxtCode.SetFocus
            Else
                TxtName.SetFocus
            End If
        End If
    End With
    Unload FrmMi41
    Set FrmMi41 = Nothing
End Sub


Private Sub Cmdtoright_Click()
    Dim i As Integer
    If LstPrg(0).SelCount > 0 Then
        For i = LstPrg(0).ListCount - 1 To 0 Step -1
            If LstPrg(0).Selected(i) = True Then
                Pglist.AddtoList(LstPrg(0).ItemData(i)) = True
                LstPrg(1).AddItem LstPrg(0).List(i)
                LstPrg(1).ItemData(LstPrg(1).NewIndex) = AnsiMidB(LstPrg(0).List(i), (AnsiInStrB(LstPrg(0).List(i), "=") + 1))
                LstPrg(0).RemoveItem i
            End If
        Next
'        Call SetInlist
'        Call SetNotinlist
    End If
    LstPrg(0).SetFocus
End Sub

Private Sub Cmdtoleft_Click()
    Dim i As Integer
    If LstPrg(1).SelCount > 0 Then
        For i = LstPrg(1).ListCount - 1 To 0 Step -1
            If LstPrg(1).Selected(i) = True Then
                Pglist.AddtoList(LstPrg(1).ItemData(i)) = False
                If Pglist.SubSystem(AnsiMidB(LstPrg(1).List(i), (AnsiInStrB(LstPrg(1).List(i), "=") + 1))) = _
                    Trim(AnsiLeftB(Trim(CboSubSystem), AnsiInStrB(Trim(CboSubSystem), "=") - 1)) Then
                    Pglist.AddtoList(AnsiMidB(LstPrg(1).List(i), (AnsiInStrB(LstPrg(1).List(i), "=") + 1))) = False
                    LstPrg(0).AddItem LstPrg(1).List(i)
                    LstPrg(0).ItemData(LstPrg(0).NewIndex) = AnsiMidB(LstPrg(1).List(i), (AnsiInStrB(LstPrg(1).List(i), "=") + 1))
                End If
                LstPrg(1).RemoveItem i
            End If
        Next
'        Call SetInlist
        Call SetNotinlist
    End If
    LstPrg(1).SetFocus
End Sub


Private Sub Cmdtoleftall_Click()
    Dim i As Integer
    For i = LstPrg(1).ListCount - 1 To 0 Step -1
        Pglist.AddtoList(AnsiMidB(LstPrg(1).List(i), (AnsiInStrB(LstPrg(1).List(i), "=") + 1))) = False
        Pglist.AddtoList(LstPrg(1).ItemData(i)) = False
        If Pglist.SubSystem(AnsiMidB(LstPrg(1).List(i), (AnsiInStrB(LstPrg(1).List(i), "=") + 1))) = _
            Trim(AnsiLeftB(Trim(CboSubSystem), AnsiInStrB(Trim(CboSubSystem), "=") - 1)) Then
            LstPrg(0).AddItem LstPrg(1).List(i), 0
            LstPrg(0).ItemData(LstPrg(0).NewIndex) = AnsiMidB(LstPrg(1).List(i), (AnsiInStrB(LstPrg(1).List(i), "=") + 1))
        End If
        LstPrg(1).RemoveItem i
    Next
End Sub


Private Sub Cmdtorightall_Click()
    Dim i As Integer
    For i = LstPrg(0).ListCount - 1 To 0 Step -1
        Pglist.AddtoList(LstPrg(0).ItemData(i)) = True
        LstPrg(0).RemoveItem i
    Next
    Call SetInlist
'    Call SetNotinlist
End Sub

Private Sub Form_Load()
    ReDim txtfmt(2) As String
    If startProc(Me) = False Then Unload Me
    Call draw3DFrm(Me)  ' 3D用Line 表示
    Call FldOp.setTxtFmt(txtfmt())
    Call GetListInINI
    Call main_proc
End Sub


Public Function GetListInINI() As Boolean
    Dim f As Long
    Dim lnbuf As String     ' 1峴僶僢僼傽
    Dim fnm As String
    Dim SubCount As Integer
    Dim SubCountALL As Integer
    Dim InSubSystem As Boolean
    Dim CurSubsys As String
    Dim i As Integer
    Dim NextRec As Boolean
    fnm = Dirname & "\DMCSW.INI"
    NextRec = False
    f = FreeFile
    Open fnm For Input As f
    ReDim SubSysteminINI(0)
    Do Until (EOF(f))          ' INI僼傽僀儖撉傒崬傒
        If NextRec = False Then Line Input #f, lnbuf
        If 0 < InStr(1, lnbuf, "[SUBSYSTEM]") Then
            '取下所有SUBSYSTEM下的子目录，放入SubSysteminINI(SubCount)中，记录由0开始
            Do Until (EOF(f))
                Line Input #f, lnbuf
                If Trim(lnbuf) <> "" Then
                    If 0 = InStr(1, lnbuf, "[") Then
                        ReDim Preserve SubSysteminINI(SubCount)
                        SubSysteminINI(SubCount) = Trim(AnsiMidB(lnbuf, 1, AnsiInStrB(1, lnbuf, "=") - 1))
                        SubCount = SubCount + 1
                    Else
                        Exit Do
                    End If
                End If
            Loop
        End If
        
'        '取入某子目录下的所有程序ID，程序名
'        If 0 < InStr(1, lnbuf, "[") Then
            '判断此子目录在SUBSYSTEM中是否存在
            InSubSystem = False
            For i = 0 To UBound(SubSysteminINI) - 1
                If AnsiMidB(lnbuf, 2, AnsiInStrB(1, lnbuf, "]") - 2) = SubSysteminINI(i) Then
                    InSubSystem = True
                    CurSubsys = SubSysteminINI(i)
                    Exit For
                End If
            Next
            NextRec = False
            '如果存在，取入某子目录下的所有程序ID，程序名
            If InSubSystem = True Then
' 　              SubCountALL = 0
                Do Until (EOF(f))
                    Line Input #f, lnbuf
                    If Trim(lnbuf) <> "" Then
                        If 0 = InStr(1, lnbuf, "]") Then
                            If 0 = InStr(1, lnbuf, "<") Then
                                ReDim Preserve Pglist.SubSystem(SubCountALL)
                                ReDim Preserve Pglist.PgID(SubCountALL)
                                ReDim Preserve Pglist.PgNAME(SubCountALL)
                                ReDim Preserve Pglist.AddtoList(SubCountALL)
                                Pglist.SubSystem(SubCountALL) = CurSubsys
                                Pglist.PgID(SubCountALL) = Trim(AnsiMidB(lnbuf, AnsiInStrB(1, lnbuf, "=") + 1))
                                Pglist.PgNAME(SubCountALL) = Trim(AnsiMidB(lnbuf, 1, AnsiInStrB(1, lnbuf, "=") - 1))
                                Pglist.AddtoList(SubCountALL) = False
                                SubCountALL = SubCountALL + 1
                            End If
                        Else
                            CurSubsys = AnsiMidB(lnbuf, 2, AnsiInStrB(1, lnbuf, "]") - 2)
                            NextRec = True
                            Exit Do
                        End If
                    End If
                Loop
            End If
'        End If
continue:
    Loop
    Close f
    GetListInINI = True
End Function

Private Function ClearData() As Boolean
    Dim i As Integer
    For i = 0 To UBound(Pglist.PgID) - 1
        Pglist.AddtoList(i) = False
    Next
End Function


Private Sub Form_Unload(Cancel As Integer)
    If (App.PrevInstance = False) Then
        If vbCancel = MsgDisplay(END_OK, "") Then
            Cancel = -1
            Exit Sub
        End If
    End If
    Call endProc    ' 结束处理
    End
End Sub

Private Sub LstPrg_DblClick(Index As Integer)
    If Index = 0 Then
        Call Cmdtoright_Click
    Else
        Call Cmdtoleft_Click
    End If
End Sub

Private Sub TxtCode_GotFocus()
    Set FldOp.ctrl = ActiveControl
    FldOp.gotFocus
End Sub
Private Sub TxtCode_KeyPress(KeyAscii As Integer)
    KeyAscii = FldOp.keyPress(KeyAscii)
    If KeyAscii = 0 Then TxtCode_LostFocus
End Sub
Private Sub TxtCode_LostFocus()
    Dim result As Integer
    FldOp.lostFocus

    If ActiveControl.Name = TxtCode.Name Then
        If Trim(TxtCode) = "" Then
            FldOp.gotFocus
            Exit Sub
        End If
        result = Code_check(False)
        Call SetSysList
        Call SetInlistfromtable
        If proc_mode = 1 And result = False Then
            proc_mode = 2               '更新?霓傊移行
            CmdEnt.Caption = "更新"
            TxtMode.Caption = "更  新"
            ds_index = 0
            Call SerDataDisplayDetail
            CmdDel.Enabled = True
        Else
            FldOp.moveFcs
        End If
        cmdClr.Enabled = True
    End If
End Sub

Private Sub SetSysList()
    Call SetSubSystem
    Call SetInlist
    Call SetNotinlist
End Sub

Private Sub SetSysList3()
    Call SetSubSystem
'    If CboSubSystem.ListIndex > 0 Then CboSubSystem.ListIndex = 0
    Call SetInlistfromtable
    Call SetNotinlist
End Sub


Private Sub SetSubSystem()
    Dim i As Integer
    CboSubSystem.Clear
    For i = 0 To UBound(SubSysteminINI) - 1
        CboSubSystem.AddItem SubSysteminINI(i) & Space(100 - AnsiLenB(SubSysteminINI(i))) & "=" & i
        CboSubSystem.ItemData(CboSubSystem.NewIndex) = i
    Next
    CboSubSystem.ListIndex = 0
End Sub

Private Sub SetNotinlist()
    Dim i As Integer
    LstPrg(0).Clear
    For i = 0 To UBound(Pglist.PgNAME) - 1
        If Pglist.SubSystem(i) = Trim(AnsiLeftB(Trim(CboSubSystem), AnsiInStrB(Trim(CboSubSystem), "=") - 1)) And Pglist.AddtoList(i) = False Then
            LstPrg(0).AddItem Trim(Pglist.PgNAME(i)) & Space(100 - AnsiLenB(Trim(Pglist.PgNAME(i)))) & "=" & i
            LstPrg(0).ItemData(LstPrg(0).NewIndex) = i
        End If
    Next
End Sub


Private Sub SetInlist()
    Dim i As Integer
    LstPrg(1).Clear
    For i = 0 To UBound(Pglist.PgNAME) - 1
'        If Pglist.SubSystem(i) = Trim(AnsiLeftB(Trim(CboSubSystem), AnsiInStrB(Trim(CboSubSystem), "=") - 1)) And Pglist.AddtoList(i) = True Then
        If Pglist.AddtoList(i) = True Then
            LstPrg(1).AddItem Trim(Pglist.PgNAME(i)) & Space(100 - AnsiLenB(Trim(Pglist.PgNAME(i)))) & "=" & i
            LstPrg(1).ItemData(LstPrg(1).NewIndex) = i
        End If
    Next
End Sub



Private Sub SetInlistfromtable()
    Dim i As Integer
    Dim j As Integer
    Dim DMQX As New ADODB.Recordset
    Dim Wksql As String
    LstPrg(1).Clear
    Wksql = "select * from dmqx"
    Wksql = Wksql & " where qxcode='" & Trim(TxtCode) & "'"
    With DMQX
        .ActiveConnection = ADOcon
        .Source = Wksql
        .Open
        If .RecordCount > 0 Then
            For i = 0 To .RecordCount - 1
                For j = 0 To UBound(Pglist.PgID) - 1
                    If NoNull(!QXPGID) = Pglist.PgID(j) Then
                        Pglist.AddtoList(j) = True
                        LstPrg(1).AddItem NoNull(!QXPGNM) & Space(100 - AnsiLenB(NoNull(!QXPGNM))) & "=" & j
                        LstPrg(1).ItemData(LstPrg(1).NewIndex) = j
                        Exit For
                    End If
                Next
                .MoveNext
            Next
        End If
    End With
End Sub


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

Private Sub TxtName_KeyPress(KeyAscii As Integer)
    KeyAscii = FldOp.keyPress(KeyAscii)
    If KeyAscii = 0 Then Call TxtName_LostFocus
End Sub

Private Sub TxtName_LostFocus()
    FldOp.lostFocus
    If ActiveControl.Name = TxtName.Name Then
        If Trim(TxtName) = "" Then
            FldOp.gotFocus
            Exit Sub
        End If
        FldOp.moveFcs
    End If
End Sub

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

Private Sub TxtRemk_KeyPress(KeyAscii As Integer)
    KeyAscii = FldOp.keyPress(KeyAscii)
    If KeyAscii = 0 Then TxtRemk_LostFocus
End Sub

Private Sub TxtRemk_LostFocus()
    FldOp.lostFocus
    If ActiveControl.Name = TxtRemk.Name Then
        FldOp.moveFcs
    End If
End Sub

Private Sub Move_Point()
'检索时偵更新·削除偟偨场合，正确的数据位置止移动偝偣傞
    DmqxSer.Move ds_index
End Sub

Private Function time_check(ByVal tm As String) As Boolean
'时间检查进行
'  参数：vd ： String宆 时间数据
'  返回值：OK：True, NG：False
    Dim stm As String
    Dim hh As Long
    Dim mm As Long
    Dim tmp As String
    
    time_check = False
    
    stm = Trim(tm)
    Call Replace(stm, ":", "") ' ":"偑偁傟偽庢傞
    If 0 < InStr(stm, ".") Then Exit Function
    If 0 < InStr(stm, ",") Then Exit Function
    If 0 < InStr(stm, "+") Then Exit Function
    If 0 < InStr(stm, "-") Then Exit Function
    If False = IsNumeric(stm) Then Exit Function
    stm = "000" & stm
    hh = CLng(Mid(stm, Len(stm) - 3, 2))
    mm = CLng(Right(stm, 2))
    
    ' 存在不进行时间偐丠
    If (hh > 23) Or (hh < 0) Or (mm > 59) Or mm < 0 Then Exit Function
    
    time_check = True

End Function