Thanks ryguy7272 and Pecoflyer
After Click on Link which is give by both of you I got This
I am totally Stupid in VBA or Marco
How can i use this.
Option Explicit
Private Const C_NUM_DAYS_UNTIL_EXPIRATION = 30
Sub TimeBombWithDefinedName()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TimeBombWithDefinedName
' This procedure uses a defined name to store this workbook's
' expiration date. If the expiration date has passed, a
' MsgBox is displayed and this workbook is closed.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ExpirationDate As String
Dim NameExists As Boolean
On Error Resume Next
ExpirationDate = Mid(ThisWorkbook.Names("ExpirationDate").Value, 2)
If Err.Number <> 0 Then
'''''''''''''''''''''''''''''''''''''''''''
' Name doesn't exist. Create it.
'''''''''''''''''''''''''''''''''''''''''''
NameExists = False
ExpirationDate = CStr(DateSerial(Year(Now), _
Month(Now), Day(Now) + C_NUM_DAYS_UNTIL_EXPIRATION))
ThisWorkbook.Names.Add Name:="ExpirationDate", _
RefersTo:=Format(ExpirationDate, "short date"), _
Visible:=False
Else
NameExists = True
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If the today is past the expiration date, close the
' workbook. If the defined name didn't exist, we need
' to Save the workbook to save the newly created name.
''''''''''''''''''''''''''''''''''''''''''''''''''''''
If CDate(Now) > CDate(ExpirationDate) Then
MsgBox "This workbook trial period has expired.", vbOKOnly
ThisWorkbook.Close savechanges:=False
End If
End Sub
Sub TimeBombMakeReadOnly()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TimeBombMakeReadOnly
' This procedure uses a defined name to store the expiration
' date and if the workbook has expired, makes the workbook
' read-only.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ExpirationDate As String
Dim NameExists As Boolean
On Error Resume Next
ExpirationDate = Mid(ThisWorkbook.Names("ExpirationDate").Value, 2)
If Err.Number <> 0 Then
'''''''''''''''''''''''''''''''''''''''''''
' Name doesn't exist. Create it.
'''''''''''''''''''''''''''''''''''''''''''
ExpirationDate = CStr(DateSerial(Year(Now), _
Month(Now), Day(Now) + C_NUM_DAYS_UNTIL_EXPIRATION))
ThisWorkbook.Names.Add Name:="ExpirationDate", _
RefersTo:=Format(ExpirationDate, "short date"), _
Visible:=False
NameExists = False
Else
NameExists = True
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If the today is past the expiration date, make the
' workbook read only. We need to Save the workbook
' to keep the newly created name intact.
''''''''''''''''''''''''''''''''''''''''''''''''''''''
If CDate(Now) >= CDate(ExpirationDate) Then
If NameExists = False Then
ThisWorkbook.Save
End If
ThisWorkbook.ChangeFileAccess xlReadOnly
End If
End Sub
Sub TimeBombWithRegistry()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TimeBombWithRegistry
' This procedure stores the expiration date in the system
' registry. Change C_REG_KEY to a registry key name that
' is used by your application.
'
' This procedure requires either the modRegistry module from
'
www.cpearson.com/Excel/Registry.htm or
'
www.cpearson.com/Excel/Registry.aspx
' or the RegistryWorx DLL from
'
www.cpearson.com/Excel/RegistryWorx.aspx.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const C_REG_KEY = "Software\Pearson\Test\Settings"
Dim KeyExists As Boolean
Dim ValueExists As Boolean
Dim ExpirationDate As Long
Dim B As Boolean
KeyExists = RegistryKeyExists(HKEY_CURRENT_USER, C_REG_KEY, False)
If KeyExists = True Then
'''''''''''''''''''''''''''''''''
' Key exists. Get the Value from
' the key.
'''''''''''''''''''''''''''''''''
ValueExists = RegistryValueExists(HKEY_CURRENT_USER, C_REG_KEY,
"Expiration")
If ValueExists = True Then
'''''''''''''''''''''''''''''''''''''''''
' Value exists. It will be the
' expiration date.
'''''''''''''''''''''''''''''''''''''''''
ExpirationDate = RegistryGetValue(HKEY_CURRENT_USER, C_REG_KEY,
"Expiration")
Else
'''''''''''''''''''''''''''''''''''''''''
' Value doesn't exist. Set the expiration
' date and update the Registry.
'''''''''''''''''''''''''''''''''''''''''
ExpirationDate = DateSerial(Year(Now), Month(Now), _
Day(Now) + C_NUM_DAYS_UNTIL_EXPIRATION)
B = RegistryCreateValue(HKEY_CURRENT_USER, C_REG_KEY, "Expiration",
CLng(ExpirationDate))
If B = False Then
' error creating registry value
End If
End If
Else
''''''''''''''''''''''''''''''''''''''''
' Key doesn't exist. Set the expiration
' date and create the Key and Value.
''''''''''''''''''''''''''''''''''''''''
ExpirationDate = DateSerial(Year(Now), Month(Now), _
Day(Now) + C_NUM_DAYS_UNTIL_EXPIRATION)
B = RegistryCreateKey(HKEY_CURRENT_USER, C_REG_KEY)
If B = True Then
B = RegistryCreateValue(HKEY_CURRENT_USER, C_REG_KEY, "Expiration",
ExpirationDate)
If B = False Then
' error creating registry value
End If
Else
' error creating registry key
End If
End If
'''''''''''''''''''''''''''''''''''''''''''
' If Now is past the expiration date,
' close the workbook.
'''''''''''''''''''''''''''''''''''''''''''
If CLng(Now) > CLng(ExpirationDate) Then
ThisWorkbook.Close savechanges:=False
End If
End Sub
Actually i want to Nobody can See the file after 10 minute or after 1 hour
Thanks in Advance
Hardeep kanwar
