frmchukucheck.frm

VB库存管理系统

    End If
    
    If chkItem(2).Value = 1 Then
        If Combo2.Text <> "" Then
            SQL3 = "And [出库单编号] = '" & Combo2.Text & "'"
        Else
            MsgBox "请选择出库单编号", vbOKOnly + vbInformation, ginfo
            Exit Sub
        End If
    ElseIf chkItem(2).Value = 0 Then
        SQL3 = ""
        Combo2.Text = ""
    End If
    
    If chkItem(3).Value = 1 Then
        If Combo3.Text <> "" Then
            SQL4 = "And [经手人] ='" & Combo3.Text & "'"
        Else
            MsgBox "请选经手人姓名", vbOKOnly + vbInformation, ginfo
            Exit Sub
        End If
    ElseIf chkItem(3).Value = 0 Then
        SQL4 = ""
        Combo3.Text = ""
    End If
    
   
    
    SQL = "select top  3000 * from [出库单信息] where 1=1" & sql1 & sql2 & SQL3 & SQL4
    
    
    Set rs = TransactSQL(SQL)
    Me.Caption = "正在查询,请稍候..."
    i = 0
    With MSFlexGrid1
        .Rows = 1
        .Cols = 8
         While Not rs.EOF
            i = i + 1
            .Rows = .Rows + 1
            .TextMatrix(.Rows - 1, 0) = i
            .TextMatrix(.Rows - 1, 1) = rs(0)
            .TextMatrix(.Rows - 1, 2) = rs(1)
            .TextMatrix(.Rows - 1, 3) = rs(2)
            .TextMatrix(.Rows - 1, 4) = rs(3)
            .TextMatrix(.Rows - 1, 5) = rs(4)
            .TextMatrix(.Rows - 1, 6) = rs(5)
            If rs(6) = "" Then
                .TextMatrix(.Rows - 1, 7) = ""
            ElseIf rs(6) <> "" Then
                .TextMatrix(.Rows - 1, 7) = rs(6)
            End If
            rs.MoveNext
       Wend
       StatusBar1.Panels(1) = "一共查询到:" & rs.RecordCount & " 条 记录"
        If rs.RecordCount = 0 Then
            MsgBox "未找到符合条件的记录"
'            Me.CmdPrint.Enabled = False
            CmdToExcel.Enabled = False
            Me.Caption = "出库查询"
            Exit Sub
        End If
    Me.Caption = "出库查询"
    End With

'    Me.cmdOutToExcel.Enabled = True
'    Me.CmdPrint.Enabled = True
    
    rs.Close
End Sub

Private Sub CmdToExcel_Click()
    Dim ExcelApp As Object             'Excel对象
    Dim ExcelBook As Object            'ExcelBook对象
    Dim ExcelSheet As Object           'ExcelSheet对象
    Dim i, j As Long
    Dim RetVal As Variant
    Dim fName As String
    Dim lngInvoiceNum As Long
    Err.Clear
     
    On Error GoTo ErrorLine
    
   Set rs = TransactSQL(SQL)
    If rs.RecordCount = 0 Then
        MsgBox "未找到符合条件的记录，不能进行导出操作"
        Exit Sub
    Else
    If rs.RecordCount <> 0 Then
    ProgressBar1.Max = rs.RecordCount
    Me.Caption = "正在导出,请稍候...."
    ProgressBar1.Value = 0
    With dlgFileSave
        .CancelError = True
        .DialogTitle = "请选择要导出文件的目录和文件名"
        .Filter = "Excel文件(*.xls)|*.xls"
        .FilterIndex = 1
        .ShowSave
    End With

    fName = dlgFileSave.FileName
    StatusBar1.Panels(2) = "正准备导出到Excel中,请稍候..."
   

    
    '检测是否已安装了Excel或是否有Excel应用程序运行
    Set ExcelApp = CreateObject("Excel.Application")
    Set ExcelBook = Nothing
    Set ExcelSheet = Nothing
        
    Set ExcelBook = ExcelApp.Workbooks().Add
    Set ExcelSheet = ExcelBook.Worksheets("sheet1")
   
    ExcelSheet.Name = "出库表"
 
    With ExcelSheet
        .Cells(1, 1) = "序号"
        .Cells(1, 1).Font.Size = 9
        .Cells(1, 2) = "出库单编号"
        .Cells(1, 2).Font.Size = 9
        .Cells(1, 3) = "经手人"
        .Cells(1, 3).Font.Size = 9
        .Cells(1, 4) = "物品编号"
        .Cells(1, 4).Font.Size = 9
        .Cells(1, 5) = "数量"
        .Cells(1, 5).Font.Size = 9
        .Cells(1, 6) = "货位编号"
        .Cells(1, 6).Font.Size = 9
        .Cells(1, 7) = "出库时间"
        .Cells(1, 7).Font.Size = 9
        .Cells(1, 8) = "备注"
        .Cells(1, 8).Font.Size = 9
        For j = 1 To 8
        .Cells(1, j).HorizontalAlignment = xlCenter '垂直居中
        .Cells(1, j).VerticalAlignment = xlTop '水平居高
        .Cells(1, j).Font.Bold = True '粗体
        Next j
    End With
    '写入Excle文件
     rs.MoveFirst
    i = 1
    With rs
        Do While Not .EOF
            StatusBar1.Panels(2) = "正在导出,请稍候..."
            ProgressBar1.Value = i
            ExcelSheet.Cells(i + 1, 1) = i
            ExcelSheet.Cells(i + 1, 2) = rs(0)
            ExcelSheet.Cells(i + 1, 3) = rs(1)
            ExcelSheet.Cells(i + 1, 4) = rs(2)
            ExcelSheet.Cells(i + 1, 5) = rs(3)
            ExcelSheet.Cells(i + 1, 6) = rs(4)
            ExcelSheet.Cells(i + 1, 7) = Format(rs(5), "yyyy-mm-dd")
            ExcelSheet.Cells(i + 1, 8) = rs(6)
            ExcelSheet.Cells(i + 1, 1).Font.Size = 9
            ExcelSheet.Cells(i + 1, 2).Font.Size = 9
            ExcelSheet.Cells(i + 1, 3).Font.Size = 9
            ExcelSheet.Cells(i + 1, 4).Font.Size = 9
            ExcelSheet.Cells(i + 1, 5).Font.Size = 9
            ExcelSheet.Cells(i + 1, 6).Font.Size = 9
            ExcelSheet.Cells(i + 1, 7).Font.Size = 9
            For j = 1 To 7
            ExcelSheet.Cells(i + 1, j).HorizontalAlignment = xlCenter
            ExcelSheet.Cells(i + 1, j).VerticalAlignment = xlCenter
            Next j
            .MoveNext
            i = i + 1
        Loop
    End With
    ProgressBar1.Value = rs.RecordCount
    rs.Close
    
    
    ExcelBook.SaveAs fName
    '是否查看
    Me.Caption = "出库查询"
    
    StatusBar1.Panels(2) = "注:一次最多可以查询3000条记录"
    RetVal = MsgBox("导出至Excel成功。现在是否查看？", vbYesNo + vbQuestion, "询问")
    
    If RetVal <> vbYes Then
        ExcelApp.Quit
        Set ExcelApp = Nothing
        Exit Sub
    End If
    
    ExcelApp.Visible = True
    'Worksheets("sheet1").Activate
    Exit Sub
    
