frm-

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

    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    Open Trim(LUploadPath) & "\newcode.txt" For Output As #1
    While Not RsTemp.EOF
        Print #1, RsTemp("商品编码") & vbTab & RsTemp("品名")
        RsTemp.MoveNext
    Wend
    
    Close #1
    
    txtLog.Text = txtLog.Text & vbCrLf & "成功写入新编码！(文件名为：NEWCODE.TXT)"

    
    txtLog.Text = txtLog.Text & vbCrLf & "正在合并编码..."
    sSQL = "INSERT INTO 商品主档 SELECT * FROM CODETEMP WHERE 商品编码 NOT IN (SELECT 商品编码 FROM 商品主档)"
    Cmd.CommandText = sSQL
    Cmd.Execute
    
    txtLog.Text = txtLog.Text & vbCrLf & "成功合并编码！"
    
    
    Exit Sub
CodeErr:
    txtLog.Text = txtLog.Text & vbCrLf & "编码同步错误!"
    MsgBox "编码同步错误!", vbExclamation, "错误窗口"
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub


Private Function Collect() As Boolean
    On Error GoTo CollectErr
    Dim DateUpLoad As String
    Dim DateB As String, DateE As String
    Dim DCODE As String, DNAME As String, DUPLOADPATH As String, DLUPLOADPATH As String
    sSQL = "SELECT * FROM LOCALMSG"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    If RsTemp.EOF Then
        MsgBox "请先设置数据传输信息!", vbInformation, "提示窗口"
        Exit Function
    End If
    
    DCODE = RsTemp("LCODE")
    DNAME = RsTemp("LNAME")
    DUPLOADPATH = RsTemp("UPLOADPATH")
    DLUPLOADPATH = RsTemp("LUPLOADPATH")
    
    DateUpLoad = Format(Now, "YYYY-MM-DD")
    DateB = Format(dtpDateBegin.Value, "YYYY-MM-DD")
    DateE = Format(dtpDateEnd.Value, "YYYY-MM-DD")
    

    
    sSQL = "SELECT * FROM UPLOAD WHERE SELLDAY='" & Format(Now, "YYYY-MM-DD") & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    If Not RsTemp.EOF Then
        Temp = "已存在日期为" & Format(Now, "YYYY-MM-DD") & "的汇总，继续将覆盖原有数据！继续吗?"
        If (MsgBox(Temp, vbQuestion + vbYesNo, "提示窗口") = vbNo) Then
           Exit Function
        End If
    End If
    
    Conn.BeginTrans
    
'    txtLog.Text = txtLog.Text & vbCrLf & "正在汇总数据..."
    
    sSQL = "DELETE UPLOAD "  'WHERE SELLDAY='" & Format(Now, "YYYY-MM-DD") & "'"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    
    
    sSQL = "INSERT INTO UPLOAD(GCODE,GNAME) SELECT 商品编码,品名 FROM 商品主档 GROUP BY 商品编码,品名"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    sSQL = "UPDATE UPLOAD SET SELLDAY='" & Format(Now, "YYYY-MM-DD") & "'" & _
           ",DCODE='" & DCODE & "',DNAME='" & DNAME & "'"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    
'    txtLog.Text = txtLog.Text & vbCrLf & "正在汇总库存数据..."
    
    sSQL = "SELECT 商品编码,SUM(进货数量) AS 数量,SUM(进价金额) AS 金额 FROM 进货单 " & _
           " WHERE 制表日期 BETWEEN '" & Format(dtpDateBegin.Value, "YYYY-MM-DD") & _
           "' AND '" & Format(dtpDateEnd.Value, "YYYY-MM-DD") & "' GROUP BY 商品编码"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        sSQL = "UPDATE UPLOAD SET STOCKQUANTITY=" & RsTemp("数量") & ",STOCKSUM=" & RsTemp("金额") & _
                " WHERE GCODE='" & Trim(RsTemp("商品编码")) & "'"
        Cmd.ActiveConnection = Conn
        Cmd.CommandText = sSQL
        Cmd.Execute
        RsTemp.MoveNext
    Wend
    
'    txtLog.Text = txtLog.Text & vbCrLf & "正在汇总销售数据..."
    
sSQL = "SELECT 商品编码,SUM(数量) AS 数量,SUM(售价差额) AS 金额 FROM 批发单 " & _
           " WHERE 制表日期 BETWEEN '" & Format(dtpDateBegin.Value, "YYYY-MM-DD") & _
           "' AND '" & Format(dtpDateEnd.Value, "YYYY-MM-DD") & "' GROUP BY 商品编码 "
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        sSQL = "UPDATE UPLOAD SET SELLQUANTITY=" & RsTemp("数量") & ",SELLSUM=" & RsTemp("金额") & _
                " WHERE GCODE='" & Trim(RsTemp("商品编码")) & "'"
        Cmd.ActiveConnection = Conn
        Cmd.CommandText = sSQL
        
        Cmd.Execute
        RsTemp.MoveNext
    Wend
    
    sSQL = "SELECT 商品编码,SUM(数量) AS 数量,SUM(零售金额) AS 金额 FROM 分店销售 " & _
           " WHERE 销售日期 BETWEEN '" & Format(dtpDateBegin.Value, "YYYY-MM-DD") & _
           "' AND '" & Format(dtpDateEnd.Value, "YYYY-MM-DD") & "' GROUP BY 商品编码 "
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        sSQL = "UPDATE UPLOAD SET SELLQUANTITY=SELLQUANTITY+" & RsTemp("数量") & ",SELLSUM=SELLSUM+" & RsTemp("金额") & _
                " WHERE GCODE='" & Trim(RsTemp("商品编码")) & "'"
        Cmd.ActiveConnection = Conn
        Cmd.CommandText = sSQL
        
        Cmd.Execute
        RsTemp.MoveNext
    Wend
    
    
'    txtLog.Text = txtLog.Text & vbCrLf & "正在汇总进货数据..."
    
    sSQL = "SELECT 商品编码,SUM(数量) AS 数量,SUM(进价金额) AS 金额 FROM 总库存 GROUP BY 商品编码"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        sSQL = "UPDATE UPLOAD SET STOREQUANTITY=" & RsTemp("数量") & ",STORESUM=" & RsTemp("金额") & _
                " WHERE GCODE='" & Trim(RsTemp("商品编码")) & "'"
        Cmd.ActiveConnection = Conn
        Cmd.CommandText = sSQL
        Cmd.Execute
        RsTemp.MoveNext
    Wend
    
'    txtLog.Text = txtLog.Text & vbCrLf & "正在整理数据..."
    
    sSQL = "DELETE UPLOAD WHERE STOCKQUANTITY=0 AND STOREQUANTITY=0 AND SELLQUANTITY=0"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    
'    txtLog.Text = txtLog.Text & vbCrLf & "成功汇总上传数据!"
    
    Conn.CommitTrans
    Collect = True
    Exit Function
CollectErr:
    Conn.RollbackTrans
    Collect = False
    
    MsgBox "汇总上传数据失败!", vbExclamation, "错误窗口"
End Function

Private Function WriteToFile() As Boolean
    On Error GoTo WriteErr
    Dim Temp, tt, I
    Dim FName As String
    
    FName = Trim(LUploadPath) & "\" & Trim(LCode) & Format(Now, "YYMMDD") & ".sxd"
    
'    txtLog.Text = txtLog.Text & vbCrLf & "正在写入文件..."
    
    sSQL = "SELECT * FROM UPLOAD"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    If RsTemp.EOF Then
        WriteToFile = False
        MsgBox "汇总数据为空!", vbExclamation, "错误窗口"
        Exit Function
    End If
    
    Open FName For Output As #1
    Print #1, LCode
    Print #1, Format(Now, "YYYY-MM-DD")
    While Not RsTemp.EOF
        Temp = "'"
        For I = 0 To RsTemp.Fields.Count - 1
            tt = RsTemp(I)
            If tt = "" Or tt = Null Then tt = "0"
            Temp = Temp & tt & "','"
        Next I
        tt = Mid(Temp, 1, Len(Temp) - 2)
        Print #1, tt
        RsTemp.MoveNext
    Wend
    
    Close #1
    
'    txtLog.Text = txtLog.Text & vbCrLf & "成功写入文件!"
    
    WriteToFile = True
    Exit Function
WriteErr:
    WriteToFile = False
    Close
    txtLog.Text = txtLog.Text & vbCrLf & "写入文件失败!"
    MsgBox "数据写入文件失败!", vbExclamation, "错误窗口"
End Function

Private Sub cmdNewCode_Click()
    Shell "notepad " & Trim(LUploadPath) & "\newcode.txt"
End Sub

Private Sub cmdSend_Click()
    Dim FName As String
    '汇总数据
    
    txtLog.Text = txtLog.Text & vbCrLf & "正在汇总数据..."
    
    If Not Collect Then Exit Sub
    
    txtLog.Text = txtLog.Text & vbCrLf & "成功汇总上传数据!"
    
    '写入文件
    
    txtLog.Text = txtLog.Text & vbCrLf & "正在写入文件..."

    If Not WriteToFile Then Exit Sub
    
    txtLog.Text = txtLog.Text & vbCrLf & "成功写入文件!"
    
    '传输文件
    FName = Trim(LUploadPath) & "\" & Trim(LCode) & Format(Now, "yymmdd") & ".sxd"
    
    txtLog.Text = txtLog.Text & vbCrLf & "正在传输文件..."
    
    FileCopy FName, Trim(UploadPath) & "\" & Trim(LCode) & Format(Now, "yymmdd") & ".sxd"
    
    txtLog.Text = txtLog.Text & vbCrLf & "传输文件完成!"
    txtLog.Text = txtLog.Text & vbCrLf & "上传数据完成!"
    
End Sub

Private Sub cmdSet_Click()
    frmLocalMsgSet.Show 1
End Sub

Private Sub Form_Load()
    On Error Resume Next
    dtpDateBegin.Value = Now
    dtpDateEnd.Value = Now
    
    sSQL = "SELECT * FROM LOCALMSG"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    
    If Not RsTemp.EOF Then
        LCode = RsTemp("LCODE")
        LName = RsTemp("LNAME")
        UploadPath = RsTemp("UPLOADPATH")
        LUploadPath = RsTemp("LUPLOADPATH")
    Else
        
        MsgBox "请先设置本地信息!", vbExclamation, "错误窗口"
        Exit Sub
    End If
End Sub

Private Sub Label1_DblClick()
    Dim Temp
    Temp = "dsn(d):dstar_c;tablename:selldaytable" & vbCrLf & _
        "dsn(s):dstar;tablename:upload"
    MsgBox Temp

End Sub