📄 act_上传界面.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Act_UploadFrm
Caption = "上传"
ClientHeight = 4410
ClientLeft = 60
ClientTop = 345
ClientWidth = 6165
Icon = "act_上传界面.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
ScaleHeight = 4410
ScaleWidth = 6165
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Fra_FileCompare
Caption = "比较文件"
Height = 3645
Left = 60
TabIndex = 8
Top = 150
Width = 5925
Begin VB.TextBox Txt_FilePropOld
BackColor = &H80000004&
Height = 795
Left = 90
Locked = -1 'True
TabIndex = 10
Top = 2760
Width = 2745
End
Begin VB.TextBox Txt_FileProp
Height = 795
Left = 2880
TabIndex = 9
Top = 2760
Width = 2955
End
Begin VB.Label Label6
AutoSize = -1 'True
Caption = "摘要:"
Height = 180
Left = 2970
TabIndex = 16
Top = 360
Width = 450
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "摘要:"
Height = 180
Left = 150
TabIndex = 15
Top = 360
Width = 450
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "备注:"
Height = 180
Left = 2970
TabIndex = 14
Top = 2460
Width = 450
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "备注:"
Height = 180
Left = 180
TabIndex = 13
Top = 2460
Width = 450
End
Begin VB.Label Lbl_FilePropOld
BorderStyle = 1 'Fixed Single
Height = 3345
Left = 90
TabIndex = 12
Top = 210
Width = 2745
End
Begin VB.Label Lbl_FileProp
BorderStyle = 1 'Fixed Single
Height = 3345
Left = 2880
TabIndex = 11
Top = 210
Width = 2955
End
End
Begin VB.Frame Fra_SelectFile
Caption = "指定文件"
Height = 3645
Left = 60
TabIndex = 2
Top = 150
Width = 5925
Begin VB.CommandButton Cmd_Locate
Caption = "浏览(&B)"
Height = 345
Left = 4560
TabIndex = 6
Top = 2130
Width = 825
End
Begin VB.TextBox Txt_FileName
Height = 315
Left = 390
TabIndex = 5
Top = 2130
Width = 4155
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "指定要更新的文件："
Height = 180
Left = 390
TabIndex = 4
Top = 1770
Width = 1620
End
Begin VB.Label Label1
BorderStyle = 1 'Fixed Single
Caption = "在下面的文本框里输入或是通过浏览按钮指定要更新的文件，从而决定是否上传"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 645
Left = 450
TabIndex = 3
Top = 630
Width = 4425
End
End
Begin VB.CommandButton Cmd_prev
Caption = "上一步(&<)"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 540
TabIndex = 7
Top = 3840
Width = 1120
End
Begin VB.CommandButton Cmd_Cancel
Caption = "取消(&C)"
Height = 300
Left = 3840
TabIndex = 1
Top = 3810
Width = 1120
End
Begin VB.CommandButton Cmd_Next
Caption = "下一步(&>)"
Default = -1 'True
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 2250
TabIndex = 0
Top = 3840
Width = 1120
End
Begin MSComDlg.CommonDialog CDlg_OpenFile
Left = 240
Top = 420
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
End
Attribute VB_Name = "Act_UploadFrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim NewAdd As Boolean
'表示选中的文件是不是新增的
Private Sub Cmd_Cancel_Click()
Unload Me
End Sub
Private Sub Cmd_Locate_Click()
CDlg_OpenFile.ShowOpen
Txt_FileName.Text = CDlg_OpenFile.Filename
End Sub
Private Sub Cmd_Next_Click()
Dim afit As FileInfoType
If Trim(Txt_FileName.Text) = "" Then
Call Xtxxts("请指定上传文件!", 0, 3)
Exit Sub
End If
If Dir(Txt_FileName.Text) = "" Then
Call Xtxxts("上传文件路径无效!", 0, 3)
Exit Sub
End If
If Me.Fra_SelectFile.Visible = True Then
Me.Fra_SelectFile.Visible = False
Me.Fra_FileCompare.Visible = True
Me.Cmd_prev.Enabled = True
sub_ShowFace
Else
afit = fun_getAttrib(Txt_FileName.Text)
'填写完成阶段的代码
If fun_Upload(Trim(Txt_FileName.Text), afit, Trim(Txt_FileProp.Text)) = False Then
Call Xtxxts("上传文件失败！", 0, 1)
Else
Call Xtxxts("上传文件成功！", 0, 4)
Call Act_UpdateFrm.Sub_FillGrid
Unload Me
End If
End If
End Sub
Private Sub sub_ShowFace()
'填写比较结果
Dim tFIT1 As FileInfoType
Dim tFIT2 As FileInfoType
Dim sStr As String
NewAdd = False
tFIT1 = fun_getAttrib(Txt_FileName.Text)
With tFIT1
If .Available Then
Lbl_FileProp.Caption = Chr(13) & Chr(13) & Chr(13) & "文件名: " & .Filename & Chr(13) _
& "版本号: " & .Version & Chr(13) _
& "编译时间: " & .CreateTime & Chr(13) _
& "文件大小: " & Format(.FileSize, "###,###,###") & "字节"
Else
Lbl_FileProp.Caption = ""
Txt_FileProp.Text = ""
End If
End With
'原有文件信息
tFIT2 = fun_getSimple(Txt_FileName.Text, sStr)
With tFIT2
If .Available Then
Lbl_FilePropOld.Caption = Chr(13) & Chr(13) & Chr(13) & "文件名: " & .Filename & Chr(13) _
& "版本号: " & .Version & Chr(13) _
& "编译时间: " & .CreateTime & Chr(13) _
& "文件大小: " & Format(.FileSize, "###,###,###") & "字节"
Txt_FilePropOld.Text = sStr
Else
Lbl_FilePropOld.Caption = ""
Txt_FilePropOld.Text = ""
End If
End With
End Sub
Private Function fun_getSimple(ByVal sFullFileName As String, ByRef sRemark As String) As FileInfoType
'从数据库里获取文件信息
Dim sSql As String
Dim rs As New ADODB.Recordset
Dim tFIT As FileInfoType
Dim fs, f
If Dir(sFullFileName) = "" Then Exit Function
'获取文件创建日期
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(sFullFileName)
sFullFileName = fs.GetFileName(sFullFileName)
sSql = "SELECT iNo, ModelName, Version, CreateTime " & Chr(13) _
& " , FileSize, UpdateTimes, Remark " & Chr(13) _
& "FROM EboSys..sys_Update " & Chr(13) _
& "WHERE modelName = '" & Trim(sFullFileName) & "'AND ProjectName='" & CurrentDBName & "'"
Set rs = Cw_DataEnvi.DataConnect.Execute(sSql)
If Not rs.EOF Then
tFIT.Available = True
tFIT.CreateTime = Format(Trim(rs.Fields("CreateTime") & ""), "YYYY-MM-DD")
tFIT.Filename = rs.Fields("ModelName") & ""
tFIT.Version = rs.Fields("Version") & ""
tFIT.FileSize = Format(Trim(rs.Fields("FileSize") & ""), "###,###,###")
sRemark = Trim(rs.Fields("Remark") & "")
NewAdd = False
Else
NewAdd = True
End If
fun_getSimple = tFIT
End Function
Private Sub Cmd_prev_Click()
Me.Cmd_prev.Enabled = False
Me.Fra_FileCompare.Visible = False
Me.Fra_SelectFile.Visible = True
End Sub
Private Sub Form_Load()
Fra_SelectFile.Visible = True
Fra_FileCompare.Visible = False
Cmd_prev.Enabled = False
Txt_FileProp.Text = GsdateT
End Sub
Private Function fun_Upload(sFullFileName As String, tFIT As FileInfoType, sRemark As String) As Boolean
Dim sSql As String
Dim rs As New ADODB.Recordset
Dim NewId As Integer
MousePointer = 11
If NewAdd Then
sSql = "INSERT INTO EboSys.dbo.sys_Update ( ProjectName, ModelName, Version, CreateTime, FileSize, UpdateTimes, Remark)" & Chr(13) _
& "VALUES ('" & CurrentDBName & "','" & tFIT.Filename & "','" & tFIT.Version & "','" & tFIT.CreateTime & "','" & tFIT.FileSize & "','1','" & sRemark & "')"
Cw_DataEnvi.DataConnect.Execute sSql
Else
Set rs = Cw_DataEnvi.DataConnect.Execute("SELECT updatetimes+1 FROM EboSys.dbo.sys_Update WHERE modelname='" & tFIT.Filename & "'")
NewId = rs.Fields(0)
If rs.state = 1 Then rs.Close
sSql = "Update EboSys.dbo.sys_Update " & Chr(13) _
& " SET Version='" & tFIT.Version & "', CreateTime='" & tFIT.CreateTime & "', FileSize='" & tFIT.FileSize & "', UpdateTimes='" & NewId & "',Remark= '" & sRemark & "'" & Chr(13) _
& " WHERE ModelName='" & tFIT.Filename & "' AND ProjectName='" & CurrentDBName & "'"
Cw_DataEnvi.DataConnect.Execute sSql
End If
Cw_DataEnvi.DataConnect.Execute "UPDATE EboSys.dbo.sys_Update SET FileBody=null WHERE ModelName='" & tFIT.Filename & "' AND ProjectName='" & CurrentDBName & "'"
rs.Open "SELECT * FROM EboSys.dbo.sys_Update WHERE ModelName='" & tFIT.Filename & "' AND ProjectName='" & CurrentDBName & "'", Cw_DataEnvi.DataConnect, adOpenDynamic, adLockOptimistic
If Not SaveBlob2DB(rs, sFullFileName, "FileBody") Then Exit Function
MousePointer = 1
fun_Upload = True
End Function
'==============================================================================='
Public Function Gsdate() As Date '服务器系统日期函数
Dim RsGdate As ADODB.Recordset
Set RsGdate = New Recordset
RsGdate.Open "select getdate() as Gdate", Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
Gsdate = Year(RsGdate!Gdate) & "-" & Month(RsGdate!Gdate) & "-" & Day(RsGdate!Gdate)
RsGdate.Close
Set RsGdate = Nothing
End Function
Public Function GsdateT() As Date '服务器系统日期函数
Dim RsGdateT As ADODB.Recordset
Set RsGdateT = New Recordset
RsGdateT.Open "select getdate() as Gdate", Cw_DataEnvi.DataConnect, adOpenKeyset, adLockOptimistic
GsdateT = RsGdateT!Gdate
RsGdateT.Close
Set RsGdateT = Nothing
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -