frmfindoutput.frm

用于生产企业设备备件管理系统

ErrFlag:
    DataShow.Redraw = True
    MsgBox Err.Description, vbOKOnly + vbCritical
End Sub

Public Sub SaveAsXLS()
On Error GoTo ErrFlag
Dim i As Long, j As Long
Dim Excel_App As Object
Dim Excel_Sheet As Object
Dim FileName As String, bFileOpen As Boolean
Dim StrTemp As String
    bFileOpen = False
    With comdlgOpen
        .Filter = "Excel File(*.XLS)|*.XLS|Text File(*.TXT)|*.TXT"
        .flags = cdlOFNOverwritePrompt
        .ShowSave
    End With
    
    FileName = comdlgOpen.FileName
    If FileName = "" Then Exit Sub
    If UCase(Right(FileName, 3)) = "TXT" Then
        SaveAsTXT FileName
        Exit Sub
    End If
    
    vkBar1.Value = 1
    vkBar1.Visible = True
    Set Excel_App = CreateObject("Excel.Application")
    Call Excel_App.workbooks.Add
    Set Excel_Sheet = Excel_App.ActiveSheet
    bFileOpen = True
        
    DataShow.Redraw = False
    StrTemp = ""
    For i = 0 To DataShow.Rows - 1
        DataShow.Row = i
        For j = 1 To DataShow.Cols - 1
            DataShow.Col = j
            StrTemp = StrTemp & DataShow.Text & vbTab
        Next j
        StrTemp = StrTemp & vbCrLf
        Clipboard.Clear
        Clipboard.SetText StrTemp
        Excel_Sheet.cells(i + 1, 1).Select
        Excel_Sheet.Paste
        Clipboard.Clear
        StrTemp = ""
        If bStopSave = True Then
            If MsgBox("确定要中止保存吗", vbYesNo + vbQuestion) = vbYes Then
                bStopSave = False
                Exit For
            End If
        End If
        vkBar1.Value = i * 50 / DataShow.Rows + 50
        DoEvents
    Next i

    With Excel_Sheet
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).Borders(1).LineStyle = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).Borders(2).LineStyle = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).Borders(3).LineStyle = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).Borders(4).LineStyle = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).HorizontalAlignment = 3
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).VerticalAlignment = 2
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).WrapText = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).Font.Size = 9
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).Font.colorindex = 5
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols - 1)).columnwidth = 10
    End With
    
    DataShow.Redraw = True
    
    vkBar1.Value = 100
    Excel_Sheet.Application.Sheets("Sheet1").Name = "签约用户"
    Excel_Sheet.SaveAs (FileName)
    Excel_Sheet.Application.Quit
    Excel_App.Quit
    Set Excel_Sheet = Nothing
    Set Excel_App = Nothing
    vkBar1.Visible = False
    MsgBox "保存成功", vbOKOnly + vbInformation
    Exit Sub
    
ErrFlag:
    If bFileOpen = True Then
        Excel_Sheet.SaveAs (FileName)
        Excel_Sheet.Application.Quit
        Excel_App.Quit
        Set Excel_Sheet = Nothing
        Set Excel_App = Nothing
    End If
    DataShow.Redraw = True
    vkBar1.Visible = False
    MsgBox Err.Description, vbOKOnly + vbCritical

End Sub

Sub InitGrid()
On Error Resume Next
Dim i As Long
    DataShow.Cols = UBound(strCaption) + 2
    With DataShow
        .Redraw = False
        .Clear
        .Rows = 1
        For i = 0 To UBound(strCaption) + 1
            .TextMatrix(0, i + 1) = strCaption(i)
            .ColWidth(i + 1) = 1500
            .ColAlignment(i) = 1
        Next
        .ColWidth(2) = 1200
        .ColWidth(6) = 1000
        .ColWidth(7) = 1000
        .ColWidth(0) = 0
        .Redraw = True
    End With
End Sub

Public Sub PrintMe()
On Error GoTo ErrFlag

    If strPrintSQL = "" Then Exit Sub
    
