frm数据接收.frm

服装销售系统,VB开发.没有解压密码

        sSQL = " WHERE 分店编码='" & Trim(ChainCode) & "'"
        Line Input #1, SendDate
        sSQL = sSQL & " AND 传输日期='" & Trim(SendDate) & "'"
    End If
    
    While Not EOF(1)
        Line Input #1, Temp
        'sSQL = "INSERT INTO 分店销售信息(分店编码,传输日期,销售单号,销售时间,操作员,商品编码,单位,商品名称,数量,优惠,售价,金额,尺寸,颜色,结账类型) VALUES('" & ChainCode & "','" & SendDate & "'," & Temp & ")"
        sSQL = "INSERT INTO 分店销售信息(分店编码,传输日期,销售单号,销售时间,操作员,商品编码,单位,商品名称,数量,优惠,售价,金额,尺寸,颜色) VALUES('" & ChainCode & "','" & SendDate & "'," & Temp & ")"
        Cmd.CommandText = sSQL
        Cmd.Execute
    Wend
    FileToDatabase = True
    Close #1
    'Kill fn
    Name fn As fn & ".bak"
    Exit Function
FDErr:
    FileToDatabase = False
    Close
    txtLog.Text = txtLog.Text & vbCrLf & "接收错误！"
End Function


Private Function FileToDatabaseDD(fn As String) As Boolean
    On Error GoTo FDErr
    Dim Temp, ChainCode, SendDate
    Open fn For Input As #1
    Cmd.ActiveConnection = Conn
    If Not EOF(1) Then
        Line Input #1, ChainCode
        sSQL = " WHERE 分店编码='" & Trim(ChainCode) & "'"
        Line Input #1, SendDate
        sSQL = sSQL & " AND 传输日期='" & Trim(SendDate) & "'"
    End If
    
    While Not EOF(1)
        Line Input #1, Temp
        sSQL = "INSERT INTO 分店订单信息(分店编码,传输日期,销售单号,销售时间,操作员,商品编码,单位,商品名称,数量,优惠,售价,金额,尺寸,颜色) VALUES('" & ChainCode & "','" & SendDate & "'," & Temp & ")"
        Cmd.CommandText = sSQL
        Cmd.Execute
    Wend
    FileToDatabaseDD = True
    Close #1
    'Kill fn
    Name fn As fn & ".bak"
    Exit Function
FDErr:
    FileToDatabaseDD = False
    Close
    txtLog.Text = txtLog.Text & vbCrLf & "接收错误！"
End Function


Private Sub cmdCode_Click()
    On Error Resume Next
    Dim I As Integer, tt
    Open Trim(txtPath.Text) & "\CODE.TXT" For Output As #1
    sSQL = "SELECT 商品编码,商品条码,品名,单位,厂商编码,进价,税率,批发价1,批发价2,零售价,含税进价,废弃标志 FROM 商品主档"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        Temp = "'"
        For I = 0 To RsTemp.Fields.Count - 1
            tt = Trim(RsTemp(I))
            If tt = "" Or tt = Null Then tt = "0"
            If UCase(tt) = "FALSE" Then
                tt = "0"
            ElseIf UCase(tt) = "TRUE" Then
                tt = "1"
            End If
            Temp = Temp & tt & "','"
        Next I
        Temp = Mid(Temp, 1, Len(Temp) - 2)
        Print #1, Temp
        RsTemp.MoveNext
    Wend
    Close #1
    txtLog.Text = txtLog.Text & vbCrLf & "成功生成编码文件！"
'    MsgBox "成功生成编码文件！", vbInformation, "提示窗口"

    Open Trim(txtPath.Text) & "\CODEinfo.TXT" For Output As #1
    sSQL = "SELECT 商品编码,商品名称,单位,颜色,尺寸 FROM 商品信息"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        Temp = "'"
        For I = 0 To RsTemp.Fields.Count - 1
            tt = Trim(RsTemp(I))
            If tt = "" Or tt = Null Then tt = "0"
            If UCase(tt) = "FALSE" Then
                tt = "0"
            ElseIf UCase(tt) = "TRUE" Then
                tt = "1"
            End If
            Temp = Temp & tt & "','"
        Next I
        Temp = Mid(Temp, 1, Len(Temp) - 2)
        Print #1, Temp
        RsTemp.MoveNext
    Wend
    Close #1
    txtLog.Text = txtLog.Text & vbCrLf & "成功生成编码信息文件！"

End Sub

Private Sub cmdExit_Click()
    SaveSetting "数据传输服务", "数据接收", "数据接收路径", txtPath.Text
    Unload Me
End Sub

