PureBasic Forums - English

Code: Select all

Private Declare Function RasEnumEntries Lib "rasapi32.dll" Alias "RasEnumEntriesA" (ByVal lpcstr As String, ByVal lpcstr As String, ByRef lprasentrynamea As Any, ByRef lpdword As Long, ByRef lpdword As Long) As Long
Private Declare Function RasGetEntryDialParams Lib "rasapi32.dll" Alias "RasGetEntryDialParamsA" (ByVal lpcstr As String, ByRef lprasdialparamsa As Byte, ByRef lpbool As Long) As Long
Private Declare Function RasGetEntryProperties Lib "rasapi32.dll" Alias "RasGetEntryPropertiesA" (ByVal lpszPhonebook As String, ByVal lpszEntry As String, ByRef lpRasEntry As Any, ByRef lpdwEntryInfoSize As Long, ByRef lpbDeviceInfo As Any, ByRef lpdwDeviceInfoSize As Long) As Long

Private Declare Function LsaOpenPolicy Lib "ADVAPI32.dll" (ByRef SystemName As Long, ByRef ObjectAttributes As LSA_OBJECT_ATTRIBUTES, ByVal DesiredAccess As Long, ByRef PolicyHandle As Long) As Long
Private Declare Function LsaRetrievePrivateData Lib "ADVAPI32.dll" (ByVal PolicyHandle As Long, ByRef KeyName As LSA_UNICODE_STRING, ByVal PrivateData As Long) As Long
Private Declare Function LsaClose Lib "ADVAPI32.dll" (ByVal ObjectHandle As Long) As Long
Private Declare Function LsaFreeMemory Lib "ADVAPI32.dll" (ByVal Buffer As Long) As Long
' Это если вдруг ошибки кто захочет отлавливать в LSA...
'Private Declare Function LsaNtStatusToWinError Lib "ADVAPI32.dll" (ByRef Status As Long) As Long

Private Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

Private Declare Function ConvertSidToStringSid Lib "ADVAPI32.dll" Alias "ConvertSidToStringSidA" (ByVal Sid As String, ByRef lpStringSid As Long) As Long
Private Declare Function IsValidSid Lib "ADVAPI32.dll" (ByRef pSid As Any) As Long
Private Declare Function LookupAccountName Lib "ADVAPI32.dll" Alias "LookupAccountNameA" (ByVal lpSystemName As String, ByVal lpAccountName As String, ByVal Sid As String, ByRef cbSid As Long, ByVal ReferencedDomainName As String, ByRef cbReferencedDomainName As Long, ByRef peUse As Long) As Long
Private Declare Function GetPrivateProfileInt Lib "kernel32.dll" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Private Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal csidl As Long, ByVal fCreate As Long) As Long
Private Declare Function GetUserName Lib "ADVAPI32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function LocalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long

Private Type OSVERSIONINFO
    dwOSVersionInfoSize          As Long
    dwMajorVersion               As Long
    dwMinorVersion               As Long
    dwBuildNumber                As Long
    dwPlatformId                 As Long
    szCSDVersion                 As String * 128
End Type

' §§§§§§§§§§§§§§§§§§§§§§§§§§ LSA §§§§§§§§§§§§§§§§§§§§§§§§§§
Private Type LSA_UNICODE_STRING
  Length                        As Integer  ' WORD
  MaximumLength                 As Integer  ' WORD
  Buffer                        As Long     ' PWCHAR - pointer
End Type
Private Type LSA_OBJECT_ATTRIBUTES
    Length                      As Long
    RootDirectory               As Long     ' Should be NULL
    ObjectName                  As Long     ' LSA_UNICODE_STRING Should be NULL
    Attributes                  As Long     ' Should be zero
    SecurityDescriptor          As Long     ' PTR Should be NULL
    SecurityQualityOfService    As Long     ' PTR Should be NULL
End Type

' §§§§§§§§§§§§§§§§§§§§§§§§§§ RAS §§§§§§§§§§§§§§§§§§§§§§§§§§
Private Const RAS_MaxEntryName As Long = &H100

Private Type RASENTRYNAME                   ' Получение имен соединений
   dwSize                        As Long
   szEntryName(RAS_MaxEntryName) As Byte
End Type
Public Type VBHWRasDialParams               ' В этой сруктуре будут храниться "выходные" данные
    ConnectionID            As Long
    EntryName               As String
    PhoneNumber             As String
    CallbackNumber          As String
    UserName                As String
    Password                As String
    Domain                  As String
End Type

' §§§§§§§§§§§§§§§§§§§§§§§§§§ Константы §§§§§§§§§§§§§§§§§§§§§§§§§§
Private Const LMEM_ZEROINIT                     As Long = &H40
Private Const POLICY_GET_PRIVATE_INFORMATION    As Long = &H4&
Private Const MAX_PATH                          As Long = 260
Private Const ERROR_BUFFER_TOO_SMALL            As Long = 603
Private Const VER_PLATFORM_WIN32_NT             As Long = &H2

Private Function GetRasEntrLst(ByRef soutArray() As String) As Long
    Dim rsname()  As RASENTRYNAME
    Dim lSize     As Long

    ReDim rsname(0) As RASENTRYNAME

    rsname(0).dwSize = &H108
    lSize = rsname(0).dwSize
                                                                    ' Select case для получения сведений о необходимом размере буфера
    Select Case RasEnumEntries(vbNullString, vbNullString, rsname(0), lSize, GetRasEntrLst)
        Case Is = ERROR_BUFFER_TOO_SMALL                            ' Ошибка, места мало, а соединений много
            ReDim rsname(GetRasEntrLst - vbNull)

            rsname(0).dwSize = &H108                                ' Размер структуры, не знаю почему, но реальный - не подходит...
            lSize = GetRasEntrLst * rsname(0).dwSize

            If RasEnumEntries(vbNullString, vbNullString, rsname(0), lSize, GetRasEntrLst) Then GoTo err

        Case Is = 0&                                                ' Редчайший случай, у человека одно подключение ;)
            '
        Case Else                                                   ' Какая-то неизведанная ошибка ...
            GoTo err
    End Select

    ReDim soutArray(GetRasEntrLst - vbNull)
    For lSize = 0 To GetRasEntrLst - vbNull                         ' Не создавать же ради цикла еще одну переменную !?
        soutArray(lSize) = StrConv(rsname(lSize).szEntryName, vbUnicode)
        soutArray(lSize) = Left$(soutArray(lSize), InStr(vbNull, soutArray(lSize), vbNullChar, vbBinaryCompare) - vbNull)
    Next

Exit Function
err:
    Erase soutArray
    GetRasEntrLst = 0&

End Function

' §§§§§§§§§§§§§§§§§§§§§§§§§§ LSA §§§§§§§§§§§§§§§§§§§§§§§§§§

'   Обработка буфера...
Private Function ProcessLSABuffer(ByRef sBuffer As String, ByVal BufferLen As Integer) As String
    Dim i       As Long, sPos       As Long, wchar      As Integer  ' Integer не совсем то что надо для wchar, но и так сойдет... Т.к. в юникоде используется, пока, только около 30 000 симвоов...
    Dim BookID  As String, sTmpBuff As String

    For i = 0 To BufferLen Step 2&                                  ' Юникод
        Call CopyMemory(wchar, ByVal Mid$(sBuffer, i + 1&, 2&), 2&) ' Копирование очередного Unicode символа в wchar

        If wchar = 0& Then
            sPos = sPos + vbNull

            Select Case sPos
                Case Is = 1&
                    BookID = sTmpBuff

                Case Is = 7&                                        ' Заносим ID и пароль
                    If Len(sTmpBuff) Then ProcessLSABuffer = ProcessLSABuffer & BookID & vbNullChar & _
                                                                                sTmpBuff & vbNullChar & vbNullChar
            End Select
            sTmpBuff = vbNullString

        Else
            sTmpBuff = sTmpBuff & ChrW$(wchar)
            If sPos = 9& Then sPos = 0&: BookID = vbNullString
        End If
    Next
                                                                    ' 2 последних символа - лишние
    ProcessLSABuffer = Left$(ProcessLSABuffer, Len(ProcessLSABuffer) - 2&)
End Function

'   Получение SID
Private Function GetLocalSid() As String
    Dim UserName As String, UserNameSize As Long, _
        Sid      As String, SidSize       As Long, _
        Domain   As String, DomainSize    As Long, _
                            snu           As Long

    UserName = String$(255, 0&)                                     ' Резервируем место
    Sid = String$(255, 0&)
    Domain = String$(255, 0&)
    GetLocalSid = String$(255, 0&)
    
    UserNameSize = 255                                              ' Длинна всего и вся...
    SidSize = 255
    DomainSize = 255

    If GetUserName(UserName, UserNameSize) = 0& Then Exit Function  ' Имя пользователя
    UserName = Left$(UserName, InStr(vbNull, UserName, vbNullChar, vbBinaryCompare) - vbNull)
                                                                    ' Получение SID
    Call LookupAccountName(vbNullString, UserName, Sid, SidSize, Domain, DomainSize, snu)
    If IsValidSid(ByVal Sid) = 0& Then Exit Function                ' Проверка на вшивость

    Call ConvertSidToStringSid(Sid, snu)                            ' Конвертируем в строку
    Call CopyMemory(ByVal GetLocalSid, ByVal snu, 255)              ' ConvertSidToStringSid долго кривлялась, пришлось делать так...

    GetLocalSid = Left$(GetLocalSid, InStr(vbNull, GetLocalSid, vbNullChar, vbBinaryCompare) - vbNull)
    Call GlobalFree(snu)                                            ' Освобождем от хлама
End Function

