Sección de código fuente Visual basic

Módulo de clase con funciones sobre Red y otros

Módulo con 21 funciones para obtener y consultar información sobre Red y otros

Algunas de las opciones que tiene el módulo son :

Descargar un archivo de internet
Cuadros de diálogo de windows para imprersoras de red ( Agregar y conectar)
Obtener las conecciones de red del sistema
Conectar y desconectar
Diálogo de windows de conección a unidad de red
Abrir el Diálogo FireWall de windows
Función para obtener la Ip y el nombre de un Host a partir de la IP
saber si se está conectado a una Lan, NetWork, Proxy
Saber si se está conectado a la red
Diálogo Buscar Equipo de Red
..y algunas otras

Para el ejemplo colocar en un formulario 21 Command, Command1, Command2 etc... como está en la imagen (no es necesario colocar los Caption)

vista del ejemplo que utiliza el módulo de clase para obtener información de red y algunas otras funciones

A continuación sigue el código del formulario y al final el del módulo de clase :

Código fuente en el formulario :

Option Explicit Dim ObjClass1 As Class1 Private Sub Command1_Click() Dim url As String Dim savePath As String url = InputBox(" Url del archio a descargar ", " Url ") savePath = InputBox("Path del fichero donde guardarlo ", " Guardar en... ") ObjClass1.DecargarArchivo url, savePath End Sub Private Sub Command2_Click() MsgBox ObjClass1.GetTypeConnected End Sub Private Sub Command20_Click() MsgBox ObjClass1.IsOnline, vbInformation End Sub Private Sub Command21_Click() MsgBox "Se está conectado a un Proxy: ?" & ObjClass1.isConnectedProxy End Sub Private Sub Command3_Click() Dim Listado() As String, i As Integer ObjClass1.ListarConexiones Listado For i = LBound(Listado) To UBound(Listado) - 1 MsgBox Listado(i) Next End Sub Private Sub Command4_Click() MsgBox ObjClass1.Desconectar End Sub Private Sub Command5_Click() MsgBox ObjClass1.Conectar(List1.Text, "un Usuario", "un Pass") End Sub Private Sub Command6_Click() MsgBox ObjClass1.BuscarEquipoRed(Me) End Sub Private Sub Command7_Click() ObjClass1.DesconectarUndidadRed End Sub Private Sub Command8_Click() ObjClass1.OpenDialogConectionRed End Sub Private Sub Command9_Click() ObjClass1.OpenDialogConfigRed End Sub Private Sub Command10_Click() ObjClass1.OpenDialogCarpetaCompartida End Sub Private Sub Command11_Click() ObjClass1.OpenDialogFireWall End Sub Private Sub Command12_Click() ObjClass1.OpenDialogConnectionPrinter End Sub Private Sub Command13_Click() ObjClass1.OpenDialogAgregarImpresora End Sub Private Sub Command14_Click() MsgBox ObjClass1.LocalIP, vbInformation, " Dirección IP " End Sub Private Sub Command15_Click() Dim url As String, n As Long url = InputBox("Ingrese la dirección de un archivo Url, por ejemplo" _ & "un fichero html", "Url") n = InputBox("Ingrese la cantidad de Bytes a leer de ese fichero", "Tamaño") MsgBox ObjClass1.GetUrlFile(url, n) End Sub Private Sub Command16_Click() ObjClass1.OpenDialogDownloadFile "http://www.yahoo.com" End Sub Private Sub Command17_Click() Dim IP As String IP = InputBox(" Escriba una dirección IP", " Obtener Host ") MsgBox ObjClass1.GetNombreHost(IP) End Sub Private Sub Command18_Click() MsgBox " Lan: " & ObjClass1.isConnectedLan End Sub Private Sub Command19_Click() MsgBox "El Modem está activo :? " & ObjClass1.IsModemActivo End Sub Private Sub Form_Load() Set ObjClass1 = New Class1 Command1.Caption = " Descargar archivo " Command2.Caption = " Tipo de red " Command3.Caption = "Obtener conecciones de red" Command4.Caption = " Desconectar " Command5.Caption = " Conectar " Command6.Caption = " Buscar Equipo de red " Command7.Caption = " Desconectar Unidad de red " Command8.Caption = " Cuadro de diálogo conexiones de red " Command9.Caption = " Diálogo configuración de Red " Command10.Caption = " Diálogo Carpetas compartidas " Command11.Caption = " Diálogo FireWall de Windows " Command12.Caption = " Diálogo Conectar a impresora " Command13.Caption = " Diálogo Agregar impresora " Command14.Caption = " Obtener IP " Command15.Caption = " Leer archivo remoto " Command16.Caption = " Diálogo Descargar archivo " Command17.Caption = " Obtener Nombre de Host " Command18.Caption = " Conectado a Lan ? " Command19.Caption = " Modem Activo ? " Command20.Caption = " Conectado a internet ? " Command21.Caption = " Conectado a un proxy ? " End Sub Private Sub Form_Unload(Cancel As Integer) Set ObjClass1 = Nothing End Sub

