Option Explicit
 
#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare PtrSafe Function CredUIPromptForWindowsCredentials Lib "credui" Alias "CredUIPromptForWindowsCredentialsW" (ByRef pUiInfo As CREDUI_INFO, ByVal dwAuthError As Long, ByRef pulAuthPackage As LongPtr, ByRef pvInAuthBuffer As Any, ByVal ulInAuthBufferSize As Long, ByRef ppvOutAuthBuffer As Any, pulOutAuthBufferSize As Long, ByRef iSave As Long, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function CredUnPackAuthenticationBuffer Lib "credui" Alias "CredUnPackAuthenticationBufferW" (ByVal dwFlags As Long, ByVal pAuthBuffer As LongPtr, ByVal cbAuthBuffer As Long, ByVal pszUserName As LongPtr, ByRef pcchMaxUserName As Long, ByVal pszDomainName As LongPtr, ByRef pcchMaxDomainName As Long, ByVal pszPassword As LongPtr, ByRef pcchMaxPassword As Long) As Long
    Private Declare PtrSafe Function CredPackAuthenticationBuffer Lib "credui" Alias "CredPackAuthenticationBufferA" (ByVal dwFlags As Long, ByRef pszUserName As Any, ByRef pszPassword As Any, ByRef pPackedCredentials As Any, ByRef pcbPackedCredentials As Long) As Long
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function CredUIPromptForWindowsCredentials Lib "CredUI" Alias "CredUIPromptForWindowsCredentialsW" (ByRef pUiInfo As CREDUI_INFO, ByVal dwAuthError As Long, ByRef pulAuthPackage As Long, ByVal pvInAuthBuffer As Any, ByVal ulInAuthBufferSize As Long, ByRef ppvOutAuthBuffer As Any, pulOutAuthBufferSize As Long, ByRef iSave As Long, ByVal dwFlags As Long) As Long
    Private Declare Function CredUnPackAuthenticationBuffer Lib "CredUI" Alias "CredUnPackAuthenticationBufferW" (ByVal dwFlags As Long, ByVal pAuthBuffer As Long, ByVal cbAuthBuffer As Long, ByVal pszUserName As Long, ByRef pcchMaxUserName As Long, ByVal pszDomainName As Long, ByRef pcchMaxDomainName As Long, ByVal pszPassword As Long, ByRef pcchMaxPassword As Long) As Long
    Private Declare Function CredPackAuthenticationBuffer Lib "credui" Alias "CredPackAuthenticationBufferW" (ByVal dwFlags As Long, ByRef pszUserName As Any, ByRef pszPassword As Any, ByRef pPackedCredentials As Any, ByRef pcbPackedCredentials As Long) As Long
#End If
Private Type CREDUI_INFO
    cbSize As Long
    #If VBA7 Then
        hwndParent As LongPtr
        pszMessageText As LongPtr
        pszCaptionText As LongPtr
    #Else
        hwndParent As Long
        pszMessageText As Long
        pszCaptionText As Long
    #End If
    hbmBanner As Long
End Type
 
Public Sub GetCred()
    
    Dim pUiInfo As CREDUI_INFO
    
    Dim pulOutAuthBufferSize As Long
    Dim pulInAuthBufferSize As Long
    
    #If VBA7 Then
        Dim ppvOutAuthBuffer As LongPtr
        Dim ppvInAuthBuffer As LongPtr
    #Else
        Dim ppvOutAuthBuffer As Long
        Dim ppvInAuthBuffer As Long
    #End If
    
    
    Dim ret&, b() As Byte, InAuthBuffer() As Byte
    Dim s1$, s2$
    pUiInfo.cbSize = LenB(pUiInfo)
    pUiInfo.hwndParent = 0
    
    s1 = "Необходимо ввести учетные данные"
    s2 = "Подключение"
    pUiInfo.pszMessageText = StrPtr(s1)
    pUiInfo.pszCaptionText = StrPtr(s2)
    
    ret = CredPackAuthenticationBuffer(4, sUserName, vbNullString, Empty, pulInAuthBufferSize)
    ReDim InAuthBuffer(pulInAuthBufferSize)
    ret = CredPackAuthenticationBuffer(4, sUserName, vbNullString, InAuthBuffer(0), pulInAuthBufferSize)
    ret = CredUIPromptForWindowsCredentials(pUiInfo, Empty, Empty, InAuthBuffer(0), pulInAuthBufferSize, ppvOutAuthBuffer, pulOutAuthBufferSize, Empty, &H20 Or &H200)
    
    If ret = 0 Then
        'CredUnPackAuthenticationBuffer
    End If
End Sub