frmdb.frm

注释：用VB开发的进销存系统源码

    End Select
End Sub


'将表的表头和明细清空
Private Sub ClearTable()
    '清空表头
    txtIptno.Text = ""
    txtIamt1.Text = ""
    txtIamt2.Text = ""
    txtPurcode.Text = ""
    txtPurdate.Text = ""
    cmbGrpOut.Text = ""
    cmbGrpIn.Text = ""
    txtGrpOut.Text = ""
    txtGrpIn.Text = ""
    '清空明细
    grdDET.Update
    grdDET.RemoveAll
End Sub

'刷新表显示

Private Sub RefreshTable(vRs As ADODB.Recordset)
    On Error GoTo RefErr
    Dim i
    If vRs.EOF Or vRs.BOF Then Exit Sub
    '清空明细
    grdDET.Update
    grdDET.RemoveAll
    
    '表头文本框刷新
    txtPurcode.Text = vRs("表单号")
    
    cmbGrpOut.Text = Trim(vRs("调出部门"))
    
    For i = 0 To cmbGrpOut.Rows - 1
        If cmbGrpOut.Columns(0).CellValue(i) = cmbGrpOut.Text Then txtGrpOut.Text = cmbGrpOut.Columns(1).CellValue(i)
    Next i
    
'    cmbGrpOut.DroppedDown = True
'    cmbGrpOut.DroppedDown = False
'    txtGrpOut.Text = cmbGrpOut.Columns(1).Text
    
    cmbGrpIn.Text = Trim(vRs("调入部门"))
    
    For i = 0 To cmbGrpIn.Rows - 1
        If cmbGrpIn.Columns(0).CellValue(i) = cmbGrpIn.Text Then txtGrpIn.Text = cmbGrpIn.Columns(1).CellValue(i)
    Next i
    
'    cmbGrpIn.DroppedDown = True
'    cmbGrpIn.DroppedDown = False
'    txtGrpIn.Text = cmbGrpIn.Columns(1).Text
    
    txtPurdate.Text = CStr(Format(vRs("制表日期"), "YYYY-MM-DD 00:00"))
    txtIptno.Text = vRs("录入员")
    
    '如果确认状态为真则不允许修改
    If vRs("确认状态").Value Then
        cmdToolCommit.Enabled = False
        cmdToolDelete.Enabled = False
        cmdToolSave.Enabled = False
    Else
        cmdToolCommit.Enabled = True
        cmdToolDelete.Enabled = True
        cmdToolSave.Enabled = True
    End If
    
    While Not vRs.EOF
        Temp = vRs("商品编码") & vbTab & vRs("品名") & vbTab & vRs("单位") & vbTab & vRs("颜色") & vbTab & vRs("尺寸") & _
              vbTab & vRs("数量") & vbTab & vRs("调出价") & vbTab & vRs("调出金额") & vbTab & vRs("调入价") & vbTab & vRs("调入金额")
        grdDET.AddItem Temp
        '记录后移
        vRs.MoveNext
    Wend
    Call CalTotalDelete
    Exit Sub
RefErr:
    ErrNum = Err.number
    MsgBox "读数据库发生错误!" & vbCrLf & Error$(ErrNum), vbExclamation, "提示窗口"

End Sub

