Tạo form đăng nhập trong Excel

Liên hệ QC

truongminhthi999

Thành viên mới
Tham gia
10/5/11
Bài viết
27
Được thích
2
Giới tính
Nam
Chào các bạn! Mình có làm một bài Excel tạo form đăng nhập nhưng mình chưa tạo được form thay đổi thông tin đăng nhập khi đăng nhập đúng. Do đó, khi muốn thay đổi phải mở Vba lên để mà thay đổi trong đó. Rất là phiền phức. Bạn nào biết thì chỉ dùm nhe. Tải file đính kèm xem thử nhe!
Xin cám ơn.
Liên lạc với mình qua truongminhthi999@gmail.com
 

File đính kèm

  • Ðang nh_p.rar
    18.7 KB · Đọc: 2,672
Bác Nghĩa chưa hiểu ý em rồi :wounded1:, chẳng là em muốn tận dụng luôn file này của bác nhưng lại tích hợp đoạn code định thời gian hết hạn và chống copy thêm vào file này của bác thì insert nó vào vị trí nào?

VD muốn thêm code này thì insert vào chỗ nào?

Private Sub Workbook_Open()
If
Date >= DateSerial(2010, 6, 20) Then
MsgBox
"Het han su dung"
Call KillFile 'Hoac thay bang Application.Quit
End
If
End Sub
Nếu vậy thì sự kiện Open được thêm vào như sau:

Mã:
Private Sub Workbook_Open()
    On Error Resume Next
