OBTENER LAS ETIKETAS
================
Attribute VB_Name = "Module1"
Option Explicit
'encontrar unidad
Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'definir tipo
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Const Disco_CD = 5
Public Const Disco_Fijo = 3
Public Const Disco_Ram = 6
Public Const Disco_Remoto = 4
Public Const Disco_Removible = 2
USARLO:
Option Explicit
'encontrar
Dim Texto As String * 255
Dim Longitud As Long
Dim CadenaResultante1 As Long
Dim i As Integer
'definir
Dim Disco As String
Dim CadenaResultante As Long
Dim Informacion As String
Dim encontrada, mensaje, tipo As String
Private Sub Command1_Click()
Longitud = Len(Texto)
CadenaResultante1 = GetLogicalDriveStrings(Longitud, Texto)
For i = 1 To CadenaResultante1 Step 4
encontrada = Mid(Texto, i, 3)
Tipo_de_disco
mensaje = encontrada & " '" & tipo
MsgBox mensaje, vbInformation, "Info by VZ"
Next i
End Sub
Sub Tipo_de_disco()
Disco = encontrada
CadenaResultante = GetDriveType(Disco)
Select Case CadenaResultante
Case Disco_Removible
Informacion = "Unidad Removible"
Case Disco_Fijo
Informacion = "Disco Fijo"
Case Disco_Remoto
Informacion = "Unidad Remota"
Case Disco_CD
Informacion = "Unidad CD"
Case Disco_Ram
Informacion = "Unidad Ram"
Case Else
Informacion = "Unidad Desconocida"
End Select
tipo = Informacion
End Sub
OBTENER LA IP, NOMBRE DEL EQUIPO
==========================
Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal addr As Long) As Long
Private Declare Function gethostname Lib "wsock32.dll" (ByVal hostname$, ByVal HostLen As Long) As Long
Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal hostname$) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADATAType) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Function WSAIsBlocking Lib "wsock32.dll" () As Long
Private Declare Function WSACancelBlockingCall Lib "wsock32.dll" () As Long
Public CadenaIp As String, NombreEqu As String
'la variable CadenaIp almacenará la ip, la variable NombreEqu alamacenará el nombre del equipo
Private Type in_addr
s_addr As Long
End Type
Private Type HostEnt
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
Private Type WSADATAType
wversion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, ByVal Src As Long, ByVal cb&)
Public Sub LocalizaIp()
On Error Resume Next
For Each Ip In ObtenerIPLocal()
CadenaIp = Ip
Next
End Sub
Private Function ObtenerIPLocal()
On Error Resume Next
If Not (StartWinsock()) Then Exit Function
Dim hostname As String * 256, hostent_addr As Long
'esta varialbe nos devolverá el nombre de equipo
Dim Host As HostEnt, hostip_addr As Long
Dim ad As in_addr, ipl As Long, ips As String
Dim ip_address() As String, x As Integer
ReDim ip_address(0 To 4)
If gethostname(hostname, 256) = -1 Then
Exit Function
Else
hostname = Trim$(hostname)
End If
hostent_addr = gethostbyname(hostname)
If hostent_addr = 0 Then Exit Function
MemCopy Host, hostent_addr, LenB(Host)
MemCopy hostip_addr, Host.h_addr_list, Host.h_length
Do
MemCopy ad.s_addr, hostip_addr, Host.h_length
ipl = inet_ntoa(ad.s_addr)
ips = String$(lstrlen(ipl) + 1, 0)
lstrcpy ips, ipl
ip_address(x) = ips
Host.h_addr_list = Host.h_addr_list + LenB(Host.h_addr_list)
MemCopy hostip_addr, Host.h_addr_list, Host.h_length
x = x + 1
Loop While (hostip_addr <> 0)
ReDim Preserve ip_address(x - 1)
ObtenerIPLocal = ip_address()
NombreEqu = hostname
Call EndWinsock
End Function
Private Function StartWinsock() As Boolean
On Error Resume Next
Dim StartupData As WSADATAType
StartWinsock = IIf(WSAStartup(&H101, StartupData) = 0, True, False)
End Function
Private Sub EndWinsock()
On Error Resume Next
If WSAIsBlocking() Then Call WSACancelBlockingCall
Call WSACleanup
End Sub
OBTENER LA CARPETA DE WINDOWS
========================
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public DirWindows As String'ESTA Almacena la ruta
Public Sub Carpeta_Windows()
Dim Temp As String
Dim Ret As Long
Const MAX_LENGTH = 145
Temp = String$(MAX_LENGTH, 0)
Ret = GetWindowsDirectory(Temp, MAX_LENGTH)
Temp = Left$(Temp, Ret)
If Temp <> "" And Right$(Temp, 1) <> "\" Then
DirWindows = Temp & "\"
Else
DirWindows = Temp
End If
End Sub
salu2
cin >
www.foroschl.tk