frmrkauditing.frm

通用书店管理系统

  Exit Sub
err:
  cN.RollbackTrans
  MsgBox "审批入库单失败：" & err.Description, vbInformation
End Sub

Private Sub chkFields_Click(Index As Integer)
  If chkFields(0).Value = 0 Then
     txtFields(0).Enabled = False
     cmdSearch(0).Enabled = False
  Else
     txtFields(0).Enabled = True
     cmdSearch(0).Enabled = True
  End If
  
  If chkFields(1).Value = 0 Then
     dtpInDate(0).Enabled = False
     dtpInDate(1).Enabled = False
  Else
     dtpInDate(0).Enabled = True
     dtpInDate(1).Enabled = True
  End If
End Sub

Public Sub cmdCancel_Click()
  Unload Me
End Sub

Private Sub cmdOK_Click()
  On Error GoTo err
  Dim itemX As ListItem
  Dim sqlstring As String
  Dim rstmp As New ADODB.Recordset
  Dim rsNewTmp As New ADODB.Recordset
    
  If chkFields(0).Value = 1 And chkFields(1).Value = 1 Then
     If txtFields(0).Text = "" Then
        MsgBox "请输入入库单号", vbInformation
        Exit Sub
     End If
     
     sqlstring = "select * from InstorageInformation where DatCheckDate is null and chrRKDH like '%" & _
                 txtFields(0).Text & "%' and datZDDate between #" & dtpInDate(0).Value & "# and #" & dtpInDate(1).Value & "# order by ChrRKDH"
     rstmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
     
  ElseIf chkFields(0).Value = 1 Then '按入库单号查询
     If txtFields(0).Text = "" Then
        MsgBox "请输入入库单号", vbInformation
        Exit Sub
     End If
     
     sqlstring = "select * from InstorageInformation where DatCheckDate is null and chrRKDH like '%" & _
                 txtFields(0).Text & "%' order by ChrRKDH"
     rstmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
     
  ElseIf chkFields(1).Value = 1 Then '按入库单填制日期查询
     sqlstring = "select * from InstorageInformation where DatCheckDate is null and datZDDate between #" & _
                 dtpInDate(0).Value & "# and #" & dtpInDate(1).Value & "# order by ChrRKDH"
     rstmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
  Else
     Exit Sub
  End If
  
   '设置视图的显示方式
   lstFields.ListItems.Clear
   lstFields.Checkboxes = True
   '添加视图内容
 
   lstFields.ListItems.Clear
   
   Do While Not rstmp.EOF
     Set itemX = lstFields.ListItems.Add(, , rstmp.Fields("ChrRKDH"))
     rstmp.MoveNext
   Loop
   
   strWhereCondition = ""
   
   sqlstring = "select top 1 ChrRKDH,ChrClientName,ChrInStorageName,ChrStorageName,ChrJBR,DatSSDate,ChrSSR,t1.DecAgio,ChrCHD,ChrFSDH," & _
              "ChrSellMode,DatPaymentDate,ChrPaymentMode,DecPaymentSum,ChrFKJBR,DecProtestSum,IntLDS,DecLDMY,DEcLDSY,IntSSS," & _
              "DecSSMY,DecSSSY,t1.ChrRemark,ChrZDR,DatZDDate FROM ((InStorageInformation t1 left JOIN ClientData t2 ON " & _
              "t1.ChrClientNo = t2.chrClientNo) left JOIN InStorageType t3 ON t1.ChrInStorageNo = t3.ChrInStorageNo) " & _
              "left JOIN StorageSection t4 ON t1.ChrStorageNo = t4.ChrStorageNo where chrRKDH='00'"
  
  Set rstmp = New ADODB.Recordset
  rstmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
  
  Set grdQryResult(1).DataSource = rstmp
  
  Call SetGridheader("入库单号|供货商号|入库类型|库区号|经办人|收书日期|收书人|折扣|传票号|发书单号|销售方式|付款日期|付款方式|付款金额|" & _
                     "付款经办人|拒付金额|来单数|来单码洋|来单实洋|实收数|实收码洋|实收实洋|备注|制单人|制单日期", 1)

  
  
  sqlstring = "select top 1 * from InstorageInformation_List where chrRKDH='00'"
  Set rsNewTmp = New ADODB.Recordset
  rsNewTmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
  
  Set grdQryResult(0).DataSource = rsNewTmp
  
  Call SetGridheader("入库单号|书号|书名|单价|折扣|册/包|包数|零头|出版日期|来单数|实收数", 0)

   
  Exit Sub