ErrorLine:
   If rs.State Then rs.Close
   
    If (Err.Number <> 0) And (Err.Number <> 32755) And (Err.Number <> 1004) Then '不是取消错误
       MsgBox "导出至Excel失败！", vbOKOnly + vbExclamation, "失败"
       Err.Clear
    End If
    On Error Resume Next
    'ExcelApp.Quit
    Set ExcelApp = Nothing
End If
End If
End Sub

Private Sub Form_Load()
Me.Left = 2000
Me.Top = 2000
Dim sqluser As String
Dim rsuser As New ADODB.Recordset
sqluser = "select * from [出库单信息] order by [出库单编号]"
Set rsuser = TransactSQL(sqluser)
Do While Not rsuser.EOF
    Combo2.AddItem rsuser.Fields(0).Value
    rsuser.MoveNext
Loop
rsuser.Filter = "出库单编号='" & Combo2.Text & "'"

Dim sqlLingJian As String
Dim rsLingjian As New ADODB.Recordset
sqlLingJian = "select * from [物品明细]"
Set rsLingjian = TransactSQL(sqlLingJian)
Do While Not rsLingjian.EOF
    Combo1.AddItem rsLingjian.Fields(0).Value
    rsLingjian.MoveNext
Loop
rsLingjian.Filter = "[物品编号]='" & Combo1.Text & "'"

Dim sqlcity As String
Dim rscity As New ADODB.Recordset
sqlcity = "select * from [userinfo]"
Set rscity = TransactSQL(sqlcity)
Do While Not rscity.EOF
    Combo3.AddItem rscity.Fields(0).Value
    rscity.MoveNext
Loop
rscity.Filter = "userID='" & Combo3.Text & "'"


DTPicker1.Value = Format(Now, "YYYY-MM-DD")
DTPicker2.Value = Format(Now, "YYYY-MM-DD")
CmdToExcel.Enabled = False


    With MSFlexGrid1
        .Cols = 8
        .TextMatrix(0, 0) = "序号"
        .TextMatrix(0, 1) = "出库单编号"
        .TextMatrix(0, 2) = "经手人"
        .TextMatrix(0, 3) = "物品编号"
        .TextMatrix(0, 4) = "数量"
        .TextMatrix(0, 5) = "货位编号"
        .TextMatrix(0, 6) = "出库日期"
        .TextMatrix(0, 7) = "备注"

        For i = 0 To 7
            .ColAlignment(i) = 4
        Next i
       
            .ColWidth(0) = 800
            .ColWidth(1) = 1100
            .ColWidth(2) = 2000
            .ColWidth(3) = 900
            .ColWidth(4) = 900
            .ColWidth(5) = 1000
            .ColWidth(6) = 1100
            .ColWidth(7) = 1100
    End With
    
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
frmMDIMain.Enabled = True
Unload Me
End Sub