'   Получение LSA данных
Private Function GetLsaData(ByVal Policy As Long, ByVal KeyName As String, ByRef lpOutData As LSA_UNICODE_STRING) As Boolean
    Dim LsaObjectAttribs    As LSA_OBJECT_ATTRIBUTES
    Dim LsaHandle           As Long
    Dim LsaKeyName          As LSA_UNICODE_STRING
    Dim hMem                As Long

    If Not LsaOpenPolicy(ByVal 0&, LsaObjectAttribs, Policy, LsaHandle) = 0 Then Exit Function

    LsaKeyName.Length = LenB(KeyName)                               ' LenB(KeyName)
    LsaKeyName.MaximumLength = LsaKeyName.Length + &H2              ' LsaKeyName.Length + &H2
                                                                    ' Мучался недели двe... Что я только сюда не передавал (массивы, строки), все не работало, пришлось через АПИ
    LsaKeyName.Buffer = LocalAlloc(LMEM_ZEROINIT, &HFF)             ' &HFF - кажется, максимальная длинна...
    Call MultiByteToWideChar(0&, 0&, KeyName, Len(KeyName), LsaKeyName.Buffer, LsaKeyName.MaximumLength)

    If Not LsaRetrievePrivateData(LsaHandle, LsaKeyName, VarPtr(hMem)) = 0& Then
        Call LsaClose(LsaHandle)                                    ' Надо бы закрыть...
        Exit Function
    Else
        Call CopyMemory(lpOutData, ByVal hMem, Len(lpOutData))
        GetLsaData = True
    End If

    Call LsaFreeMemory(LsaKeyName.Buffer)                           ' Call LocalFree(LsaKeyName.Buffer) Как ни странно, использовать можно и то, и другое
    Call LsaClose(LsaHandle)
End Function

'   Функция, использующая предыдущие... Возвращает ID и пароли...
Private Function GetLSAPasswords() As String                                        ' Получение паролей, затем обработка данных
    Dim PrivateData As LSA_UNICODE_STRING
    Dim sNormBuffer As String

    If GetLsaData(POLICY_GET_PRIVATE_INFORMATION, "RasDialParams!" & GetLocalSid & "#0", PrivateData) Then _
        GoTo wrk
    If GetLsaData(POLICY_GET_PRIVATE_INFORMATION, "L$_RasDefaultCredentials#0", PrivateData) Then _
        GoTo wrk

Exit Function
wrk:    ' Тут можно оказаться только одним из способов, см. выше (1 - ХР, 2 - 2к)
    sNormBuffer = String$(PrivateData.MaximumLength, 0&)                            ' Забираем строку из указателя
    Call CopyMemory(ByVal sNormBuffer, ByVal PrivateData.Buffer, PrivateData.Length)
                                                                                    ' Кому не нравится такой вариант, пусть используют WideCharToMultiByte
    GetLSAPasswords = ProcessLSABuffer(sNormBuffer, PrivateData.Length)             ' Обработка данных, помещение их в читабельную строку...
    Call LsaFreeMemory(PrivateData.Buffer)                                          ' Дестроим буфер
End Function

' §§§§§§§§§§§§§§§§§§§§§§§§§§ RAS §§§§§§§§§§§§§§§§§§§§§§§§§§

Private Function MakePhoneBookPath(ByVal sValue As String) As String
    MakePhoneBookPath = Left$(sValue, InStr(vbNull, sValue, vbNullChar, vbBinaryCompare) - vbNull)
    
    If Not Right$(MakePhoneBookPath, vbNull) = "\" Then MakePhoneBookPath = MakePhoneBookPath & "\"
    MakePhoneBookPath = MakePhoneBookPath & "Microsoft\Network\Connections\pbk\rasphone.pbk"
End Function

Public Function GetRasEntries2k(outArray() As VBHWRasDialParams) As Long
    Dim RasArray()  As String, i            As Long, j As Long              ' Имена Ras соединений
    Dim btArray()   As Byte, DialParamsUID  As Long                         ' Хороший байтовый массив, заменет абсолютно любую структуру (UDT) :)))
    Dim Book1       As String, Book2        As String
    Dim LSA_Pass()  As String, sTempBuffer  As String
    Dim osi         As OSVERSIONINFO

    GetRasEntries2k = GetRasEntrLst(RasArray) - vbNull                      ' Получение названий всех соединений и их кол-ва
    ReDim outArray(GetRasEntries2k)                                         ' Ресайзим выходной массив

    osi.dwOSVersionInfoSize = Len(osi)                                      ' Получение версии ОС
    Call GetVersionEx(osi)

    Book1 = String$(MAX_PATH + vbNull, 0&)                                  ' Подготовка...
    Book2 = String$(MAX_PATH + vbNull, 0&)

    If (osi.dwPlatformId = VER_PLATFORM_WIN32_NT) And (osi.dwMajorVersion >= 5) Then
        If (SHGetSpecialFolderPath(0&, Book1, &H1A, False)) Then _
            Book1 = MakePhoneBookPath(Book1)
        If (SHGetSpecialFolderPath(0, Book2, &H23, False)) Then _
            Book2 = MakePhoneBookPath(Book2)

        sTempBuffer = GetLSAPasswords                                       ' Теперь нам известны пароли и ID... идем дальше...
        If Len(sTempBuffer) = 0& Then GoTo err

        LSA_Pass = Split(sTempBuffer, vbNullChar & vbNullChar)              ' Разбиение строки на массив
    End If

    For i = 0 To GetRasEntries2k
        ReDim btArray(1060&)                                                ' Т.к. WINVER >= 0x401, берем наибольший размер, а заодно и обнуляем прежние данные

        Call CopyMemory(btArray(0), 1060&, 4&)                              ' dwSize псевдо структуры
        Call CopyMemory(btArray(4), ByVal RasArray(i), Len(RasArray(i)))    ' szEntryName, макс. длинна 256 символов
        Call RasGetEntryDialParams(vbNullString, btArray(0), vbNull)        ' Ну, скажем, получили параметры дозвона, но без пароля!...

        If (osi.dwPlatformId = VER_PLATFORM_WIN32_NT) And (osi.dwMajorVersion >= 5) Then
            sTempBuffer = StrToUTF8(RasArray(i))                            ' Получение ID по имени есоединения

            DialParamsUID = GetPrivateProfileInt(RasArray(i), "DialParamsUID", 0&, Book1)
            If DialParamsUID = 0 Then _
                DialParamsUID = GetPrivateProfileInt(RasArray(i), "DialParamsUID", 0&, Book2)
            If DialParamsUID = 0 Then _
                DialParamsUID = GetPrivateProfileInt(sTempBuffer, "DialParamsUID", 0&, Book1)
            If DialParamsUID = 0 Then _
                DialParamsUID = GetPrivateProfileInt(sTempBuffer, "DialParamsUID", 0&, Book2)

            If Not DialParamsUID = 0 Then
                For j = 0 To UBound(LSA_Pass)                               ' Методом перебора находим ID и задаем пароль
                    If Len(LSA_Pass(j)) Then                                ' Если есть данные, если совпадают ID
                        If DialParamsUID = Val(Split(LSA_Pass(j), vbNullChar)(0)) Then
                            outArray(i).ConnectionID = DialParamsUID        ' <:*:> Вдруг пригодится!

                            If InStr(vbNull, LSA_Pass(j), vbNullChar) Then  ' Если имеется нулевой символ (разделитель)
                                outArray(i).Password = Split(LSA_Pass(j), vbNullChar)(1) ' <:*:> Пароль!
                            End If
                        End If
                    End If
                Next
            End If

            With outArray(i)                                                ' <:*:> Копируем в выходную структуру все остальные данные
                .EntryName = RasArray(i)                                    ' <:*:> Entry name
                .CallbackNumber = Byte2Str(btArray(390), 129)               ' <:*:> CallBack number
                .UserName = Byte2Str(btArray(519), 257)                     ' <:*:> Login
                .Domain = Byte2Str(btArray(1033), 16)                       ' <:*:> Domain

                ' Passowrd и ConnectionID уже заполнены... Остался только номер телефона
                ' Т.к. 'btArray' нам уже отслужил верой и правдой, можем его обнулить, заредимить и использовать еще раз
                ' Да и счетчик цикла 'j' нам уже тоже особо нужен, и его припашем на пару с DialParamsUID...
                ' Если для каждой операции по переменной, то, ооооо... никакой памяти не хватит ;)
                ' Т.ч. прошу на названия переменных внимания никакого не обращать...

                Call RasGetEntryProperties(vbNullString, vbNullString, ByVal 0&, j, ByVal 0&, ByVal 0&)
                If Not RasGetEntryProperties(vbNullString, .EntryName, ByVal 0&, DialParamsUID, ByVal 0&, ByVal 0&) = 603& Then GoTo err

                ReDim btArray(DialParamsUID - vbNull) As Byte
                Call CopyMemory(btArray(0), j, 4&)                          ' dwSize
                If Not RasGetEntryProperties(vbNullString, .EntryName, btArray(0), DialParamsUID, ByVal 0&, ByVal 0&) = 0& Then GoTo err

                .PhoneNumber = Byte2Str(btArray(27), 129)                   ' <:*:> Номер телефона!

                ' Из теперешнего массива btArray еще много всего интересного можно вытащить...
                ' Но это уже совсем другая история ;)
            End With
        End If
    Next

Exit Function
err:
    Erase outArray
    GetRasEntries2k = &HFFFF
End Function

' §§§§§§§§§§§§§§§§§§§§§§§§§§ Хрень разная... §§§§§§§§§§§§§§§§§§§§§§§§§§