Dim i As Long
Dim TotalField As Long
Dim ConnTemp As New ADODB.Connection
Dim RSResult As New ADODB.Recordset
Dim strSQL As String
Dim TotalWidth As Long
    TotalField = UBound(strCaption)
    
    ConnTemp.Open StrConn
    RSResult.Open strPrintSQL, ConnTemp, adOpenStatic, adLockReadOnly
    
    If RSResult.RecordCount > 0 Then
        Set DRPT.DataSource = RSResult
        With DRPT
            .TopMargin = txtMargin(1).Text * 56.7
            .BottomMargin = txtMargin(2).Text * 56.7
            .RightMargin = txtMargin(3).Text * 56.7
            .LeftMargin = txtMargin(0).Text * 56.7
            .Sections(1).Controls(1).Caption = txtTitle.Text
            TotalWidth = 0
            For i = 1 To TotalField + 1
                .Sections(2).Controls(i).Caption = strCaption(i - 1)
                .Sections(2).Controls(i).Left = DataShow.ColPos(i)
                .Sections(2).Controls(i).Width = DataShow.ColWidth(i)
                TotalWidth = TotalWidth + DataShow.ColWidth(i)
            Next i
            .Sections(2).Controls(TotalField + 2).Width = TotalWidth
            .Sections(1).Controls(1).Width = TotalWidth
            .Sections(1).Controls(1).Alignment = Combo7.ListIndex
            For i = 1 To TotalField + 1
                .Sections(3).Controls(i).BorderStyle = Combo6.ListIndex
                .Sections(3).Controls(i).DataField = RSResult.Fields(i).Name
                .Sections(3).Controls(i).Left = DataShow.ColPos(i)
                .Sections(3).Controls(i).Width = DataShow.ColWidth(i)
                .Sections(3).KeepTogether = True
            Next i
            .Sections(3).Height = DataShow.RowHeight(0)
            .WindowState = 2
            .Show vbModal
        End With
    End If
    RSResult.Close
    ConnTemp.Close
    Set RSResult = Nothing
    Set ConnTemp = Nothing
    
    Exit Sub
    
ErrFlag:
    MsgBox Err.Description, vbOKOnly + vbCritical
End Sub

Sub UpdateShow()
On Error GoTo ErrFlag
Dim ConnTemp As New ADODB.Connection
Dim RSTemp As New ADODB.Recordset
Dim strSQL As String
Dim i As Long, j As Long
    Call InitGrid
   
    ConnTemp.Open StrConn
    RSTemp.Open strPrintSQL, ConnTemp, adOpenStatic, adLockReadOnly
    If RSTemp.RecordCount > 0 Then
        With DataShow
            .Redraw = False
            .Rows = RSTemp.RecordCount + 1
            For i = 1 To RSTemp.RecordCount
                .Row = i
                For j = 0 To RSTemp.Fields.Count - 1
                    .Col = j
                    If IsNull(RSTemp.Fields(j).Value) = False Then
                        .Text = RSTemp.Fields(j).Value
                    End If
                Next j
                RSTemp.MoveNext
            Next i
            .Redraw = True
        End With
    End If
    RSTemp.Close
    ConnTemp.Close
    Set RSTemp = Nothing
    Set ConnTemp = Nothing
    Exit Sub
    
ErrFlag:
    DataShow.Redraw = True
    If RSTemp.State = adStateOpen Then RSTemp.Close
    If ConnTemp.State = adStateOpen Then ConnTemp.Close
    Set RSTemp = Nothing
    Set ConnTemp = Nothing
    MsgBox "[显示数据]" & Err.Description, vbOKOnly + vbCritical
End Sub

Private Sub Combo1_Click()
    Combo4.ListIndex = Combo1.ListIndex
End Sub

Private Sub Combo2_Click()
    Combo3.ListIndex = Combo2.ListIndex
    Combo5.ListIndex = Combo2.ListIndex
End Sub

Private Sub Combo3_Click()
    Combo2.ListIndex = Combo3.ListIndex
    Combo5.ListIndex = Combo3.ListIndex
End Sub

