Доброго времени суток. Пишу форму запроса логина/пароля в VBA, никак не могу вывести форму с предварительно заполненным именем пользователя. Подскажите, пожалуйста, что не так, что забыл
| Код |
|---|
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 |
