frmsql_ok.frm

ktv场所的包房开房、迎宾、预定管理系统。

      Top             =   2880
      Width           =   630
   End
End
Attribute VB_Name = "frmsql_ok"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const UNIT = 0.03937 * 1440

Private Sub Command1_Click(Index As Integer)
   Dim TxtSQL As String
   Dim msgtext As String
   Dim mrc As ADODB.Recordset
   Dim rpt         As New report
   Dim txt         As clsText
   Dim BTarray(8) As Integer
   Dim recBT(8) As String
    Dim t_xlsname As String
    Dim appxl As Object
    Dim xl As Object
    Dim ws As Object
    Dim i As Integer
    Dim tem2 As Long
    Dim tem3 As Long
 
    Select Case Index
        Case 0
            Select Case comb_lx.ListIndex
                Case 0
                    TxtSQL = "select  b.p_id,b.p_name,b.unit,avg(b.unit_price) as price,format(sum(b.qty),'0.00') as qty,sum(b.price) as finalprice"
                    TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                    TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                    TxtSQL = TxtSQL & " and a.p_flag=false "
                    TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM-dd')='" & Format(dtptime(0).Value, "yyyy-MM-dd") & "'"
                Case 1
                    TxtSQL = "select  b.p_id,b.p_name,b.unit,avg(b.unit_price) as price,format(sum(b.qty),'0.00') as qty,sum(b.price) as finalprice"
                    TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                    TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                    TxtSQL = TxtSQL & " and a.p_flag=false "
                    TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM')='" & Format(dtptime(0).Value, "yyyy-MM") & "'"
                Case 2
                    TxtSQL = "select  b.p_id,b.p_name,b.unit,avg(b.unit_price) as price,format(sum(b.qty),'0.00') as qty,sum(b.price) as finalprice"
                    TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                    TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                    TxtSQL = TxtSQL & " and a.p_flag=false "
                    TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM-dd')>='" & Format(dtptime(0).Value, "yyyy-MM-dd") & "'"
                    TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM-dd')<='" & Format(dtptime(1).Value, "yyyy-MM-dd") & "'"
            End Select
            
            If Combo1.text <> "" Then
                TxtSQL = TxtSQL & "and a.ps_rid='" & Combo1.ItemData(Combo1.ListIndex) & "'"
            End If
            
            TxtSQL = TxtSQL & " group by p_id,p_name,unit"
            TxtSQL = TxtSQL & " order by p_id"
            
            
            Set mrc = ExecuteSQL(TxtSQL, msgtext)
            Set msglist.DataSource = mrc
            mrc.Close
            Set mrc = Nothing
            showtitle
            tem2 = 0
            tem3 = 0
            For i = 1 To msglist.rows - 1
                tem2 = tem2 + msglist.TextMatrix(i, 5) '金额
                tem3 = tem3 + msglist.TextMatrix(i, 4) '金额
            Next i
            msglist.rows = msglist.rows + 1
            msglist.TextMatrix(i, 1) = "合计"
            msglist.TextMatrix(i, 5) = tem2
            msglist.TextMatrix(i, 4) = tem3
        Case 1

            Set txt = New clsText
            With txt
                .stringX = "出库单" & comb_lx.text & ""
                .fontsize = 12
                '.FontUnderLine = True
                '.ForeColor = &HFF8080
                .FontBold = True
                .Align = tymiddle
            End With
            rpt.Header.AddText "head1", txt
            Set txt = Nothing

            Set txt = New clsText
