Změna hesla ve Windows NT

Postup:
Založte nový projekt a na formulář přidejte následující komponenty:

Prvek	Popis
Label1	Jméno:
Label2	Doména:
Label3	Staré heslo:
Label4	Nové heslo:
txtUser
txtMachine
txtOld
txtNew
cmdOk	&Ok
cmdClose	&Storno

Pro TextBoxy nastavte PasswordChar na "*". nyní zapište následující kód:

    Option Explicit

    Const FORMAT_MESSAGE_FROM_HMODULE = &H800
    Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

    Const NERR_BASE = 2100
    Const MAX_NERR = NERR_BASE + 899 
    Const LOAD_LIBRARY_AS_DATAFILE = &H2

    Private Declare Function LoadLibraryEx Lib "kernel32" Alias  _
       "LoadLibraryExA" (ByVal lpLibFileName As String, _
       ByVal hFile As Long, ByVal dwFlags As Long) As Long

    Private Declare Function FreeLibrary Lib "kernel32" _
       (ByVal hLibModule As Long) As Long

    Private Declare Function NetApiBufferFree& Lib "netapi32" _
       (ByVal Buffer As Long)

    Private Declare Sub lstrcpyW Lib "kernel32" _
       (dest As Any, ByVal src As Any)

    Private Declare Function FormatMessage Lib "kernel32" Alias _
       "FormatMessageA" (ByVal dwFlags As Long, _
       ByVal lpSource As Long, _
       ByVal dwMessageId As Long, _
       ByVal dwLanguageId As Long, ByVal lpBuffer As String, _
       ByVal nSize As Long, Arguments As Any) As Long

    Private Declare Function NetUserSetInfo Lib "netapi32.dll" _
       (ByVal ServerName As String, ByVal Username As String, _
       ByVal Level As Long, UserInfo As Any, ParmError As Long) As Long

    Private Declare Function NetGetDCName Lib "netapi32.dll" ( _
       ServerName As Long, domainname As Byte, bufptr As Long) As Long

    Private Declare Function NetUserChangePassword Lib "netapi32.dll" ( _
       ByVal domainname As String, ByVal Username As String, _
       ByVal OldPassword As String, ByVal NewPassword As String) As Long

    Private Type USER_INFO_1003
       usri1003_password As Long
    End Type

    Private Sub cmdClose_Click()
      Unload Me
    End Sub

    Private Sub cmdOK_Click()

      Dim sServer As String, sUser As String
      Dim sNewPass As String, sOldPass As String
      Dim UI1003 As USER_INFO_1003
      Dim dwLevel As Long
      Dim lRet As String
      Dim sNew As String

      MousePointer = vbHourglass
      sUser = StrConv(txtUser, vbUnicode)
      sNewPass = StrConv(txtNew, vbUnicode)

      If Left(txtMachine, 2) = "\\" Then
        sServer = StrConv(txtMachine, vbUnicode)
      Else
        sServer = StrConv(GetPrimaryDCName(txtMachine), vbUnicode)
      End If

      If txtOld = "" Then
         dwLevel = 1003
         sNew = txtNew
         UI1003.usri1003_password = StrPtr(sNew)
         lRet = NetUserSetInfo(sServer, sUser, dwLevel, UI1003, 0&)
      Else
         sOldPass = StrConv(txtOld, vbUnicode)
         lRet = NetUserChangePassword(sServer, sUser, sOldPass, sNewPass)
      End If

      MousePointer = vbDefault
      If lRet <> 0 Then
         DisplayError lRet
      Else
         MsgBox "Změna hesla proběhla úspěšně."
      End If

    End Sub

    Private Sub DisplayError(ByVal lCode As Long)

       Dim sMsg As String
       Dim sRtrnCode As String
       Dim lFlags As Long
       Dim hModule As Long
       Dim lRet As Long

        hModule = 0
        sRtrnCode = Space$(256)
        lFlags = FORMAT_MESSAGE_FROM_SYSTEM

         If (lCode >= NERR_BASE And lCode <= MAX_NERR) Then
            hModule = LoadLibraryEx("netmsg.dll", 0&, _
                      LOAD_LIBRARY_AS_DATAFILE)

            If (hModule <> 0) Then
                lFlags = lFlags Or FORMAT_MESSAGE_FROM_HMODULE
            End If

         End If

        lRet = FormatMessage(lFlags, hModule, lCode, 0&, _
                             sRtrnCode, 256&, 0&)
        If lRet = 0 Then
           MsgBox "Chyba : "  & Err.LastDllError
        End If

        If (hModule <> 0) Then
          FreeLibrary (hModule)
        End If

        sMsg = "Chyba: " & lCode & " - " & sRtrnCode

     MsgBox sMsg

    End Sub

    Public Function GetPrimaryDCName(ByVal DName As String) As String

       Dim DCName As String, DCNPtr As Long
       Dim DNArray() As Byte, DCNArray(100) As Byte
       Dim result As Long

       DNArray = DName & vbNullChar
       result = NetGetDCName(0&, DNArray(0), DCNPtr)
       If result <> 0 Then
          Msgbox "Chyba: " & result
          Exit Function
       End If
       lstrcpyW DCNArray(0), DCNPtr
       result = NetApiBufferFree(DCNPtr)
       DCName = DCNArray()
       GetPrimaryDCName = Left(DCName, InStr(DCName, Chr(0)) - 1)

    End Function 

Zpět