frmrkd.frm

一个简单的用vb制作的公司贸易管理系统

      AutoSize        =   -1  'True
      Caption         =   "落单时间："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   240
      TabIndex        =   1
      Top             =   1020
      Width           =   1125
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "工厂名称："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   240
      TabIndex        =   0
      Top             =   660
      Width           =   1125
   End
End
Attribute VB_Name = "FrmRKD"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim gRow As Integer
Dim gCol As Integer
Dim CKID As String
Dim Number As Integer
Dim txtsql, Msgtext As String
Dim XSDExcel As Excel.Application

Private Sub Form_Load()
    Dim Rst, mrcc As ADODB.Recordset

    DTPicker1.Value = Date$
    DTPicker2.Value = Date$
    Text1.Visible = False
    Set IDlist = New Collection
    Call ReSet

    txtsql = "select max(进货ID) from 进货总表 where 进货ID like '" & Format(Date$, "yyyymmdd") & "%'"
    Set Rst = ExecuteSQL(txtsql, Msgtext)

    '    If IsNull(Rst.Fields(0)) Then
    '      Number = 1
    '    Else
    '      Number = Val(Mid(Rst.Fields(0), 10)) + 1
    '    End If
    '    Rst.Close
    '    Set Rst = Nothing

    '    LblBH.Caption = Format(Date$, "yyyymmdd") & Format(CStr(Number), "000")
    txtNo = GetRkno()

    Combo1.Clear
    txtsql = "select DISTINCT cn_CompanyName from suppliers"
    Set mrcc = ExecuteSQL(txtsql, Msgtext)
    If Not mrcc.EOF Then

        Do While Not mrcc.EOF
            Combo1.AddItem Trim(mrcc.Fields(0))
            mrcc.MoveNext
        Loop
    Else
        MsgBox "请先进行公司信息设置！", vbOKOnly + vbExclamation, "警告"
        Exit Sub
    End If
    mrcc.Close

End Sub
Private Sub ReSet()
    Grid.Clear
    Grid.Rows = 1
    Grid.FormatString = "序号|^   商   品   名   称    |^  货   号  |^  规   格   |^  材   料  |^  数   量  |^  单   价  |^  金    额   "
    Grid.ColWidth(8) = 0
    lblSL.Caption = "0"
    lblJE.Caption = "0.00"

    Set IDlist = New Collection

    Grid.Enabled = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set IDlist = Nothing
    Unload Me
End Sub

Private Sub Grid_DblClick()
    If Grid.Rows = 1 Then Exit Sub

    Text1.Top = Grid.CellTop + Grid.Top
    Text1.Left = Grid.CellLeft + Grid.Left

    gRow = Grid.Row
    gCol = Grid.Col

    If gCol <> 5 And gCol <> 6 Then Exit Sub

    Text1.Width = Grid.CellWidth '- 2 * Screen.TwipsPerPixelX
    Text1.Height = Grid.CellHeight ' - 2 * Screen.TwipsPerPixelY

    Text1.Text = Grid.Text
    ' Show the text box:
    Text1.Visible = True
    Text1.ZOrder 0 ' 把 Text1 放到最前面！
    Text1.SetFocus
    ' Redirect this KeyPress event to the text box:
    If KeyAscii <> 13 Then
        SendKeys Chr$(KeyAscii)
    End If

End Sub

Private Sub Text1_GotFocus()
    Text1.SelStart = 0
    Text1.SelLength = Len(Text1)
    Text1.BackColor = &HFFFF&

End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        Grid.SetFocus ' Set focus back to grid, see Text_LostFocus.
        KeyAscii = 0 ' Ignore this KeyPress.
    End If
    If KeyAscii <> 8 And KeyAscii <> 45 And KeyAscii <> 46 And KeyAscii < 48 Or KeyAscii > 57 Then
        ' 'Beep
        KeyAscii = 0
    End If
End Sub
Private Sub Text1_LostFocus()
    On Error GoTo Errorhandler
    Dim tmpRow As Integer
    Dim tmpCol As Integer
    ' Save current settings of Grid Row and col. This is needed only if
    ' the focus is set somewhere else in the Grid.
    tmpRow = Grid.Row
    tmpCol = Grid.Col
    ' Set Row and Col back to what they were before Text1_LostFocus:
    Grid.Row = gRow
    Grid.Col = gCol
    If gCol = 5 Then
        Grid.Text = Val(Text1.Text)
    ElseIf gCol = 6 Then
        Grid.Text = Format(Val(Text1.Text), "###0.00") ' Transfer text back to grid.
    End If
    Text1.SelStart = 0 ' Return caret to beginning.
    Text1.Visible = False ' Disable text box.
    ' Return row and Col contents:
    Grid.TextMatrix(gRow, 7) = Format(Val(Grid.TextMatrix(gRow, 5)) * Val(Grid.TextMatrix(gRow, 6)), "###0.00")

    For I = 1 To Grid.Rows - 1
        SumSL = SumSL + Val(Grid.TextMatrix(I, 5))
        SumJE = SumJE + Val(Grid.TextMatrix(I, 7))
    Next

    lblJE.Caption = Format(CStr(SumJE), ".00")
    lblSL.Caption = SumSL

    Grid.Row = tmpRow
    Grid.Col = tmpCol

