|
232
|
Programación / Programación Visual Basic / Re: [SNIPPET] mBSOD - Revienta tu Windows
|
en: 17 Julio 2009, 18:50 pm
|
Lo probé nuevamente, activé el UAC (a nivel predeterminado), luego reinicié windows y ejecuté el code sin ninguna respuesta (tampoco ningun error). Luego volví a desactivar el UAC y reiniciar windows, en este caso sí funcionó (con el UAC dasactivado) Probé con Windows Seven RC 7100 con todas las actualizaciones al dia
S2
|
|
|
234
|
Programación / Programación Visual Basic / Re: Serial y Unidad de Pen Drive
|
en: 13 Julio 2009, 03:58 am
|
dios mio todo ésto para que reconozca la letra de unidad y del serial buffffff.pasate a net dios mio de mi alma.y no me digas que es net.
Mejor ni opino, ya tengo dos "vacaciones del foro" este año. si puede estar deshabilitado segun los permisos , si es administrador o no, sobre todo en vista...hay un codigo para saber si esta disponible.
Gracias Seba, On Error Resume Next, luego cargar GetObject("winmgmts:") y si el error es igual a cero WMI está disponible, algo así ? S2
|
|
|
236
|
Programación / Programación Visual Basic / Re: Serial y Unidad de Pen Drive
|
en: 12 Julio 2009, 00:40 am
|
Paso para el que le sirva y a modo de concepto el siguiente code para relacionar los seriales de los Pendrive con sus respectivas unidades utilizando APIs, repito que es a modo de concepto y solo para XP (En W7 es mas directo ya que el serial se encuentra en el binario de HKEY_LOCAL_MACHINE\SYSTEM\MountedDevices y no hay nesecidad de enumerar las claves de USBSTOR). PD1: Si hay una manera mejor o mas directa les agradecería si la pueden compartir. PD2: Si alguien tiene claro en que casos WMI puede estar no disponible tambien lo agradecería ya que no encuentro mucho al respecto en la web. (por lo menos en español). FORMULARIO: Option Explicit
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ '@@@ Function Datos by Dessa '@@@ '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Private Sub Form_DblClick(): Me.Print Datos: End Sub
Private Sub Form_Load() Me.AutoRedraw = True Me.FontBold = True Me.Print Datos End Sub
Private Function Datos() As String
Dim x As Long: Dim i As Long Dim USBSTOR As String: Dim inUSBSTOR() As String Dim Seriales As String: Dim inSeriales() As String Dim Historial As String: Dim inHistorial() As String Dim ingDrives() As String Dim Unidades As String
If CheckRegistryKey(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR") = True Then 'MsgBox EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR").Count '---------------------------------------------------------------------------------------- If EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR").Count > 0 Then For i = 1 To EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR").Count USBSTOR = USBSTOR + EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR").Item(i) + vbNewLine Next i 'MsgBox USBSTOR Else MsgBox "No hay Unidades de USB registradas" Exit Function End End If '---------------------------------------------------------------------------------------- inUSBSTOR() = Split(USBSTOR, vbNewLine) For x = 0 To UBound(inUSBSTOR) - 1 For i = 1 To EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR\" + inUSBSTOR(x)).Count Seriales = Seriales + inUSBSTOR(x) + "\" + EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR\" + inUSBSTOR(x)).Item(i) + vbNewLine Next i Next x 'MsgBox Seriales '---------------------------------------------------------------------------------------- inSeriales() = Split(Seriales, vbNewLine) Dim valor As String: Dim clave As String: Dim dato As Variant For x = 0 To UBound(inSeriales) - 1 clave = "SYSTEM\CurrentControlSet\Enum\USBSTOR\" + inSeriales(x) valor = "ParentIdPrefix" dato = GetRegistryValue(&H80000002, clave, valor) Historial = Historial + inSeriales(x) + " " + dato + vbNewLine Next x 'MsgBox Historial '---------------------------------------------------------------------------------------- inHistorial() = Split(Historial, vbNewLine) ingDrives() = Split(lDrives, ":") For x = 0 To UBound(ingDrives) - 1 For i = 0 To UBound(inHistorial) - 1 If InStr(1, inHistorial(i), Parent_Id_Prefix(ingDrives(x))) > 1 Then Unidades = Mid(inHistorial(i), InStr(1, inHistorial(i), "\") + 1, Len(inHistorial(i))) Unidades = Mid(Unidades, 1, InStr(1, Unidades, "&") - 1) Datos = Datos + ingDrives(x) + ": " + Unidades + vbNewLine End If Next i Next x 'MsgBox Datos '---------------------------------------------------------------------------------------- Else MsgBox "NO EXISTE USBSTOR, NUNCA SE CONECTARON DISPOSITIVOS USB EN ESTE EQUIPO" End End If
If Datos = "" Then Datos = "NO HAY DISPOSITIVOS USB CONECTADOS"
End Function
Private Function lDrives() As String
Dim LDs As Long: Dim Cnt As Long: Dim sDrives As String
LDs = GetLogicalDrives
For Cnt = 2 To 25 If (LDs And 2 ^ Cnt) <> 0 Then If GetDriveType(Chr$(65 + Cnt) + ":\") = 2 Then sDrives = sDrives + Chr$(65 + Cnt) + ":" End If End If Next Cnt
lDrives = sDrives
End Function
MODULO1 Option Explicit
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 'http://binaryworld.net/Main/ApiDetail.aspx?ApiId=32141 '@@@ '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Public 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 Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)
Public Const KEY_READ = &H20019 Public Const KEY_ALL_ACCESS = &H3F
Const REG_SZ = 1 Const REG_EXPAND_SZ = 2 Const REG_BINARY = 3 Const REG_DWORD = 4 Const REG_MULTI_SZ = 7 Const ERROR_MORE_DATA = 234
Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _ ByVal ValueName As String, Optional DefaultValue As Variant) As Variant Dim handle As Long Dim resLong As Long Dim resString As String Dim resBinary() As Byte Dim length As Long Dim retVal As Long Dim valueType As Long ' Prepare the default result GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue) ' Open the key, exit if not found. If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function End If ' prepare a 1K receiving resBinary length = 1024 ReDim resBinary(0 To length - 1) As Byte ' read the registry key retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _ length) ' if resBinary was too small, try again If retVal = ERROR_MORE_DATA Then ' enlarge the resBinary, and read the value again ReDim resBinary(0 To length - 1) As Byte retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _ length) End If ' return a value corresponding to the value type Select Case valueType Case REG_DWORD CopyMemory resLong, resBinary(0), 4 GetRegistryValue = resLong Case REG_SZ, REG_EXPAND_SZ ' copy everything but the trailing null char resString = Space$(length - 1) CopyMemory ByVal resString, resBinary(0), length - 1 GetRegistryValue = resString Case REG_BINARY ' resize the result resBinary If length <> UBound(resBinary) + 1 Then ReDim Preserve resBinary(0 To length - 1) As Byte End If GetRegistryValue = resBinary() Case REG_MULTI_SZ ' copy everything but the 2 trailing null chars resString = Space$(length - 2) CopyMemory ByVal resString, resBinary(0), length - 2 GetRegistryValue = resString Case Else RegCloseKey handle Err.Raise 1001, , "Unsupported value type" End Select ' close the registry key RegCloseKey handle End Function
Function EnumRegistryKeys(ByVal hKey As Long, ByVal KeyName As String) As Collection 'Enumerate registry keys under a given key 'Returns a collection of strings
Dim handle As Long Dim length As Long Dim index As Long Dim subkeyName As String ' initialize the result collection Set EnumRegistryKeys = New Collection ' Open the key, exit if not found If Len(KeyName) Then If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function ' in all case the subsequent functions use hKey hKey = handle End If Do ' this is the max length for a key name length = 260 subkeyName = Space$(length) ' get the N-th key, exit the loop if not found If RegEnumKey(hKey, index, subkeyName, length) Then Exit Do ' add to the result collection subkeyName = Left$(subkeyName, InStr(subkeyName, vbNullChar) - 1) EnumRegistryKeys.Add subkeyName, subkeyName ' prepare to query for next key index = index + 1 Loop ' Close the key, if it was actually opened If handle Then RegCloseKey handle End Function
Function CheckRegistryKey(ByVal hKey As Long, ByVal KeyName As String) As Boolean ' Return True if a Registry key exists Dim handle As Long ' Try to open the key If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) = 0 Then ' The key exists CheckRegistryKey = True ' Close it before exiting RegCloseKey handle End If
End Function
MODULO2 Option Explicit
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ '@@@ Function Parent_Id_Prefix by Dessa '@@@ '@@@ Function LeerIdMontaje by Daniel Aue '@@@ '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Private 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 'Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long 'Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Any) As Long
Private Const KEY_QUERY_VALUE As Long = &H1 Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8 Private Const KEY_NOTIFY As Long = &H10 Private Const SYNCHRONIZE As Long = &H100000 Private Const STANDARD_RIGHTS_READ As Long = &H20000 Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) Private Const ERROR_SUCCESS As Long = 0&
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Public Function Parent_Id_Prefix(ByVal sLetra As String) As String
Dim strBinario As String: Dim DatosBinario() As Byte
If LeerIdMontaje("SYSTEM\MountedDevices", "\DosDevices\" & sLetra + ":", DatosBinario) = False Then Exit Function strBinario = DatosBinario 'MsgBox DatosBinario, , "DatosBinario" If Mid(strBinario, 1, 4) <> "\??\" Then Exit Function strBinario = Replace(Mid(strBinario, 1, InStr(1, strBinario, "{") - 2), "#", "\") 'MsgBox strBinario, , "strBinario" Parent_Id_Prefix = Mid(strBinario, InStrRev(strBinario, "\") + 1, InStrRev(strBinario, "&") - 1 - InStrRev(strBinario, "\")) 'MsgBox Parent_Id_Prefix, , "Parent_Id_Prefix"
End Function
Private Function LeerIdMontaje(ByVal strPath As String, ByVal strValueName As String, btValue() As Byte) As Boolean Dim hKey As Long Dim lngDataLen As Long Dim lngResult As Long Dim regType As Long Dim btDataBuf() As Byte If RegOpenKeyEx(HKEY_LOCAL_MACHINE, strPath, 0, KEY_READ, hKey) = ERROR_SUCCESS Then If RegQueryValueEx(hKey, strValueName, 0, regType, ByVal 0&, lngDataLen) = ERROR_SUCCESS Then ReDim btDataBuf(lngDataLen - 1) As Byte If RegQueryValueEx(hKey, strValueName, 0, regType, btDataBuf(0), lngDataLen) = ERROR_SUCCESS Then btValue = btDataBuf 'MsgBox btValue, , "btValue = DatosBinario" LeerIdMontaje = True End If End If RegCloseKey hKey End If End Function
|
|
|
237
|
Programación / Programación Visual Basic / Re: Serial y Unidad de Pen Drive
|
en: 9 Julio 2009, 14:58 pm
|
Ok, cobein, gracias por el aporte, pero cual seria la mejor solución para relacionar los seriales de los Pendrive con sos respectivas unidades ?
Por ejemplo usando APIs en XP se puede enumerar los seriales que se encuentran en HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum\USBSTOR y a travez del dato del valor ParentIdPrefix de cada serial se puede relacionar con la unidad de cada pendrive conectado que se encuentran en HKEY_LOCAL_MACHINE\SYSTEM\MountedDevices (en el interior del dato Binario de cada unidad montada con Pendrive se encuentra tambien el valor ParentIdPrefix de cada serial, esto permitiria relacionar directamente los seriales con sus respectivas unidades). Pero no hay una manera mas directa ???
|
|
|
238
|
Programación / Programación Visual Basic / Re: Serial y Unidad de Pen Drive
|
en: 7 Julio 2009, 21:03 pm
|
No encuentro una propiedad comun entre Win32_LogicalDisk y Win32_DiskDrive para relacionar directamente la letra de un pen con su serial
Retomé el tema hace unos dias y por fin pude encontrar la forma de relacionar directamente la unidad lógica de un Pendrive con con su serial (Win32_DiskDrive-PNPDeviceID), no es por intermedio de Win32_LogicalDisk sino por intermedio de Win32_LogicalDiskToPartition, esta clase me devuelve la letra Lógica (dependent) y el numero de index del disco al que corresponde (Antecedent), lo que queda es solo relacionar este numero de index con el tambien numero de index que devuelve Win32_DiskDrive (Win32_DiskDrive-index ) Y (Win32_DiskDrive-PNPDeviceID). Paso el code para el que le pueda servir Private Function UsbSerial() As String
Dim disco1 As Object: Dim Objeto1 As Object ' Detecta seriales de Pendrive, MP3, Etc Dim disco2 As Object: Dim Objeto2 As Object ' Autor = Dessa Dim sDisco As String: Dim sLetra As String ' http://foro.elhacker.net/programacion_vb-b50.0/
Set Objeto1 = GetObject("winmgmts:").ExecQuery("Select * from Win32_LogicalDiskToPartition") Set Objeto2 = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_DiskDrive")
For Each disco1 In Objeto1 sLetra = Mid(disco1.dependent, InStr(1, disco1.dependent, "=") + 2, 2) sDisco = Mid(disco1.Antecedent, InStr(1, disco1.Antecedent, "#") + 1, InStrRev(disco1.Antecedent, ",") - InStr(1, disco1.Antecedent, "#")) For Each disco2 In Objeto2 If disco2.InterfaceType = "USB" Then If disco2.Index = Val(Mid(sDisco, 1, Len(sDisco) - 1)) Then UsbSerial = UsbSerial + sLetra + " " & Mid(disco2.PNPDeviceID, InStrRev(disco2.PNPDeviceID, "\") + 1, InStrRev(disco2.PNPDeviceID, "&") - InStrRev(disco2.PNPDeviceID, "\") - 1) + vbNewLine End If End If Next Next
End Function
PD: Funcinó en XP-SP3 y W7 S2
|
|
|
240
|
Programación / Programación Visual Basic / Re: Conexion de area local
|
en: 19 Junio 2009, 12:19 pm
|
Probá si te sirve este code. Option Explicit
Private Sub Form_Load() Me.AutoRedraw = True: Me.Height = 6045: Me.Width = 4300 LoadControl End Sub
Sub LoadControl() If WMI_disponible() Then 'Me.Print "TU SISTEMA TIENE WMI", vbOKOnly + vbInformation, "WMI" getWMI_Info Else Me.Print "TU SISTEMA NO TIENE WMI", vbOKOnly + vbExclamation, "WMI" End If End Sub
Public Function WMI_disponible() As Boolean Dim WMI As Object On Error Resume Next Set WMI = GetObject("winmgmts:") WMI_disponible = (Err.Number = 0) End Function
Private Sub getWMI_Info()
Dim oAdapters As Object Dim oAdapter As Object On Error GoTo Fehler_WMI
Me.Print "----------------------------------------------------------------------------------------------"
Set oAdapters = GetObject("winmgmts:").ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
Dim ctlip1 As String: Dim ctlip2 As String
For Each oAdapter In oAdapters With oAdapter 'Me.Cls ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' If Join(.IPAddress) <> ctlip1 Then Me.Print "NOMBRE:" & vbTab & vbTab & vbTab & Environ$("computername") Me.Print "DIRECCION IP:" & vbTab & vbTab & vbTab & Join(.IPAddress) Me.Print "MASCARA DE SUBRED:" & vbTab & Join(.IPSubnet) 'If Not IsNull(.DefaultIPGateway) Then Me.Print "PUERTA DE ENLACE:" & vbTab & vbTab & Join(.DefaultIPGateway) 'End If Me.Print "DIRECCION MAC:" & vbTab & vbTab & .MACAddress Me.Print "DNS:" & vbTab & vbTab & vbTab & vbTab & .DNSHostName 'If .WINSPrimaryServer <> "" Then Me.Print "WINS 1:" & vbTab & vbTab & vbTab & .WINSPrimaryServer 'End If 'If .WINSSecondaryServer <> "" Then Me.Print "WINS 2:" & vbTab & vbTab & vbTab & .WINSSecondaryServer 'End If Me.Print ":---------------------------------------------------------------------------------------------" ctlip1 = Join(.IPAddress) End If End With Next
On Error GoTo 0 Exit Sub
Fehler_WMI: MsgBox "Error: " & Err.Number & vbTab & Err.Description, vbCritical Resume Next End Sub
S2
|
|
|
|
|
|
|