frmbookoutstorage.frm

来自「通用书店管理系统」· FRM 代码 · 共 1,729 行 · 第 1/5 页

            Me.Caption = "出库单管理----新增"
            
            setTxtWritable ("01101111")
            setCmbWritable ("111")
            setDtpWritable ("1")
            
            tdbBook.AllowAddNew = True
            tdbBook.AllowUpdate = True
            tdbBook.AllowDelete = True
            SetToolBar ("0011X00X001X111X1")
        Case modEdit
            Me.Caption = "出库单管理----修改"
            setTxtWritable ("01101111")
            setCmbWritable ("111")
            setDtpWritable ("1")
                
            tdbBook.AllowAddNew = True
            tdbBook.AllowUpdate = True
            tdbBook.AllowDelete = True
            SetToolBar ("0011X00X001X111X1")
    End Select

End Sub

Private Sub clearAll()          '清除所有可填数据的位置
    Dim i As Integer
    
    For i = 0 To txtFields.UBound
        Select Case i
          Case 5 '数量
              txtFields(i).Text = "0"
          Case 6, 7 '码洋、实洋
              txtFields(i).Text = "0.00"
          Case Else
              txtFields(i).Text = ""
        End Select
    Next i
    
    For i = 0 To cmbFields.UBound
       cmbFields(i).Text = ""
    Next i
    
    For i = 0 To dtpInDate.UBound
       dtpInDate(i).Value = Format(Date, "yyyy-mm-dd")
    Next i
    
    
    X.ReDim 0, -1, 0, 8
    tdbBook.ReBind
    
End Sub

Private Sub setTxtWritable(strIn As String)     '设置各文本框的可写属性
    Dim i As Integer
    
    For i = 0 To txtFields.UBound
        If Mid(strIn, i + 1, 1) = 1 Then
            txtFields(i).Locked = False
            txtFields(i).BackColor = RGB(255, 255, 255)
        Else
            txtFields(i).Locked = True
            txtFields(i).BackColor = gColor_LockedText
        End If
    Next i
End Sub

Private Sub setCmbWritable(strIn As String)     '设置各下拉框的可写属性
    Dim i As Integer
    
    For i = 0 To cmbFields.UBound
        If Mid(strIn, i + 1, 1) = 1 Then
            cmbFields(i).Locked = False
            cmbFields(i).BackColor = RGB(255, 255, 255)
        Else
            cmbFields(i).Locked = True
            cmbFields(i).BackColor = gColor_LockedText
        End If
    Next i
End Sub


Private Sub setDtpWritable(strIn As String)     '设置各日期下拉框的可写属性
    Dim i As Integer
    
    For i = 0 To dtpInDate.UBound
        If Mid(strIn, i + 1, 1) = 1 Then
            dtpInDate(i).Enabled = True
        Else
            dtpInDate(i).Enabled = False
        End If
    Next i
End Sub



'保存新增的记录
Private Function SaveAddingNew() As Boolean     'True for success
    
    Dim i As Integer
    Dim strSQL As String
    Dim lngAffectedRow As Long
    
    SaveAddingNew = False
    

    strSQL = "insert into OutstorageInformation(ChrCKDH,ChrOutStorageNo,ChrStorageNo1,ChrStorageNo2,DecAgio," & _
                     "IntTotal,DecMY,DecSY,ChrRemark,ChrJBR,ChrZDR,DatDate) values("
   
    strSQL = strSQL & _
                 "'" & txtFields(0).Text & "','" & GetOutStorageNo(cmbFields(0).Text) & "'," & _
                 "'" & GetStorageNo(cmbFields(1).Text) & "'," & "'" & GetStorageNo(cmbFields(2).Text) & _
                 "'," & txtFields(2).Text & "," & CLng(txtFields(5).Text) & "," & CDbl(txtFields(6)) & _
                 "," & CDbl(txtFields(7).Text) & ",'" & txtFields(4).Text & "','" & txtFields(1).Text & _
                 "','" & txtFields(3).Text & "',#" & Format((dtpInDate(0).Value), "yyyy-mm-dd") & "#)"
   
   
    On Error GoTo ToError
    cN.BeginTrans
    
    '开始保存主表
    cN.Execute strSQL, lngAffectedRow
    If lngAffectedRow <> 1 Then GoTo ToError
    
     
    '如果主表保存成功，开始保存从表
    cN.Execute "delete from OutstorageInformation_List where ChrCKDH='" & txtFields(0).Text & "'", lngAffectedRow

    For i = 0 To X.UpperBound(1)
        strSQL = "insert into OutstorageInformation_List(ChrCKDH,ChrBookNo,ChrBookName,DecPrice," & _
                 "DecAgio,IntAmount,ChrCB,IntBagCount,IntOddment) values("
        strSQL = strSQL & _
                     "'" & txtFields(0) & "','" & _
                           X(i, 1) & "','" & _
                           X(i, 2) & "'," & _
                           CDbl(X(i, 3)) & "," & _
                           CDbl(X(i, 4)) & "," & _
                           CLng(X(i, 8)) & ",'" & _
                           X(i, 5) & "'," & _
                           CLng(X(i, 6)) & "," & _
                           CLng(X(i, 7)) & ")"

        
        cN.Execute strSQL, lngAffectedRow
        If lngAffectedRow <> 1 Then GoTo ToError
    Next i
