产量核对_sc.frm

适合于中小型企业管理

      Height          =   285
      Left            =   3360
      TabIndex        =   1
      Top             =   960
      Width           =   1140
   End
End
Attribute VB_Name = "FrmYcl_Sc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Rsbj As ADODB.Recordset
Dim CmdExe As ADODB.Command
Dim i As Integer
Dim dbName As String
Dim txtSQLBJ As String

Private Sub CmbJsfa_Click()
    Dim StrSqlTmp As String
    If CmbJsfa.ListIndex > -1 Then
        With Rsbj
            If .RecordCount <> 0 Then
                    .MoveFirst
                    .Find "方案名称='" & CmbJsfa.Text & "'"
            End If
        End With
        txtLdate.Text = Rsbj!起始日期
        txtZdate.Text = Rsbj!终止日期
        Command7.Enabled = True
    Else
        Command7.Enabled = False
    End If
OutTxt1.Text = "C:\产量核对SC(" & CmbJsfa.Text & ")1.xls"
OutTxt2.Text = "C:\产量核对SC(" & CmbJsfa.Text & ")2.xls"
End Sub

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

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

Private Sub Command3_Click()
    If Command3.Caption = "保存产量记录" Then
        Command3.Caption = "存储数据中..."
        Set CmdExe = New ADODB.Command
        CmdExe.ActiveConnection = Cw_DataEnvi.DataConnect
        CmdExe.CommandTimeout = 0
        CmdExe.CommandText = "Execute Gz_产量SCS  '" & CmbJsfa.Text & "','" & txtLdate.Text & "','" & txtZdate.Text & "'"
        CmdExe.Execute
        CmbJsfa.Enabled = False
        Command3.Enabled = False
        Command3.Caption = "存储成功！"
    End If
End Sub

Private Sub Command4_Click()
        Set CmdExe = New ADODB.Command
        CmdExe.ActiveConnection = Cw_DataEnvi.DataConnect
        CmdExe.CommandText = "delete Gz_产量核对SC where 方案名称='" & CmbJsfa.Text & "'"
        CmdExe.Execute
        Command4.Enabled = False
End Sub

Private Sub Command5_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 "select * from Gz_产量核对SC where 方案名称='" & CmbJsfa.Text & "' order by 部门名称,员工姓名", Cw_DataEnvi.DataConnect, , adLockReadOnly, adCmdText
        RecordsetToExcel Rs, ExcelSheet
        If OutTxt1.Text = "" Then
          MsgBox "请指定输出文件位置和文件名！", 16, "严重错误"
          Exit Sub
        End If
        On Error GoTo ErrSave
         ExcelBook.Close True, OutTxt1.Text
         MsgBox "输出成功！文件位于" & OutTxt1.Text
         Rs.Close
    
        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 "SELECT 方案名称,部门名称,工序名称,图号,SUM(领一级) as 领一级,SUM(领二级) as 领二级,SUM(送检数) as 送检数,SUM(一级品) as 一级品,SUM(二级品) as 二级品,SUM(料质数) as 料质数,SUM(欠交数) as 欠交数,SUM(废品数) as 废品数,SUM(留用数) as 留用数 from Gz_产量核对SC where 方案名称='" & CmbJsfa.Text & "' GROUP BY 部门名称,方案名称,部门名称,工序名称,图号", Cw_DataEnvi.DataConnect, , adLockReadOnly, adCmdText
        RecordsetToExcel Rs, ExcelSheet
        If OutTxt2.Text = "" Then
          MsgBox "请指定输出文件位置和文件名！", 16, "严重错误"
          Exit Sub
        End If
        On Error GoTo ErrSave
         ExcelBook.Close True, OutTxt2.Text
         MsgBox "输出成功！文件位于" & OutTxt2.Text
         Rs.Close
         
    Exit Sub
errs:
        MsgBox "Select 语句错误！", 16, "严重错误"
        ExcelBook.Close False
         Exit Sub
ErrSave:
        MsgBox "输出错误！", 16, "严重错误"
End Sub

