[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 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