'
    
    '主从表都保存成功
    cN.CommitTrans
    SaveAddingNew = True
    
    Exit Function

ToError:
    Select Case err.Number
      Case "-2147467259"
        cN.RollbackTrans
        txtFields(0).Text = GetMaxNo("ChrCKDH", "OutstorageInformation", strDate)
        Call SaveAddingNew
        SaveAddingNew = True
        Exit Function
      Case Else
        cN.RollbackTrans
    
        MsgBox "保存记录出错:" & err.Description, vbInformation
        SaveAddingNew = False
    End Select
    
End Function

'更新修改的内容
Private Function SaveUpdate() As Boolean        'True for success
    
    Dim i As Integer
    Dim strSQL As String
    Dim lngAffectedRow As Long
    
    SaveUpdate = False
    Select Case cmbFields(0)
      Case "调拨"
           strSQL = "update  OutstorageInformation set " & _
                "ChrOutStorageNo='" & GetOutStorageNo(cmbFields(0)) & "'," & _
                "ChrStorageNo1='" & GetStorageNo(cmbFields(1)) & "'," & "ChrStorageNo2='" & GetStorageNo(cmbFields(2)) & "'," & _
                "DecAgio=" & CDbl(txtFields(2)) & "," & "intTotal=" & CLng(txtFields(5)) & "," & _
                "decMY=" & CDbl(txtFields(6)) & "," & "decSY=" & CDbl(txtFields(7)) & "," & _
                "ChrRemark='" & txtFields(4) & "',chrJBR='" & txtFields(1) & "',ChrZDR='" & txtFields(3) & "'," & _
                "DatDate=#" & Format((dtpInDate(0).Value), "yyyy-mm-dd") & "# " & _
                " where ChrCKDH='" & txtFields(0).Text & "'"
    
      Case Else
           strSQL = "update  OutstorageInformation set " & _
                "ChrOutStorageNo='" & GetOutStorageNo(cmbFields(0)) & "'," & _
                "ChrStorageNo1='" & GetStorageNo(cmbFields(1)) & "',ChrStorageNo2=''," & _
                "DecAgio=" & CDbl(txtFields(2)) & "," & "intTotal=" & CLng(txtFields(5)) & "," & _
                "decMY=" & CDbl(txtFields(6)) & "," & "decSY=" & CDbl(txtFields(7)) & "," & _
                "ChrRemark='" & txtFields(4) & "',chrJBR='" & txtFields(1) & "',ChrZDR='" & txtFields(3) & "'," & _
                "DatDate=#" & Format((dtpInDate(0).Value), "yyyy-mm-dd") & "# " & _
                " where ChrCKDH='" & txtFields(0).Text & "'"
    
    End Select
    
    On Error GoTo ToError
    cN.BeginTrans
    
    '开始更新主表
    cN.Execute strSQL, lngAffectedRow
    If lngAffectedRow <> 1 Then GoTo ToError
    
    
      
    '如果主表保存成功，开始保存从表
    cN.Execute "delete from OutstorageInformation_List where ChrCKDH='" & txtFields(0).Text & "'", lngAffectedRow

    For i = 0 To X.UpperBound(1)
        strSQL = "insert into OutstorageInformation_List(ChrCKDH,ChrBookNo,ChrBookName,DecPrice," & _
                 "DecAgio,IntAmount,ChrCB,IntBagCount,IntOddment) values("
        strSQL = strSQL & _
                     "'" & txtFields(0) & "','" & _
                           X(i, 1) & "','" & _
                           X(i, 2) & "'," & _
                           CDbl(X(i, 3)) & "," & _
                           CDbl(X(i, 4)) & "," & _
                           CLng(X(i, 8)) & ",'" & _
                           X(i, 5) & "'," & _
                           CLng(X(i, 6)) & "," & _
                           CLng(X(i, 7)) & ")"

        cN.Execute strSQL, lngAffectedRow
        If lngAffectedRow <> 1 Then GoTo ToError
    Next i
    
    '主从表都更新成功
    cN.CommitTrans
    SaveUpdate = True
    Exit Function