Private Sub Form_Load()
On Error GoTo ErrFlag
Dim StrTitle As String
Dim strSQL As String, i As Long
Dim ConnTemp As New ADODB.Connection
Dim RSTemp As New ADODB.Recordset
    strPrintSQL = ""
    StrTitle = "入库单编号|日期|仓库名称|物品编号|物品名称|数量|签收人|备注"
    strCaption = Split(StrTitle, "|")
    InitGrid
    
    strSQL = "select * from WH order by ID"
    ConnTemp.Open StrConn
    RSTemp.Open strSQL, ConnTemp, adOpenStatic, adLockReadOnly
    
    Combo1.AddItem ""
    Combo4.AddItem ""
    If RSTemp.RecordCount > 0 Then
        For i = 1 To RSTemp.RecordCount
            Combo1.AddItem RSTemp(1)
            Combo4.AddItem RSTemp(0)
            RSTemp.MoveNext
        Next
        Combo1.ListIndex = 0
        Combo4.ListIndex = 0
    End If
    RSTemp.Close
    
    strSQL = "select * from goods order by ID"
    RSTemp.Open strSQL, ConnTemp, adOpenStatic, adLockReadOnly
    Combo2.AddItem ""
    Combo3.AddItem ""
    Combo5.AddItem ""
    If RSTemp.RecordCount > 0 Then
        For i = 1 To RSTemp.RecordCount
            Combo2.AddItem RSTemp(1)
            Combo3.AddItem RSTemp(2)
            Combo5.AddItem RSTemp(0)
            RSTemp.MoveNext
        Next
        Combo2.ListIndex = 0
        Combo3.ListIndex = 0
        Combo5.ListIndex = 0
    End If
    RSTemp.Close
    
    ConnTemp.Close
    Set RSTemp = Nothing
    Set ConnTemp = Nothing
    
    Combo6.AddItem "无"
    Combo6.AddItem "实线"
    Combo6.AddItem "长虚线"
    Combo6.AddItem "短虚线"
    Combo6.AddItem "虚短线"

    Combo6.ListIndex = 0
    txtInput(2).Text = Date
    txtInput(3).Text = Date
    Combo7.AddItem "左对齐"
    Combo7.AddItem "右对齐"
    Combo7.AddItem "置中"
    Combo7.ListIndex = 0
    vkMouseKeyEvents1.ControlHwnd = DataShow.hWnd
    vkMouseKeyEvents1.LaunchKeyMouseEvents
    Exit Sub
    
ErrFlag:
    MsgBox Err.Description, vbOKOnly + vbCritical
    
End Sub

Private Sub vkCommand1_Click()
On Error GoTo ErrFlag
Dim strSQL As String
    
    strSQL = "SELECT OutData.AutoID, OutData.ID, OutData.InDate, WH.WHName, goods.ID, goods.GoodsName, OutData.Qty,OutData.OPName, OutData.memo "
    strSQL = strSQL & "FROM (OutData LEFT JOIN goods ON OutData.GoodsID = goods.AutoID) LEFT JOIN WH ON OutData.WHID = WH.ID where "
    
    If txtInput(0).Text <> "" Then strSQL = strSQL & "OutData.ID='" & txtInput(0).Text & " AND "
        
    If Combo1.Text <> "" Then strSQL = strSQL & "OutData.WHID=" & Combo4.Text & " AND "
    
    If Combo2.Text <> "" Then strSQL = strSQL & "OutData.GoodsID=" & Combo5.Text & " AND "
    
    If txtInput(1).Text <> "" Then strSQL = strSQL & "OutData.OPName='" & txtInput(1).Text & " AND "
    
    strSQL = strSQL & "(OutData.InDate Between #" & txtInput(2).Text & "# AND #" & txtInput(3).Text & "#) "
    strSQL = strSQL & " order by OutData.AutoID DESC"
    
    strPrintSQL = strSQL
    Call UpdateShow
    
    Exit Sub
    
ErrFlag:
    MsgBox Err.Description, vbOKOnly + vbCritical
End Sub

Private Sub vkCommand2_Click()
    Call SaveAsXLS
End Sub

Private Sub vkCommand3_Click()
    Unload Me
End Sub

Private Sub vkMouseKeyEvents1_MouseWheel(Sens As vkUserContolsXP.Wheel_Sens)
On Error Resume Next
    If Sens = WHEEL_DOWN Then
        If DataShow.Row = DataShow.Rows - 1 Then Exit Sub
        DataShow.Row = DataShow.Row + 1
    Else
        If DataShow.Row = 1 Then Exit Sub
        DataShow.Row = DataShow.Row - 1
    End If
    DataShow.TopRow = DataShow.Row
End Sub