百货/超市行业

开发平台：
Visual Basic

frm_RKD.frm：源码内容
							VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "Msflxgrd.ocx"
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frm_RKD 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "入库单"
   ClientHeight    =   6120
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9405
   Icon            =   "frm_RKD.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6120
   ScaleWidth      =   9405
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.ComboBox cboClerk 
      Height          =   300
      ItemData        =   "frm_RKD.frx":000C
      Left            =   4560
      List            =   "frm_RKD.frx":000E
      Style           =   2  'Dropdown List
      TabIndex        =   18
      Top             =   120
      Width           =   1335
   End
   Begin VB.TextBox txtNum 
      BackColor       =   &H8000000F&
      BorderStyle     =   0  'None
      Enabled         =   0   'False
      Height          =   225
      Left            =   3240
      Locked          =   -1  'True
      TabIndex        =   9
      Text            =   "0"
      Top             =   5715
      Width           =   1215
   End
   Begin VB.TextBox txtM 
      BackColor       =   &H8000000F&
      BorderStyle     =   0  'None
      Enabled         =   0   'False
      Height          =   225
      Left            =   5520
      Locked          =   -1  'True
      TabIndex        =   8
      Text            =   "0"
      Top             =   5715
      Width           =   1215
   End
   Begin VB.TextBox txtAdmin 
      BackColor       =   &H8000000F&
      BorderStyle     =   0  'None
      Enabled         =   0   'False
      Height          =   225
      Left            =   960
      Locked          =   -1  'True
      TabIndex        =   7
      Top             =   5715
      Width           =   1215
   End
   Begin VB.CommandButton cmdExit 
      Cancel          =   -1  'True
      Caption         =   "退出(&X)"
      Height          =   300
      Left            =   7920
      TabIndex        =   3
      Top             =   5670
      Width           =   975
   End
   Begin VB.TextBox idnumber 
      Appearance      =   0  'Flat
      BackColor       =   &H8000000F&
      Height          =   240
      Left            =   7680
      Locked          =   -1  'True
      TabIndex        =   4
      TabStop         =   0   'False
      Top             =   90
      Width           =   1575
   End
   Begin VB.TextBox txtDATA 
      BorderStyle     =   0  'None
      Height          =   270
      Left            =   8640
      TabIndex        =   2
      Top             =   1125
      Visible         =   0   'False
      Width           =   495
   End
   Begin VB.TextBox txtExp 
      Height          =   300
      Left            =   600
      TabIndex        =   1
      Top             =   540
      Width           =   5295
   End
   Begin MSFlexGridLib.MSFlexGrid GD1 
      Height          =   4530
      Left            =   120
      TabIndex        =   6
      Top             =   945
      Width           =   9195
      _ExtentX        =   16219
      _ExtentY        =   7990
      _Version        =   393216
      Rows            =   16
      Cols            =   9
      RowHeightMin    =   275
      AllowBigSelection=   0   'False
      HighLight       =   0
      AllowUserResizing=   1
      FormatString    =   "序|食品名称|食品类别|食品属性|单位|数量|单价|金额|备注"
   End
   Begin MSComCtl2.DTPicker DTPicker2 
      Height          =   300
      Left            =   600
      TabIndex        =   13
      Top             =   135
      Width           =   1335
      _ExtentX        =   2355
      _ExtentY        =   529
      _Version        =   393216
      CustomFormat    =   "yyyy-MM-dd"
      Format          =   24903683
      CurrentDate     =   38718
   End
   Begin MSComCtl2.DTPicker DTPicker1 
      Height          =   300
      Left            =   2520
      TabIndex        =   17
      Top             =   120
      Width           =   1335
      _ExtentX        =   2355
      _ExtentY        =   529
      _Version        =   393216
      CustomFormat    =   "HH:mm:ss"
      Format          =   24903682
      CurrentDate     =   38718
   End
   Begin VB.Label lblxcd 
      Caption         =   "日期"
      Height          =   195
      Index           =   0
      Left            =   120
      TabIndex        =   16
      Top             =   195
      Width           =   375
   End
   Begin VB.Label lblxcd 
      Caption         =   "经手人"
      Height          =   195
      Index           =   2
      Left            =   3960
      TabIndex        =   15
      Top             =   195
      Width           =   615
   End
   Begin VB.Label lblxcd 
      Caption         =   "时间"
      Height          =   195
      Index           =   5
      Left            =   2040
      TabIndex        =   14
      Top             =   195
      Visible         =   0   'False
      Width           =   375
   End
   Begin VB.Label Label1 
      Caption         =   "数量合计"
      Height          =   195
      Left            =   2400
      TabIndex        =   12
      Top             =   5715
      Width           =   735
   End
   Begin VB.Label Label2 
      Caption         =   "金额合计"
      Height          =   195
      Left            =   4680
      TabIndex        =   11
      Top             =   5715
      Width           =   735
   End
   Begin VB.Label Label3 
      Caption         =   "制单人"
      Height          =   195
      Left            =   360
      TabIndex        =   10
      Top             =   5715
      Width           =   615
   End
   Begin VB.Label Label5 
      Caption         =   "单号"
      Height          =   165
      Left            =   7320
      TabIndex        =   5
      Top             =   135
      Width           =   375
   End
   Begin VB.Label lblxcd 
      Caption         =   "摘要"
      Height          =   195
      Index           =   4
      Left            =   120
      TabIndex        =   0
      Top             =   600
      Width           =   375
   End
