frmitemunitcard.frm

金算盘软件代码

    Dim blnSQLExec As Boolean
    
    DelCard = False
    strSql = "SELECT * FROM ItemUnit WHERE lngUnitID=" & lngRecordID
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recSelect.EOF Then
        recSelect.Close
        Exit Function
    End If
    If CheckIDUsed("Item", "lngMinUnitID", lngRecordID) Then
       ShowMsg lnghWnd, "“" & recSelect!strUnitName & "”基本计量单位不能删除！", _
                 vbExclamation + MB_TASKMODAL, "删除计量单位"
       Exit Function
    End If
    If ItemUnitIsUsed(lngRecordID) Then
       ShowMsg lnghWnd, "“" & recSelect!strUnitName & "”计量单位已经发生业务,不能删除！", _
                 vbExclamation + MB_TASKMODAL, "删除计量单位"
       Exit Function
    End If
    intMsgReturn = ShowMsg(lnghWnd, "你确实要删除“" & recSelect!strUnitName & "”计量单位吗？", _
                 MB_ICONQUESTION + MB_YESNO + MB_SYSTEMMODAL, "删除计量单位")
    If intMsgReturn = IDYES Then
        strSql = "DELETE FROM ItemUnit  WHERE lngUnitID = " & lngRecordID
        blnSQLExec = gclsBase.ExecSQL(strSql)
        If blnSQLExec Then
           gclsSys.SendMessage CStr(Me.hWnd), Message.msgItem
        End If
    End If
    DelCard = blnSQLExec
    recSelect.Close
End Function

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
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
        cmdUnit(0).Value = True
    End If
End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandle
    Utility.LoadFormResPicture Me

    'Set mclsMainControl = gclsSys.MainControls.Add(Me)
'    SetHelpID Me.hwnd, 10214
    'frmItemList.IsShowCard = True
'    SendKeys "%{U}"
    Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim intMsgReturn As Integer
    
    If UnloadMode = vbFormControlMenu Then
       If mIsChanged = True Then
          intMsgReturn = ShowMsg(0, "当前计量单位已被修改，是否保存？", _
                        vbExclamation + vbYesNoCancel + MB_TASKMODAL, Me.Caption)
          If intMsgReturn = vbYes Then
             Cancel = Not SaveCard(True)
          ElseIf intMsgReturn = vbCancel Then
             Cancel = True
          End If
       End If
    End If
    If Not Cancel Then mIsChanged = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
     On Error Resume Next
     Utility.UnLoadFormResPicture Me
End Sub

Private Sub Form_Paint()
    FrameBox Me.hWnd, 120, 240, 3135, 1700 '画边框
End Sub

Private Sub InputAgain()
    tedUnitName(0).SelStart = 0
    tedUnitName(0).SelLength = StrLen(tedUnitName(0).Text)
    tedUnitName(0).SetFocus
End Sub

Private Sub cmdunit_Click(Index As Integer)
    Dim strSql As String
    Dim recUnit As rdoResultset
    
    Select Case Index
        Case 0    '确定
            If SaveCard(True) Then
'               strSql = "select * from itemunit order by lngUnitID"
'               Set recUnit = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'               If recUnit.RowCount > 0 Then
'                  recUnit.MoveLast
'                  ID = recUnit!lngUnitID
'               Else
'                  ID = 0
'               End If
               Unload Me
            End If
        Case 1    '取消
            Unload Me
        Case 2    '下一个
            SaveCard False
    End Select
End Sub

'通过事务处理完成对数据库的操作
'blnClickOK：是按[确定]按钮还是按[下一个]按钮
Private Function SaveCard(blnClickOK As Boolean, Optional blnByAdd As Boolean = False) As Boolean
    Dim intMsgReturn As Integer
    
    SaveCard = False
    If validityCheck(blnClickOK, blnByAdd) Then '检查数据的有效性并整理记录值成功
        gclsBase.BaseWorkSpace.BeginTrans
        If ExecBuffer Then  '修改数据库成功
            gclsBase.BaseWorkSpace.CommitTrans
            gclsSys.SendMessage CStr(Me.hWnd), Message.msgItemUnit
            SaveCard = True
            If Not blnClickOK Then
                InitAddCard , mUnit.lngItemID '为新增记录作设置
                InputAgain
                Exit Function
            End If
            
        Else '修改数据库不成功
            gclsBase.BaseWorkSpace.RollBacktrans
            mblnAddRecord = True
            InitAddCard '初始化
            InputAgain
        End If
    Else '检查数据的有效性并整理记录值不成功
        InitBuffer   '清空暂时存储数据库操作的数组
    End If
End Function

