frmzjdj-a.frm

适合于中小型企业管理

                        MsgBox "日期数据不支持“LIKE”！", vbOKOnly + vbExclamation, "警告"
                        Exit Sub
                    Else
                        TxtSql = TxtSql & Cmb2.Text & " " & Like2.Text & " '" & Trim(Txt02.Text) & "' "
                    End If
                End If
            Else
                dd(1) = True
                If dd(0) = True Then
                    If Like2.Text = "Like" Then
                        TxtSql = TxtSql & " and " & Cmb2.Text & " " & Like2.Text & " '%" & Trim(Txt02.Text) & "%' "
                    Else
                        TxtSql = TxtSql & " and " & Cmb2.Text & " " & Like2.Text & " '" & Trim(Txt02.Text) & "' "
                    End If
                Else
                    If Like2.Text = "Like" Then
                        TxtSql = TxtSql & Cmb2.Text & " " & Like2.Text & " '%" & Trim(Txt02.Text) & "%' "
                    Else
                        TxtSql = TxtSql & Cmb2.Text & " " & Like2.Text & " '" & Trim(Txt02.Text) & "' "
                    End If
                End If
            End If
        End If
    End If
    
    If Check1(2).Value Then
        If Trim(Txt03.Text) = "" Or Cmb3.Text = "" Or Like3.Text = "" Then
            MsgBox "搜索条件第3行有空", vbOKOnly + vbExclamation, "警告"
            Cmb3.SetFocus
            Exit Sub
        Else
            If Cmb3.Text = "领料日期" Or Cmb3.Text = "送检日期" Then
                dd(2) = True
                If dd(0) Or dd(1) Then
                    If Like3.Text = "Like" Then
                        MsgBox "日期数据不支持“LIKE”！", vbOKOnly + vbExclamation, "警告"
                        Exit Sub
                    Else
                        TxtSql = TxtSql & " and " & Cmb3.Text & " " & Like3.Text & " '" & Trim(Txt03.Text) & "' "
                    End If
                Else
                    If Like3.Text = "Like" Then
                        MsgBox "日期数据不支持“LIKE”！", vbOKOnly + vbExclamation, "警告"
                        Exit Sub
                    Else
                        TxtSql = TxtSql & Cmb3.Text & " " & Like3.Text & " '" & Trim(Txt03.Text) & "' "
                    End If
                End If
            Else
                dd(2) = True
                If dd(0) Or dd(1) Then
                    If Like3.Text = "Like" Then
                        TxtSql = TxtSql & " and " & Cmb3.Text & " " & Like3.Text & " '%" & Trim(Txt03.Text) & "%' "
                    Else
                        TxtSql = TxtSql & " and " & Cmb3.Text & " " & Like3.Text & " '" & Trim(Txt03.Text) & "' "
                    End If
                Else
                    If Like3.Text = "Like" Then
                        TxtSql = TxtSql & Cmb3.Text & " " & Like3.Text & " '%" & Trim(Txt03.Text) & "%' "
                    Else
                        TxtSql = TxtSql & Cmb3.Text & " " & Like3.Text & " '" & Trim(Txt03.Text) & "' "
                    End If
                End If
            End If
        End If
    End If
    
    If Not (dd(0) Or dd(1) Or dd(2) Or dd(3)) Then
        MsgBox "请设置查询方式！", vbOKOnly + vbExclamation, "警告"
        txt01.Text = ""
        Txt02.Text = ""
        Txt03.Text = ""
        Exit Sub
    End If
        TxtSql = TxtSql & "order by 送检日期"
      Set Rstmp = New ADODB.Recordset
    Rstmp.Open TxtSql, Cw_DataEnvi.DataConnect, adOpenStatic, adLockPessimistic, adCmdText
      Set DataGrid2.DataSource = Rstmp
      'Rstmp.Close
      'Set Rstmp = Nothing
    Exit Sub
ErrLine:
    MsgBox Err.Description, vbCritical, "查询出错提示："

        txt01.Text = ""
        Txt02.Text = ""
        Txt03.Text = ""
    Exit Sub
End Sub


Private Sub Command1_Click()
    Call Toolbjzt
        TxtSjs.Text = ""
        TxtYjp.Text = ""
        TxtEjp.Text = ""
        TxtLzs.Text = ""
        TxtFgs.Text = ""
        TxtFps.Text = ""
        TxtLys.Text = ""
    AddFlg = True
    
End Sub

Private Sub Command10_Click()
    Cdlg.DialogTitle = "另存为Excel文件："
    Cdlg.Filter = "Excel文件|*.Xls|所有文件|*.*"
    Cdlg.ShowSave
    If Cdlg.FileName = "" Then Exit Sub
         OutTxt.Text = Cdlg.FileName
End Sub