End
Attribute VB_Name = "frm_RKD"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const Bpname = 1
Const Bguige = 2
Const Bppcd = 3
Const Bdw = 4
Const Bnum = 5
Const Bprice = 6
Const Bje = 7
Const Bbak = 8
Public Dmodi As Boolean
Private Sub cmdExit_Click()
    Unload Me
End Sub
Private Sub Form_Load()
    With GD1
        .ColWidth(0) = 300
        .ColWidth(Bpname) = 1400
        .ColWidth(Bguige) = 1400
        .ColWidth(Bppcd) = 1400
        .ColWidth(Bdw) = 600
        .ColWidth(Bnum) = 600
        .ColWidth(Bprice) = 600
        .ColWidth(Bje) = 800
        .ColWidth(Bbak) = 1200
    Dim i As Integer
        .TextMatrix(0, 0) = "序"
    For i = 1 To .Rows - 1
        .TextMatrix(i, 0) = i
        .Row = i
        .Col = Bje
        .CellBackColor = &HFFF800
        .Col = Bguige
        .CellBackColor = &HFFF800
        .Col = Bppcd
        .CellBackColor = &HFFF800
        .Col = Bdw
        .CellBackColor = &HFFF800
    Next i
        .Row = 1
        .Col = 1
    End With
    If Dmodi Then
        LoadModi (Pidn)
    Else
        DTPicker2.Value = Gdate
        idnumber = IDnum("RKD", "XCDZ")
        txtAdmin = Admin
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
If qx(0) Then
Dim str As String
str = MsgBox(vbCr & "请选择（是/否）保存此单据？按<ESC>放弃本次操作。" & vbCr, vbYesNoCancel, "保存提示：")
Select Case str
    Case "6"
        If Chk Then
            If Dmodi Then ModiData Else SaveData
            Dmodi = False
        Else
            Cancel = 1
            GD1.SetFocus
        End If
    Case "7"
        Dmodi = False
    Case "2"
        Cancel = 1
End Select
End If
End Sub
Private Sub GD1_Click()
Select Case GD1.Col
Case Bje, Bguige, Bppcd, Bdw
Case Else
    txtDATA = GD1
    Modi
End Select
End Sub
Private Sub GD1_KeyPress(KeyAscii As Integer)
Select Case GD1.Col
Case Bje, Bguige, Bppcd, Bdw
Case Else
    Select Case KeyAscii
        Case 0 To 32
            KeyAscii = 0
            txtDATA = GD1
            txtDATA.Move GD1.CellLeft + GD1.Left + 20, GD1.CellTop + GD1.Top + 20, GD1.CellWidth - 8, GD1.CellHeight - 8
            txtDATA.Visible = True
            txtDATA.SetFocus
            txtDATA.SelStart = Len(txtDATA.Text)
        Case Else
            txtDATA = Chr(KeyAscii)
            txtDATA.Move GD1.CellLeft + GD1.Left + 20, GD1.CellTop + GD1.Top + 20, GD1.CellWidth - 8, GD1.CellHeight - 8
            txtDATA.Visible = True
            txtDATA.SetFocus
            txtDATA.SelStart = Len(txtDATA.Text)
    End Select