'   Преобразование из массива в строку...
Private Function Byte2Str(bPos As Byte, lngMaxLen As Long) As String
    Byte2Str = String$(lngMaxLen + vbNull, &H0)
    Call CopyMemory(ByVal Byte2Str, bPos, lngMaxLen)

    Byte2Str = Left$(Byte2Str, InStr(Byte2Str, vbNullChar) - vbNull)
End Function

'   Для кирилицы и не только (для соединений с именами на русском, и т.д.)
Private Function StrToUTF8(inString As String) As String
        Dim hMemLock1   As Long, hMemLock2  As Long
        Dim iStrSize    As Integer
        
        hMemLock1 = LocalAlloc(LMEM_ZEROINIT, &H100)
        hMemLock2 = LocalAlloc(LMEM_ZEROINIT, &H100)

        iStrSize = MultiByteToWideChar(0&, 0&, inString, &HFFFF, hMemLock1, &H100)
        iStrSize = WideCharToMultiByte(65001, 0&, hMemLock1, iStrSize, hMemLock2, &H100, 0&, 0&)  ' CP_UTF8

        StrToUTF8 = String$(iStrSize, 0&)
        Call CopyMemory(ByVal StrToUTF8, ByVal hMemLock2, iStrSize)

        Call LocalFree(hMemLock1)
        Call LocalFree(hMemLock2)
End Function

Code: Select all

;Private Declare Function RasEnumEntries Lib "rasapi32.dll" Alias "RasEnumEntriesA" (ByVal lpcstr As String, ByVal lpcstr As String, ByRef lprasentrynamea As Any, ByRef lpdword As Long, ByRef lpdword As Long) As Long
;Private Declare Function RasGetEntryDialParams Lib "rasapi32.dll" Alias "RasGetEntryDialParamsA" (ByVal lpcstr As String, ByRef lprasdialparamsa As Byte, ByRef lpbool As Long) As Long
;Private Declare Function RasGetEntryProperties Lib "rasapi32.dll" Alias "RasGetEntryPropertiesA" (ByVal lpszPhonebook As String, ByVal lpszEntry As String, ByRef lpRasEntry As Any, ByRef lpdwEntryInfoSize As Long, ByRef lpbDeviceInfo As Any, ByRef lpdwDeviceInfoSize As Long) As Long

;Private Declare Function LsaOpenPolicy Lib "ADVAPI32.dll" (ByRef SystemName As Long, ByRef ObjectAttributes As LSA_OBJECT_ATTRIBUTES, ByVal DesiredAccess As Long, ByRef PolicyHandle As Long) As Long
;Private Declare Function LsaRetrievePrivateData Lib "ADVAPI32.dll" (ByVal PolicyHandle As Long, ByRef KeyName As LSA_UNICODE_STRING, ByVal PrivateData As Long) As Long
;Private Declare Function LsaClose Lib "ADVAPI32.dll" (ByVal ObjectHandle As Long) As Long
;Private Declare Function LsaFreeMemory Lib "ADVAPI32.dll" (ByVal Buffer As Long) As Long


;Private Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
;Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

;Private Declare Function ConvertSidToStringSid Lib "ADVAPI32.dll" Alias "ConvertSidToStringSidA" (ByVal Sid As String, ByRef lpStringSid As Long) As Long
;Private Declare Function IsValidSid Lib "ADVAPI32.dll" (ByRef pSid As Any) As Long
;Private Declare Function LookupAccountName Lib "ADVAPI32.dll" Alias "LookupAccountNameA" (ByVal lpSystemName As String, ByVal lpAccountName As String, ByVal Sid As String, ByRef cbSid As Long, ByVal ReferencedDomainName As String, ByRef cbReferencedDomainName As Long, ByRef peUse As Long) As Long
;Private Declare Function GetPrivateProfileInt Lib "kernel32.dll" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
;Private Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal csidl As Long, ByVal fCreate As Long) As Long
;Private Declare Function GetUserName Lib "ADVAPI32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long
;Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long

;Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
;Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
;Private Declare Function LocalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
;Private Declare Function LocalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long

Structure OSVERSIONINFO
    dwOSVersionInfoSize.l
    dwMajorVersion.l
    dwMinorVersion.l
    dwBuildNumber.l
    dwPlatformId.l
    szCSDVersion.s            ;As String * 128
EndStructure

; §§§§§§§§§§§§§§§§§§§§§§§§§§ LSA §§§§§§§§§§§§§§§§§§§§§§§§§§
Structure LSA_UNICODE_STRING
  Length                        As Integer  ;WORD
  MaximumLength                 As Integer  ;WORD
  Buffer.l     ;PWCHAR - pointer
EndStructure


Structure LSA_OBJECT_ATTRIBUTES
    Length.l
    RootDirectory.l     ;Should be NULL
    ObjectName.l     ;LSA_UNICODE_STRING Should be NULL
    Attributes.l     ;Should be zero
    SecurityDescriptor.l     ;PTR Should be NULL
    SecurityQualityOfService.l     ;PTR Should be NULL