Exit Sub

Errorhandler:

Exit Sub

End Sub
Private Sub Grid_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        Call Grid_DblClick
    End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
      Case Is = "Exit"
        Unload Me
      Case Is = "Addline"
        Call Grid_KeyUp(vbKeyF2, 0)
      Case Is = "Delline"
        Call Grid_KeyUp(vbKeyDelete, 0)
      Case Is = "Save"
        Call Grid_KeyUp(vbKeyF8, 0)
      Case Is = "Print"
        Call Grid_KeyUp(vbKeyF10, 0)
    End Select

End Sub
Private Sub Grid_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim Rst As ADODB.Recordset
    Dim Cmd As ADODB.Command
    Dim SQL As String
    Dim I As Integer
    Dim N As Integer

    Select Case KeyCode
      Case vbKeyF2
        'FrmSPZL.txtsql = "select * from products where 工厂编号='" & Combo1.Text & "'"
        SPFlag = 2

        FrmSPZL.Show 1
      Case vbKeyF3
        If MsgBox("请确信要取消此单?", vbOKCancel + vbCritical, "提示") = vbOK Then
            Call ReSet
        End If
      Case vbKeyF8
        If Grid.Rows <= 1 Then Exit Sub

        '        If Combo1.Text = "" Then
        '            MsgBox "请选择入库方式！", vbOKOnly + vbCritical, "提示"
        '            Exit Sub
        '        ElseIf Combo2.Text = "" Then
        '            MsgBox "请选择仓库！", vbOKOnly + vbCritical, "提示"
        '            Exit Sub
        '        End If

        For I = 1 To Grid.Rows - 1
            If Grid.TextMatrix(I, 5) = "0" Then
                MsgBox "第" & I & "行'数量'不能为零！", vbOKOnly + vbExclamation, "警告"
                Exit Sub
            ElseIf Grid.TextMatrix(I, 6) = "0.00" Then
                MsgBox "第" & I & "行'单价'不能为零！", vbOKOnly + vbExclamation, "警告"
                Exit Sub
            End If
        Next I

        Dim Rst1, Rst2 As ADODB.Recordset
        Dim NumId, id As Integer

        '更新进货总表
        SQL = "insert into 进货总表 values ('" & txtNo.Text & "','" & Combo1.Text & "','" _
              & Format(DTPicker1.Value, "yyyy-mm-dd") & "','" & Format(DTPicker2.Value, "yyyy-mm-dd") _
              & "'," & Val(lblJE.Caption) & ")"
        Set Rst = ExecuteSQL(SQL, Msgtext)

        '更新进货明细表
        SQL = "select max(id) from 进货表"
        Set Rst1 = ExecuteSQL(SQL, Msgtext)

        'Rst1.Open SQL, db, 1, 3

        If IsNull(Rst1.Fields(0)) Then
            NumId = 0
        Else
            NumId = Val(Rst1.Fields(0).Value)
        End If

        For I = 1 To Grid.Rows - 1
            NumId = NumId + 1
            SQL = "insert into 进货表  values('" & NumId & "','" & Trim(txtNo) & "','" & Val(Grid.TextMatrix(I, 0)) & "','" _
                  & Grid.TextMatrix(I, 8) & "','" & Grid.TextMatrix(I, 1) & "','" & Grid.TextMatrix(I, 2) & "','" _
                  & Grid.TextMatrix(I, 3) & "','" & Grid.TextMatrix(I, 4) & "','" & Grid.TextMatrix(I, 5) & "'," _
                  & Val(Grid.TextMatrix(I, 6)) & "," & Val(Grid.TextMatrix(I, 7)) & ")"

            Set Rst2 = ExecuteSQL(SQL, Msgtext)

            '            '更新库存动态表
            '                        Dim KCRst As ADODB.Recordset
            '                        Dim KCRst1 As ADODB.Recordset
            '                        Dim RstID As ADODB.Recordset
            '                        Dim NumKCID As Integer
            '
            '                        Set KCRst = New ADODB.Recordset
            '                        SQL = "select * from kcdtb where spid=" & Val(Grid.TextMatrix(I, 8))
            '                        KCRst.Open SQL, db, 1, 3
            '
            '                        If KCRst.EOF Then
            '                            Set RstID = New ADODB.Recordset
            '                            SQL = "select max(id) from KCDTB"
            '                            RstID.Open SQL, db, 1, 3
            '
            '                            If IsNull(RstID.Fields(0)) Then
            '                                NumKCID = 0
            '                            Else
            '                                NumKCID = Val(RstID.Fields(0).Value)
            '                            End If
            '
            '                            NumKCID = NumKCID + 1
            '
            '                            Set KCRst1 = New ADODB.Recordset
            '
            '                            SQL = "insert into kcdtb values('" & NumKCID & "','" & CKID & "','" & Val(Grid.TextMatrix(I, 8)) & _
                '                                      "','" & Grid.TextMatrix(I, 1) & "','" & Val(Grid.TextMatrix(I, 5)) & "')"
            '
            '                            KCRst1.Open SQL, db, 1, 3
            '
            '                        Else
            '                            KCRst.Fields(4).Value = KCRst.Fields(4).Value + Val(Grid.TextMatrix(I, 5))
            '                            KCRst.Update
            '                        End If
        Next

        If MsgBox("数据保存成功,是否要打印?", vbOKCancel + vbInformation, "提示") = vbOK Then
            Call FPPrint
        End If

        Call ReSet
        Number = Number + 1
        'LblBH.Caption = Format(Date$, "yyyymmdd") & Format(CStr(Number), "000")
        txtNo = GetRkno()
      Case vbKeyF10
        Call FPPrint
      Case vbKeyDelete, vbKeyBack
        Dim SumJE, SumSE, SumJSHJ As Currency
        Dim SumSL As Integer

        If Grid.RowSel = 0 Then Exit Sub
        If Grid.Rows = 2 Then ReSet: Exit Sub
        IDlist.Remove Grid.RowSel
        Grid.RemoveItem Grid.RowSel
        For I = 1 To Grid.Rows - 1
            SumJE = SumJE + Val(Grid.TextMatrix(I, 7))
            SumSL = SumSL + Val(Grid.TextMatrix(I, 5))
        Next

        lblJE.Caption = Format(CStr(SumJE), ".00")
        lblSL.Caption = SumSL

        For I = 1 To Grid.Rows - 1
            Grid.TextMatrix(I, 0) = CStr(I)
        Next
    End Select