ToError:
    cN.RollbackTrans
    MsgBox "保存记录出错:" & err.Description
    SaveUpdate = False
    
End Function
'显示主表信息
Private Function ShowMainRecorder() As Boolean
  On Error GoTo err
  Dim sqlstring As String
  Dim rsNewTmp As New ADODB.Recordset
  
  sqlstring = "select * from OutstorageInformation where ChrCKDH='" & txtFields(0).Text & "'"
  rsNewTmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
     
  If rsNewTmp.EOF Then
    ShowMainRecorder = False
    Exit Function
  End If
     
  Do While Not rsNewTmp.EOF
     txtFields(1).Text = rsNewTmp("chrJBR")
     txtFields(2).Text = rsNewTmp("decAgio")
     txtFields(3).Text = rsNewTmp("chrZDR")
     txtFields(4).Text = rsNewTmp("chrRemark")
     txtFields(5).Text = rsNewTmp("intTotal")
     txtFields(6).Text = rsNewTmp("decMY")
     txtFields(7).Text = rsNewTmp("decSY")
               
     cmbFields(0) = GetOutStorageName(rsNewTmp.Fields("ChrOutStorageNo"))
     Select Case cmbFields(0)
       Case "调拨"
         cmbFields(2).Visible = True
         Label1(7).Visible = True
       Case Else
         cmbFields(2).Visible = False
         Label1(7).Visible = False
     End Select
     cmbFields(1) = GetStorageName(rsNewTmp.Fields("ChrStorageNo1"))
     cmbFields(2) = GetStorageName(rsNewTmp.Fields("ChrStorageNo2"))
              
     dtpInDate(0).Value = Format((rsNewTmp.Fields("datDate").Value), "yyyy-mm-dd")
     
     
     rsNewTmp.MoveNext
  Loop
  
  ShowMainRecorder = True
  Exit Function
err:
  ShowMainRecorder = False
  MsgBox "查询记录失败：" & err.Description, vbInformation
  

End Function

'显示从表信息
Private Sub ShowSubRecorder()
  On Error GoTo err
  Dim i As Integer
  Dim sqlstring As String
  Dim rsNewTmp As New ADODB.Recordset
  
  sqlstring = "select * from OutstorageInformation_List where ChrCKDH='" & txtFields(0).Text & "'"
  rsNewTmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
     
  X.ReDim 0, rsNewTmp.Recordcount - 1, 0, 8
  
     
  For i = 0 To rsNewTmp.Recordcount - 1
     X(i, 0) = rsNewTmp.Fields("ChrCKDH").Value
     X(i, 1) = rsNewTmp.Fields("chrBookNo").Value
     X(i, 2) = rsNewTmp.Fields("chrBookName").Value
     X(i, 3) = rsNewTmp.Fields("decPrice").Value
     X(i, 4) = rsNewTmp.Fields("DecAgio").Value
     X(i, 5) = rsNewTmp.Fields("chrCB").Value
     X(i, 6) = rsNewTmp.Fields("intBagCount").Value
     X(i, 7) = rsNewTmp.Fields("intOddment").Value
     X(i, 8) = rsNewTmp.Fields("intAmount").Value
     rsNewTmp.MoveNext
  Next i
  
  tdbBook.ReBind
  
  Exit Sub
err:
  MsgBox "查询记录失败：" & err.Description, vbInformation
  
End Sub


Private Function CheckRepeatData(ByVal strBookID As String, ByVal strBookName As String) As Boolean
    Dim absRow As Long
    Dim i As Long
    
    CheckRepeatData = False
    
    absRow = IIf(tdbBook.FirstRow = "", 0, tdbBook.FirstRow) + tdbBook.row
    i = 0
    'tdbbook.MoveFirst
    Do While True
        If i <> absRow Then
            If tdbBook.Columns(1).CellText(i) = strBookID And tdbBook.Columns(2).CellText(i) = strBookName Then
                Debug.Print "repeat"
                CheckRepeatData = True
'                X(i, 6) = IIf(IsEmpty(tdbBook.Columns(6).CellText(i)), "1", tdbBook.Columns(6).CellText(i)) + 1
'                X(i, 6) = tdbBook.Columns(6).CellText(i) + 1
'                X(i, 7) = tdbBook.Columns(7).CellText(i) + 1
                X(i, 8) = tdbBook.Columns(