Bạn thử dùng code này
Sub auto_open()
On Error Resume Next
Dim myDate As Date
Dim Ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
myDate = Date
If Sheets("Userlog").Range("a1").Value <= myDate Then [COLOR=darkgreen]'A1 là ngày kết thúc[/COLOR]
MsgBox "File nay khong mo duoc vi qua han su dung." & vbNewLine _
& "Vui long goi dien thoai cho tui", vbExclamation, "Thong bao"
ThisWorkbook.Close
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_Open()
ng = Day(Date)
th = Month(Date)
nam = Year(Date)
If ng > 1 And th > 5 And nam >= 2008 Then
tb = "This program have any problems for used." + Chr(10) + Chr(13)
tb = tb + "Please close and save avoid to lose data." + Chr(10) + Chr(13)
tb = tb + "Sorry very much !"
MsgBox (tb)
ActiveWorkbook.Save
Application.Quit
End If
End Sub
Thêm 1 phương án phụ là đếm số lần mở file ----> Khi ấy code sẽ xét 2 trường hợp Date > Giới hạn hoặc Số lần mở file > giới hạn thì sẽ đóng file, thậm chí xóa file mất xác luôn (điều kiện nào đến trước thì lấy)
[COLOR=blue]Private Sub Workbook_Open()[/COLOR]
Range("[COLOR=red]Sheet1!A1[/COLOR]").Value = Range("Sheet1!A1").Value + 1 'Dung de luu so lan mo file
If Range("[COLOR=red]Sheet1!A2[/COLOR]").Value = 1 Then
'Range("[COLOR=red]Sheet1!B2[/COLOR]").Value = DateSerial(Year(Now()), Month(Now()), Day(Now())) 'Chi ghi vao ngay, thang, nam thoi!
Range("[COLOR=red]Sheet1!B2[/COLOR]").Value = Now() 'Ghi day du thoi gian mo lan dau
ElseIf Round((Now() - Range("Sheet1!B2").Value), 0) [COLOR=red]>= 30[/COLOR] Or Range("[COLOR=red]Sheet1!A1[/COLOR]").Value [COLOR=red]> 10[/COLOR] Then 'Khi du 30 ngay hoac qua 10 lan thi se het han
Call [COLOR=magenta]Hethan[/COLOR]
End If
End Sub
[COLOR=blue]Private Sub Workbook_BeforeClose(Cancel As Boolean)[/COLOR]
Me.Save
End SubSub [COLOR=magenta]hethan[/COLOR]()
MsgBox ("Chuong trinh het han!")
Application.DisplayAlerts = False
ThisWorkbook.Close
End Sub
Private Sub Workbook_Open()
Dim fs, f, s
Dim tb As String
Application.Visible = False
tep = ThisWorkbook.Name
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(tep)
s = f.DateCreated + 1 / 96
If Now() > s Then
tb = "File nay da qua han test, de co the test ban copy file nay" & Chr(13) & _
"thanh ban copy khac de test hoac goi cho so 123456789. Cam on!"
MsgBox tb, , "TEST KHONG CHE THOI GIAN"
Application.Quit
Else
tb = "File nay chi mo duoc trong thoi gian 15 phut. Qua han de co the test" & Chr(13) & _
"ban copy file nay thanh ban copy khac de test hoac goi cho so 123456789. Cam on!"
MsgBox tb, , "TEST KHONG CHE THOI GIAN"
Application.Visible = True
End If
End SubEm thử file này cũng không được anh à ---> Mở lên, nó báo lổi và thoát luôn
Anh ơi... em nghĩ giải pháp này hay hơn: Số giờ mà ta hạn chế phải tính là số giờ người ta dùng file chứ ... Ví dụ anh hạn chế trong 1 giờ, vậy khi em mở file 15 phút rồi đóng lại thì vẫn tính 15 phút thôi... Sau đó em mở file này thêm 30 phút nữa thì cộng dồn vào là 45 phút sử dụng
Bạn tham khảo code lấy các thông số về file nhé. (Trong Help của Exc có đủ cả)
Sub ShowFileAccessInfo()
Dim fs, f, s
filespec = ThisWorkbook.path & "\" & ThisWorkbook.Name
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(filespec)
s = "Ten file: " & f.Name & vbCrLf
s = s & "O dia: " & UCase(f.Drive) & vbCrLf
s = s & "Created: " & f.DateCreated & vbCrLf
s = s & "Last Accessed: " & f.DateLastAccessed & vbCrLf
s = s & "Last Modified: " & f.DateLastModified
MsgBox s, 0, "File Access Info"
End Sub
Sub thu()
MsgBox Environ("COMPUTERNAME")
MsgBox Environ("LOGONSERVER")
End Sub
Theo tôi nghĩ: file ít nhiều cũng hỗ trợ được ý tưởng của bạn. Bạn tải về xem thử nhé!
Trong trường hợp này nếu lâu ngày mình không sử dụng file, sau này mở ra thì đã quá hạn không vào file được. Như vậy, làm sao mở lại file để chỉnh sửa ngày giới hạn nhỉ, chẳng lẻ bỏ luôn file này. Có cách nào khắc phục được không các bạn.
Mở file ở dạng Dissable Macro
| Em thấy code này rất hợp với mục đích sử dụng của em nhưng em muốn sửa thành nếu ngày dùng quá ngày 1-5-2008 thì mình có thể viết code yêu cầu người dùng nhập mật khẩu vào nếu nhập sai mật khẩu thì đóng file lại còn nếu nhập đúng thì cho phép mở file để dùng được không ạ >> xin bác giúp em code chỗ đó ạ >>> mục đích em muốn giới hạn thời gian sử dụng của người khác nếu muốn dùng thì phải xin mật khẩu đăng nhập từ em mới có thể dùng tiếp ạ. |
Code vba khó bảo mật lắm bạn ơi!
Bạn có thể tham khảo đoạn mã:
Dim strPass As String
strPass = InputBox("Nhap mat khau: hoangtuan.net", "Your Password")
If strPass <> "hoangtuan.net" Then
MsgBox "Mat khau khong chinh xac. File se duoc dong.", vbCritical
ThisWorkbook.Close False
End Ifvâng em cũng chỉ cần bảo mật vừa vừa thôi ko cần bảo mật đến mức cao thủ cũng ko mở được
em dùng code riêng của bác ra 1 file thì rất ok nhưng ý của em ở trên là em muốn thêm vào phần code của bác sealand ở trên sau cái đoạn "If ng > 1 And th > 5 And nam >= 2008 Then". tức là sửa code chỗ đó nếu ngày mở sau ngày 1-5-2008 thì không phải đóng file đó nữa mà là hỏi tiếp ng mở mật khẩu nếu họ điền đúng mật khẩu thì cho họ vào còn không mới đóng file lại.
Bạn thử coi:
Private Sub Workbook_Open()
Dim strPass As String
ng = Day(Date)
th = Month(Date)
nam = Year(Date)
If ng > 1 And th > 5 And nam >= 2008 Then
strPass = InputBox("Nhap mat khau: hoangtuan.net", "Your Password")
If strPass <> "hoangtuan.net" Then
MsgBox "Mat khau khong chinh xac. File se duoc dong.", vbCritical
ThisWorkbook.Close False
End If
End If
End SubEm rất cảm ơn Bác Nhưng có thể xem hộ em file đã copy code vào đc ko ạ em cho vào nhưng mở ra đang báo lỗi.
Option Explicit
Private Sub Workbook_Open()
Dim strPass As String
Dim ng As Integer, th As Integer, nam As Integer
ng = Day(Date)
th = Month(Date)
nam = Year(Date)
If ng > 1 And th > 5 And nam >= 2008 Then
strPass = InputBox("Nhap mat khau: hoangtuan.net", "Your Password")
If strPass <> "hoangtuan.net" Then
MsgBox "Mat khau khong chinh xac. File se duoc dong.", vbCritical
ThisWorkbook.Close False
End If
End If
End SubTrước tiên em rất cảm ơn Bác vì đã nhiệt tình giúp em. Nhưng em đã sửa lại file theo cách 1 bác chỉ em nhưng không hiểu sao khi em vào lại nó lại không yêu cầu em nhập mật khẩu nhỉ vì hôm này là ngày 40-4-2024 điều kiện đều thỏa mãn lớn hơn ngày 1-5-2008 >>> thì nó phải thực hiện code đoạn sau bác viết bổ xung cho em chứ nhỉ >> em mở cái nó lại vào trong file luôn đc.
If ng > 1 And th > 5 And nam >= 2008 Then: Điều kiện này kiểm tra xem ngày, tháng và năm hiện tại có thỏa mãn điều kiện (ngày lớn hơn 1, tháng lớn hơn 5 và năm lớn hơn hoặc bằng 2008) hay không. Nếu thỏa mãn, thì yêu cầu người dùng nhập mật khẩu.Trước tiên em rất cảm ơn Bác vì đã nhiệt tình giúp em. Nhưng em đã sửa lại file theo cách 1 bác chỉ em nhưng không hiểu sao khi em vào lại nó lại không yêu cầu em nhập mật khẩu nhỉ vì hôm này là ngày 40-4-2024 điều kiện đều thỏa mãn lớn hơn ngày 1-5-2008 >>> thì nó phải thực hiện code đoạn sau bác viết bổ xung cho em chứ nhỉ >> em mở cái nó lại vào trong file luôn đc.
Vâng, em ngu ngơ quá, cảm ơn Bác nhiều, em sửa lại cái điều kiện cho hợp lý là được file như em mong muốn
Bạn có thể tham khảo:
...
'Lấy ngày hiện tại
today = Date
' Đặt ngày cần kiểm tra
checkDate = DateSerial(2008, 5, 1)
' Kiểm tra xem ngày hiện tại có lớn hơn hoặc bằng ngày cần kiểm tra không
If today >= checkDate Then
...