'保存表
Private Function SaveTable() As Boolean
    On Error GoTo SaveErr
    Dim Temp2, i, j
    Temp2 = 0
    Temp = 0
    grdDET.MoveFirst
    For i = 0 To grdDET.Rows - 1
        sSQL = "INSERT INTO  " & TableName & " (表单号,调入部门,调出部门,制表日期," & _
            " 录入员,商品编码,品名,单位,颜色,尺寸,数量,调出价" & _
            ",调出金额,调入价,调入金额)" & _
            " VALUES('"
        sSQL = sSQL & _
            Trim(txtPurcode.Text) & "','" & _
            Trim(cmbGrpIn.Text) & "','" & _
            Trim(cmbGrpOut.Text) & "','" & _
            Trim(txtPurdate.Text) & "','" & _
            Trim(txtIptno.Text) & "','"
            
        sSQL = sSQL & _
            Trim(grdDET.Columns("商品编码").Text) & "','" & _
            Trim(grdDET.Columns("品名").Text) & "','" & _
            Trim(grdDET.Columns("单位").Text) & "','" & _
            Trim(grdDET.Columns("颜色").Text) & "','" & _
            Trim(grdDET.Columns("尺寸").Text) & "'," & _
            Val(grdDET.Columns("数量").Value) & "," & _
            Val(grdDET.Columns("调出价").Value) & "," & _
            Val(grdDET.Columns("调出金额").Value) & "," & _
            Val(grdDET.Columns("调入价").Value) & "," & _
            Val(grdDET.Columns("调入金额").Value) & ")"
        If RunSQL(sSQL) <> 0 Then
            SaveTable = False
            Exit Function
        End If
        grdDET.MoveNext
    Next i
    SaveTable = True
    Exit Function
SaveErr:
    ErrNum = Err.number
    MsgBox "保存数据库发生错误!", vbExclamation, "提示窗口"
End Function

Private Sub cmbGrpIn_CloseUp()
    txtGrpIn.Text = cmbGrpIn.Columns(1).Text
End Sub

Private Sub cmbGrpIn_GotFocus()
    cmbGrpIn.DroppedDown = True
End Sub

Private Sub cmbGrpOut_CloseUp()
    txtGrpOut.Text = cmbGrpOut.Columns(1).Text
End Sub

Private Sub cmbGrpOut_GotFocus()
    cmbGrpOut.DroppedDown = True
End Sub

Private Sub cmbGrpOut_InitColumnProps()
    On Error GoTo LinkErr
    Set Rs = Nothing
    Rs.Open "SELECT * FROM 分店主档", Conn, adOpenStatic, adLockReadOnly
    While Not Rs.EOF
        cmbGrpOut.AddItem Trim(Rs("分店编码")) + vbTab + Trim(Rs("分店名称"))
        Rs.MoveNext
    Wend
    Exit Sub
LinkErr:
    MsgBox "初始化数据错误！" & Err.Description, vbExclamation, "错误窗口"

End Sub

Private Sub cmbGrpIn_InitColumnProps()
    On Error GoTo LinkErr
    Set Rs = Nothing
    Rs.Open "SELECT * FROM 分店主档", Conn, adOpenStatic, adLockReadOnly
    While Not Rs.EOF
        cmbGrpIn.AddItem Trim(Rs("分店编码")) + vbTab + Trim(Rs("分店名称"))
        Rs.MoveNext
    Wend
    Exit Sub
LinkErr:
    MsgBox "初始化数据错误！" & Err.Description, vbExclamation, "错误窗口"
End Sub

Private Sub cmdPrintBill_Click()
    On Error Resume Next
    Dim N, i, j
    Dim strControl As String, strValue As String
    Load rptDB
    rptDB.Sections("Indent").Controls("lbltitle").Caption = GetSetting("进销存管理系统", "单据标题", "调拨单", "调拨单")
    rptDB.Sections("Indent").Controls("lblno").Caption = "NO:" & txtPurcode.Text
    rptDB.Sections("Indent").Controls("lblGrpOut").Caption = "调出部门:" & cmbGrpOut.Columns(1).Text
    rptDB.Sections("Indent").Controls("lblgrp").Caption = "调入部门:" & cmbGrpIn.Columns(1).Text
    rptDB.Sections("Indent").Controls("lblDate").Caption = "日期:" & txtPurdate.Text
    rptDB.Sections("Indent").Controls("lblIptno").Caption = "开票:" & txtIptno.TheName
    rptDB.Sections("Indent").Controls("lblIamt").Caption = txtIamt1.Text
    rptDB.Sections("Indent").Controls("lblIamt2").Caption = txtIamt2.Text
    rptDB.Sections("Indent").Controls("lbl大写").Caption = D2X(Val(txtIamt1.Text))
    rptDB.Sections("Indent").Controls("lbl大写2").Caption = D2X(Val(txtIamt2.Text))
    grdDET.MoveFirst
    For N = 1 To grdDET.Rows
        If N > 6 Then Exit For
        For j = 0 To 8