err:
  MsgBox "查询记录失败：" & err.Description, vbInformation
End Sub

Private Sub cmdSearch_Click(Index As Integer)
  On Error GoTo err
  Dim strQuery As String
  Dim arrQuery
  
  strQuery = g_CommonSelect("   入库单号   |    供应商号   |   入库类型   |  库区  |  经办人  |  发书单号  |  来单数  |  实收数  |  制单人  |  制单日期  ", "select t1.ChrRKDH,t1.ChrClientNo,t2.ChrInStorageName,t3.ChrStorageName," & _
             "t1.ChrJBR,t1.ChrFSDH,t1.IntLDS,t1.IntSSS,t1.ChrZDR,t1.DatZDDate from (InstorageInformation t1 left join InStorageType t2 ON  t1.ChrInStorageNo=t2.ChrInStorageNo) left join StorageSection t3 ON " & _
             "t1.ChrStorageNo=t3.ChrStorageNo where DatCheckDate is null order by ChrRKDH")
  txtFields(0).Text = strQuery

  Exit Sub
err:
   MsgBox "查询数据失败：" & err.Description, vbInformation
End Sub

Private Sub Form_Activate()
  Call ChangeToolBar(frmMain, 7, "审批", 14, "Audit")
  SetToolBar ("0000X01X001X111X1")
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    Call autoreturn(KeyAscii)
End Sub

Private Sub Form_Load()
  Frame2.BackColor = &HF0C0C0
  chkFields(0).BackColor = &HF0C0C0
  chkFields(1).BackColor = &HF0C0C0
  dtpInDate(0).Value = Format(Date, "yyyy-mm-dd")
  dtpInDate(1).Value = Format(Date, "yyyy-mm-dd")
  
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Call ChangeToolBar(frmMain, 7, "刷新", 6, "Refresh")
  SetToolBar ("0000X00X001X111X1")
End Sub