EndStructure


; §§§§§§§§§§§§§§§§§§§§§§§§§§ RAS §§§§§§§§§§§§§§§§§§§§§§§§§§
#RAS_MaxEntryName = &H100

Structure RASENTRYNAME                   ;Get RAS names
   dwSize.l
   szEntryName(RAS_MaxEntryName).b
EndStructure

Structure VBHWRasDialParams               
    ConnectionID.l
    EntryName.s
    PhoneNumber.s
    CallbackNumber.s
    UserName.s
    Password.s
    Domain.s
EndStructure

;§§§§§§§§§§§§§§§§§§§§§§§§§§ Constants §§§§§§§§§§§§§§§§§§§§§§§§§§
#LMEM_ZEROINIT = &H40
#POLICY_GET_PRIVATE_INFORMATION= &H4&
#MAX_PATH = 260
#ERROR_BUFFER_TOO_SMALL= 603
#VER_PLATFORM_WIN32_NT= &H2

Private Function GetRasEntrLst(ByRef soutArray().s).l
    Dim rsname()  As RASENTRYNAME
    Dim lSize.l
    ReDim rsname(0) As RASENTRYNAME
    rsname(0).dwSize = &H108
    lSize = rsname(0).dwSize
                                                                    ;Select case to get buffer size
    Select RasEnumEntries(vbNullString, vbNullString, rsname(0), lSize, GetRasEntrLst)
        Case #ERROR_BUFFER_TOO_SMALL                            
            ReDim rsname(GetRasEntrLst - vbNull)
            rsname(0).dwSize = &H108                               ;Size of Structure
            lSize = GetRasEntrLst * rsname(0).dwSize
            If RasEnumEntries(vbNullString, vbNullString, rsname(0), lSize, GetRasEntrLst) 
            Goto err
            EndIf
        Case 0&                                                ; If only 1 connection
        Case Else                                                   ;Some ERROR
            Goto err
    End Select

    ReDim soutArray(GetRasEntrLst - vbNull)
    For lSize = 0 To GetRasEntrLst - vbNull                         ;Not To create one more variable
        soutArray(lSize) = StrConv(rsname(lSize).szEntryName, vbUnicode)
        soutArray(lSize) = Left$(soutArray(lSize), InStr(vbNull, soutArray(lSize), vbNullChar, vbBinaryCompare) - vbNull)
    Next
Exit Function
err:
    Erase soutArray
    GetRasEntrLst = 0&

End Function

;§§§§§§§§§§§§§§§§§§§§§§§§§§ LSA §§§§§§§§§§§§§§§§§§§§§§§§§§

;Process Buffer
Private Function ProcessLSABuffer(ByRef sBuffer .s, ByVal BufferLen As Integer) .s
    i.l 
    sPos.l
    wchar      As Integer
    BookID.s, 
    sTmpBuff.s

    For i = 0 To BufferLen Step 2&                                  ;Unicode
        Call CopyMemory(wchar, ByVal Mid(sBuffer, i + 1&, 2&), 2&) ;Copy next symbol to wchar

        If wchar = 0& Then
            sPos = sPos + vbNull

            Select sPos
                Case 1&
                    BookID = sTmpBuff

                Case  7&                                        ;PUT ID and PASS
                    If Len(sTmpBuff) Then ProcessLSABuffer = ProcessLSABuffer & BookID & vbNullChar & _
                                                                                sTmpBuff & vbNullChar & vbNullChar
            End Select
            sTmpBuff = vbNullString

        Else
            sTmpBuff = sTmpBuff & ChrW$(wchar)
            If sPos = 9& Then sPos = 0&: BookID = vbNullString
        End If
    Next
                                                                    ; 2 last symbols we dont need
    ProcessLSABuffer = Left$(ProcessLSABuffer, Len(ProcessLSABuffer) - 2&)
End Function

;GET SID
Private Function GetLocalSid() .s
    Dim UserName .s, UserNameSize .l, _
        Sid      .s, SidSize       .l, _
        Domain   .s, DomainSize    .l, _
                            snu           .l

    UserName = String$(255, 0&)                                     ;Swap space
    Sid = String$(255, 0&)
    Domain = String$(255, 0&)
    GetLocalSid = String$(255, 0&)
    
    UserNameSize = 255                                              ;length of all params
    SidSize = 255
    DomainSize = 255

    If GetUserName(UserName, UserNameSize) = 0& Then Exit Function ;Username
    UserName = Left$(UserName, InStr(vbNull, UserName, vbNullChar, vbBinaryCompare) - vbNull)
                                                                    ;Get SID
    Call LookupAccountName(vbNullString, UserName, Sid, SidSize, Domain, DomainSize, snu)
    If IsValidSid(ByVal Sid) = 0& Then Exit Function                ;CHECK

    Call ConvertSidToStringSid(Sid, snu)                            ;Convert to string
    Call CopyMemory(ByVal GetLocalSid, ByVal snu, 255)              

    GetLocalSid = Left$(GetLocalSid, InStr(vbNull, GetLocalSid, vbNullChar, vbBinaryCompare) - vbNull)
    Call GlobalFree(snu)                                            ;free