End Select
End Sub
Private Sub GD1_LeaveCell()
If txtDATA.Visible Then
Select Case GD1.Col
    Case Bnum, Bprice
        If TOnum(txtDATA) <> 0 Then GD1 = TOnum(txtDATA) Else GD1 = ""
        txtDATA = ""
    Case Bbak
        GD1 = txtDATA
        txtDATA.Text = ""
    Case Else
        If txtDATA = "" Then GD1 = txtDATA: txtDATA = ""
    End Select
    txtDATA.Visible = False
End If
End Sub
Private Sub GD1_RowColChange()
    Dim cs, cc As Double
    Dim i As Integer
    cs = 0
    cc = 0
    For i = 1 To GD1.Rows - 1
        If TOnum(GD1.TextMatrix(i, Bnum)) <> 0 Or TOnum(GD1.TextMatrix(i, Bprice)) <> 0 Then
            GD1.TextMatrix(i, Bje) = TOnum(GD1.TextMatrix(i, Bprice)) * TOnum(GD1.TextMatrix(i, Bnum))
        End If
        cs = cs + TOnum(GD1.TextMatrix(i, Bnum))
        cc = cc + TOnum(GD1.TextMatrix(i, Bje))
    Next i
    txtNum = cs
    txtM = cc
End Sub
Private Sub txtDATA_DblClick()
Set obj = Me
    Select Case GD1.Col
    Case Bpname
        Tbl = "goods"
    Case Else
    Exit Sub
    End Select
frmFindSP.Show vbModal
End Sub
Private Sub txtdata_GotFocus()
txtDATA.Visible = True
End Sub
Private Sub txtDATA_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
    Case 38 'UP
        If GD1.Row > 1 Then
            GD1.Row = GD1.Row - 1
            MovIn
        End If
    Case 40 'DOWN
        If GD1.Row < GD1.Rows - 1 Then
            GD1.Row = GD1.Row + 1
            MovIn
        End If
    Case 37 'LEFT
        If GD1.Col > 1 Then
            If txtDATA.SelStart = 0 Then
                GD1.Col = GD1.Col - 1
                MovIn
            End If
        End If
    Case 39 'RIGHT
        If txtDATA.SelStart = Len(txtDATA.Text) Then
            If GD1.Col < GD1.Cols - 1 Then
                GD1.Col = GD1.Col + 1
                MovIn
            Else
                If GD1.Col = GD1.Cols - 1 And GD1.Row < GD1.Rows - 1 Then
                    GD1.Row = GD1.Row + 1
                    GD1.Col = 1
                    MovIn
                End If
            End If
        End If
    Case 13 'ENTER
        txtDATA_DblClick
End Select
End Sub
Private Sub txt_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyDelete Then txt(Index) = ""
End Sub
Private Sub txt_DblClick(Index As Integer)
     Fdtxt = txt(Index)
        Set obj = txt(Index)
        Select Case Index
        Case 1
            Tbl = "kehu"
        Case 3, 2
            Tbl = "zhiyuan"
        End Select
        frmFind.Show vbModal
     Fdtxt = ""
End Sub
Private Sub txt_KeyPress(Index As Integer, KeyAscii As Integer)
    If KeyAscii = 13 Then txt_DblClick (Index)
End Sub
Private Sub txt_LostFocus(Index As Integer)
Select Case Index
Dim Rs As New ADODB.Recordset
Case 1
Tbl = "kehu"
    Rs.Open "select bname from " & Tbl & " WHERE DEL = 0 and BNAME ='" & txt(Index) & "'", CnStr & DBName, adOpenStatic, adLockReadOnly
    If Rs.EOF Then txt(Index) = ""
    Rs.Close
Case 2, 3
Tbl = "zhiyuan"
    Rs.Open "select bname from " & Tbl & " WHERE DEL = 0 and BNAME ='" & txt(Index) & "'", CnStr & DBName, adOpenStatic, adLockReadOnly
    If Rs.EOF Then txt(Index) = ""
    Rs.Close
