目的：
目前有很多共享软件都有试用期，过了使用期后就不能使用了。但是把系统时间退回去又可以使用了。我们可以简单的利用VBA技术把系统时间该回去执行共享软件。
原理：
1.设定打开程序的路径
2.打开前取得系统时间
3.把系统时间调整到启动程序的安装时间到过期时间中的任意一个时间
4.把系统时间设置到启动前的时间。
5.把自动关闭设置为自动的话，下次启动的时间就会自动启动默认程序。
画面：
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
閉じる： [自動 ▼]
[実行] [・・・] [C:/Windwos/notepad.exe ]
[実行] [・・・] [ ]
[実行] [・・・] [ ]
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
ThisBook的代码：
Private Sub Workbook_Open()
Dim sPath As String
Dim execDate As String
If Cells(5, 7).Value = "自動" Then
sPath = Cells(7, 16).Value
execDate = Cells(7, 11).Value
If doExec(sPath, execDate) = True Then
ThisWorkbook.Close
End If
End If
End Sub
------------------------------------------------------------------------------------------------------------------------------------
Sheet1的代码：
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sPath As String
Dim execDate As String
If Target.Cells(1, 1) = "実行" Then
sPath = Cells(Target.Row, 16).Value
execDate = Cells(Target.Row, 11).Value
Call doExec(sPath, execDate)
ElseIf Target.Cells(1, 1) = "・・・" Then
sPath = Cells(Target.Row, 16).Value
Call doGetPath(sPath)
If sPath <> "" Then
Cells(Target.Row, 16).Value = sPath
ThisWorkbook.Save
End If
End If
Cells(Target.Row, 2).Select
End Sub
-----------------------------------------------------------------------------------------------------------------------------------
添加bas的代码：
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Function doExec(ByVal sPath As String, ByVal execDate As String) As Boolean
Dim dCurrDate As Date
On Error GoTo ERR_FUN
dCurrDate = Date
If Trim(execDate) = "" Then
MsgBox "実行日付を設定してください。"
doExec = False
Exit Function
ElseIf Trim(sPath) = "" Then
MsgBox "実行プログラムのパスを設定してください。"
doExec = False
Exit Function
End If
Date = execDate
Call Shell(sPath, vbMaximizedFocus)
Date = dCurrDate
doExec = True
Exit Function
ERR_FUN:
doExec = False
MsgBox Err.Description
End Function
Sub doGetPath(ByRef sPath As String)
Dim ofn As OPENFILENAME
Dim rtn As String
On Error GoTo ERR_FUN
ofn.lStructSize = Len(ofn)
'ofn.hwndOwner = Me.
'ofn.hInstance = Me.Application.hInstance
ofn.lpstrFilter = "*.exe"
ofn.lpstrFile = Space(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = sPath
ofn.lpstrTitle = "打開文件"
ofn.flags = 6148
rtn = GetOpenFileName(ofn)
If rtn >= 1 Then
sPath = ofn.lpstrFile
Else
sPath = ""
End If
Exit Sub
ERR_FUN:
MsgBox Err.Description
End Sub