frm-

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

    
    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 & "正在传输文件..."
    
    If Not FTPPutFile(FName, Trim(UploadPath) & "\" & Trim(LCode) & Format(Now, "yymmdd") & ".sxd") Then
        Exit Sub
    End If
'    inetFTP.Execute txtServer.Text, "PUT " & FName & "  " & Trim(UploadPath) & "\" & Trim(LCode) & Format(Now, "yymmdd") & ".sxd"
    
'    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
    
    txtServer.Text = GetSetting("LSDSTAR", "数据传输管理", "FTP服务器", "SERVER01")
    txtUid.Text = GetSetting("LSDSTAR", "数据传输管理", "FTP用户", "anonymous")
    txtPwd.Text = GetSetting("LSDSTAR", "数据传输管理", "FTP口令", "[e-mail]")
    
    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 FTP_TransferProgress(ByVal BytesTransferred As Long, ByVal TotalBytes As Long)

    If CancelFlag = True Then
        FTP.CancelTransfer = True
    End If
    
    If ProgressBar.Max = 1 Then
        ProgressBar.Max = TotalBytes
    End If
    ProgressBar.Value = BytesTransferred
    DoEvents ' to give the cancel button a chance

End Sub


Private Sub inetFTP_StateChanged(ByVal State As Integer)
'    Select Case State
'        Case icNone
'            txtLog.Text = txtLog.Text & vbCrLf & "无状态可报告。"
'        Case 1 'icHostResolvingHost:
'            txtLog.Text = txtLog.Text & vbCrLf & "正在查询所指定的主机的 IP 地址。"
'        Case icHostResolved
'            txtLog.Text = txtLog.Text & vbCrLf & "已成功地找到所指定的主机的 IP 地址。"
'        Case icConnecting
'            txtLog.Text = txtLog.Text & vbCrLf & "正在与主机连接。"
'        Case icConnected
'            txtLog.Text = txtLog.Text & vbCrLf & "已与主机连接成功。"
'        Case icRequesting
'            txtLog.Text = txtLog.Text & vbCrLf & "正在向主机发送请求。"
'        Case icRequestSent
'            txtLog.Text = txtLog.Text & vbCrLf & "发送请求已成功。"
'        Case icReceivingResponse
'            txtLog.Text = txtLog.Text & vbCrLf & "正在接收主机的响应。"
'        Case icResponseReceived
'            txtLog.Text = txtLog.Text & vbCrLf & "已成功地接收到主机的响应。"
'        Case icDisconnecting
'            txtLog.Text = txtLog.Text & vbCrLf & "正在解除与主机的连接。"
'        Case icDisconnected
'            txtLog.Text = txtLog.Text & vbCrLf & "已成功地与主机解除了连接。"
'        Case icError
'            txtLog.Text = txtLog.Text & vbCrLf & "与主机通讯时出现了错误。"
'        Case icResponseCompleted
'            txtLog.Text = txtLog.Text & vbCrLf & "该请求已经完成，并且所有数据均已接收到。"
'            ftpState = True
'    End Select

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

Private Sub SSCommand1_Click()
    
    FTP.RemoteAddress = txtServer.Text
    FTP.UserName = txtUid.Text
    FTP.Password = txtPwd.Text
    On Error Resume Next
    Screen.MousePointer = vbHourglass
    FTP.Connect
    Screen.MousePointer = vbDefault
    If Err <> 0 Then
        txtLog.Text = txtLog.Text & vbCrLf & "连接失败！"
    Else
        txtLog.Text = txtLog.Text & vbCrLf & "连接成功！"
    End If
End Sub

Private Sub SSCommand2_Click()
'    inetFTP.Execute "CLOSE"
    On Error GoTo DisErr
    FTP.Disconnect
    txtLog.Text = txtLog.Text & vbCrLf & "成功与远程主机断开连接！"
    Exit Sub
    
DisErr:
    txtLog.Text = txtLog.Text & vbCrLf & "与远程主机断开连接失败！"
End Sub