Private Sub lstFields_ItemCheck(ByVal Item As MSComctlLib.ListItem)
  Dim i As Integer
  Dim j As Integer
  Dim strItem As String
  Dim sqlstring As String
  Dim rstmp As New ADODB.Recordset
  Dim rsNewTmp As New ADODB.Recordset
  
  On Error GoTo err
  
  If Item.Checked = True Then
    strWhereCondition = strWhereCondition & "'" & CStr(Item) & "',"
    
  Else
     Call DelTxtItem(strWhereCondition, Trim(CStr(Item)))
  End If
  
  If Trim(strWhereCondition) = "" Then
     sqlstring = "select top 1 ChrRKDH,ChrClientName,ChrInStorageName,ChrStorageName,ChrJBR,DatSSDate,ChrSSR,t1.DecAgio,ChrCHD,ChrFSDH," & _
              "ChrSellMode,DatPaymentDate,ChrPaymentMode,DecPaymentSum,ChrFKJBR,DecProtestSum,IntLDS,DecLDMY,DEcLDSY,IntSSS," & _
              "DecSSMY,DecSSSY,t1.ChrRemark,ChrZDR,DatZDDate FROM ((InStorageInformation t1 left JOIN ClientData t2 ON " & _
              "t1.ChrClientNo = t2.chrClientNo) left JOIN InStorageType t3 ON t1.ChrInStorageNo = t3.ChrInStorageNo) " & _
              "left JOIN StorageSection t4 ON t1.ChrStorageNo = t4.ChrStorageNo where chrRKDH='00'"
  
      Set rstmp = New ADODB.Recordset
      rstmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
      
      Set grdQryResult(1).DataSource = rstmp
      
      Call SetGridheader("入库单号|供货商号|入库类型|库区号|经办人|收书日期|收书人|折扣|传票号|发书单号|销售方式|付款日期|付款方式|付款金额|" & _
                         "付款经办人|拒付金额|来单数|来单码洋|来单实洋|实收数|实收码洋|实收实洋|备注|制单人|制单日期", 1)
    
      
      
      sqlstring = "select top 1 * from InstorageInformation_List where chrRKDH='00'"
      Set rsNewTmp = New ADODB.Recordset
      rsNewTmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
      
      Set grdQryResult(0).DataSource = rsNewTmp
      
      Call SetGridheader("入库单号|书号|书名|单价|折扣|册/包|包数|零头|出版日期|来单数|实收数", 0)
       
      Exit Sub
  End If
  
  sqlstring = "select ChrRKDH,ChrClientName,ChrInStorageName,ChrStorageName,ChrJBR,DatSSDate,ChrSSR,t1.DecAgio,ChrCHD,ChrFSDH," & _
              "ChrSellMode,DatPaymentDate,ChrPaymentMode,DecPaymentSum,ChrFKJBR,DecProtestSum,IntLDS,DecLDMY,DEcLDSY,IntSSS," & _
              "DecSSMY,DecSSSY,t1.ChrRemark,ChrZDR,DatZDDate FROM ((InStorageInformation t1 left JOIN ClientData t2 ON " & _
              "t1.ChrClientNo = t2.chrClientNo) left JOIN InStorageType t3 ON t1.ChrInStorageNo = t3.ChrInStorageNo) " & _
              "left JOIN StorageSection t4 ON t1.ChrStorageNo = t4.ChrStorageNo where chrRKDH in (" & Mid(strWhereCondition, 1, Len(strWhereCondition) - 1) & ")"
  
  rstmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
  
  Set grdQryResult(1).DataSource = rstmp
  
  Call SetGridheader("入库单号|供货商号|入库类型|库区号|经办人|收书日期|收书人|折扣|传票号|发书单号|销售方式|付款日期|付款方式|付款金额|" & _
                     "付款经办人|拒付金额|来单数|来单码洋|来单实洋|实收数|实收码洋|实收实洋|备注|制单人|制单日期", 1)

  
  
  sqlstring = "select * from InstorageInformation_List where chrRKDH in (" & Mid(strWhereCondition, 1, Len(strWhereCondition) - 1) & ")"
  rsNewTmp.Open sqlstring, cN, adOpenKeyset, adLockReadOnly
  
  Set grdQryResult(0).DataSource = rsNewTmp
  
  Call SetGridheader("入库单号|书号|书名|单价|折扣|册/包|包数|零头|出版日期|来单数|实收数", 0)

  
  Exit Sub
err:
  MsgBox "显示记录出错：" & err.Description, vbInformation
End Sub

'在文本框中删除一列
Private Sub DelTxtItem(ByVal strTxtSql As String, strDelTxtSql As String)

  Dim strTmpsql As String
  
  strTmpsql = Replace(strTxtSql, "'" & strDelTxtSql & "',", " ", 1, , vbTextCompare)
  strWhereCondition = strTmpsql
   
End Sub

'设置TDBGRID的列头
Private Sub SetGridheader(ByVal strHeader As String, intNo As Integer)
  On Error Resume Next
  Dim arrHeader() As String
  Dim i As Integer
  
  arrHeader = Split(strHeader, "|", -1, vbTextCompare)
  For i = 0 To UBound(arrHeader)
     grdQryResult(intNo).Columns(i).Caption = arrHeader(i)
     grdQryResult(intNo).Columns(i).Alignment = dbgRight
     If Not IsDate(grdQryResult(intNo).Columns(i).Value) Then
        If i <> 0 And i <> 1 Then
            grdQryResult(intNo).Columns(i).NumberFormat = "#,##0.00"
        End If
     End If
     '自定义宽度
     grdQryResult(intNo).Columns(i).Width = grdQryResult(intNo).Columns(i).Width * (0.986 * grdQryResult(intNo).Font.Size / 9) + 100
     
  Next i
  
End Sub