Private Sub Command11_Click()
    On Error GoTo errs
        Dim Rs As ADODB.Recordset
        Dim ExcelApp As Excel.Application
        Dim ExcelBook As Excel.Workbook
        Dim ExcelSheet As Excel.Worksheet
    
        Set ExcelApp = New Excel.Application
        ExcelApp.Visible = False
        Set ExcelBook = ExcelApp.Workbooks.Add
        Set ExcelSheet = ExcelBook.Worksheets.Item(1)
        
        Set Rs = New ADODB.Recordset
         
        Rs.Open TxtSql, Cw_DataEnvi.DataConnect, , adLockPessimistic, adCmdText
        RecordsetToExcel Rs, ExcelSheet
        If OutTxt.Text = "" Then
          MsgBox "请指定输出文件位置和文件名！", 16, "严重错误"
          Exit Sub
        End If
        On Error GoTo ErrSave
         ExcelBook.Close True, OutTxt.Text
         MsgBox "输出成功！文件位于" & OutTxt.Text
         Rs.Close
    
    Exit Sub
errs:
        MsgBox "Select 语句错误！", 16, "严重错误"
        ExcelBook.Close False
         Exit Sub
ErrSave:
        MsgBox "输出错误！", 16, "严重错误"
End Sub

Private Sub Command12_Click()
    Frm选择产品图号.Show 1
End Sub

Private Sub Command2_Click()
    Call Toolbjzt
    AddFlg = False
    
End Sub

Private Sub Command3_Click()
    If BoolDate(DTPSjrq.Value) = False Or RsQx() = False Then
        If Not Security_Log("XT_Modify ", Xtczybm, 1, True) Then
            
            Exit Sub
        End If
    End If
    If vbYes = MsgBox("确认要删除此记录么？(" & Lablsh.Caption & ")", vbYesNo, "删除对话框") Then
        CmdExe.CommandText = "delete  from sc_检验表 where id='" & Lablsh.Caption & "'"
        CmdExe.Execute
    End If
    Call Toolfbjzt
    Call ToolList
End Sub

Private Sub Command4_Click()
   If AddFlg = True Then  '添加
        If BoolDate(DTPSjrq.Value) = False Then
            If Not Security_Log("XT_Modify ", Xtczybm, 1, True) Then
                
                Exit Sub
            End If
        End If
   Else                     '修改
        If BoolDate(DTPSjrq.Value) = False Or RsQx() = False Then
            If Not Security_Log("XT_Modify ", Xtczybm, 1, True) Then
                
                Exit Sub
            End If
        End If
    End If
Set Mrc = New ADODB.Recordset
  
If Trim(TxtYgxm.Text) = "" Then
        TxtYgxm.SetFocus
        MsgBox "请正确填选员工姓名！"
        Exit Sub
Else
      Set Mrc = New ADODB.Recordset
      TxtSql = "select * from Bs_员工明细 where 员工姓名 = '" & TxtYgxm.Text & "' and 部门名称='" & CJMC & "'"
      Mrc.Open Trim$(TxtSql), Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
      Set ExecuteSQL = Mrc
      
        If Mrc.EOF = True Then
            TxtYgxm.SetFocus
            MsgBox "请正确填选员工姓名！"
            Exit Sub
        End If
        Mrc.Close
End If

If Trim(CmbGX.Text) = "" Then
        CmbGX.SetFocus
        MsgBox "请正确填选工序名称！"
        Exit Sub
Else
      Set Mrc = New ADODB.Recordset
      TxtSql = "select * from Bs_生产流程 where 工序名称 = '" & CmbGX.Text & "'"
      Mrc.Open Trim$(TxtSql), Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
      Set ExecuteSQL = Mrc
      
        If Mrc.EOF = True Then
            CmbGX.SetFocus
            MsgBox "请正确填选工序名称！"
            Exit Sub
        End If
        Mrc.Close
End If

If Trim(CmbTH.Text) = "" Then
        CmbTH.SetFocus
        MsgBox "请正确填选图号、品名规格！"
        Exit Sub
Else
      Set Mrc = New ADODB.Recordset
      TxtSql = "select * from Bs_产品图号 where 图号='" & CmbTH.Text & "'"
      Mrc.Open Trim$(TxtSql), Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
      Set ExecuteSQL = Mrc
      
        If Mrc.EOF = True Then
            CmbTH.SetFocus
            MsgBox "请正确填选图号、品名规格！"
            Exit Sub
        End If
        CmbPM.Text = Mrc!品名
        TxtGG.Text = Mrc!规格
        Mrc.Close
End If

If Trim(CmbCK1.Text) = "" Then
        CmbCK1.SetFocus
        MsgBox "请正确填选仓库名称！"
        Exit Sub
Else
      Set Mrc = New ADODB.Recordset
      TxtSql = "select * from Bs_仓库列表 where 仓库名称 = '" & CmbCK1.Text & "'"
      Mrc.Open Trim$(TxtSql), Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
      Set ExecuteSQL = Mrc
      
        If Mrc.EOF = True Then
            CmbCK1.SetFocus
            MsgBox "请正确填选仓库名称！"
            Exit Sub
        End If
        TxtSql = ""
        Mrc.Close
