Access VBA 的眉眉角角Day26: Windows認證與Active Directory認證

2017 iT 邦幫忙鐵人賽

DAY 26

自我挑戰組

Access VBA的眉眉角角系列第 26 篇

2017鐵人賽

Andy Chiu

2016-12-27 00:10:31

3974 瀏覽

分享至

在開發程式上，通常不會只有一個人使用該程式，該如何防範非認可的使用者使用程式，通常會使用認證方式來處理，一般使用者可能使用Windows認證，而企業內部則可使用AD認證。筆者之前也有類似的需求，除了認證外，也要連上檔案伺服器上的分享路徑，以便寫入相關檔案，當時筆者沒有去找認證相關的程式碼，僅用所知的命令列模式配合執行外部程式的方式，來達到這樣的需求。這次趁鐵人賽，找了一下是否有相關的資訊，並且彙整出來提供給大家參考。

在這之前，要先介紹之前「Excel VBA 的眉眉角角」系列的兩個子程式，以便帶入今天的程式中使用

「Excel VBA 的眉眉角角Day13: InputBox輸入密碼字串顯示*字串」，請將程式碼另建一個模組存入，InputBoxDK子程式呼叫後，輸入的字串會以「＊」表示，以便能輸入密碼等機密資料：

Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'////////////////////////////////////////////////////////////////////
 
 
'API functions to be used
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
                                                      ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
 
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
 
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
                                          (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
                                          ByVal dwThreadId As Long) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
 
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
                                            (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
                                            ByVal wParam As Long, ByVal lParam As Long) As Long
 
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
                                                                          ByVal lpClassName As String, _
                                                                          ByVal nMaxCount As Long) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
 
'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
 
Private hHook As Long
 
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim RetVal
    Dim strClassName As String, lngBuffer As Long
 
    If lngCode < HC_ACTION Then
        NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
        Exit Function
    End If
 
    strClassName = String$(256, " ")
    lngBuffer = 255
 
    If lngCode = HCBT_ACTIVATE Then    'A window has been activated
 
        RetVal = GetClassName(wParam, strClassName, lngBuffer)
 
        If Left$(strClassName, RetVal) = "#32770" Then  'Class name of the Inputbox
 
            'This changes the edit control so that it display the password character *.
            'You can change the Asc("*") as you please.
            SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, asc("*"), &H0
        End If
 
    End If
 
    'This line will ensure that any other hooks that may be in place are
    'called correctly.
    CallNextHookEx hHook, lngCode, wParam, lParam
 
End Function
 
Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional Xpos, _
                        Optional Ypos, Optional HelpFile, Optional Context) As String
 
    Dim lngModHwnd As Long, lngThreadID As Long
 
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
 
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
 
    InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, HelpFile, Context)
    UnhookWindowsHookEx hHook
 
End Function  'Hope someone can use it!

以下再把「Excel VBA 的眉眉角角Day25: 控制pdf檔案產生」裡面提到的Sleep功能帶入：

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
'For 32 Bit Systems 帶入Sleep功能

以下子程式參考了幾個網站，程式中，主要是呼叫了ADSystemInfo物件，然後使用GetObject方法與OpenDSObject方法來判斷帳號密碼是否能通過認證，而使用Windows認證時，若僅使用OpenDSObject方法，是沒有辦法觸發錯誤事件，後來筆者發現，若查詢有錯誤帳號密碼產生的物件屬性，就會觸發錯誤事件，若帳號密碼正確，則會取得屬性，不會觸發錯誤事件。因此此程式有改了一下，以便適合Windows認證(WinNT)與AD認證(LDAP)這兩種認證方式：