End Sub
Private Sub FPPrint()
    Dim t As Integer
    Dim j As Integer
    Dim sum, sum1 As Integer
    Set zsbexcel = New Excel.Application
    zsbexcel.Visible = True
    zsbexcel.SheetsInNewWorkbook = 1
    Set zsbworkbook = zsbexcel.Workbooks.Open(App.Path + "\" + "sheet\进货订单.xlt")
    With zsbexcel.ActiveSheet
        .Range("C3").Value = Me.Combo1.Text

        .Range("G3").Value = txtNo
        .Range("C5").Value = Format(DTPicker1, "yyyy-mm-dd")
        .Range("G5").Value = Format(DTPicker2, "yyyy-MM-dd")
        .Range("C17").Value = Me.lblSL
        .Range("G17").Value = Me.lblJE

        For t = 1 To Grid.Rows - 1

            Grid.Col = 7
            a = "A" + CStr(t + 7)
            b = "B" + CStr(t + 7)
            d = "D" + CStr(t + 7)
            e = "E" + CStr(t + 7)
            f = "F" + CStr(t + 7)
            g = "G" + CStr(t + 7)
            h = "H" + CStr(t + 7)
            a1 = "I" + CStr(t + 7)
            .Range(a).Value = Grid.TextMatrix(t, 0)
            .Range(b).Value = Grid.TextMatrix(t, 1)
            .Range(d).Value = Grid.TextMatrix(t, 2)
            .Range(e).Value = Grid.TextMatrix(t, 3)
            .Range(f).Value = Grid.TextMatrix(t, 4)
            .Range(g).Value = Grid.TextMatrix(t, 5)
            .Range(h).Value = Grid.TextMatrix(t, 6)
            .Range(a1).Value = Grid.TextMatrix(t, 7)

        Next t

    End With
    'dd = MsgBox("yes or no", vbYesNo + vbSystemModal)
    'If dd = vbNo Then Exit Sub
    ' zsbexcel.ActiveSheet.PageSetup.Orientation = xlPortrait       'xlLandscape
    'zsbexcel.ActiveSheet.PageSetup.PaperSize = xlPaperA4
    zsbexcel.Caption = "打印预览"
    zsbexcel.ActiveWindow.SelectedSheets.PrintPreview
    'zsbexcel.ActiveSheet.PrintOut
    zsbexcel.DisplayAlerts = False
    zsbexcel.Quit
    zsbexcel.DisplayAlerts = True
    Set zsbexcel = Nothing

Exit Sub

End Sub