Modulos utiles a la hora de programar en vb6

Hola aca dejo algunos módulos que son bastantes útiles a la hora de programar, modificar registro de windows, detectar version de windows, capturas de pantalla y escalar privilegios en win XP, NT, etc:


====================================================================================
Detectar versión, devolver revisión y compilación:

====================================================================================
Option Explicit
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
wSPMajor As Integer
End Type

Public Enum EnumWinVer
Win95 = 0
Win95OSR2 = 1
Win98 = 2
Win98SE = 3
WinME = 4
WinNT3_0 = 5
WinNT3_1 = 6
WinNT3_5 = 7
WinNT4 = 8
WinNT5 = 9
Win2k = 10
WinXP = 11
WinVista = 12
End Enum


Public Function Winversion(param As Integer) As EnumWinVer
Dim myVer As OSVERSIONINFO
Dim dl&
myVer.dwOSVersionInfoSize = 148
dl& = GetVersionEx&(myVer)
If param = 1 Then 'param=1 devuelve la versiòn de Windows (95, 98,ME, 2000, XP, Vista)
If myVer.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
If myVer.dwMajorVersion = 4 And myVer.dwMinorVersion = 0 Then
If myVer.dwBuildNumber = 950 Then
GetVersion = Win95
Else
GetVersion = Win95OSR2
End If
ElseIf myVer.dwMajorVersion = 4 And myVer.dwMinorVersion = 10 Then
If myVer.dwBuildNumber = 1998 Then
GetVersion = Win98
Else
GetVersion = Win98SE
End If
ElseIf myVer.dwMajorVersion >= 4 And myVer.dwMinorVersion > 10 Then
GetVersion = WinME
End If
ElseIf myVer.dwPlatformId = VER_PLATFORM_WIN32_NT Then
If myVer.dwMajorVersion = 3 And myVer.dwMinorVersion = 0 Then
GetVersion = WinNT3_0
ElseIf myVer.dwMajorVersion = 3 And myVer.dwMinorVersion = 1 Then
GetVersion = WinNT3_1
ElseIf myVer.dwMajorVersion = 3 And myVer.dwMinorVersion = 5 Then
GetVersion = WinNT3_5
ElseIf myVer.dwMajorVersion = 4 Then
GetVersion = WinNT4
ElseIf myVer.dwMajorVersion = 5 And myVer.dwMinorVersion = 0 Then
GetVersion = Win2k
ElseIf myVer.dwMajorVersion = 5 And myVer.dwMinorVersion = 1 Then
GetVersion = WinXP
ElseIf myVer.dwMajorVersion = 6 And myVer.dwMinorVersion = 1 Then
GetVersion = WinVista
End If
End If
Else
If param = 2 Then 'param=2 devuelve la Compilación
Winversion = osvi.dwBuildNumber
Else
If param = 3 Then 'Param=3 devuelve la revisión
Winversion = osvi.szCSDVersion
Else
If param = 4 Then
Winversion = Str(osvi.dwMajorVersion) + "." + Trim(Str(osvi.dwMinorVersion))
Else
Winversion = MsgBox("El identificador seleccionado no es válido.", vbCritical, "Error #1Ver")
End If
End If
End If
End If
End Function

====================================================================================


Funciones para el Registro de Windows:
====================================================================================
Option Explicit

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
Global Const REG_BINARY As Long = 3

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F

Global Const REG_OPTION_NON_VOLATILE = 0

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Declare Function RegSetValueExBinary Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)

Public Function DeleteKey(lPredefinedKey As Long, sKeyName As String)



Dim lRetVal As Long
Dim hKey As Long


lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)

End Function

Public Function DeleteValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)


Dim lRetVal As Long
Dim hKey As Long


lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = RegDeleteValue(hKey, sValueName)
RegCloseKey (hKey)
End Function

Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String
Dim bValue As String

Select Case lType
Case REG_SZ
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
Case REG_BINARY
bValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, bValue, Len(bValue))
End Select

End Function





Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
Dim bValue As String

On Error GoTo QueryValueExError



lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5

Select Case lType
' Cadenas
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If

' Binario
Case REG_BINARY:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, bValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(bValue, cch)
Else
vValue = Empty
End If

' DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'Otros tipos
lrc = -1
End Select

QueryValueExExit:

QueryValueEx = lrc
Exit Function

QueryValueExError:

Resume QueryValueExExit

End Function
Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)



Dim hNewKey As Long
Dim lRetVal As Long

lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
RegCloseKey (hNewKey)
End Function


Sub Main()
'Ejemplos para llamar a cada función:
'CreateNewKey HKEY_CURRENT_USER, "Prueba\Rama1\Rama2"
'SetKeyValue HKEY_CURRENT_USER, "Prueba\Rama1", "Prueba", "Probando, Probando", REG_SZ
'MsgBox QueryValue(HKEY_CURRENT_USER, "Prueba\Rama1", "Prueba")
'DeleteKey HKEY_CURRENT_USER, "Prueba\Rama1|Rama2"
'DeleteValue HKEY_CURRENT_USER, "Prueba\Rama1", "Prueba"
End Sub


Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)

Dim lRetVal As Long
Dim hKey As Long



lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
RegCloseKey (hKey)

End Function

Public Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
Dim lRetVal As Long
Dim hKey As Long
Dim vValue As Variant


lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function

====================================================================================


Funciones para hacer una captura de pantalla y guardarla:
====================================================================================



Option Explicit


Public Enum GpStatus
Ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
End Enum

Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long

SuppressExternalCodecs As Long

End Type