End Select
End Sub
Function LoadModi(IdnStr As String)
idnumber.Text = IdnStr
Dim Rsndx As New ADODB.Recordset
Rsndx.Open "select * from XCDZ where idn = '" & IdnStr & "'", CnStr & DBName, adOpenDynamic, adLockPessimistic
DTPicker2.Value = Rsndx("Fdate")
'txt(1).Text = TOstr(Rsndx("Fkehu"), "kehu")
txt(2).Text = TOstr(Rsndx("Fjsr"), "zhiyuan")
'txt(3).Text = TOstr(Rsndx("Fbgy"), "zhiyuan")
'Combo2 = Rsndx("Ftype")
'txtAdmin.Text = toAnyStr(Rsndx("Fmanager"), "dbadmin", "dbu")
'txtNO = Rsndx("Sid")
txtExp = Rsndx("Fexp")
Rsndx.Close
With GD1
Rsndx.Open "SELECT * FROM XCDF WHERE IDN = '" & IdnStr & "'", CnStr & DBName, adOpenStatic, adLockPessimistic
Dim i, ii As Integer
For i = 1 To 15
    For ii = 1 To 8
    .TextMatrix(i, ii) = ""
    Next
Next
ii = Rsndx.RecordCount
For i = 1 To ii
    .TextMatrix(TOnum(Rsndx("Fline")), Bpname) = TOstr(Rsndx("Fgoods"), "goods")
    .TextMatrix(TOnum(Rsndx("Fline")), Bguige) = toAnyStr(Rsndx("Fgoods"), "goods", "Fggxh")
    .TextMatrix(TOnum(Rsndx("Fline")), Bppcd) = toAnyStr(Rsndx("Fgoods"), "goods", "Fppcd")
    .TextMatrix(TOnum(Rsndx("Fline")), Bdw) = TOstr(toAnyStr(Rsndx("Fgoods"), "goods", "Fdw"), "danwei")
    .TextMatrix(TOnum(Rsndx("Fline")), Bnum) = Rsndx("Fnum")
    .TextMatrix(TOnum(Rsndx("Fline")), Bprice) = Rsndx("Fprice")
    .TextMatrix(TOnum(Rsndx("Fline")), Bje) = Rsndx("Fje")
    .TextMatrix(TOnum(Rsndx("Fline")), Bbak) = Rsndx("Fbak")
    Rsndx.MoveNext
Next
Rsndx.Close
End With
GD1_RowColChange
End Function
Private Sub MovIn()
txtDATA.Visible = False
GD1.SetFocus
End Sub
Private Sub Modi()
txtDATA = GD1
txtDATA.Move GD1.CellLeft + GD1.Left + 20, GD1.CellTop + GD1.Top + 20, GD1.CellWidth - 8, GD1.CellHeight - 8
txtDATA.Visible = True
txtDATA.SetFocus
txtDATA.SelStart = Len(txtDATA.Text)
End Sub
Private Sub ModiData()
On Error Resume Next
Dim i, ii As Integer
Dim cnn As New ADODB.Connection
cnn.ConnectionString = CnStr & DBName
cnn.CursorLocation = adUseClient
cnn.Open
cnn.BeginTrans
With GD1
For i = 1 To .Rows - 1
    If TOnum(.TextMatrix(i, Bnum)) <> 0 And .TextMatrix(i, Bpname) <> "" Then
        cnn.Execute ("UPDATE XCDF SET Fgoods='" & _
                        TOid(.TextMatrix(i, Bpname), "goods") & "',Fnum='" & _
                        TOnum(.TextMatrix(i, Bnum)) & "',Fprice='" & _
                        TOnum(.TextMatrix(i, Bprice)) & "',Fbak='" & _
                        .TextMatrix(i, Bbak) & "' WHERE IDN ='" & idnumber & "' AND Fline='" & i & "'")
    End If
Next
       cnn.Execute ("UPDATE XCDZ SET Fdate='" & _
                        Format(DTPicker2, "yyyy-MM-dd") & "',Fjsr='" & _
                        TOid(txt(2), "zhiyuan") & "',Fexp='" & _
                        txtExp & "' WHERE IDN ='" & idnumber & "'")
End With
If Err.Number <> 0 Then
    cnn.RollbackTrans
    MsgBox "修改未成功！" & vbCr & Err.Description
