1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
| 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 |
(
Сообщение от krosav4ig