Private Sub cmdReceive_Click()
    On Error Resume Next
    Dim FName() As String, FCount As Integer
    Dim Temp, I
    FCount = 0
    ReDim FName(0)
    
    Temp = Dir(txtPath & "\*.sxd")
    While Temp <> ""
        FName(FCount) = Temp
        FCount = FCount + 1
        ReDim Preserve FName(FCount)
        Temp = Dir
    Wend
    If FCount = 0 Then
        txtLog.Text = txtLog.Text & vbCrLf & "未发现上传数据(*.sxd)!"
    Else
        
        txtLog.Text = txtLog.Text & vbCrLf & "正在接收文件(共" & FCount & "个)..."
        
        For I = 0 To FCount - 1
            txtLog.Text = txtLog.Text & vbCrLf & "正在第" & I + 1 & "个文件..."
            If FileToDatabase(Trim(txtPath) & "\" & FName(I)) Then
                txtLog.Text = txtLog.Text & vbCrLf & "文件" & FName(I) & "接收成功！"
            Else
                txtLog.Text = txtLog.Text & vbCrLf & "文件" & FName(I) & "接收失败！"
            End If
        Next I
    End If
    '///////////////////////////////////////////////////////
    
    FCount = 0
    ReDim FName(0)
    
    Temp = Dir(txtPath & "\*.ddd")
    While Temp <> ""
        FName(FCount) = Temp
        FCount = FCount + 1
        ReDim Preserve FName(FCount)
        Temp = Dir
    Wend
    If FCount = 0 Then
        txtLog.Text = txtLog.Text & vbCrLf & "未发现上传数据(*.ddd)!"
    Else
    
        txtLog.Text = txtLog.Text & vbCrLf & "正在接收文件(共" & FCount & "个)..."
        
        For I = 0 To FCount - 1
            txtLog.Text = txtLog.Text & vbCrLf & "正在第" & I + 1 & "个文件..."
            If FileToDatabaseDD(Trim(txtPath) & "\" & FName(I)) Then
                txtLog.Text = txtLog.Text & vbCrLf & "文件" & FName(I) & "接收成功！"
            Else
                txtLog.Text = txtLog.Text & vbCrLf & "文件" & FName(I) & "接收失败！"
            End If
        Next I
    End If

End Sub

Private Sub cmdSaveLog_Click()
    Open Trim(txtPath.Text) & "\log" & Format(Now, "yymmdd") & ".log" For Output As #1
    Print #1, txtLog.Text
    Close #1

End Sub

Private Sub cmdSet_Click()
    frmSet.Show 1
End Sub

Private Sub Form_Load()
    On Error GoTo ConnErr
    txtPath.Text = GetSetting("数据传输服务", "数据接收", "数据接收路径", "C:\DSTAR")
    If GetSetting("LSDSTAR", "数据接收", "是否自动", "0") = "0" Then
        Timer1.Enabled = False
    Else
        Timer1.Enabled = True
    End If
    Exit Sub
ConnErr:
    txtLog.Text = txtLog.Text & vbCrLf & "连接发生错误！"
End Sub


Private Sub SSCommand1_Click()
    On Error Resume Next
    Dim I As Integer, tt
    Open Trim(txtPath.Text) & "\NEWCODE.TXT" For Append As #1
    sSQL = "SELECT 商品编码,商品条码,品名,单位,厂商编码,进价,税率,批发价1,批发价2,零售价,含税进价,废弃标志 FROM 商品主档 where 更新标志=0"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        Temp = "'"
        For I = 0 To RsTemp.Fields.Count - 1
            tt = Trim(RsTemp(I))
            If tt = "" Or tt = Null Then tt = "0"
            If UCase(tt) = "FALSE" Then
                tt = "0"
            ElseIf UCase(tt) = "TRUE" Then
                tt = "1"
            End If
            Temp = Temp & tt & "','"
        Next I
        Temp = Mid(Temp, 1, Len(Temp) - 2)
        Print #1, Temp
        RsTemp.MoveNext
    Wend
    Close #1
    sSQL = "update 商品主档 set 更新标志=1 where 更新标志=0"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    txtLog.Text = txtLog.Text & vbCrLf & "成功生成编码文件！"
'    MsgBox "成功生成编码文件！", vbInformation, "提示窗口"

    Open Trim(txtPath.Text) & "\NEWCODEinfo.TXT" For Append As #1
    sSQL = "SELECT 商品编码,商品名称,单位,颜色,尺寸 FROM 商品信息 where 更新标志=0"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        Temp = "'"
        For I = 0 To RsTemp.Fields.Count - 1
            tt = Trim(RsTemp(I))
            If tt = "" Or tt = Null Then tt = "0"
            If UCase(tt) = "FALSE" Then
                tt = "0"
            ElseIf UCase(tt) = "TRUE" Then
                tt = "1"
            End If
            Temp = Temp & tt & "','"
        Next I
        Temp = Mid(Temp, 1, Len(Temp) - 2)
        Print #1, Temp
        RsTemp.MoveNext
    Wend
    Close #1
    sSQL = "update 商品信息 set 更新标志=1 where 更新标志=0"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    txtLog.Text = txtLog.Text & vbCrLf & "成功生成编码信息文件！"
End Sub

Private Sub Timer1_Timer()
    Dim t As Date, tt
    t = Format(Now, "HH:MM")
    tt = GetSetting("LSDSTAR", "数据接收", "工作时间", "12:00")
    tt = CDate(tt)
    If t = tt Then
        t = GetSetting("LSDSTAR", "数据接收", "接收自动", "0")
        If t <> "0" Then Call cmdReceive_Click
        t = GetSetting("LSDSTAR", "数据接收", "编码自动", "0")
        If t <> "0" Then Call cmdCode_Click
        t = GetSetting("LSDSTAR", "数据接收", "日志自动", "0")
        If t <> "0" Then Call cmdSaveLog_Click
    End If
End Sub