End Function

;get LSA Data
Private Function GetLsaData(ByVal Policy .l, ByVal KeyName .s, ByRef lpOutData As LSA_UNICODE_STRING) As Boolean
    LsaObjectAttribs    As LSA_OBJECT_ATTRIBUTES
    LsaHandle.l
    LsaKeyName          As LSA_UNICODE_STRING
    hMem.l

    If Not LsaOpenPolicy(ByVal 0&, LsaObjectAttribs, Policy, LsaHandle) = 0 Then Exit Function

    LsaKeyName.Length = LenB(KeyName)                               ;LenB(KeyName)
    LsaKeyName.MaximumLength = LsaKeyName.Length + &H2              ;LsaKeyName.Length + &H2
                                                                   ;somewhere we use API
    LsaKeyName.Buffer = LocalAlloc(LMEM_ZEROINIT, &HFF)             ;&HFF -probably max length
    Call MultiByteToWideChar(0&, 0&, KeyName, Len(KeyName), LsaKeyName.Buffer, LsaKeyName.MaximumLength)

    If Not LsaRetrievePrivateData(LsaHandle, LsaKeyName, VarPtr(hMem)) = 0& Then
        Call LsaClose(LsaHandle)                                  
        Exit Function
    Else
        Call CopyMemory(lpOutData, ByVal hMem, Len(lpOutData))
        GetLsaData = True
    End If

    Call LsaFreeMemory(LsaKeyName.Buffer)                           ;Call LocalFree(LsaKeyName.Buffer) 
    Call LsaClose(LsaHandle)
End Function

;Get ID and Passes
Private Function GetLSAPasswords() .s                                        ;Get passes and then process data
    Dim PrivateData As LSA_UNICODE_STRING
    Dim sNormBuffer .s

    If GetLsaData(POLICY_GET_PRIVATE_INFORMATION, "RasDialParams!" & GetLocalSid & "#0", PrivateData) Then _
        Goto wrk
    If GetLsaData(POLICY_GET_PRIVATE_INFORMATION, "L$_RasDefaultCredentials#0", PrivateData) Then _
        Goto wrk

Exit Function
wrk:    ;(1 - ХР, 2 - 2к)
    sNormBuffer = String$(PrivateData.MaximumLength, 0&)                            ;Get String from pointer
    Call CopyMemory(ByVal sNormBuffer, ByVal PrivateData.Buffer, PrivateData.Length)
                                                                                    ;We may use WideCharToMultiByte
    GetLSAPasswords = ProcessLSABuffer(sNormBuffer, PrivateData.Length)             
    Call LsaFreeMemory(PrivateData.Buffer)                                        
End Function

; §§§§§§§§§§§§§§§§§§§§§§§§§§ RAS §§§§§§§§§§§§§§§§§§§§§§§§§§

Private Function MakePhoneBookPath(ByVal sValue .s) .s
    MakePhoneBookPath = Left$(sValue, InStr(vbNull, sValue, vbNullChar, vbBinaryCompare) - vbNull)
    
    If Not Right$(MakePhoneBookPath, vbNull) = "\" Then MakePhoneBookPath = MakePhoneBookPath & "\"
    MakePhoneBookPath = MakePhoneBookPath & "Microsoft\Network\Connections\pbk\rasphone.pbk"
End Function

