📄 regmsg.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form RegMsg
BorderStyle = 3 'Fixed Dialog
ClientHeight = 5430
ClientLeft = 45
ClientTop = 45
ClientWidth = 6180
ControlBox = 0 'False
Icon = "RegMsg.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5430
ScaleWidth = 6180
ShowInTaskbar = 0 'False
StartUpPosition = 3 '窗口缺省
Begin VB.PictureBox Picture2
Height = 2895
Left = 135
ScaleHeight = 2835
ScaleWidth = 5835
TabIndex = 3
Top = 1980
Width = 5895
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 270
Left = 0
TabIndex = 5
Top = 2580
Width = 5835
_ExtentX = 10292
_ExtentY = 476
_Version = 393216
Appearance = 1
Max = 30
End
Begin VB.Line Line8
BorderColor = &H00808080&
X1 = 405
X2 = 5550
Y1 = 2535
Y2 = 2535
End
Begin VB.Line Line7
BorderColor = &H00E0E0E0&
X1 = 405
X2 = 5550
Y1 = 2550
Y2 = 2550
End
Begin VB.Line Line6
BorderColor = &H00E0E0E0&
X1 = 5565
X2 = 5565
Y1 = 1455
Y2 = 2580
End
Begin VB.Line Line5
BorderColor = &H00808080&
X1 = 5550
X2 = 5550
Y1 = 1455
Y2 = 2565
End
Begin VB.Line Line4
BorderColor = &H00E0E0E0&
X1 = 405
X2 = 405
Y1 = 1470
Y2 = 2565
End
Begin VB.Line Line3
BorderColor = &H00808080&
X1 = 390
X2 = 390
Y1 = 1455
Y2 = 2550
End
Begin VB.Line Line2
BorderColor = &H00E0E0E0&
X1 = 390
X2 = 5550
Y1 = 1470
Y2 = 1470
End
Begin VB.Line Line1
BorderColor = &H00808080&
X1 = 405
X2 = 5565
Y1 = 1455
Y2 = 1455
End
Begin VB.Label Label8
ForeColor = &H000000FF&
Height = 195
Left = 3060
TabIndex = 12
Top = 2235
Width = 2655
End
Begin VB.Label Label7
Caption = "今天的日期:"
Height = 195
Left = 1365
TabIndex = 11
Top = 2235
Width = 1125
End
Begin VB.Label Label6
ForeColor = &H000000FF&
Height = 195
Left = 3075
TabIndex = 10
Top = 1935
Width = 2640
End
Begin VB.Label Label5
Caption = "程序期满日期:"
Height = 195
Left = 1365
TabIndex = 9
Top = 1890
Width = 1185
End
Begin VB.Label Label4
ForeColor = &H000000FF&
Height = 180
Left = 3075
TabIndex = 8
Top = 1545
Width = 2280
End
Begin VB.Label Label3
Caption = "程序启动日期:"
Height = 270
Left = 1350
TabIndex = 7
Top = 1545
Width = 1215
End
Begin VB.Label Label2
Caption = $"RegMsg.frx":000C
Height = 810
Left = 360
TabIndex = 6
Top = 105
Width = 5160
End
Begin VB.Label Label1
Height = 750
Left = 360
TabIndex = 4
Top = 945
Width = 5070
End
End
Begin VB.PictureBox Picture1
Height = 1815
Left = 150
Picture = "RegMsg.frx":00EC
ScaleHeight = 1755
ScaleWidth = 5835
TabIndex = 2
Top = 15
Width = 5895
End
Begin VB.Timer Timer1
Interval = 1
Left = -90
Top = 2520
End
Begin VB.CommandButton Command2
Caption = "申请注册(&E)"
Height = 405
Left = 3435
TabIndex = 1
Top = 4935
Width = 1215
End
Begin VB.CommandButton Command1
Caption = "以后再说(&N)"
Height = 405
Left = 1305
TabIndex = 0
Top = 4965
Width = 1215
End
End
Attribute VB_Name = "RegMsg"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Command2_Click()
SysRegedit.Show
End Sub
Private Sub Form_Load()
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
Me.Caption = "欢迎使用" & App.ProductName & App.Major & "." & App.Minor
If Dir(GetWinSysTmpPath(1) & "\windate.dll", vbSystem + vbReadOnly) = "windate.dll" Then
Name GetWinSysTmpPath(1) & "\windate.dll" As GetWinSysTmpPath(1) & "\windate.mdb"
SetAttr GetWinSysTmpPath(1) & "\windate.mdb", vbArchive
End If
Call mail
End Sub
'如果用户无意改动系统日前，难道也取消使用??????
Public Sub mail()
Static pargess As Integer
On Error GoTo error
If Dir(GetWinSysTmpPath(1) & "\windate.mdb") = "" Then
Dim ws As Workspace
Dim db As Database
Dim td As TableDef
Dim fld As Field
Dim idx As Index
Dim rd As Recordset
Set ws = DBEngine.Workspaces(0)
Set db = ws.CreateDatabase(GetWinSysTmpPath(1) & "\windate.mdb", dbLangGeneral)
db.Connect = ";pwd=andy"
Set td = db.CreateTableDef("windate")
td.Attributes = 0
td.Connect = ""
td.SourceTableName = ""
td.ValidationRule = ""
td.ValidationText = ""
' field first_time
Set fld = td.CreateField("first_time", 8, 8)
fld.Attributes = 1
fld.DefaultValue = 0
fld.OrdinalPosition = 0
fld.Required = False
fld.ValidationRule = ""
fld.ValidationText = ""
td.Fields.Append fld
'field last_time
Set fld = td.CreateField("last_time", 8, 8)
fld.Attributes = 1
fld.DefaultValue = ""
fld.OrdinalPosition = 1
fld.Required = False
fld.ValidationRule = ""
fld.ValidationText = ""
td.Fields.Append fld
'filed times
Set fld = td.CreateField("times", 3, 2)
fld.Attributes = 1
fld.DefaultValue = ""
fld.OrdinalPosition = 2
fld.Required = False
fld.ValidationRule = ""
fld.ValidationText = ""
td.Fields.Append fld
db.TableDefs.Append td
db.Close
Set db = ws.OpenDatabase(GetWinSysTmpPath(1) & "\windate.mdb")
Set rd = db.OpenRecordset("windate")
With rd
.AddNew
.Fields("first_time") = Date
.Fields("last_time") = Date
.Fields("times") = 1
.Update
End With
rd.MoveFirst
Label4.Caption = Format(rd.Fields("first_time"), "YYYY-MM-DD")
Label6.Caption = Mid(Format(rd.Fields("first_time"), "YYYY-MM-DD"), 1, 4) & "-" & Format(Val(Mid(Format(rd.Fields("first_time"), "YYYY-MM-DD"), 6, 2)) + 1, "0#") & "-" & Format(Val(Mid(Format(rd.Fields("first_time"), "YYYY-MM-DD"), 9, 2)))
Label8.Caption = Format(Date, "YYYY-MM-DD")
Label1.Caption = "这是你第一次启动本系统！你的试用期为30天，今天是第一天，谢谢使用！"
rd.Close
db.Close
'效果如图
ProgressBar1.Value = (pargess + 1) Mod 30
'picturegame.Show '启动你的主窗体
Else '系统有windate.mdb文件，则不是第一次运行，就不用建立数据库文件了
Dim ws2 As Workspace
Dim db2 As Database
Dim rd2 As Recordset
Dim pwd
Dim num%
Set ws2 = Workspaces(0)
Set db2 = ws2.OpenDatabase(GetWinSysTmpPath(1) & "\windate.mdb", pwd = "springlover")
Set rd2 = db2.OpenRecordset("windate")
'开始检测用户是否修改了系统日期
rd2.MoveFirst
If rd2.Fields("last_time") > Date Then
MsgBox "对不起，你在本软件的试用期内不可以修改系统日期，否则将取消你对系统的试用权。如果你想继续使用本软件，请你恢复系统日期，谢谢合作！", 48
db2.Close
Name GetWinSysTmpPath(1) & "\windate.mdb" As GetWinSysTmpPath(1) & "\windate.dll"
SetAttr GetWinSysTmpPath(1) & "\windate.dll", vbSystem + vbReadOnly
End
End If
'开始检测是否超期
If Date - rd2.Fields("first_time") >= 30 Then
'设定试用期为30天
ProgressBar1.Value = (pargess + 1) Mod 30
Label1.Caption = "你已经启动本系统" & rd2.Fields("times") & "次了，而且已经到了30天的试用期，如果你想继续使用本软件，请你到本公司注册并购买正版的软件！"
db2.Close
Name GetWinSysTmpPath(1) & "\windate.mdb" As GetWinSysTmpPath(1) & "\windate.dll"
SetAttr GetWinSysTmpPath(1) & "\windate.dll", vbSystem + vbReadOnly
End
Else
'仍在试用期内
num% = rd2.Fields("times")
rd2.Edit
rd2.Fields("last_time") = Date
rd2.Fields("times") = num + 1
rd2.Update
ProgressBar1.Value = Date - rd2.Fields("first_time")
Label4.Caption = Format(rd2.Fields("first_time"), "YYYY-MM-DD")
Label6.Caption = Mid(Format(rd2.Fields("first_time"), "YYYY-MM-DD"), 1, 4) & "-" & Format(Val(Mid(Format(rd2.Fields("first_time"), "YYYY-MM-DD"), 6, 2)) + 1, "0#") & "-" & Format(Val(Mid(Format(rd2.Fields("first_time"), "YYYY-MM-DD"), 9, 2)))
Label8.Caption = Format(Date, "YYYY-MM-DD")
Label1.Caption = " 这是你第" & rd2.Fields("times") & "次使用本系统，你还有" & 30 - (Date - rd2.Fields("first_time")) & "天的试用期，祝你今天工作愉快！"
End If
End If
Exit Sub
error:
MsgBox "系统错误！"
Name GetWinSysTmpPath(1) & "\windate.mdb" As GetWinSysTmpPath(1) & "\windate.dll"
SetAttr GetWinSysTmpPath(1) & "\windate.dll", vbSystem + vbReadOnly
End
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -