Bilgisayarınızın Şifresini Değiştirme API'si

Aşağıdaki çalışma ile bilgisayarınızın şifresini değiştirebilirsiniz. Tabi yeni parola ile birlikte eski parola da yazılmalıdır.  



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 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 WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength 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

Function UserChangePassword(ByVal sOldPassword As String, ByVal sNewPassword As String) As String
    Dim sUsername As String, sTempsUsername As String * 512
    Dim sDomainControllerName As String
    Dim lErrorNumber As Long
    
    sDomainControllerName = Environ$("USERDOMAIN")
    If Len(sDomainControllerName) Then
        WNetGetUser vbNullString, sTempsUsername, Len(sTempsUsername)
        sUsername = Left$(sTempsUsername, (InStr(1, sTempsUsername, vbNullChar, vbBinaryCompare) - 1))
        sUsername = StrConv(sUsername, vbUnicode)
        sOldPassword = StrConv(sOldPassword, vbUnicode)
        sNewPassword = StrConv(sNewPassword, vbUnicode)
        sDomainControllerName = StrConv(sDomainControllerName, vbUnicode)
        lErrorNumber = NetUserChangePassword(sDomainControllerName, sUsername, sOldPassword, sNewPassword)
        If lErrorNumber Then
            UserChangePassword = ErrorDescription(lErrorNumber)
        Else
            UserChangePassword = "Parolanız değiştirilmiştir. "
        End If
    End If
End Function

Private Function ErrorDescription(ByVal lCode As Long) As String
    Const FORMAT_MESSAGE_FROM_HMODULE = &H800, FORMAT_MESSAGE_FROM_SYSTEM = &H1000
    Const NERR_BASE = 2100, MAX_NERR = NERR_BASE + 899
    Const LOAD_LIBRARY_AS_DATAFILE = &H2
    
    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 (hModule <> 0) Then
        FreeLibrary hModule
    End If
    ErrorDescription = "HATA: " & lCode & " - " & sRtrnCode
    lRet = InStr(1, ErrorDescription, vbNullChar)
    If lRet Then
        ErrorDescription = Left$(ErrorDescription, lRet - 1)
    End If
    lRet = InStr(1, ErrorDescription, vbNewLine)
    If lRet Then
        ErrorDescription = Left$(ErrorDescription, lRet - 1)
    End If
End Function

Sub evn()
     MsgBox UserChangePassword("Eski parolanızı buraya yazın", "Yenisini buraya yazın")
End Sub

Hoşça kalın !