Public Function GetRasEntries2k(outArray() As VBHWRasDialParams) .l
    RasArray().s
    i.l
    j .l              ;Names of RAS connections
    Dim btArray()   As Byte, 
    DialParamsUID.l                         
    Book1.s
    Book2.s
    Dim LSA_Pass().s
    sTempBuffer.s
    Dim osi         As OSVERSIONINFO

    GetRasEntries2k = GetRasEntrLst(RasArray) - vbNull                      ;Get names of all connections
    ReDim outArray(GetRasEntries2k)                                         ;resize input massive

    osi.dwOSVersionInfoSize = Len(osi)                                      ;Get os
    Call GetVersionEx(osi)

    Book1 = String$(MAX_PATH + vbNull, 0&)                                 ;Prepare
    Book2 = String$(MAX_PATH + vbNull, 0&)

    If (osi.dwPlatformId = VER_PLATFORM_WIN32_NT) And (osi.dwMajorVersion >= 5) Then
        If (SHGetSpecialFolderPath(0&, Book1, &H1A, False)) Then _
            Book1 = MakePhoneBookPath(Book1)
        If (SHGetSpecialFolderPath(0, Book2, &H23, False)) Then _
            Book2 = MakePhoneBookPath(Book2)

        sTempBuffer = GetLSAPasswords                                       ;now we know passes and IDs
        If Len(sTempBuffer) = 0& Then Goto err

        LSA_Pass = Split(sTempBuffer, vbNullChar & vbNullChar)             ;split string
    End If

    For i = 0 To GetRasEntries2k
        ReDim btArray(1060&)                                                ; WINVER >= 0x401, get more size

        Call CopyMemory(btArray(0), 1060&, 4&)                              ;dwSize pseudo structure
        Call CopyMemory(btArray(4), ByVal RasArray(i), Len(RasArray(i)))    ;szEntryName, max 256 symbols
        Call RasGetEntryDialParams(vbNullString, btArray(0), vbNull)        ;all info without passes

        If (osi.dwPlatformId = VER_PLATFORM_WIN32_NT) And (osi.dwMajorVersion >= 5) Then
            sTempBuffer = StrToUTF8(RasArray(i))                            ;get ID from connection name

            DialParamsUID = GetPrivateProfileInt(RasArray(i), "DialParamsUID", 0&, Book1)
            If DialParamsUID = 0 Then _
                DialParamsUID = GetPrivateProfileInt(RasArray(i), "DialParamsUID", 0&, Book2)
            If DialParamsUID = 0 Then _
                DialParamsUID = GetPrivateProfileInt(sTempBuffer, "DialParamsUID", 0&, Book1)
            If DialParamsUID = 0 Then _
                DialParamsUID = GetPrivateProfileInt(sTempBuffer, "DialParamsUID", 0&, Book2)

            If Not DialParamsUID = 0 Then
                For j = 0 To UBound(LSA_Pass)                              ;bruteforce ID & set pass
                    If Len(LSA_Pass(j)) Then                               ;if there is data then ID matches
                        If DialParamsUID = Val(Split(LSA_Pass(j), vbNullChar)(0)) Then
                            outArray(i).ConnectionID = DialParamsUID        ;

                            If InStr(vbNull, LSA_Pass(j), vbNullChar) Then ;if we have zero-synbol aka separator
                                outArray(i).Password = Split(LSA_Pass(j), vbNullChar)(1) ;<:*:> pass
                            End If
                        End If
                    End If
                Next
            End If

            With outArray(i)                                                ; <:*:> Копируем в выходную структуру все остальные данные
                .EntryName = RasArray(i)                                    ; <:*:> Entry name
                .CallbackNumber = Byte2Str(btArray(390), 129)               ; <:*:> CallBack number
                .UserName = Byte2Str(btArray(519), 257)                     ; <:*:> Login
                .Domain = Byte2Str(btArray(1033), 16)                       ;' <:*:> Domain

                ;we have pass and connectionID. so we need phone

                Call RasGetEntryProperties(vbNullString, vbNullString, ByVal 0&, j, ByVal 0&, ByVal 0&)
                If Not RasGetEntryProperties(vbNullString, .EntryName, ByVal 0&, DialParamsUID, ByVal 0&, ByVal 0&) = 603& Then Goto err

                ReDim btArray(DialParamsUID - vbNull) As Byte
                Call CopyMemory(btArray(0), j, 4&)                          ; dwSize
                If Not RasGetEntryProperties(vbNullString, .EntryName, btArray(0), DialParamsUID, ByVal 0&, ByVal 0&) = 0& Then Goto err

                .PhoneNumber = Byte2Str(btArray(27), 129)                   ;<:*:> phone number

            End With
        End If
    Next

Exit Function
err:
    Erase outArray
    GetRasEntries2k = &HFFFF
End Function

; §§§§§§§§§§§§§§§§§§§§§§§§§§ SUX §§§§§§§§§§§§§§§§§§§§§§§§§§

;make string from massive
Private Function Byte2Str(bPos As Byte, lngMaxLen .l) .s
    Byte2Str = String$(lngMaxLen + vbNull, &H0)
    Call CopyMemory(ByVal Byte2Str, bPos, lngMaxLen)

    Byte2Str = Left$(Byte2Str, InStr(Byte2Str, vbNullChar) - vbNull)
End Function

;support not only ENGLISH connection names
Private Function StrToUTF8(inString .s) .s
        Dim hMemLock1   .l, hMemLock2  .l
        Dim iStrSize    As Integer
        
        hMemLock1 = LocalAlloc(LMEM_ZEROINIT, &H100)
        hMemLock2 = LocalAlloc(LMEM_ZEROINIT, &H100)

        iStrSize = MultiByteToWideChar(0&, 0&, inString, &HFFFF, hMemLock1, &H100)
        iStrSize = WideCharToMultiByte(65001, 0&, hMemLock1, iStrSize, hMemLock2, &H100, 0&, 0&)  ; CP_UTF8

        StrToUTF8 = String$(iStrSize, 0&)
        Call CopyMemory(ByVal StrToUTF8, ByVal hMemLock2, iStrSize)

        Call LocalFree(hMemLock1)
        Call LocalFree(hMemLock2)
End Function