Else
    cnn.CommitTrans
    MsgBox "此单据已修改成功！", , "恭喜："
End If
cnn.Close
End Sub
Private Sub SaveData()
On Error Resume Next
Dim i, ii As Integer
Dim cnn As New ADODB.Connection
cnn.ConnectionString = CnStr & DBName
cnn.CursorLocation = adUseClient
cnn.Open
cnn.BeginTrans
    
'出入库单附
'cnn.Execute ("CREATE TABLE XCDF     (ID int IDENTITY primary key," & _
                                    "IDN varchar(17) not null," & _
                                    "Fline int not null," & _
                                    "Fgoods int not null," & _
                                    "Finout int default 1," & _
                                    "Fnum float(20) default 0," & _
                                    "Fprice float(20) default 0," & _
                                    "Fje as Fnum * Fprice," & _
                                    "Fbak varchar(50))")
With GD1
For i = 1 To .Rows - 1
    If TOnum(.TextMatrix(i, Bnum)) <> 0 And .TextMatrix(i, Bpname) <> "" Then
        '客户1
        cnn.Execute ("INSERT INTO XCDF " & _
                "(IDN,Fline,Fgoods,Finout,Fnum,Fprice,Fbak) " & _
                "VALUES('" & idnumber.Text & "','" & _
                        i & "','" & _
                        TOid(.TextMatrix(i, Bpname), "goods") & "','" & _
                        1 & "','" & _
                        TOnum(.TextMatrix(i, Bnum)) & "','" & _
                        TOnum(.TextMatrix(i, Bprice)) & "','" & _
                        .TextMatrix(i, Bbak) & "')")
    End If
Next
'出入库单主
'cnn.Execute ("CREATE TABLE XCDZ     (ID int identity primary key," & _
                                    "IDN varchar(17) not null," & _
                                    "Fcls int not null," & _
                                    "Fred BIT not null," & _
                                    "Fdate varchar(10)," & _
                                    "Fcarno int," & _
                                    "Fkehu int," & _
                                    "Fjsr int," & _
                                    "Fbgy int," & _
                                    "Fmanager int," & _
                                    "Ftype varchar(10) default ''," & _
                                    "Fpiao varchar(15) default ''," & _
                                    "Ftotje float(20) default 0," & _
                                    "Fexp varchar(50) default '')")
cnn.Execute ("INSERT INTO XCDZ (IDN,Fcls,Fred,Fdate,Fjsr,Ftotje,Fexp)" & _
                        " VALUES('" & idnumber.Text & "','" & _
                        1 & "','" & _
                        0 & "','" & _
                        Format(DTPicker2.Value, "yyyy-MM-dd") & "','" & _
                        TOid(txt(2), "zhiyuan") & "'," & _
                        TOnum(txtM) & ",'" & _
                        txtExp & "')")
End With
If Err.Number <> 0 Then
cnn.RollbackTrans
MsgBox "保存未成功！" & vbCr & Err.Description
Else
cnn.CommitTrans
MsgBox "此单据已保存成功！", , "恭喜："
End If
cnn.Close
End Sub
Function Chk() As Boolean
Dim i As Integer
Dim ii As Integer
ii = 0
If Trim(txt(2)) = "" Then
    MsgBox "错误，经手人不能为空!"
    Chk = False
    Exit Function
End If
With GD1
For i = 1 To 15
    If .TextMatrix(i, Bpname) <> "" Then
    ii = ii + 1
        If TOnum(.TextMatrix(i, Bnum)) = 0 Then
            MsgBox "第" & i & "行错误，数量不能为零!"
            .Row = i
            Chk = False
            Exit Function
        ElseIf TOnum(.TextMatrix(i, Bprice)) = 0 Then
            MsgBox "第" & i & "行错误，单价不能为零！"
            .Row = i
            Chk = False
            Exit Function
        ElseIf Len(.TextMatrix(i, Bbak)) > 25 Then
            MsgBox "第" & i & "行错误，备注应小于25个字符！"
            .Row = i
            Chk = False
            Exit Function
        End If
    End If
Next i
End With
If ii > 0 Then
    Chk = True
Else
    MsgBox "没有要保存的数据！"
    Chk = False
End If
End Function

						