'            With txt
'                .stringX = "供应商:" & DCboSup
'                .fontsize = 10
'                '.ForeColor = &H8000&
'                '.FontBold = True
'                .Align = tyLeft
'            End With
            rpt.Header.AddText "head2", txt
            Set txt = Nothing
            Set txt = New clsText
            With txt
                Select Case comb_lx.ListIndex
                    Case 0
                        .stringX = "日期:" & dtptime(0)
                    Case 1
                        .stringX = "日期:" & Format(dtptime(0), "yyyy-MM")
                    Case 2
                        .stringX = "日期:" & dtptime(0) & "至" & dtptime(1)
                End Select
                .fontsize = 10
                '.ForeColor = &H8000&
                '.FontBold = True
                .Align = tyLeft
                .orient = Portrait
            End With
            rpt.Header.AddText "head3", txt
            Set txt = Nothing
            Set txt = New clsText
            With txt
                .stringX = "" '"合计:<大写：> " & lab_total & Space(9) & "<小写：>" & Label2 & "|制单人:" & txtps_maker
                .fontsize = 10
                '.ForeColor = vbRed
                '.FontBold = True
                .Align = tyLeft
            End With
            rpt.Footer.AddText "footer1", txt
            Set txt = Nothing
            rpt.LeftSection.AlignMode = tyContent
            rpt.RightSection.AlignMode = tyContent
            rpt.Align = tymiddle
            BTarray(1) = 1000
            BTarray(2) = 2600
            BTarray(3) = 800
            BTarray(4) = 800
            BTarray(5) = 800
            BTarray(6) = 1000
            recBT(1) = "产品编号"
            recBT(2) = "产品名称"
            recBT(3) = "单位"
            recBT(4) = "单价"
            recBT(5) = "数量"
            recBT(6) = "金额"
            Select Case comb_lx.ListIndex
                Case 0
                    TxtSQL = "select  b.p_id,b.p_name,b.unit,avg(b.unit_price) as price,sum(b.qty) as qty,sum(b.price) as finalprice"
                    TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                    TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                    TxtSQL = TxtSQL & " and a.p_flag=false "
                    TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM-dd')='" & Format(dtptime(0).Value, "yyyy-MM-dd") & "'"
                    TxtSQL = TxtSQL & " group by p_id,p_name,unit"
                    TxtSQL = TxtSQL & " order by p_id"
                Case 1
                    TxtSQL = "select  b.p_id,b.p_name,b.unit,avg(b.unit_price) as price,sum(b.qty) as qty,sum(b.price) as finalprice"
                    TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                    TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                    TxtSQL = TxtSQL & " and a.p_flag=false "
                    TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM')='" & Format(dtptime(0).Value, "yyyy-MM") & "'"
                    TxtSQL = TxtSQL & " group by p_id,p_name,unit"
                    TxtSQL = TxtSQL & " order by p_id"
                Case 2
                    TxtSQL = "select  b.p_id,b.p_name,b.unit,avg(b.unit_price) as price,sum(b.qty) as qty,sum(b.price) as finalprice"
                    TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                    TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                    TxtSQL = TxtSQL & " and a.p_flag=false "
                    TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM-dd')>='" & Format(dtptime(0).Value, "yyyy-MM-dd") & "'"
                    TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM-dd')<='" & Format(dtptime(1).Value, "yyyy-MM-dd") & "'"
                    TxtSQL = TxtSQL & " group by p_id,p_name,unit"
                    TxtSQL = TxtSQL & " order by p_id"
            End Select
            Set mrc = ExecuteSQL(TxtSQL, msgtext)
            If mrc.EOF Then
                Exit Sub
            End If
            rpt.Attachmrc mrc, recBT, BTarray
            rpt.Preview
            mrc.Close
            Set mrc = Nothing

        Case 3
            Unload Me
    End Select
End Sub

Private Sub Form_Load()
    comb_lx.AddItem "日报表"
    comb_lx.AddItem "月报表"
    comb_lx.AddItem "时间段报表"
    comb_lxx.AddItem "出库单"
    dtptime(0).Value = Now
    dtptime(1).Value = Now
    
    Dim rs As New ADODB.Recordset
    rs.Open "select * from department", cnn, adOpenDynamic, adLockOptimistic
    While Not rs.EOF
        Combo1.AddItem "" & rs!department_name
        Combo1.ItemData(Combo1.NewIndex) = "" & rs!department_id
        rs.MoveNext
    Wend
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    If Combo1.ListCount > 1 Then
        Combo1.ListIndex = 0
    End If
    
    comb_lx.ListIndex = 0
    comb_lxx.ListIndex = 0
    Command1_Click (0)
End Sub

Private Sub msglist_Click()
Dim TxtSQL As String
    Dim msgtext As String
    Dim mrc As ADODB.Recordset
    
    If msglist.row > 0 Then
        Select Case comb_lx.ListIndex
            Case 0
                TxtSQL = "select  a.ps_id,b.p_id,b.p_name,b.unit,b.unit_price,b.qty,b.price,a.ps_maker,a.ps_men,a.ps_rid,a.ps_demo,a.ps_date"
                TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                TxtSQL = TxtSQL & " and a.p_flag=false "
                TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM')='" & Format(dtptime(0).Value, "yyyy-MM") & "'"
                TxtSQL = TxtSQL & " and p_id='" & msglist.TextMatrix(msglist.row, 0) & "'"
                TxtSQL = TxtSQL & " order by order_id"
            Case 1
                TxtSQL = "select  a.ps_id,b.p_id,b.p_name,b.unit,b.unit_price,b.qty,b.price,a.ps_maker,a.ps_men,a.ps_rid,a.ps_demo,a.ps_date"
                TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                TxtSQL = TxtSQL & " and a.p_flag=false "
                TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM')='" & Format(dtptime(0).Value, "yyyy-MM") & "'"
                TxtSQL = TxtSQL & " and p_id='" & msglist.TextMatrix(msglist.row, 0) & "'"
                TxtSQL = TxtSQL & " order by order_id"
            Case 2
                TxtSQL = "select  a.ps_id,b.p_id,b.p_name,b.unit,b.unit_price,b.qty,b.price,a.ps_maker,a.ps_men,a.ps_rid,a.ps_demo,a.ps_date"
                TxtSQL = TxtSQL & " from psout_head as a,psout_detail as b"
                TxtSQL = TxtSQL & " where a.ps_id=b.order_id"
                TxtSQL = TxtSQL & " and a.p_flag=false "
                TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM-dd')>='" & Format(dtptime(0).Value, "yyyy-MM-dd") & "'"
                TxtSQL = TxtSQL & " and format(a.ps_date,'yyyy-MM-dd')<='" & Format(dtptime(1).Value, "yyyy-MM-dd") & "'"
                TxtSQL = TxtSQL & " and p_id='" & msglist.TextMatrix(msglist.row, 0) & "'"
                TxtSQL = TxtSQL & " order by order_id"
            Case 3
            End Select
        Set mrc = ExecuteSQL(TxtSQL, msgtext)
        Set msglist1.DataSource = mrc
        showtitle1
        mrc.Close
        Set mrc = Nothing
    End If
End Sub
Private Sub showtitle()
    Dim i As Integer
    
    With msglist
        .Cols = 6
        '.Rows = 2
        .TextMatrix(0, 0) = "编号"
        .TextMatrix(0, 1) = "产品名称"
        .TextMatrix(0, 2) = "单位"
        .TextMatrix(0, 3) = "单价"
        .TextMatrix(0, 4) = "数量"
        .TextMatrix(0, 5) = "金额"
        '设置各列的对齐方
        For i = 1 To 5
            .ColAlignment(i) = 1
        Next i
        '表头项居中
        .FillStyle = flexFillRepeat
        .col = 0
        .row = 0
        '.RowSel = 1
        .ColSel = .Cols - 1
        '.CellAlignment = 4
        '设置单元大小
        .colWidth(0) = 1000
        .colWidth(1) = 2500
        .colWidth(2) = 800
        .colWidth(3) = 800
        .colWidth(4) = 800
        .colWidth(5) = 1000
        '.Row = 1
    End With
End Sub

Private Sub showtitle1()
    Dim i As Integer
    
    With msglist1
        .Cols = 12
        '.Rows = 2
        .TextMatrix(0, 0) = "单号"
        .TextMatrix(0, 1) = "编号"
        .TextMatrix(0, 2) = "产品名称"
        .TextMatrix(0, 3) = "单位"
        .TextMatrix(0, 4) = "单价"
        .TextMatrix(0, 5) = "数量"
        .TextMatrix(0, 6) = "金额"
        .TextMatrix(0, 7) = "制单人"
        .TextMatrix(0, 8) = "领物人"
        .TextMatrix(0, 9) = "对方单位"
        .TextMatrix(0, 10) = "领物人所在"
        .TextMatrix(0, 11) = "出库日期"
        '设置各列的对齐方
        For i = 1 To 11
            .ColAlignment(i) = 1
        Next i
        '表头项居中
        .FillStyle = flexFillRepeat
        .col = 0
        .row = 0
        '.RowSel = 1
        .ColSel = .Cols - 1
        '.CellAlignment = 4
        '设置单元大小
        .colWidth(0) = 620
        .colWidth(1) = 620
        .colWidth(2) = 1500
        .colWidth(3) = 650
        .colWidth(4) = 650
        .colWidth(5) = 650
        .colWidth(6) = 800
        .colWidth(7) = 750
        .colWidth(8) = 750
        .colWidth(9) = 1400
        .colWidth(10) = 1400
        .colWidth(11) = 1100
        '.Row = 1
    End With
End Sub

Private Sub txt_id_Change()
  Dim i, j, m As Integer
  Dim s As String
    If Trim$(txt_id.text) <> "" Then
        s = Mid(txt_id.text, 1, 1)
        If Asc(s) > 57 Or Asc(s) < 48 Then
            m = 0
            With msglist
                For i = 1 To .rows - 1
                    For j = 1 To Len(Trim$(txt_id.text))
                        If Mid(Trim$(.TextMatrix(i, 1)), j, 1) = Mid(Trim$(txt_id.text), j, 1) Then
                            If j > m Then
                                .col = 1
                                .row = i
                                .TopRow = i
                                m = j
                            End If
                        Else
                            Exit For
                        End If
                    Next j
                Next i
            End With
        Else
            m = 0
            With msglist
                For i = 1 To .rows - 1
                    For j = 1 To Len(Trim$(txt_id.text))
                        If Mid(Trim$(.TextMatrix(i, 0)), j, 1) = UCase(Mid(Trim$(txt_id.text), j, 1)) Then
                            If j > m Then
                                .col = 1
                                .row = i
                                .TopRow = i
                                m = j
                            End If
                        Else
                            Exit For
                        End If
                    Next j
                Next i
            End With
        End If
    End If

End Sub