End If

If Trim(CmbCK2.Text) = "" Then
        CmbCK2.SetFocus
        MsgBox "请正确填选仓库名称！"
        Exit Sub
Else
      Set Mrc = New ADODB.Recordset
      TxtSql = "select * from Bs_仓库列表 where 仓库名称 = '" & CmbCK2.Text & "'"
      Mrc.Open Trim$(TxtSql), Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
      Set ExecuteSQL = Mrc
      
        If Mrc.EOF = True Then
            CmbCK2.SetFocus
            MsgBox "请正确填选仓库名称！"
            Exit Sub
        End If
        Mrc.Close
End If
If Mrc.State <> adStateClosed Then Mrc.Close
Set Mrc = Nothing

If Trim(TxtSjs.Text) = "" Or Trim(TxtYjp.Text) = "" Or Trim(TxtEjp.Text) = "" Or Trim(TxtLzs.Text) = "" Or Trim(TxtFgs.Text) = "" Or Trim(TxtFps.Text) = "" Or Trim(TxtLys.Text) = "" Then
    TxtSjs.SetFocus
    MsgBox "填写数量错误！"
    Exit Sub
End If
If (TxtSjs.Text) * 1 <> (TxtYjp.Text) * 1 + (TxtEjp.Text) * 1 + (TxtLzs.Text) * 1 + (TxtFgs.Text) * 1 + (TxtFps.Text) * 1 + (TxtLys.Text) * 1 Then
    TxtSjs.SetFocus
    MsgBox "送检数总计数量错误！"
    Exit Sub
End If
    
    If AddFlg = True Then  '添加
        
        SqlTxt = "INSERT INTO Sc_检验表(员工姓名,部门名称,工序名称,图号,送检数,一级品,二级品,料质数,返工数,废品数,留用数,送检日期,仓库名称1,仓库名称2,创建者) VALUES ('" & TxtYgxm.Text _
        & "', '" & CJMC & "', '" & CmbGX.Text & "', '" & CmbTH.Text & "', '" & TxtSjs.Text & "','" & TxtYjp.Text & "','" & TxtEjp.Text & "','" & TxtLzs.Text & "','" & TxtFgs.Text & "','" & TxtFps.Text & "','" & TxtLys.Text _
        & "','" & DTPSjrq.Value & "','" & CmbCK1.Text & "','" & CmbCK2.Text _
        & "','" & Xtczy & "')"
        CmdExe.CommandText = SqlTxt
        CmdExe.Execute
       MsgBox "记录添加成功！", vbInformation
    Else                '修改
        
        SqlTxt = "Update Sc_检验表 Set 员工姓名='" & TxtYgxm.Text & "',部门名称='" & CJMC & "',工序名称='" & CmbGX.Text & "',图号='" & CmbTH.Text _
        & "',送检数='" & TxtSjs.Text & "',一级品='" & TxtYjp.Text & "',二级品='" & TxtEjp.Text & "',料质数='" & TxtLzs.Text & "',废品数='" & TxtFps.Text & "',留用数='" & TxtLys.Text & "',返工数='" & TxtFgs.Text _
        & "',送检日期='" & DTPSjrq.Value & "',仓库名称1='" & CmbCK1.Text & "',仓库名称2='" & CmbCK2.Text _
        & "',创建者='" & Xtczy & "' WHERE (ID=" & Lablsh.Caption & ")"
        
        CmdExe.CommandText = SqlTxt
        CmdExe.Execute
        MsgBox "记录修改成功！", vbInformation
            
    End If
    Call ToolList
    Call Toolfbjzt
    tv.SetFocus
End Sub

Private Sub Command5_Click()
    
    Call Toolfbjzt
End Sub

Private Sub Form_Load()
    SSTab1.Tab = 0
    lstContracts.ColumnHeaders.Clear
    lstContracts.ColumnHeaders.Add , , "  ID", 800
    lstContracts.ColumnHeaders.Add , , "部门名称", 1100
    lstContracts.ColumnHeaders.Add , , "员工姓名", 1100
    lstContracts.ColumnHeaders.Add , , "工序", 750
    lstContracts.ColumnHeaders.Add , , "  图号", 1200
    lstContracts.ColumnHeaders.Add , , "  品名", 1300
    lstContracts.ColumnHeaders.Add , , "    规格", 1400
    lstContracts.ColumnHeaders.Add , , "送检数", 900
    lstContracts.ColumnHeaders.Add , , "一级品", 900
    lstContracts.ColumnHeaders.Add , , "二级品", 900
    lstContracts.ColumnHeaders.Add , , "料质数", 900
    lstContracts.ColumnHeaders.Add , , "返工数", 900
    lstContracts.ColumnHead