[COLOR=#0000ff]    If Date >= DateSerial(2010, 6, 20) Then[/COLOR]
[COLOR=#0000ff]        MsgBox "Het han su dung"[/COLOR]
[COLOR=#0000ff]        Call KillFile 'Hoac thay bang Application.Quit[/COLOR]
[COLOR=#0000ff]    Else[/COLOR]
        Call StructureUnLock
        With Home
            .Select
            .cmdAdmin.Enabled = False
            .cmdUser1.Enabled = False
            .cmdUser2.Enabled = False
            .cmdUser3.Enabled = False
        End With
        Application.ScreenUpdating = False
        Dim sh As Worksheet
        For Each sh In ThisWorkbook.Worksheets
            If sh.CodeName <> "Home" Then
                sh.Visible = xlSheetVeryHidden
            End If
        Next
        UsfUser.Show
[COLOR=#0000ff]    End If[/COLOR]
End Sub
 
Upvote 0
Nếu vậy thì sự kiện Open được thêm vào như sau:

Mã:
Private Sub Workbook_Open()
    On Error Resume Next
[COLOR=#0000ff]    If Date >= DateSerial(2010, 6, 20) Then[/COLOR]
[COLOR=#0000ff]        MsgBox "Het han su dung"[/COLOR]
[COLOR=#0000ff]        Call KillFile 'Hoac thay bang Application.Quit[/COLOR]
[COLOR=#0000ff]    Else[/COLOR]
        Call StructureUnLock
        With Home
            .Select
            .cmdAdmin.Enabled = False
            .cmdUser1.Enabled = False
            .cmdUser2.Enabled = False
            .cmdUser3.Enabled = False
        End With
        Application.ScreenUpdating = False
        Dim sh As Worksheet
        For Each sh In ThisWorkbook.Worksheets
            If sh.CodeName <> "Home" Then
                sh.Visible = xlSheetVeryHidden
            End If
        Next
        UsfUser.Show
[COLOR=#0000ff]    End If[/COLOR]
End Sub

Nếu thêm tiếp nữa vào đoạn code trên điều kiện kiểm tra nếu đúng mã máy thì cho mở file thì như thế nào ạ. Bác Nghĩa chỉ em với !!!
 
Upvote 0
Nếu thêm tiếp nữa vào đoạn code trên điều kiện kiểm tra nếu đúng mã máy thì cho mở file thì như thế nào ạ. Bác Nghĩa chỉ em với !!!

Trong file đó, bạn tạo thêm 1 module (tôi gọi là ModuleSeries) và chép vào hàm này:

Mã:
Function ReadSeriesNumber()
    With CreateObject("Scripting.FileSystemObject")
        With .GetDrive(Environ("SystemDrive"))
            If .IsReady Then
                ReadSeriesNumber = Abs(.Serialnumber)
            Else
                ReadSeriesNumber = -1
            End If
        End With
    End With
End Function


Sau đó dùng hàm đó để kiểm tra máy của bạn có Series là bao nhiêu.

dùng thủ tục này để kiểm tra:

Mã:
Sub test()
    Debug.Print ReadSeriesNumber
End Sub

Sau khi có số series, bạn đặt câu màu đỏ này lên trên cùng của ModuleSeries


Public Const YourSeries As Long = 1964788159 '<<< Số series của máy tính bạn thay cho số này.

Bây giờ, code của sự kiện Open sẽ như sau:

Mã:
Private Sub Workbook_Open()
    On Error Resume Next
    If Date >= DateSerial(2010, 6, 20) Then
        MsgBox "Het han su dung"
        Call KillFile 'Hoac thay bang Application.Quit
[COLOR=#0000ff]    ElseIf [/COLOR][COLOR=#ff0000]ReadSeriesNumber <> YourSeries[/COLOR][COLOR=#0000ff] Then[/COLOR]
[COLOR=#0000ff]        MsgBox "May nay khong duoc quyen su dung"[/COLOR]
[COLOR=#0000ff]        Call KillFile 'Hoac thay bang Application.Quit[/COLOR]
    Else
        Call StructureUnLock
        With Home
            .Select
            .cmdAdmin.Enabled = False
            .cmdUser1.Enabled = False
            .cmdUser2.Enabled = False
            .cmdUser3.Enabled = False
        End With
        Application.ScreenUpdating = False
        Dim sh As Worksheet
        For Each sh In ThisWorkbook.Worksheets
            If sh.CodeName <> "Home" Then
                sh.Visible = xlSheetVeryHidden
            End If
        Next
        UsfUser.Show
    End If
End Sub
 
Upvote 0
Trong file đó, bạn tạo thêm 1 module (tôi gọi là ModuleSeries) và chép vào hàm này:

Mã:
Function ReadSeriesNumber()
    With CreateObject("Scripting.FileSystemObject")
        With .GetDrive(Environ("SystemDrive"))
            If .IsReady Then
                ReadSeriesNumber = Abs(.Serialnumber)
            Else
                ReadSeriesNumber = -1
            End If
        End With
    End With
End Function


Sau đó dùng hàm đó để kiểm tra máy của bạn có Series là bao nhiêu.

dùng thủ tục này để kiểm tra:

Mã:
Sub test()
    Debug.Print ReadSeriesNumber
End Sub

Sau khi có số series, bạn đặt câu màu đỏ này lên trên cùng của ModuleSeries


Public Const YourSeries As Long = 1964788159 '<<< Số series của máy tính bạn thay cho số này.

Bây giờ, code của sự kiện Open sẽ như sau:

Mã:
Private Sub Workbook_Open()
    On Error Resume Next
    If Date >= DateSerial(2010, 6, 20) Then
        MsgBox "Het han su dung"
        Call KillFile 'Hoac thay bang Application.Quit
[COLOR=#0000ff]    ElseIf [/COLOR][COLOR=#ff0000]ReadSeriesNumber <> YourSeries[/COLOR][COLOR=#0000ff] Then[/COLOR]
[COLOR=#0000ff]        MsgBox "May nay khong duoc quyen su dung"[/COLOR]
[COLOR=#0000ff]        Call KillFile 'Hoac thay bang Application.Quit[/COLOR]
    Else
        Call StructureUnLock
        With Home
            .Select
            .cmdAdmin.Enabled = False
            .cmdUser1.Enabled = False
            .cmdUser2.Enabled = False
            .cmdUser3.Enabled = False
        End With
        Application.ScreenUpdating = False
        Dim sh As Worksheet
        For Each sh In ThisWorkbook.Worksheets
            If sh.CodeName <> "Home" Then
                sh.Visible = xlSheetVeryHidden
            End If
        Next
        UsfUser.Show
    End If
End Sub
Hix, em đã xem 1 hồi lâu nhưng cũng không hiểu gì được cả... Anh nghĩa có thể cho em xin file kèm bài trên được không ạ?
 
Upvote 0
Hix, em đã xem 1 hồi lâu nhưng cũng không hiểu gì được cả... Anh nghĩa có thể cho em xin file kèm bài trên được không ạ?
Đơn giản là như vầy, tạo một module rồi chép thủ tục dưới đây vào trong đó:

Mã:
Option Explicit
[COLOR=#ff0000]Public Const MyComputerSeries = 1964788159[/COLOR]

Function ReadSeriesNumber()
    With CreateObject("Scripting.FileSystemObject")
        With .GetDrive(Environ("SystemDrive"))
            If .IsReady Then
                ReadSeriesNumber = Abs(.Serialnumber)
            Else
                ReadSeriesNumber = -1
            End If
        End With
    End With
End Function


[COLOR=#0000ff]''Thu tuc nay de ban lay so series cua may tinh[/COLOR]
[COLOR=#0000ff]''Mo Immediate (Ctrl+G) de xem so[/COLOR]
[COLOR=#0000ff]''sau do copy so do vao [/COLOR][COLOR=#ff0000]Const MyComputerSeries[/COLOR]
[COLOR=#0000ff]''o phia tren thay cho day so [/COLOR][COLOR=#ff0000]1964788159[/COLOR]
Sub KiemTraSeries()
    Debug.Print ReadSeriesNumber
End Sub

Chép trong ThisWorkbook thủ tục của sự kiện Open:

Mã:
Private Sub Workbook_Open()
    On Error Resume Next
    [COLOR=#0000ff]''Thoi han su dung:[/COLOR]
    If Date > DateSerial(2014, 3, 12) Then
        MsgBox "Het han su dung"
        GoTo ExitSub
    [COLOR=#0000ff]''Kiem tra so series, neu dung may minh moi cho mo file:[/COLOR]
    ElseIf ReadSeriesNumber <> MyComputerSeries Then
        MsgBox "May nay khong duoc quyen su dung"
        GoTo ExitSub
    Else
        MsgBox "Ban da xem duoc file!"
    End If
    Exit Sub
ExitSub:
    If Workbooks.Count = 1 Then
        Application.Quit
    Else
        ThisWorkbook.Close False
    End If
End Sub
 

File đính kèm

  • KiemTraWorkbook.xls
    30 KB · Đọc: 195
Upvote 0
Anh Nghĩa cho em hỏi, em đã tải bài # 26 của anh về và muốn vận dụng vào file của em thì phải làm sao hả anh Nghĩa. (Tức là em muốn lấy cái Form của Anh để làm Pass mở file của em Ah.)
 
Upvote 0
Anh Nghĩa cho em hỏi, em đã tải bài # 26 của anh về và muốn vận dụng vào file của em thì phải làm sao hả anh Nghĩa. (Tức là em muốn lấy cái Form của Anh để làm Pass mở file của em Ah.)
Bạn đưa cái file của bạn lên đây đi, tôi "vận dụng" dùm cho, chứ không có file thì tôi cũng như "Thầy bói xem voi" thôi.

Cũng lưu ý là khi gửi file lên, bạn ghi rõ yêu cầu của bạn như thế nào để tôi dễ dàng nắm bắt và thực hiện cho bạn.
 
Lần chỉnh sửa cuối:
Upvote 0
Em đưa File cho Anh Nghĩa đây Ah. Anh Nghĩa có thể giúp cho em có form Pass để mở file(Anh chỉnh cho form to ra thêm một tí) và Anh có thể tạo code không cho ai xóa được file này (ổ D) Mong Anh giúp đỡ!!!!
 

File đính kèm

  • NXT.rar
    75.6 KB · Đọc: 54
Upvote 0
Sory Anh Nghĩa,Em đưa lộn file có pass VBA. vì lý do công việc em xóa bớt 1 số Module và tên hàng , đơn hàng. Mong Anh giúp đỡ!!!
 

File đính kèm

  • NXT.rar
    60.6 KB · Đọc: 41
Lần chỉnh sửa cuối:
Upvote 0
Em đưa File cho Anh Nghĩa đây Ah. Anh Nghĩa có thể giúp cho em có form Pass để mở file(Anh chỉnh cho form to ra thêm một tí) và Anh có thể tạo code không cho ai xóa được file này (ổ D) Mong Anh giúp đỡ!!!!

Lưu ý nha bạn, lần sau có gửi file lên thì cũng phải bỏ VBA Password ra cho người khác còn giúp bạn nữa nha!

Ngoài việc đưa Form đăng nhập vào, tôi còn thấy trong ThisWorkbook Module, bạn có thủ tục này:

Mã:
Private Sub Workbook_Open()
    On Error Resume Next
    Application.ScreenUpdating = False
    ThisWorkbook.Application.Caption = ("Chuong trinh Nhap Xuat Ton")
    With Application
        .StatusBar = ("Written by Do Minh Quang - Ban quyen thuoc ve tac gia")
 Application.ScreenUpdating = True
 End With
End Sub

Khi bạn mở file, sự kiện này kích hoạt, thế là tất cả các file Excel đang mở chịu sự tác động của nó nên Caption và StatusBar đều có 2 dòng chuỗi đó hiện lên, cho dù không phải chương trình đó hiện hành (activate). Cho nên tôi sửa lại cho bạn bằng 2 thủ tục này, khi file của bạn hiện hành thì chúng hiện lên, khi qua file khác thì mất đi:

Mã:
Private Sub Workbook_Activate()
    On Error Resume Next
    Application.Caption = "Chuong trinh Nhap Xuat Ton"
    Application.StatusBar = "Written by Do Minh Quang - Ban quyen thuoc ve tac gia"
End Sub


Private Sub Workbook_Deactivate()
    On Error Resume Next
    Application.Caption = ""
    Application.StatusBar = ""
End Sub

À, việc không cho xóa tôi không thực hiện được nha!
 

File đính kèm

  • NXT_HTN.rar
    82.3 KB · Đọc: 218
Upvote 0
Xin lỗi Anh Nghĩa nhe!!!Thực chất là em cũng sưu tầm file này trên DD, vì trình độ VBA gà mờ, nên em thêm chổ này bỏ chổ kia một tí cho phù hợp với công việc của em. Em chả viết được đến 1/2 đoạn code nào cả. Đúng là khi mở file này lên là tất cả các file excell khác đều có chuỗi đó hiện lên.Cám ơn Anh nhiều!!!
 
Upvote 0
Chào bác Hoàng Trọng Nghĩa!Bác cho em hỏi:Có cách nào để ghi lại nhật ký làm việc của từng User trong 1 File Excel ko ạ.Ví dụ như mình muốn biết trong phiên đăng nhập của 1 user,người đó đã làm gì,đã chỉnh sửa thông tin ra sao,thêm bớt số liệu như thế nào.Nhật ký tất nhiên chỉ có admin mới có quyền xem dc ạ.
Em xin cảm ơn!
 
Upvote 0
sao mình dùng office 2013 64bit (win 8.1 64 bit) để mở file thì bị báo lỗi:
"Could not load some objects because they are not avaiable on this machine"
Khi vào VBA thì báo lỗi:
"The code in this projects must be updated for use on 64-bit system. Please review and update Declare statements and then mark them with the PtrSafe attribute"
ở 2 dòng sau:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long


Sau khi sửa lại thành:
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, _
ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If

thì lại bị báo lỗi:'
"Type mismatch"
ở dòng:
hwnd = FindWindow("ThunderDFrame", Me.Caption)

không biết phải sửa lại ntn???
 
Upvote 0
sao mình dùng office 2013 64bit (win 8.1 64 bit) để mở file thì bị báo lỗi:
"Could not load some objects because they are not avaiable on this machine"
Khi vào VBA thì báo lỗi:
"The code in this projects must be updated for use on 64-bit system. Please review and update Declare statements and then mark them with the PtrSafe attribute"
ở 2 dòng sau:
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long


Sau khi sửa lại thành:
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, _
ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If

thì lại bị báo lỗi:'
"Type mismatch"
ở dòng:
hwnd = FindWindow("ThunderDFrame", Me.Caption)

không biết phải sửa lại ntn???

Đã tìm ra nguyên nhân. Thanks.
Phải khai báo lại biến hwnd như sau:
#If VBA7 Then
Dim hwnd As LongPtr
#Else
Dim hwnd As Long
#End If
 
Upvote 0
file đăng nhập của anh Hoàng Trọng hay ở chỗ không bật "Enable macro" vẫn chạy phần đăng nhập .
Nhưng sao sử dụng thì hay bị lỗi không save được và tiếp theo bị crash luôn . Có lúc đang mở file mà không làm gì thì nó cũng bị crash , bó tay luôn , không biết có phải do em bỏ hết delete hết sheet chỉ chừa lại sheet "Nguon" và UsfUser nên bị như thế
 
Upvote 0
Đây là file "Demo" cho bạn dùng thử chơi cho vui nè! Mọi password đều là HoangTrongNghia.

Trong file tôi có 4 người được dùng, với Admin là cao nhất, sử dụng được mọi thứ, kể cả reset lại tất cả user & pass (thủ công, nếu muốn tự động, tự các bạn mày mò đi nhé, không khó); và 3 User, chỉ được quyền mở sheet của mình.

[NOTE1]Các Username / Password:

1) ADMIN / Admin

2) USER1 / User1

3) USER2 / User2

4) USER3 / User3[/NOTE1]

Các bạn cứ lần lượt mở file rồi chọn thử từng Username xem sao (mở và đóng 4 lần), nên chọn lần cuối là Admin cho thú vị!

[TIP]Click vào Box Username để xổ ra danh sách Users nha các bạn

attachment.php
[/TIP]



File đã được cập nhật mới, sửa lỗi đăng nhập, các bạn nên tải file AdminAndUsers2.rar nhé!

Bác Nghĩa có thể cho mình hỏi làm sao cải thiện thời gian đăng nhập vào nhanh hơn được hay không?

Và muốn hỏi anh cách tạo user cho file với các tiêu chí sau:
1. User Admin: Có quyền full toàn bộ trên file
2. User Người A: Chỉ được phép nhập tại các sheet xxx,
3. User Người B: Chỉ được thao tác tại vùng A5:E10 và G5:L5 của sheet xxx và được xem các sheet a, b, c...
4. User Người C: Chỉ được xem sheet xxx.

Với xxx ở đây là 1 sheet do mình chỉ định.
Có thể tạo được nhiều user cho ng A, ng B... (Mỗi loại vài user)

Cảm ơn và mong sớm nhận được phản hồi của anh.
 
Upvote 0
mọi người ơi sao t cũng làm theo bài GPEV sang file khác mà khi mở excel lên nó ko hiện form đăng nhập pass Word là sao ạ...các form làm xong hết rồi..giờ chỉ cần làm ntn để khi tắt excel lên nó chi hiện form đăng nhập để đăng nhập vậy mọi người...chỉ giúp mình với...cảm ơn nhé%#^#$:-=}}}}}
 
Upvote 0
Kính gửi Anh Nghĩa
Theo tham khảo từ file của anh, em đã tạo được đăng nhập riêng.
Tuy nhiên file của em có nhiều sheet riêng lẻ, và em muốn một người đăng nhập vào có thể vào một số sheet cố định ( ý của em cũng giống của tiennam
user-offline.png
là:Cách tạo User cho file với tiêu chí:
1. User Admin: Có quyền đăng nhập tất cả các sheet
2. User Người A: Dăng nhập vào sheet A, Sheet C
3. User Người B: Đăng nhập sheetB, Sheet D

Như vây có thể tạo user đang nhập cho 1 người ( VD Người A:) đăng nhập vào Sheet A, Sheet C mà các sheet nay vẫn hiện trên sheet Home như user Admin.
Anh Nghĩa vui lòng giúp đỡ để em có thể tìm ra hướng viết tiếp chương trình
Cảm ơn anh Nghĩa nhiều
 
Upvote 0
Kính gửi anh ndu96081631 qua tìm hiểu nhiều bài viết của anh, em thấy anh rất rành về code

Hiện nay em đang dựa trên bài viết và file của anh HoangTrongNghia để làm form đăng nhập
Mục đích chỉ để phân quyền vào các sheet cụ thể cho từng người
Tuy nhiên theo cách đăng nhập của anh HoangTrongNghia thì 1 người chỉ đăng nhập vào 1 sheet mà thôi ( Ngoại trừ Admin)
Anh vui long chỉnh giúp em code để :
1. User Admin: Có quyền đăng nhập tất cả các sheet
2. User Người A: Dăng nhập vào sheet A, Sheet C
3. User Người B: Đăng nhập sheetB, Sheet D

Như vây có thể tạo user đang nhập cho 1 người ( VD Người A:) đăng nhập vào Sheet A, Sheet C mà các sheet nay vẫn hiện trên sheet Home như user Admin.
Anh ndu96081631 và các anh chi trong diễn đàn vui lòng giúp đỡ để em có thể tìm ra hướng viết tiếp chương trình




CODE CỦA EM ĐƯỢC TRÍCH DẪN TỪ BÀI VIẾT CỦA ANH HOANGTRONGNGHIA

quote_icon.png
Nguyên văn bởi Hoàng Trọng Nghĩa

Đây là file "Demo" cho bạn dùng thử chơi cho vui nè! Mọi password đều là HoangTrongNghia.

Trong file tôi có 4 người được dùng, với Admin là cao nhất, sử dụng được mọi thứ, kể cả reset lại tất cả user & pass (thủ công, nếu muốn tự động, tự các bạn mày mò đi nhé, không khó); và 3 User, chỉ được quyền mở sheet của mình.

Chú ý: Các Username / Password:

1) ADMIN / Admin

2) USER1 / User1

3) USER2 / User2

4) USER3 / User3




Các bạn cứ lần lượt mở file rồi chọn thử từng Username xem sao (mở và đóng 4 lần), nên chọn lần cuối là Admin cho thú vị!

Tips: Click vào Box Username để xổ ra danh sách Users nha các bạn

attachment.php






File đã được cập nhật mới, sửa lỗi đăng nhập, các bạn nên tải file AdminAndUsers2.rar nhé!


 
Upvote 0
Web KT
Back
Top Bottom