Private Sub Command7_Click()
    If txtLdate.Text = "" Or txtZdate.Text = "" Then Exit Sub
    
    Dim RsSc As ADODB.Recordset
    Set RsSc = New ADODB.Recordset
    RsSc.Open "select * from Gz_产量核对SC where 方案名称='" & CmbJsfa.Text & "'", Cw_DataEnvi.DataConnect, adOpenStatic, adLockPessimistic, adCmdText
    
    If RsSc.BOF = True And RsSc.EOF = True Then '重新计算
        Command3.Caption = "正在计算中..."
        Set CmdExe = New ADODB.Command
        CmdExe.ActiveConnection = Cw_DataEnvi.DataConnect
        CmdExe.CommandTimeout = 0
        CmdExe.CommandText = "Execute Gz_产量SC  '" & txtLdate.Text & "','" & txtZdate.Text & "'"
        CmdExe.Execute
        CmbJsfa.Enabled = False
        Command3.Enabled = True
        dbName = "Gz_产量核对SCTmp"
        LoadTree
        Command3.Caption = "保存产量记录"
    Else                                        '载入上次保存结果
        Command3.Caption = "载入存储数据..."
        dbName = "Gz_产量核对SC"
        LoadTree
        Command3.Enabled = False
        Command3.Caption = "载入成功!！"
    End If

End Sub

Private Sub LoadTree()
    '添加车间列表
    Dim topNode As Node
    
    Dim Rsb As ADODB.Recordset
    Set Rsb = New ADODB.Recordset
    Rsb.Open "select distinct 部门名称 from " & dbName, Cw_DataEnvi.DataConnect, adOpenStatic, adLockReadOnly, adCmdText
    tv.Nodes.Clear
            
    
        i = 1
    Do While Not Rsb.EOF
        Set topNode = tv.Nodes.Add(, , "A" & CStr(Rsb!部门名称), Rsb!部门名称, "Root")
        topNode.Tag = Rsb!部门名称
        
        LoadChild (Rsb!部门名称)
        Rsb.MoveNext
    Loop
End Sub

Private Sub LoadChild(StrCjmm As String)
        Dim child As Node
        
        Set Rsyg = New ADODB.Recordset
    
        Rsyg.Open "select distinct 员工姓名 from " & dbName & " where 部门名称 = '" & StrCjmm & "'", Cw_DataEnvi.DataConnect, adOpenStatic, adLockPessimistic, adCmdText

        Do While Not Rsyg.EOF
            Set child = tv.Nodes.Add("A" & StrCjmm, tvwChild, "B" & CStr(i), Rsyg!员工姓名, "Child")
                child.Tag = Rsyg!员工姓名
                i = i + 1
            Rsyg.MoveNext
        Loop
End Sub

Private Sub Form_Load()
    lstContracts.ColumnHeaders.Clear
    lstContracts.ColumnHeaders.Add , , "ID", 700
    lstContracts.ColumnHeaders.Add , , "车间", 950
    lstContracts.ColumnHeaders.Add , , "姓名", 800
    lstContracts.ColumnHeaders.Add , , "工序", 700
    lstContracts.ColumnHeaders.Add , , "图号", 950
    lstContracts.ColumnHeaders.Add , , "品名", 1200
    lstContracts.ColumnHeaders.Add , , "规格", 1100
    lstContracts.ColumnHeaders.Add , , "硝材", 800
    lstContracts.ColumnHeaders.Add , , "领一级", 800
    lstContracts.ColumnHeaders.Add , , "领二级", 800
    lstContracts.ColumnHeaders.Add , , "送检数", 800
    lstContracts.ColumnHeaders.Add , , "一级品", 800
    lstContracts.ColumnHeaders.Add , , "二级品", 800
    lstContracts.ColumnHeaders.Add , , "料质数", 800
    lstContracts.ColumnHeaders.Add , , "废品数", 800
    lstContracts.ColumnHeaders.Add , , "留用数", 800
    lstContracts.ColumnHeaders.Add , , "欠交数", 800
    
    Set Rsbj = New ADODB.Recordset
    Rsbj.Open "select * from Gz_结算方案 order by 创建日期 desc", Cw_DataEnvi.DataConnect, adOpenStatic, adLockPessimistic, adCmdText
    CmbJsfa.Clear
    Do While Not Rsbj.EOF
        CmbJsfa.AddItem Rsbj!方案名称
        Rsbj.MoveNext
    Loop
    lstContracts.Enabled = False

End Sub

'纪录导出到Execl
Public Sub RecordsetToExcel(Rs As ADODB.Recordset, excel_sheet As Excel.Worksheet)
    Dim i As Long, j As Long
    Dim excel_range As Excel.Range
    Dim col_count As Long

    If Rs.RecordCount = 0 Then
        Exit Sub
    End If

    Set excel_range = excel_sheet.Cells
    col_count = Rs.Fields.Count
                
    For i = 0 To col_count - 1
        excel_sheet.Cells(1, i + 1).Value = Rs.Fields(i).Name
    Next
    excel_sheet.Range(excel_sheet.Cells(1, 1), _
                      excel_sheet.Cells(1, col_count)).Font.Bold = True
        
    excel_sheet.Range("A2").CopyFromRecordset Rs
            
