📄 frm-
字号:
_Version = 131073
Font3D = 1
PictureFrames = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Picture = "frm通讯FTP.frx":1138
Caption = "设置[&S]"
Alignment = 8
ButtonStyle = 3
PictureAlignment= 11
End
Begin Threed.SSCommand cmdSend
Height = 885
Left = 15
TabIndex = 2
Top = 0
Width = 1395
_ExtentX = 2461
_ExtentY = 1561
_Version = 131073
Font3D = 1
PictureFrames = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Picture = "frm通讯FTP.frx":158A
Caption = "上传数据[&T]"
Alignment = 8
ButtonStyle = 3
PictureAlignment= 11
End
End
Begin ComctlLib.ProgressBar ProgressBar
Height = 375
Left = 1920
TabIndex = 20
Top = 3285
Width = 6255
_ExtentX = 11033
_ExtentY = 661
_Version = 327682
Appearance = 1
End
Begin VB.Label Label8
AutoSize = -1 'True
Caption = "传输进度:"
Height = 180
Left = 720
TabIndex = 21
Top = 3285
Visible = 0 'False
Width = 810
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "传输信息"
BeginProperty Font
Name = "宋体"
Size = 15.75
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 3435
TabIndex = 0
Top = 3615
Width = 1335
End
End
Attribute VB_Name = "frm通讯FTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim ConnL As New ADODB.Connection
Dim ConnR As New ADODB.Connection
Dim ftpState As Boolean
Dim CancelFlag As Boolean
Private Sub cmdConnect_Click()
On Error GoTo Err:
'启动默认拨号连接
Shell "rundll rnaui.dll,RnaDial " + GetConnect, vbNormalFocus
Exit Sub
Err:
MsgBox "建立拨号连接失败!请检查默认拨号网络."
End Sub
Private Sub About_Click()
CancelFlag = True
End Sub
Private Sub chkAnonymous_Click()
If chkAnonymous.Value = False Then
txtUid.Text = ""
txtPwd.Text = ""
Else
txtUid.Text = "anonymous"
txtPwd.Text = "user@domain.com"
End If
End Sub
Private Function FTPPutFile(sf As String, df As String) As Boolean
FTP.LocalFile = sf
FTP.RemoteFile = df
'Fancy stuff for the Pro Edition
If FTP.ProfessionalEdition = True Then
BinaryMode.Visible = False
ASCIIMode.Visible = False
' ProgressBar.Visible = True
ProgressBar.Value = 0
ProgressBar.Max = 1
CancelFlag = False
' About.Caption = "&Cancel"
DoEvents
End If
Screen.MousePointer = vbHourglass
On Error Resume Next
FTP.PutFile
Screen.MousePointer = vbDefault
If Err <> 0 Then
txtLog.Text = txtLog.Text & vbCrLf & "向远程系统传输文件失败！"
FTPPutFile = False
Else
If CancelFlag = True Then
On Error GoTo 0
Screen.MousePointer = vbHourglass
FTP.Disconnect
FTP.Connect
' FTP.RemoteDirectory = RemotePWD.Caption
CancelFlag = False
Screen.MousePointer = vbDefault
End If
Beep
FTPPutFile = True
txtLog.Text = txtLog.Text & vbCrLf & "成功向远程系统传输文件！"
' RefreshRemote
End If
If FTP.ProfessionalEdition = True Then
BinaryMode.Visible = True
ASCIIMode.Visible = True
' ProgressBar.Visible = False
About.Caption = "&About"
End If
End Function
Private Function FTPGetFile(sf As String, df As String) As Boolean
FTP.RemoteFile = Trim(sf)
FTP.LocalFile = df
Screen.MousePointer = vbHourglass
'Fancy stuff for the Pro Edition
If FTP.ProfessionalEdition = True Then
BinaryMode.Visible = False
ASCIIMode.Visible = False
' ProgressBar.Visible = True
ProgressBar.Value = 0
ProgressBar.Max = 1
CancelFlag = False
About.Caption = "&Cancel"
DoEvents
End If
On Error Resume Next
FTP.GetFile
Screen.MousePointer = vbDefault
If Err <> 0 Then
txtLog.Text = txtLog.Text & vbCrLf & "从远程下载文件失败!"
FTPGetFile = False
Else
If CancelFlag = True Then
On Error GoTo 0
Screen.MousePointer = vbHourglass
FTP.Disconnect
FTP.Connect
' FTP.RemoteDirectory = RemotePWD.Caption
CancelFlag = False
Screen.MousePointer = vbDefault
End If
Beep
FTPGetFile = True
txtLog.Text = txtLog.Text & vbCrLf & "成功从远程下载文件!"
' RefreshLocal
End If
If FTP.ProfessionalEdition = True Then
BinaryMode.Visible = True
ASCIIMode.Visible = True
' ProgressBar.Visible = False
About.Caption = "&About"
End If
End Function
Private Sub cmdCode_Click()
On Error GoTo CodeErr
Dim FName As String, Temp
txtLog.Text = txtLog.Text & vbCrLf & "正在下载编码文件..."
ftpState = False
If Not FTPGetFile(Trim(UploadPath) & "\code.txt", Trim(LUploadPath) & "\code.txt") Then
Exit Sub
End If
Open Trim(LUploadPath) & "\code.txt" For Input As #1
Cmd.ActiveConnection = Conn
sSQL = "DELETE CODETEMP"
Cmd.CommandText = sSQL
Cmd.Execute
While Not EOF(1)
Line Input #1, Temp
sSQL = "INSERT INTO CODETEMP VALUES(" & Temp & ")"
Cmd.CommandText = sSQL
Cmd.Execute
Wend
Close #1
txtLog.Text = txtLog.Text & vbCrLf & "正在写新编码..."
sSQL = "SELECT * FROM CODETEMP WHERE 商品编码 NOT IN (SELECT 商品编码 FROM 商品主档)"
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, "错误窗口"
Close
End Sub
Private Sub cmdExit_Click()
SaveSetting "LSDSTAR", "数据传输管理", "FTP服务器", txtServer.Text
SaveSetting "LSDSTAR", "数据传输管理", "FTP用户", txtUid.Text
SaveSetting "LSDSTAR", "数据传输管理", "FTP口令", txtPwd.Text
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")
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -