[VBA]VBA编写的时光倒流软件

目的：

目前有很多共享软件都有试用期，过了使用期后就不能使用了。但是把系统时间退回去又可以使用了。我们可以简单的利用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 IfEnd 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).SelectEnd Sub

———————————————————————————————————————————–

添加bas的代码：

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As LongType 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 StringEnd 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 FunctionERR_FUN: doExec = False MsgBox Err.DescriptionEnd 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 SubERR_FUN: MsgBox Err.DescriptionEnd Sub

感悟了不同的人生。凌晨，随着滑轮接触地面，