End Sub

Private Sub tv_NodeClick(ByVal Node As MSComctlLib.Node)
   On Error Resume Next
   Set Rs = New ADODB.Recordset
    If Left(Node.Key, 1) = "B" Then
                CBJ = Right(Node.Parent.Key, Len(Node.Parent.Key) - 1)
               
                Command1.Enabled = True
        
                Text1.Enabled = False
                Text2.Enabled = False
                Text3.Enabled = False
        
                CJMC = Node.Parent.Tag
                YGXM = Node.Tag
              
            If dbName = "Gz_产量核对SC" Then
              txtSQLBJ = "select * from " & dbName & " where 方案名称='" & CmbJsfa.Text & "'and 部门名称 = '" & CJMC & "' and 员工姓名='" & YGXM & "'"
            Else
                txtSQLBJ = "select * from " & dbName & " where 部门名称 = '" & CJMC & "' and 员工姓名='" & YGXM & "'"
            End If
            If Rs.State <> adStateClosed Then Rs.Close
              Rs.Open txtSQLBJ, Cw_DataEnvi.DataConnect, adOpenStatic, adLockPessimistic, adCmdText
              'Set DataGrid1.DataSource = Rs
               DoList txtSQLBJ
    ElseIf Left(Node.Key, 1) = "A" Then
            CBJ = Right(Node.Key, Len(Node.Key) - 1)
            Command1.Enabled = True
            Text1.Enabled = False
            Text2.Enabled = False
            Text3.Enabled = False
    
            CJMC = Node.Tag
            
            If dbName = "Gz_产量核对SC" Then
              txtSQLBJ = "select * from " & dbName & " where 方案名称='" & CmbJsfa.Text & "'and 部门名称 = '" & CJMC & "'"
            Else
                txtSQLBJ = "select * from " & dbName & " where 部门名称 = '" & CJMC & "'"
            End If
            
            If Rs.State <> adStateClosed Then Rs.Close
            Rs.Open txtSQLBJ, Cw_DataEnvi.DataConnect, adOpenStatic, adLockPessimistic, adCmdText
            'Set DataGrid1.DataSource = Rs
            DoList txtSQLBJ
    End If
    
    lstContracts.Enabled = True

End Sub

Private Sub DoList(StrSql As String)
    Dim ItmX As ListItem

    Set LConRs = New ADODB.Recordset
    LConRs.Open StrSql, Cw_DataEnvi.DataConnect, adOpenStatic, adLockReadOnly, adCmdText
    If Not LConRs.BOF Then LConRs.MoveFirst
    lstContracts.ListItems.Clear
    Do While Not LConRs.EOF
        Set ItmX = lstContracts.ListItems.Add(, , LConRs!Id)
         ItmX.SubItems(1) = LConRs!部门名称
         ItmX.SubItems(2) = LConRs!员工姓名
         ItmX.SubItems(3) = LConRs!工序名称
         ItmX.SubItems(4) = LConRs!图号
         If dbName = "Gz_产量核对SC" Then
            ItmX.SubItems(5) = LConRs!品名
            ItmX.SubItems(6) = LConRs!规格
            ItmX.SubItems(7) = LConRs!硝材
         End If
         ItmX.SubItems(8) = IIf(IsNull(LConRs!领一级) = True, "0", LConRs!领一级)
         ItmX.SubItems(9) = IIf(IsNull(LConRs!领二级) = True, "0", LConRs!领二级)
         ItmX.SubItems(10) = IIf(IsNull(LConRs!送检数) = True, "0", LConRs!送检数)
         ItmX.SubItems(11) = IIf(IsNull(LConRs!一级品) = True, "0", LConRs!一级品)
         ItmX.SubItems(12) = IIf(IsNull(LConRs!二级品) = True, "0", LConRs!二级品)
         ItmX.SubItems(13) = IIf(IsNull(LConRs!料质数) = True, "0", LConRs!料质数)
         ItmX.SubItems(14) = IIf(IsNull(LConRs!废品数) = True, "0", LConRs!废品数)
         ItmX.SubItems(15) = IIf(IsNull(LConRs!留用数) = True, "0", LConRs!留用数)
         ItmX.SubItems(16) = IIf(IsNull(LConRs!欠交数) = True, "0", LConRs!欠交数)
        LConRs.MoveNext
    Loop
    If Not LConRs.EOF Then LConRs.MoveFirst
    lstContracts.Refresh
End Sub