Public Type CLSID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Public Enum ImageCodecFlags
ImageCodecFlagsEncoder = &H1
ImageCodecFlagsDecoder = &H2
ImageCodecFlagsSupportBitmap = &H4
ImageCodecFlagsSupportVector = &H8
ImageCodecFlagsSeekableEncode = &H10
ImageCodecFlagsBlockingDecode = &H20

ImageCodecFlagsBuiltin = &H10000
ImageCodecFlagsSystem = &H20000
ImageCodecFlagsUser = &H40000
End Enum

Public Type ImageCodecInfo
ClassID As CLSID
FormatID As CLSID
CodecName As Long
DllName As Long
FormatDescription As Long
FilenameExtension As Long
MimeType As Long
flags As ImageCodecFlags
Version As Long
SigCount As Long
SigSize As Long
SigPattern As Long
SigMask As Long
End Type

Public Enum EncoderParameterValueType
EncoderParameterValueTypeByte = 1
EncoderParameterValueTypeASCII = 2

EncoderParameterValueTypeShort = 3
EncoderParameterValueTypeLong = 4
EncoderParameterValueTypeRational = 5

EncoderParameterValueTypeLongRange = 6

EncoderParameterValueTypeUndefined = 7
EncoderParameterValueTypeRationalRange = 8

End Enum

Public Type EncoderParameter
GUID As CLSID
NumberOfValues As Long
type As EncoderParameterValueType
value As Long
End Type

Public Type EncoderParameters
count As Long
Parameter As EncoderParameter
End Type

Public Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)
Public Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As GpStatus
Public Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal filename As String, clsidEncoder As CLSID, encoderParams As Any) As GpStatus
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Public Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, size As Long) As GpStatus
Public Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal size As Long, encoders As Any) As GpStatus
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpszProgID As Long, pCLSID As CLSID) As Long
Private token As Long

Public Function SaveAsJPEG(pb As PictureBox, ByVal filename As String, Optional ByVal Quality As Long = 80) As Long
Dim stat As GpStatus
Dim bm As Long
Dim encoderCLSID As CLSID
Dim encoderParams As EncoderParameters
Dim lQuality As Long

stat = GdipCreateBitmapFromHBITMAP(pb.Picture.Handle, pb.Picture.hpal, bm)

Call GetEncoderClsid("image/jpeg", encoderCLSID)

If (stat = Ok) Then
lQuality = Quality
encoderParams.count = 1
With encoderParams.Parameter
.NumberOfValues = 1
.type = EncoderParameterValueTypeLong

.GUID = DEFINE_GUID(EncoderQuality)
.value = VarPtr(lQuality)
End With

stat = GdipSaveImageToFile(bm, StrConv(filename, vbUnicode), encoderCLSID, encoderParams)

End If

SaveAsJPEG = stat

Call GdipDisposeImage(bm)
End Function

Public Function gdipLoad() As Boolean

Dim GpInput As GdiplusStartupInput

gdipLoad = False
GpInput.GdiplusVersion = 1
If GdiplusStartup(token, GpInput) = Ok Then
gdipLoad = True
End If

End Function

Public Sub gdipUnLoad()
Call GdiplusShutdown(token)
End Sub

Public Function GetEncoderClsid(strMimeType As String, ClassID As CLSID)
Dim num As Long, size As Long, i As Long
Dim ICI() As ImageCodecInfo
Dim buffer() As Byte

GetEncoderClsid = -1

Call GdipGetImageEncodersSize(num, size)
If size = 0 Then Exit Function

ReDim ICI(1 To num) As ImageCodecInfo
ReDim buffer(1 To size) As Byte

Call GdipGetImageEncoders(num, size, buffer(1))

Call CopyMemory(ICI(1), buffer(1), (Len(ICI(1)) * num))

For i = 1 To num

If StrComp(PtrToStrW(ICI(i).MimeType), strMimeType, vbTextCompare) = 0 Then
ClassID = ICI(i).ClassID
GetEncoderClsid = i
Exit For
End If
Next

Erase ICI
Erase buffer
End Function

Public Function DEFINE_GUID(ByVal sGuid As String) As CLSID
Call CLSIDFromString(StrPtr(sGuid), DEFINE_GUID)
End Function

Public Function PtrToStrW(ByVal lpsz As Long) As String
Dim sOut As String
Dim lLen As Long

lLen = lstrlenW(lpsz)

If (lLen > 0) Then
sOut = StrConv(String$(lLen, vbNullChar), vbUnicode)
Call CopyMemory(ByVal sOut, ByVal lpsz, lLen * 2)
PtrToStrW = StrConv(sOut, vbFromUnicode)
End If
End Function


====================================================================================

Algo muy importante a la hora de hacer programas q requieran reiniciar windows, escribir un ejecutable cargado ya en memoria y otras cosas que necesiten que el programa escale privilegios:
====================================================================================

Option explicit


Private Type LUID
UsedPart As Long
IgnoredForNowHigh32BitPart As Long
End Type

Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type


Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long

Public Sub AdjustToken()
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8
Const SE_PRIVILEGE_ENABLED = &H2
Dim hdlProcessHandle As Long
Dim hdlTokenHandle As Long
Dim tmpLuid As LUID
Dim tkp As TOKEN_PRIVILEGES
Dim tkpNewButIgnored As TOKEN_PRIVILEGES
Dim lBufferNeeded As Long

hdlProcessHandle = GetCurrentProcess()
OpenProcessToken hdlProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), hdlTokenHandle

LookupPrivilegeValue "", "SeShutdownPrivilege", tmpLuid

tkp.PrivilegeCount = 1
tkp.TheLuid = tmpLuid
tkp.Attributes = SE_PRIVILEGE_ENABLED



AdjustTokenPrivileges hdlTokenHandle, False, tkp, Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded

End Sub


====================================================================================
okas por ahora publico eso nomas.