Function WindowsLogin(ByVal strUserName As String, _
                      ByVal strPassword As String, _
                     ByVal strDomain As String, _
                     Optional AuthType As String = "LDAP") As Boolean
    ' 參考：
    'http://www.programmer-club.com.tw/ShowSameTitleN/vb/33142.html
    'https://social.msdn.microsoft.com/Forums/office/en-US/4d2290d9-d9d6-4ebb-aea3-026c640a3cd2/login-using-windows-authentication?forum=accessdev
    'http://visualbasic.ittoolbox.com/groups/technical-functional/visualbasic-l/validate-windows-login-password-for-microsoft-access-database-application-5458978

    'Authenticates user and password entered with Active Directory.
    'AuthType: LDAP , WinNT
    
    On Error GoTo IncorrectPassword
    
    Dim oADsObject, oADsNamespace As Object, ADSI As Object
    Dim strADsPath As String
    
    Set ADSI = CreateObject("ADSystemInfo")
    strADsPath = AuthType & "://" & strDomain
    Set oADsNamespace = GetObject(AuthType & ":")

    If AuthType = "LDAP" Then
        Set oADsObject = oADsNamespace.OpenDSObject(strADsPath, strDomain & "\" & strUserName, strPassword, 0)
    Else
        Set oADsObject = oADsNamespace.OpenDSObject(strADsPath, strUserName, strPassword, 0)
    End If
            
        
         
    If AuthType = "WinNT" Then
        'WinNT的認證有問題，執行後即使密碼錯誤也不會觸發err
        '需要呼叫物件的屬性才會觸發錯誤
        a = oADsObject.Owner
 
    ElseIf AuthType = "LDAP" Then
        a = oADsObject.Name
        a = oADsObject.ADsPath
        a = oADsObject.HomeDirectory
        a = oADsObject.Guid
        a = oADsObject.schema
        a = oADsObject.TelephoneNumber
    End If
    
    WindowsLogin = True    'ACCESS GRANTED
        
ExitSub:
    Exit Function
        
IncorrectPassword:
    Debug.Print Err.Number & ": " & Err.Description
    WindowsLogin = False   'ACCESS DENIED
    Resume ExitSub
        
End Function

以下程式用來測試WindowsLogin子程式：

Sub WindowsLogin測試()
    Dim strUser As String, strPassword As String, strDomain As String, strAuthType As String
    
    strUser = InputBox("請輸入帳號:")
    strPassword = InputBoxDK("請輸入密碼:")
    strDomain = InputBox("請輸入網域或電腦名稱:", , "")
    
    If MsgBox("驗證方式為AD認證請按「確認」，Windows認證請按「取消」。", vbOKCancel) = vbOK Then
        strAuthType = "LDAP"
    Else
        strAuthType = "WinNT"
    End If
    
    If WindowsLogin(strUser, strPassword, strDomain, strAuthType) = True Then
        MsgBox "認證成功！"
    Else
        MsgBox "認證失敗！"
    End If

End Sub

以下子程式為筆者撰寫的，使用命令列模式下的net use來連線到指定的檔案伺服器或者主機分享的資料夾，只要該分享資料夾權限可以讀取，就認證成功，不能讀取，就認證失敗，用這種方式來進行認證，並且連線到指定的路徑，以便讀寫相關資料，將資料留在遠端伺服器內備存：

Function ConnectToAD(strPath As String, Optional strAccount As String, Optional strPassword As String, Optional strDomain As String = "") As Boolean
    Dim strCMD1 As String
    Dim strCMD2 As String
    Dim bnConnectToServer_Status As Boolean
    Dim strPassword2 As String
    Dim iTry As Integer
    '
    ' strPath 最後一碼不能有斜線，否則net use的方式連線時會出錯
    ' \\domain\share\ <= x
    ' \\domain\share  <= o
    
    '如果有斜線在最後一碼則刪除斜線
    If Right(strPath, 1) = "\" Then
        strPath = Mid(strPath, 1, Len(strPath) - 1)
    End If
    
    If Len(strAccount) = 0 Then
        strAccount = InputBox("Please input AD account(Windows account):")
        strPassword = InputBoxDK("Please input password(Windows password):")
    End If
    
    strCMD1 = "net use " & strPath & " /DELETE /YES"
    
    If strDomain = "" Then
        strCMD2 = "net use " & strPath & " /user:" & strAccount & " " & strPassword
    Else
        strCMD2 = "net use " & strPath & " /user:" & strDomain & "\" & strAccount & " " & strPassword
    End If
     
    Call RunCMD2(strCMD1, True, True, 0)
    
    '反覆嘗試登入，上一步驟刪除登入資訊後，馬上又登入似乎會產生問題？
    iTry = 0
    Do
        Call RunCMD2(strCMD2, True, True, 0)
        iTry = iTry + 1
        Sleep 200
    Loop Until ConnectToServer_Status(strPath) = True Or iTry = 10
    
    bnConnectToServer_Status = ConnectToServer_Status(strPath)
    ConnectToAD = bnConnectToServer_Status

End Function

以下為測試程式，可以依照自己的環境替換相關參數：

Sub ConnectToAD測試()

    If ConnectToAD("\\server\share", "username", "password", "domain") = True Then
        MsgBox "連線成功！"
    Else
        MsgBox "連線失敗！"
    End If

End Sub

有了以上的處理方式教學，相信各位也能簡易的帶入到自己的程式中使用。以上教學希望對各位有幫助。