'            strControl = "lblc" & (j + 1) & "r" & N
            If j = 4 Or j = 5 Then
                strControl = "lblc" & (j + 1) & "r" & N
                strValue = Format(grdDET.Columns(j).Text, DecNum)
            ElseIf j = 7 Or j = 8 Then
                strControl = "lblc" & (j) & "r" & N
                strValue = Format(grdDET.Columns(j).Text, DecNum)
            ElseIf j = 0 Or j = 1 Or j = 2 Or j = 3 Then
                strControl = "lblc" & (j + 1) & "r" & N
                strValue = grdDET.Columns(j).Text
            End If
            If j <> 6 Then
                rptDB.Sections("Indent").Controls(strControl).Caption = strValue
            End If
        Next j
        grdDET.MoveNext
    Next N
'    rptDB.Show
    rptDB.PrintReport
    Unload rptDB
    MsgBox "打印完成!", vbInformation, "提示窗口"

End Sub

'增加新表
Private Sub cmdToolAdd_Click()
    On Error Resume Next
    TableState = "新建"
    grdDET.AllowUpdate = True
    grdDET.SelectByCell = False
    Set Rs = Nothing
    QueryFlag = False
    Call ShowStatus(2)
    '清除整个表显示
    Call ClearTable
    txtIptno.Text = UserCode
    txtPurdate.Text = Format(Now, "yyyy-mm-dd")
    If GetSetting("进销存管理系统", "进销管理", "调拨单单号是否自动生成", "1") = "1" Then
        txtPurcode.Text = GeneratePurcode(TableName)
    End If
    
    cmdToolSave.Enabled = True
    cmdToolCommit.Enabled = False
    cmdToolPrevious.Enabled = False
    cmdToolNext.Enabled = False
    cmdToolDelete.Enabled = False
    txtPurcode.SetFocus
End Sub

'
'改变确认状态
'只有审核员才能进行该操作
'
'***************************************************
'   修改库存时根据商品编码,部门,供应商
'***************************************************


Private Sub cmdToolCommit_Click()
    If cmdToolCommit.Caption = "审核[&O]" Then
        AcceptVil (True)
    Else
        AcceptVil (False)
    End If
End Sub


'删除当前表
Private Sub cmdToolDelete_Click()
    On Error Resume Next
    Call ShowStatus(88)
    If txtPurcode.Text = "" Then
        MsgBox "当前表单为空!", vbExclamation, "提示窗口"
        Exit Sub
    End If

    Temp = "确认之要删除该表吗?" & vbCrLf & "表单号为：" & txtPurcode.Text
    Temp = MsgBox(Temp, vbQuestion + vbYesNo, "提示窗口")
    If Temp = vbYes Then
        
        sSQL = "DELETE  FROM " & TableName & " WHERE 表单号='" & txtPurcode.Text & "'"
        RunSQL sSQL
        
        Call ClearTable
        cmdToolPrevious.Enabled = False
        cmdToolNext.Enabled = False
        Call ShowStatus(5)
    End If
End Sub

'退出
Private Sub cmdToolExit_Click()
    Unload Me
End Sub

'设置是否进行合法性验证
Private Sub SetValidate(Flag As Boolean)
    txtPurcode.CausesValidation = Flag
    txtPurdate.CausesValidation = Flag
    txtIptno.Validation = Flag
    grdDET.CausesValidation = Flag
End Sub

'生成查询条件
Private Function GenerateQuerySQL() As String
    Dim strTemp As String
    sSQL = "SELECT  表单号 FROM LSDBD "
    If txtPurcode.Text <> "" Then
        strTemp = strTemp & "  表单号" & _
            AnalyseCondition(txtPurcode.Text, True) & " AND"
    End If
    If txtPurdate.Text <> "" Then
        strTemp = strTemp & "  制表日期 BETWEEN '" & _
                Format(txtPurdate.Text, "YYYY-MM-DD HH:MM") & "' AND '" & _
                Format(txtPurdate.Text, "YYYY-MM-DD") & " 23:59' AND "
    End If
    If txtIptno.Text <> "" Then
        strTemp = strTemp & "  录入员 " & _
            AnalyseCondition(txtIptno.Text, True) & " AND"
    End If
    If grdDET.Columns("商品编码").CellText(0) <> "" Then
        strTemp = strTemp & "  商品编码 " & _
            AnalyseCondition(grdDET.Columns("商品编码").CellText(0), True) & " AND"
    End If
    If grdDET.Columns("数量").CellText(0) <> "" Then
        strTemp = strTemp & "  数量 " & _
            AnalyseCondition(grdDET.Columns("数量").CellText(0), False) & " AND"
    End If
    If strTemp <> "" Then
        sSQL = sSQL & " WHERE " & Mid(strTemp, 1, Len(strTemp) - 4)         '& " AND LEN(表单号)<15 "
    Else
        sSQL = sSQL         ' & " WHERE LEN(表单号)<15 "
    End If
    sSQL = sSQL & " GROUP BY 表单号,制表日期 ORDER BY 制表日期 desc,表单号 desc"
    GenerateQuerySQL = sSQL
End Function

Private Sub cmdToolJian_Click()
    Dim s, ss, Qty, i
    Load frmDist
    'Set frmDist.frm = Me
    frmDist.Show 1
    sSQL = "SELECT 品名,单位,进价,零售价,税率,含税进价 FROM 商品主档 WHERE 商品编码='" & frmDist.GCode & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If RsTemp.EOF Then
        MsgBox "该商品编码不存在!" & vbCrLf & "请检查输入是否正确或查询商品编码.", vbExclamation, "提示窗口"
        Exit Sub
    End If
    If frmDist.R <> "" Then
        ss = frmDist.R
        
        i = 1
        While i <= Len(ss)
            s = ""
            Qty = ""
            While Mid(ss, i, 1) <> "#" And i <= Len(ss)
                If Mid(ss, i, 1) = "@" Then
                    s = s & vbTab
                ElseIf Mid(ss, i, 1) = "$" Then
                    Qty = ""
                    s = s & vbTab
                Else
                    Qty = Qty & Mid(ss, i, 1)
                    s = s & Mid(ss, i, 1)
                End If
                i = i + 1
            Wend
            i = i + 1
            Temp = frmDist.GCode & vbTab & RsTemp("品名") & vbTab & _
                    RsTemp("单位") & vbTab & s
            grdDET.AddItem Temp
        Wend
    End If


    Unload frmDist

End Sub

'查询
Private Sub cmdToolQuery_Click()
    Dim strTemp As String
    TableState = "查询"
    grdDET.AllowUpdate = True
    grdDET.SelectByCell = False
    If cmdToolQuery.Caption = "查询[&Q]" Then
        cmdToolQuery.Caption = "开始[&Q]"
        QueryFlag = True
        Call ShowStatus(1)
        
        cmdToolAdd.Enabled = False
        cmdToolSave.Enabled = False
        cmdToolPrevious.Enabled = False
        cmdToolNext.Enabled = False
        cmdToolDelete.Enabled = False
        cmdToolCommit.Enabled = False
        
        Call SetValidate(False)
        Call ClearTable
        txtPurcode.SetFocus
    ElseIf cmdToolQuery.Caption = "开始[&Q]" Then
        cmdToolQuery.Caption = "查询[&Q]"
        QueryFlag = False