En el módulo de clase

Option Explicit 'Funcion Api y constantes que obtiene información sobre el estado de Red '######################################################################### Private Declare Function InternetGetConnectedState Lib "wininet.dll" _ (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long 'Constantes para obtener la información Private Const INTERNET_CONNECTION_MODEM As Long = &H1 Private Const INTERNET_CONNECTION_LAN As Long = &H2 Private Const INTERNET_CONNECTION_PROXY As Long = &H4 Private Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8 Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20 Private Const INTERNET_CONNECTION_CONFIGURED As Long = &H40 Private dwFlags As Long 'Constantes para determinar que tipo de Red estamos conectados '########################################################################## Private Const NETWORK_ALIVE_AOL = &H4 Private Const NETWORK_ALIVE_LAN = &H1 Private Const NETWORK_ALIVE_WAN = &H2 'Función Api IsNetworkAlive para detectar si estamos conectados y a que tipo de red Private Declare Function IsNetworkAlive Lib "SENSAPI.DLL" ( _ ByRef lpdwFlags As Long) As Long ' Para Listar las conexiones, conectar y desconectar de internet '############################################################## Private Const RAS95_MaxEntryName = 256 Private Type RASENTRYNAME95 dwSize As Long szEntryName(RAS95_MaxEntryName) As Byte End Type Private Declare Function RasEnumEntries Lib "rasapi32.dll" Alias "RasEnumEntriesA" _ (ByVal reserved As String, ByVal lpszPhonebook As String, _ lprasentryname As Any, lpcb As Long, lpcEntries As Long) As Long Private Declare Sub Sleep Lib "kernel32.dll" (ByVal miliseg As Long) Private Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" _ (ByVal handle As Long) As Integer Private Declare Sub strcpyn Lib "kernel32.dll" Alias "lstrcpynA" (ByVal a As String, _ ByVal de As String, ByVal n As Long) Private Declare Function RasDial Lib "rasapi32.dll" Alias "RasDialA" _ (ByVal p1 As Long, ByVal p2 As Long, rd As RASDIALPARAMS, _ ByVal p4 As Long, ByVal p5 As Long, handle As Long) As Integer Private Type RASDIALPARAMS dwSize As Long szEntryName As String * 257 szPhoneNumber As String * 129 szCallbackNumber As String * 129 szUserName As String * 257 szPassword As String * 257 szDomain As String * 16 filler As String * 16 End Type Private hdial As Long 'Abre el Commondialog de buscar equipo de red '############################################# 'Constantes Private Const ERROR_SUCCESS As Long = 0 Private Const MAX_PATH As Long = 260 Private Const CSIDL_NETWORK As Long = &H12 Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 'Estructura BROWSEINFO necesaria para el Api Private Type BROWSEINFO 'BI hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type 'Api SHBrowseForForlder Private Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" _ (lpBrowseInfo As BROWSEINFO) As Long 'Api SHGetSpecialFolderLocation Private Declare Function SHGetSpecialFolderLocation _ Lib "shell32.dll" _ (ByVal hwndOwner As Long, _ ByVal nFolder As Long, _ pidl As Long) As Long 'Para Recuperar la IP '################# 'Estructuras Private Type IPINFO dwAddr As Long ' Dirección Ip dwIndex As Long dwMask As Long dwBCastAddr As Long dwReasmSize As Long unused1 As Integer unused2 As Integer End Type Private Type MIB_IPADDRTABLE dEntrys As Long 'Numero de entradas de la tabla mIPInfo(5) As IPINFO 'Array de entradas de direcciones Ip End Type Private Type IP_Array mBuffer As MIB_IPADDRTABLE BufferLen As Long End Type ' Api CopyMemory Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As Any, Source As Any, ByVal Length As Long) ' Api GetIpAddrTable para recuperar la tabla de direcciones IP Private Declare Function GetIpAddrTable Lib "IPHlpApi" (pIPAdrTable As Byte, _ pdwSize As Long, ByVal Sort As Long) As Long 'Para leer un archivo desde una URL '################################### ' Constantes para las funciones Api Private Const INTERNET_OPEN_TYPE_DIRECT = 1 Private Const INTERNET_OPEN_TYPE_PROXY = 3 Private Const INTERNET_FLAG_RELOAD = &H80000000 ' Esta función crea una conexión a internet Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" _ (ByVal sAgent As String, ByVal lAccessType As Long, ByVal _ sProxyName As String, ByVal sProxyBypass As String, ByVal _ lFlags As Long) As Long ' Abre un Url Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" _ (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal _ lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal _ dwFlags As Long, ByVal dwContext As Long) As Long ' Cierra el Handle de la conexión a internet Private Declare Function InternetCloseHandle Lib "wininet" _ (ByVal hInet As Long) As Integer ' Lee el contenido del archivo y lo devuelve en un Buffer Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, _ ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _ lNumberOfBytesRead As Long) As Integer 'Abre el cuadro de diálogo descargar archivo de internet '######################################################### Private Declare Function DoFileDownload Lib "shdocvw.dll" ( _ ByVal lpszFile As String) As Long 'Funciones y estructuras para recuperar el nombre de un _ Host a partir de su dirección IP '############################################################# Private Type WSADATA wVersion As Integer wHighVersion As Integer szDescription(0 To 256) As Byte szSystemStatus(0 To 128) As Byte imaxsockets As Integer imaxudp As Integer lpszvenderinfo As Long End Type 'Declaración de las Api Winsock '****************************************************** Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal VersionReq As Long, _ WSADataReturn As WSADATA) As Long Private Declare Function WSACleanup Lib "wsock32.dll" () As Long Private Declare Function inet_addr Lib "wsock32.dll" (ByVal s As String) As Long Private Declare Function gethostbyaddr Lib "wsock32.dll" (haddr As Long, _ ByVal hnlen As Long, ByVal addrtype As Long) As Long Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (lpString As Any) As Long 'Función Api para descargar un archivo '###################################################################### ' API URLDownloadToFile Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long '##################################################################### ' # 'Fin de las declaraciones # ' # ' # '##################################################################### ' Función para saber el estado de la Red Lan '############################################ Public Property Get isConnectedLan() As Boolean Call InternetGetConnectedState(dwFlags, 0&) isConnectedLan = dwFlags And INTERNET_CONNECTION_LAN End Property ' Función Booleana para saber si se está conectado a un servidor Proxy '###################################################################### Public Property Get isConnectedProxy() As Boolean Call InternetGetConnectedState(dwFlags, 0&) isConnectedProxy = dwFlags And INTERNET_CONNECTION_PROXY End Property ' Función Booleana para saber si el Modem está activo '####################################################### Public Property Get IsModemActivo() As Boolean Call InternetGetConnectedState(dwFlags, 0&) IsModemActivo = dwFlags And INTERNET_CONNECTION_MODEM End Property ' Función Booleana para saber si se está conectado a internet '######################################################### Public Property Get IsOnline() As Boolean IsOnline = InternetGetConnectedState(0&, 0&) End Property 'Devuelve el tipo de conexión de red que estamos usando '######################################################### Public Property Get GetTypeConnected() Dim Ret As Long 'Si la Api retorna en Ret 0 quiere decir que no hay ningun tipo de conexión de Red IsNetworkAlive Ret Select Case Ret Case 0: GetTypeConnected = "No hay conexión" Case 1: GetTypeConnected = "Lan" Case 2: GetTypeConnected = "NetWork" Case 4: GetTypeConnected = "Aol" End Select End Property 'Lista las conexiones del equipo '################################# 'Enumera las conexiones instaladas Public Sub ListarConexiones(Lista) Dim s As Long, l As Long, ln As Long, a$, li As String ReDim r(255) As RASENTRYNAME95 r(0).dwSize = 264 s = 256 * r(0).dwSize l = RasEnumEntries(vbNullString, vbNullString, r(0), s, ln) 'Bucle para agregar las conexiones al List1 For l = 0 To ln - 1 a$ = StrConv(r(l).szEntryName(), vbUnicode) li = li & Left$(a$, InStr(a$, Chr$(0)) - 1) & vbNewLine Next Lista = Split(li, vbNewLine) End Sub 'función que Desconecta la conexión activa '########################################## Function Desconectar() As Boolean Dim n As Long, Ret As Long If hdial = 0 Then Desconectar = False Exit Function End If n = RasHangUp(hdial) If n = 0 Then hdial = 0 Desconectar = True Sleep (3000) Else Desconectar = False End If End Function 'Función que realiza la conexión iniciada '######################################## Function Conectar(NombreConection As String, Usuario As String, _ PassWord As String) As Boolean Dim Rdp As RASDIALPARAMS Rdp.dwSize = 1052 strcpyn Rdp.szEntryName, NombreConection + Chr$(0), 256 strcpyn Rdp.szPhoneNumber, Chr$(0), 128 strcpyn Rdp.szCallbackNumber, Chr$(0), 128 strcpyn Rdp.szUserName, Usuario + Chr$(0), 256 strcpyn Rdp.szPassword, PassWord + Chr$(0), 256 strcpyn Rdp.szDomain, Chr$(0), 15 If RasDial(0, 0, Rdp, 0, 0, hdial) = 0 Then Conectar = True Else Conectar = False End If End Function 'Abre el Commondialog para buscar un equipo y retornar el nombre '############################################################### Function BuscarEquipoRed(Form As Form) As String 'muestra sólo ordenadores Dim BI As BROWSEINFO, pidl As Long, sPath As String, pos As Integer Dim i As Long If SHGetSpecialFolderLocation(Form.hWnd, CSIDL_NETWORK, pidl) = ERROR_SUCCESS Then With BI .hOwner = Form.hWnd .pidlRoot = pidl .pszDisplayName = Space$(MAX_PATH) .lpszTitle = "Seleccione un ordenador :" .ulFlags = BIF_BROWSEFORCOMPUTER End With ' Abrimos el diálogo de búsqueda. If SHBrowseForFolder(BI) <> 0 Then 'se ha seleccionado un ordenador. i = InStr(BI.pszDisplayName, Chr(0)) If i = 0 Then BuscarEquipoRed = BI.pszDisplayName Else BuscarEquipoRed = "\\" & Left(BI.pszDisplayName, i - 1) End If End If End If End Function 'funciones para los cuadro de diálogo de windows de red usando el Shell '###################################################################### Function DesconectarUndidadRed() Shell "RunDll32.exe shell32.dll,SHHelpShortcuts_RunDLL Disconnect" End Function Function OpenDialogConectionRed() Shell "RunDll32.exe shell32.dll,Control_RunDLL ncpa.cpl" End Function Function OpenDialogConfigRed() Shell "RunDll32.exe hnetwiz.dll,HomeNetWizardRunDll", vbNormalFocus End Function Function OpenDialogCarpetaCompartida() Shell "RunDll32.exe NTLANUI.DLL,ShareManage" End Function Function OpenDialogFireWall() Shell "RunDll32.exe shell32.dll,Control_RunDLL firewall.cpl" End Function Function OpenDialogConnectionPrinter() Shell "RunDll32.exe WINSPOOL.DRV,ConnectToPrinterDlg" End Function Function OpenDialogAgregarImpresora() Shell "RunDll32.exe SHELL32.DLL,SHHelpShortcuts_RunDLL AddPrinter" End Function 'Propiedad que consulta la IP '############################## Property Get LocalIP() As String On Error GoTo errSub Dim Ret As Long, Tel As Long, bBytes() As Byte, TempList() As String, TempIP As String Dim Tempi As Long, Listing As MIB_IPADDRTABLE, L3 As String GetIpAddrTable ByVal 0&, Ret, True If Ret <= 0 Then Exit Function ReDim bBytes(0 To Ret - 1) As Byte ReDim TempList(0 To Ret - 1) As String GetIpAddrTable bBytes(0), Ret, False CopyMemory Listing.dEntrys, bBytes(0), 4 For Tel = 0 To Listing.dEntrys - 1 CopyMemory Listing.mIPInfo(Tel), bBytes(4 + _ (Tel * Len(Listing.mIPInfo(0)))), Len(Listing.mIPInfo(Tel)) TempList(Tel) = ConvertirDirecciónAstring(Listing.mIPInfo(Tel).dwAddr) Next Tel TempIP = TempList(0) For Tempi = 0 To Listing.dEntrys - 1 L3 = Left(TempList(Tempi), 3) If L3 <> "169" And L3 <> "127" And L3 <> "192" Then TempIP = TempList(Tempi) End If Next Tempi LocalIP = TempIP Exit Property errSub: MsgBox Err.Description, vbCritical, "Error" LocalIP = "" End Property 'Lee un archivo remoto y devuelve un String '############################################ Function GetUrlFile(url As String, ByVal NBytes As Long) As String On Local Error GoTo errSub Dim hOpen As Long, hFile As Long, sBuffer As String, Ret As Long sBuffer = Space(CLng(NBytes)) ' Abrir conexión a internet hOpen = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_DIRECT, _ vbNullString, vbNullString, 0) 'Abrimos una url hFile = InternetOpenUrl(hOpen, Trim$(url), vbNullString, _ ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&) 'Leemos los bytes pasandole el valor del text2 InternetReadFile hFile, sBuffer, CLng(NBytes), Ret 'Cerramos el handle anterior InternetCloseHandle hFile InternetCloseHandle hOpen 'Mostramos el fichero en el control RichTextBox GetUrlFile = Trim$(sBuffer) Exit Function errSub: MsgBox Err.Description, vbCritical, " Error " End Function 'Función que descarga un fichero remoto y abr el cuadro de diálogo de 'Windows para seleccionar la ruta donde guardarlo '##################################################################### Function OpenDialogDownloadFile(url As String) On Error GoTo errSub DoFileDownload StrConv(Trim$(url), vbUnicode) Exit Function errSub: MsgBox Err.Description End Function Function DecargarArchivo(ByVal url As String, ByVal savePath As String) 'Descargamos el archivo al disco. El parametro1 es la url y _ el segundo es el path donde se guarda URLDownloadToFile 0, Trim$(url), Trim$(savePath), 0, 0 End Function 'Función para obtener el nombre de un Host a partir de su IP '##################################################################### 'Devuelve el nombre del Host a partir de su IP Public Function GetNombreHost(ByVal direccion_IP As String) As String On Error GoTo errSub Dim PH As Long, hDir As Long, nb As Long If Socket() Then hDir = inet_addr(direccion_IP) 'Si devuelve -1 ocurrió un error If hDir <> -1 Then PH = gethostbyaddr(hDir, 4, 2) If PH <> 0 Then CopyMemory PH, ByVal PH, 4 nb = lstrlen(ByVal PH) If nb > 0 Then direccion_IP = Space$(nb) CopyMemory ByVal direccion_IP, ByVal PH, nb GetNombreHost = direccion_IP End If Else MsgBox "Error." End If SocketsCleanup Else MsgBox "La dirección Ip no es válida." End If Else MsgBox "Error" End If Exit Function errSub: MsgBox Err.Description, vbCritical, "Error" End Function '######################################################################### ' # 'Funciones privadas # ' # '######################################################################### 'Función para Convertir el valor de tipo Long a un string para la propiedad anterior Private Function ConvertirDirecciónAstring(longAddr As Long) As String Dim myByte(3) As Byte, Cnt As Long CopyMemory myByte(0), longAddr, 4 For Cnt = 0 To 3 ConvertirDirecciónAstring = ConvertirDirecciónAstring + CStr(myByte(Cnt)) + "." Next Cnt ConvertirDirecciónAstring = Left$(ConvertirDirecciónAstring, _ Len(ConvertirDirecciónAstring) - 1) End Function Private Sub SocketsCleanup() If WSACleanup() <> 0 Then MsgBox "Error.", vbExclamation End If End Sub 'Iniciliza el Socket Private Function Socket() As Boolean Dim W As WSADATA Socket = WSAStartup(&H101, W) = 0 End Function

Buscar en Recursos vb