'检查数据的有效性并整理记录值,存储记录
'blnClickOK：是按[确定]按钮还是按[下一个]按钮
Private Function validityCheck(blnClickOK As Boolean, Optional blnByAdd As Boolean = False) As Boolean
    Dim intMsgReturn As Integer
    Dim strSql As String
    Dim recSelect As rdoResultset

    validityCheck = True
    If StrLen(Trim(tedUnitName(0).Text)) = 0 Then  '检查非空项
        If Not blnByAdd Then
            ShowMsg 0, " 计量单位名称必需输入！", _
                   vbExclamation + MB_SYSTEMMODAL, Me.Caption
            InputAgain
        End If
        validityCheck = False
        Exit Function
    ElseIf InStr(1, tedUnitName(0).Text, "'") <> 0 Then
        If Not blnByAdd Then
            ShowMsg 0, " 计量单位名称不能有‘'’符号！", _
                   vbExclamation + MB_SYSTEMMODAL, Me.Caption
        End If
       validityCheck = False
       InputAgain
       Exit Function
    ElseIf InStr(1, tedUnitName(0).Text, "|") <> 0 Then
        If Not blnByAdd Then
            ShowMsg 0, " 计量单位名称不能有‘|’符号！", _
                   vbExclamation + MB_SYSTEMMODAL, Me.Caption
        End If
       validityCheck = False
       InputAgain
       Exit Function
    End If
    If StrLen(Trim(tedUnitName(1).Text)) = 0 Then  '检查非空项
        If Not blnByAdd Then
            ShowMsg 0, " 计量规格必需输入！", _
                   vbExclamation + MB_SYSTEMMODAL, Me.Caption
        End If
        validityCheck = False
        tedUnitName(1).SetFocus
        Exit Function
    End If
    If Val(tedUnitName(1).Text) = 0 Then '检查非空项
        If Not blnByAdd Then
            ShowMsg 0, " 计量规格必需大于零！", _
                    vbExclamation + MB_SYSTEMMODAL, Me.Caption
        End If
        validityCheck = False
        tedUnitName(1).SetFocus
        Exit Function
    End If
    
    With mUnit
        If mIsChanged = True Then       '编码已改变
            strSql = "SELECT * FROM itemunit WHERE strUnitName='" & tedUnitName(0).Text & _
            "' and lngItemID = " & .lngItemID & " and lngUnitID not in (" & .lngUnitID & ")"
            Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recSelect.RowCount <> 0 Then          '编码不唯一，摘要不能重复
                If Not blnByAdd Then
                    ShowMsg 0, "此计量单位已存在，请重新输入。", _
                               vbExclamation + MB_TASKMODAL, Me.Caption
                    InputAgain
                End If
                validityCheck = False
                recSelect.Close
                Exit Function
            Else '编码唯一
                SettingRecord '整理记录
                If mblnAddRecord Then
                    ID = GetNewID("ItemUnit")
                    SetBuffer "INSERT INTO ItemUnit(LNGUNITID,strUnitname,dblfactor,lngitemid) " _
                        & "VALUES(" & ID & ", '" & mUnit.strUnitName & "'," _
                        & mUnit.dblFactor & "," & mUnit.lngItemID & ")"    '插入数据库记录
                Else
                    SetBuffer "UPDATE itemunit SET strunitname='" & .strUnitName & "',dblfactor=" & .dblFactor _
                        & " WHERE lngunitID =" & .lngUnitID  '修改数据库记录
                End If
                recSelect.Close
            End If
'        Else '编码未改变
'            SettingRecord '整理记录
'            SetBuffer "UPDATE itemunit SET strUnitName='" & .strUnitName _
'                & "' WHERE lngUnitID =" _
'                & .lngUnitID  '修改数据库记录
        End If
    End With
End Function

'存入数据库之前整理记录值
Private Sub SettingRecord()
    With mUnit
        .strUnitName = Trim(tedUnitName(0).Text)
        .dblFactor = Val(tedUnitName(1).Text)
    End With
End Sub

'把对数据库的增删改操作暂时存储在数组中
Private Sub SetBuffer(strSql As String)
    If mintSQLIndex = 0 Then
        ReDim mstrSQLBuffer(0)
    Else
        ReDim Preserve mstrSQLBuffer(UBound(mstrSQLBuffer) + 1)
    End If
    mstrSQLBuffer(mintSQLIndex) = strSql
    mintSQLIndex = mintSQLIndex + 1
End Sub

'清空暂时存储数据库操作的数组
Private Sub InitBuffer()
    ReDim mstrSQLBuffer(0)
    mintSQLIndex = 0
End Sub

'执行暂时存储在数组中的数据库操作
Private Function ExecBuffer() As Boolean
    Dim blnExecSQL As Boolean
    Dim intSQLIndex As Integer
    
    If mintSQLIndex = 0 Then
        ExecBuffer = True
        Exit Function
    End If
    For intSQLIndex = 0 To mintSQLIndex - 1
        blnExecSQL = gclsBase.ExecSQL(mstrSQLBuffer(intSQLIndex))
        If Not blnExecSQL Then Exit For
    Next intSQLIndex
    ExecBuffer = blnExecSQL
End Function


Private Sub Label1_Click()

End Sub

Private Sub tedUnitName_Change(Index As Integer)
    Dim i As Integer
    
    Select Case Index
           Case 0
                If ContainErrorChar(tedUnitName(0).Text, "'|") Then
                   BKKEY tedUnitName(0).hWnd
                   Exit Sub
                End If
                If StrLen(tedUnitName(0).Text) > 6 Then
                   BKKEY tedUnitName(0).hWnd
                   Exit Sub
                End If
           Case 1
                If Left(tedUnitName(1).Text, 1) = "0" Then
                   BKKEY tedUnitName(1).hWnd
                   Exit Sub
                End If
                For i = 1 To StrLen(tedUnitName(1).Text)
                    If InStr(1, "0123456789", Mid(tedUnitName(1).Text, i, 1)) = 0 Then
                       BKKEY tedUnitName(1).hWnd
                       Exit Sub
                    End If
                Next
    End Select
     
End Sub

Private Sub tedUnitName_KeyPress(Index As Integer, KeyAscii As Integer)
      mIsChanged = True
End Sub

Private Sub tedUnitName_LostFocus(Index As Integer)
    mIsChanged = True
End Sub

Private Sub tedUnitName_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
     mIsChanged = True
End Sub