frmfindwh.frm

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

        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)).Borders(1).LineStyle = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).Borders(2).LineStyle = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).Borders(3).LineStyle = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).Borders(4).LineStyle = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).HorizontalAlignment = 3
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).VerticalAlignment = 2
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).WrapText = 1
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).Font.Size = 9
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).Font.colorindex = 5
        .range(.cells(1, 1), .cells(DataShow.Rows, DataShow.Cols)).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) + 1
    With DataShow
        .Redraw = False
        .Clear
        .Rows = 1
        For i = 0 To UBound(strCaption)
            .TextMatrix(0, i) = strCaption(i)
            .ColWidth(i) = 1500
            .ColAlignment(i) = 1
        Next
        .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 DRPT2.DataSource = RSResult
        With DRPT2
            .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 - 1)
                .Sections(2).Controls(i).Width = DataShow.ColWidth(i - 1)
                TotalWidth = TotalWidth + DataShow.ColWidth(i - 1)
            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 - 1).Name
                .Sections(3).Controls(i).Left = DataShow.ColPos(i - 1)
                .Sections(3).Controls(i).Width = DataShow.ColWidth(i - 1)
                .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
    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 vkCheck2_Click()
    If vkCheck2.Value = vbChecked Then
        vkCheck1.Enabled = False
    Else
        vkCheck1.Enabled = True
    End If
End Sub

Private Sub vkCommand1_Click()
On Error GoTo ErrFlag
Dim strSQL As String

    strSQL = "SELECT WH.WHName, WHQty.GoodsID, goods.GoodsName, WHSetting.MaxValue, WHQty.Qty, WHSetting.MinValue "
    strSQL = strSQL & "FROM ((WHQty LEFT JOIN goods ON WHQty.GoodsID = goods.AutoID) LEFT JOIN WH ON WHQty.WHID = WH.ID) LEFT JOIN WHSetting ON (WHQty.WGType = WHSetting.WHID) AND (WHQty.GoodsID = WHSetting.GoodsID) where "
           
    If Combo1.Text <> "" Then strSQL = strSQL & "WHQty.WHID=" & Combo4.Text & " AND "
    
    If Combo2.Text <> "" Then strSQL = strSQL & "WHQty.GoodsID=" & Combo5.Text & " AND "
    
    If vkCheck2.Value = vbChecked Then
        strSQL = strSQL & "((([WHQty]![Qty])>[WHSetting]![MaxValue] Or ([WHQty]![Qty])<[WHSetting]![MinValue]))"
    Else
        If vkCheck1.Value = vbUnchecked Then strSQL = strSQL & "WHQty.Qty<>0"
    End If
    
    If Right(strSQL, 6) = "where " Then
        strSQL = Replace(strSQL, "where ", " ")
    End If
    If Right(strSQL, 5) = " AND " Then
        strSQL = Left(strSQL, Len(strSQL) - 5)
    End If
    strSQL = strSQL & " order by WH.WHName, WHQty.GoodsID"
    
    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