Este es un módulo con una función para poder insertar imágenes de todo tipo en un ImageList de los Microsoft Common Controls, tanto para la versión 5.0 o 6.0.
El módulo sólo tiene la función para leer desde archivos, faltaría agregarle la opción para leer desde recursos, si a alguien le interesa pueden comunicarlo.
Para la versión 6.0, a quienes no le funcione, les recomiendo descargarse la última actualización aquí.
Este es un Módulo .bas, el cual contiene una función que permite dibujar un texto justificado. A esta función se le debe pasar un tipo definido (estructura), el cual contiene ciertos parámetros: el área del rectángulo que este debe ocupar y la línea donde se quiere comenzar a dibujar, también dentro de este tipo o estructura la función nos retorna la cantidad de caracteres y líneas que se fueron dibujando dentro de dicho rectángulo y otros más.
En la siguiente descarga hay cuatro formularios con diferentes ejemplos para entender mejor su uso.
Esta clase sirve para buscar archivos y carpetas, está bien completa ya que podemos aplicar filtros tales como fecha de modificación, creación y de último acceso, también tamaño mínimo y máximo. Cuenta con un filtro en el que podemos indicar con asteriscos ( * ) y signos de interrogación ( ? ) para lograr una búsqueda exacta. Resumiendo cuenta con las mismas opciones que el buscador de Windows, además corrige el fallo de XP en buscar una palabra dentro de un archivo, es decir, supongamos que quisiéramos buscar la palabra «ConnectionString» en uno de nuestros proyectos, entonces podremos poner *.frm; *.bas y nos buscará dicha palabra en todos los formularios y módulos que se encuentren el directorio previamente indicado.
Option Explicit
'---------------------------------------------------------------------------------------
' Module : ClsSearch
' DateTime : 31/08/2010
' Author : Leandro Ascierto
' WebPage : http://www.leandroascierto.com.ar
' Purpose : File and Folder search class
' Reference : cFileList by Cobein(http://www.advancevb.com.ar)
' Credits : raul338 and *PsYkE1* for regular expressions
' Tested on : XP-SP3, Vista Home Premium and Seven
' Requirements: None
'
' History : 31/08/2010 - First Cut
'---------------------------------------------------------------------------------------
'Apis
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32.dll" (ByRef lpSystemTime As SYSTEMTIME, ByRef lpFileTime As FILETIME) As Long
Private Declare Function CompareFileTime Lib "kernel32.dll" (ByRef lpFileTime1 As FILETIME, ByRef lpFileTime2 As FILETIME) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByRef lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CharUpperBuffA& Lib "user32" (lpsz As Any, ByVal cchLength&)
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'Constantes
Private Const DRIVE_FIXED As Long = 3
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const OPEN_EXISTING As Long = 3
Private Const FILE_BEGIN As Long = 0
'Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
'Enumere
Public Enum eDateTimeFilter
NoDateTimeFilter = 0
LastWriteTime = 1
CreationTime = 2
LastAccessTime = 3
End Enum
Public Enum eFileSizeFilter
NoFilterSize = 0
MinSize = 1
MaxSize = 2
MinAndMax = 3
End Enum
'Events
Public Event FileFound(ByVal sPath As String, ByVal sFile As String, ByVal bZipFile As Boolean)
Public Event FolderFound(ByVal sPath As String, ByVal sFolder As String, ByVal bZipFolder As Boolean)
Public Event SearchWordInFile(ByVal sFile As String)
Private aUChars(255) As Byte
Private c_bCancel As Boolean
Private c_cFolders As Collection
Private c_cFiles As Collection
Private m_FindInSubFolder As Boolean
Private m_DoEvents As Boolean
Private m_MinDate As Date
Private m_MaxDate As Date
Private m_FT_MinDate As FILETIME
Private m_FT_MaxDate As FILETIME
Private m_MinSize As Currency
Private m_MaxSize As Currency
Private m_SpecificWord As String
Private m_FilterDateTime As eDateTimeFilter
Private m_FilterFileSize As eFileSizeFilter
Private m_SearchInSysFolder As Boolean
Private m_SearchInSubFolder As Boolean
Private m_SearchHidePath As Boolean
Private m_WindowsDir As String
Private m_StrMatch As String
Private m_IgnoreCase As Boolean
Private m_sPath As String
Private m_SearchInZipFolder As Boolean
Private oRegExp As Object
Private objShell As Object
'Property Let
Public Property Let SearchInZipFolder(ByVal Value As Boolean): m_SearchInZipFolder = Value: End Property
Public Property Let IgnoreCase(ByVal Value As Boolean): m_IgnoreCase = Value: End Property
Public Property Let Path(ByVal sValue As String): m_sPath = sValue: End Property
Public Property Let CallDoEvents(ByVal Value As Boolean): m_DoEvents = Value: End Property
Public Property Let Match(ByVal sValue As String): m_StrMatch = sValue: End Property
Public Property Let SearchInSubFolder(ByVal Value As Boolean): m_SearchInSubFolder = Value: End Property
Public Property Let SearchInSystemFolder(ByVal Value As Boolean): m_SearchInSysFolder = Value: End Property
Public Property Let SearchHidePath(ByVal Value As Boolean): m_SearchHidePath = Value: End Property
Public Property Let SpecificWord(ByVal sWord As String): m_SpecificWord = sWord: End Property
Public Property Let FilterDateTime(ByVal Value As eDateTimeFilter): m_FilterDateTime = Value: End Property
Public Property Let MinFileSize(ByVal NewSize As Currency): m_MinSize = NewSize: End Property
Public Property Let MaxFileSize(ByVal NewSize As Currency): m_MaxSize = NewSize: End Property
Public Property Let FilterFileSize(ByVal Value As eFileSizeFilter): m_FilterFileSize = Value: End Property
Public Property Let MinDate(ByVal NewDate As Date): m_MinDate = NewDate: End Property
Public Property Let MaxDate(ByVal NewDate As Date): m_MaxDate = NewDate: End Property
'Property Get
Public Property Get SearchInZipFolder() As Boolean: SearchInZipFolder = m_SearchInZipFolder: End Property
Public Property Get IgnoreCase() As Boolean: IgnoreCase = m_IgnoreCase: End Property
Public Property Get Path() As String: Path = m_sPath: End Property
Public Property Get CallDoEvents() As Boolean: CallDoEvents = m_DoEvents: End Property
Public Property Get Match() As String: Match = m_StrMatch: End Property
Public Property Get SearchInSubFolder() As Boolean: SearchInSubFolder = m_SearchInSubFolder: End Property
Public Property Get SearchInSystemFolder() As Boolean: SearchInSystemFolder = m_SearchInSysFolder: End Property
Public Property Get SearchHidePath() As Boolean: SearchHidePath = m_SearchHidePath: End Property
Public Property Get SpecificWord() As String: SpecificWord = m_SpecificWord: End Property
Public Property Get FilterDateTime() As eDateTimeFilter: FilterDateTime = m_FilterDateTime: End Property
Public Property Get MinFileSize() As Currency: MinFileSize = m_MinSize: End Property
Public Property Get MaxFileSize() As Currency: MaxFileSize = m_MaxSize: End Property
Public Property Get FilterFileSize() As eFileSizeFilter: FilterFileSize = m_FilterFileSize: End Property
Public Property Get MinDate() As Date: MinDate = m_MinDate: End Property
Public Property Get MaxDate() As Date: MaxDate = m_MaxDate: End Property
Public Function Folders() As Collection: Set Folders = c_cFolders: End Function
Public Function Files() As Collection: Set Files = c_cFiles: End Function
Public Sub Cancel(): c_bCancel = True: End Sub
Public Sub StartSearch()
Dim ArrPaths() As String
Dim i As Long
Set c_cFolders = New Collection
Set c_cFiles = New Collection
Set oRegExp = CreateObject("VBScript.RegExp")
m_FT_MinDate = DateToFileTime(m_MinDate)
m_FT_MaxDate = DateToFileTime(m_MaxDate)
c_bCancel = False
With oRegExp
.Pattern = ReplaceFilter(m_StrMatch)
Debug.Print .Pattern
.Global = True
.IgnoreCase = m_IgnoreCase
End With
If m_SearchInZipFolder Then
Set objShell = CreateObject("Shell.Application")
End If
ArrPaths = Split(m_sPath, ";")
For i = 0 To UBound(ArrPaths)
pvFindFiles Trim(ArrPaths(i))
If c_bCancel Then Exit For
Next
Set oRegExp = Nothing
Set objShell = Nothing
End Sub
Private Function pvFindFiles(ByVal sPath As String) As Boolean
Dim lRet As Long
Dim lDateDiff As Long
Dim lhSearch As Long
Dim tWFD As WIN32_FIND_DATA
Dim svDirs() As String
Dim lCount As Long
Dim sDir As String
Dim sFile As String
Dim i As Long
Dim sFolder As String
Dim FileSize As Currency
Dim tFT As FILETIME
Dim sMatch As String
If c_bCancel Then Exit Function
Call NormalizePath(sPath)
lhSearch = FindFirstFile(sPath & "*", tWFD)
If Not lhSearch = INVALID_HANDLE_VALUE Then
Do
If (tWFD.dwFileAttributes And vbDirectory) <> vbDirectory Then
sFile = StripNulls(tWFD.cFileName)
If m_SearchInZipFolder Then
If Len(m_SpecificWord) = 0 Then
If UCase$(Right$(sFile, 4)) = ".ZIP" Then
Call FindInZipFolder(sPath & sFile)
End If
End If
End If
If Not m_SearchHidePath Then
If (tWFD.dwFileAttributes And vbHidden) = vbHidden Then GoTo FINDNEXT
End If
If m_FilterDateTime <> NoDateTimeFilter Then
If m_FilterDateTime = LastWriteTime Then
tFT = tWFD.ftLastWriteTime
ElseIf m_FilterDateTime = CreationTime Then
tFT = tWFD.ftCreationTime
Else 'If m_FilterDateTime = LastAccessTime Then
tFT = tWFD.ftLastAccessTime
End If
If Not ((CompareFileTime(tFT, m_FT_MinDate) >= 0) And (CompareFileTime(tFT, m_FT_MaxDate) <= 0)) Then GoTo FINDNEXT
End If
If m_FilterFileSize <> NoFilterSize Then
FileSize = LargeIntToCurrency(tWFD.nFileSizeLow, tWFD.nFileSizeHigh)
If m_FilterFileSize = MinSize Then
If FileSize < m_MinSize Then GoTo FINDNEXT
ElseIf m_FilterFileSize = MaxSize Then
If FileSize >= m_MaxSize Then GoTo FINDNEXT
Else 'if m_FilterFileSize = MinAndMax Then
If (FileSize < m_MinSize And FileSize > m_MaxSize) Then GoTo FINDNEXT
End If
End If
If oRegExp.Execute(sFile).Count = 0 Then GoTo FINDNEXT
If Len(m_SpecificWord) Then
RaiseEvent SearchWordInFile(sPath & sFile)
If Not FindWordInFile(sPath & sFile, m_SpecificWord) Then GoTo FINDNEXT
End If
Call c_cFiles.Add(sPath & sFile)
RaiseEvent FileFound(sPath, sFile, False)
Else
If Not m_SearchHidePath Then
If (tWFD.dwFileAttributes And vbHidden) = vbHidden Then GoTo FINDNEXT
End If
sFolder = StripNulls(tWFD.cFileName)
If InStrB(sFolder, ".") <> 1 Then
sDir = sPath & sFolder & "\"
If Not m_SearchInSysFolder Then
If sDir = m_WindowsDir Then GoTo FINDNEXT
End If
ReDim Preserve svDirs(lCount)
svDirs(lCount) = sDir
lCount = lCount + 1
If m_FilterFileSize <> NoFilterSize Then
If m_FilterFileSize = MinSize Then GoTo FINDNEXT
If m_FilterFileSize = MinAndMax Then GoTo FINDNEXT
End If
If oRegExp.Execute(sFolder).Count = 0 Then GoTo FINDNEXT
Call c_cFolders.Add(sFolder)
RaiseEvent FolderFound(sPath, sFolder, False)
End If
End If
FINDNEXT:
If c_bCancel Then Call FindClose(lhSearch): Exit Function
If m_DoEvents Then DoEvents
lRet = FindNextFile(lhSearch, tWFD)
Loop While lRet
Call FindClose(lhSearch)
End If
If m_SearchInSubFolder Then
For i = 0 To lCount - 1
Call pvFindFiles(svDirs(i))
Next
End If
End Function
Private Function FindInZipFolder(ByVal Root As String, Optional ByVal sPath As String)
Dim objFolder As Object
Dim oItem As Object
Dim sFolder As String
Dim sFile As String
Dim ItemName As String
Dim FileSize As Currency
Dim tFT As FILETIME
Set objFolder = objShell.NameSpace(CVar(Root & sPath))
If objFolder Is Nothing Then Exit Function
For Each oItem In objFolder.ITEMS()
If Not oItem.IsFolder Then
ItemName = Right(oItem.Path, Len(oItem.Path) - InStrRev(oItem.Path, "/"))
If oRegExp.Execute(ItemName).Count = 0 Then GoTo FINDNEXT
If m_FilterDateTime <> NoDateTimeFilter Then
If m_FilterDateTime <> LastWriteTime Then
GoTo FINDNEXT
End If
tFT = DateToFileTime(CDate(objFolder.ParentFolder.GetDetailsOf(oItem, 7)))
If Not ((CompareFileTime(tFT, m_FT_MinDate) >= 0) And (CompareFileTime(tFT, m_FT_MaxDate) <= 0)) Then GoTo FINDNEXT
End If
If m_FilterFileSize <> NoFilterSize Then
FileSize = oItem.Size
If m_FilterFileSize = MinSize Then
If oItem.Size < m_MinSize Then GoTo FINDNEXT
ElseIf m_FilterFileSize = MaxSize Then
If FileSize >= m_MaxSize Then GoTo FINDNEXT
Else 'if m_FilterFileSize = MinAndMax Then
If (FileSize < m_MinSize And FileSize > m_MaxSize) Then GoTo FINDNEXT
End If
End If
sFile = Root & "\" & oItem.Path
Call c_cFiles.Add(sFile)
RaiseEvent FileFound(Root, oItem.Path, True)
Else
If m_FilterFileSize <> NoFilterSize Then
If m_FilterFileSize = MinSize Then GoTo FINDNEXTFOLDER
End If
If m_FilterDateTime <> NoDateTimeFilter Then GoTo FINDNEXTFOLDER
If oRegExp.Execute(oItem).Count = 0 Then GoTo FINDNEXTFOLDER
sFolder = Root & "\" & oItem.Path
Call c_cFolders.Add(sFolder)
RaiseEvent FolderFound(Root & "\", oItem.Path, True)
FINDNEXTFOLDER:
If c_bCancel Then Exit Function
If m_DoEvents Then DoEvents
FindInZipFolder Root, "\" & oItem.Path
End If
FINDNEXT:
If c_bCancel Then Exit Function
If m_DoEvents Then DoEvents
Next
End Function
Private Function FindWordInFile(ByVal sPath As String, ByVal sWord As String, Optional ByVal bUnicode As Boolean) As Boolean
Dim bArray() As Byte
Dim lRet As Long
Dim hFile As Long
Dim sFind() As Byte
Dim s As String
Dim t As Long
Dim i As Long
Dim FileSize As Currency
Dim tLI As LARGE_INTEGER
Dim LenBuffer As Long
Dim CurPos As Currency
sWord = UCase(sWord)
If bUnicode Then sWord = StrConv(sWord, vbUnicode)
sFind = StrConv(sWord, vbFromUnicode)
hFile = CreateFile(sPath, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
If hFile <> INVALID_HANDLE_VALUE Then
tLI.LowPart = GetFileSize(hFile, tLI.HighPart)
LenBuffer = &H2800 ' 10 KB
FileSize = LargeIntToCurrency(tLI.LowPart, tLI.HighPart)
If FileSize < UBound(sFind) Then GoTo OutSearch
If LenBuffer > FileSize Then LenBuffer = FileSize
ReDim bArray(LenBuffer - 1)
Do
ReadFile hFile, bArray(0), UBound(bArray) + 1, lRet, 0&
If lRet = 0 Then Exit Do
CurPos = CurPos + lRet
If lRet < LenBuffer Then
ReDim Preserve bArray(lRet)
End If
If InBytes(bArray, sFind) <> -1 Then
FindWordInFile = True
Exit Do
End If
If CurPos = FileSize Then Exit Do
tLI = CurrencyToLargeInt(CurPos - UBound(sFind) + 1)
SetFilePointer hFile, tLI.LowPart, tLI.HighPart, FILE_BEGIN
If c_bCancel Then GoTo OutSearch
Loop
OutSearch:
CloseHandle hFile
End If
End Function
Private Function InBytes(ByRef bvSource() As Byte, ByRef bvMatch() As Byte) As Long
Dim i As Long
Dim J As Long
Dim lChr As Byte
Dim LenMach As Long
LenMach = UBound(bvMatch)
lChr = bvMatch(0)
If LenMach > 0 Then
For i = 0 To UBound(bvSource) - LenMach
If (lChr = aUChars(bvSource(i))) Then
J = LenMach - 1
Do
If bvMatch(J) <> aUChars(bvSource(i + J)) Then GoTo NotEqual
J = J - 1
Loop While J
InBytes = i
Exit Function
End If
NotEqual:
Next
Else
For i = 0 To UBound(bvSource)
If (lChr = aUChars(bvSource(i))) Then
InBytes = i
Exit Function
End If
Next
End If
InBytes = -1
End Function
Private Function StripNulls(sData As String) As String
StripNulls = Left$(sData, lstrlen(sData))
End Function
Private Sub NormalizePath(sData As String)
sData = IIf(Right$(sData, 1) = "\", sData, sData & "\")
End Sub
Private Function DateToFileTime(ByVal vbDate As Date) As FILETIME
Dim ST As SYSTEMTIME
With ST
.wYear = Year(vbDate)
.wMonth = Month(vbDate)
.wDay = Day(vbDate)
.wHour = Hour(vbDate)
.wMinute = Minute(vbDate)
.wSecond = Second(vbDate)
End With
SystemTimeToFileTime ST, DateToFileTime
LocalFileTimeToFileTime DateToFileTime, DateToFileTime
End Function
Private Function LargeIntToCurrency(Low As Long, High As Long) As Currency
Dim LI As LARGE_INTEGER
LI.LowPart = Low: LI.HighPart = High
CopyMemory LargeIntToCurrency, LI, LenB(LI)
LargeIntToCurrency = LargeIntToCurrency * 10000
End Function
Private Function CurrencyToLargeInt(ByVal Curr As Currency) As LARGE_INTEGER
Curr = Curr / 10000
CopyMemory CurrencyToLargeInt, Curr, LenB(Curr)
End Function
Private Function ReplaceFilter(ByVal sFilter As String) As String
sFilter = Replace(sFilter, "+", "\+")
sFilter = Replace(sFilter, ".", "\.")
sFilter = Replace(sFilter, "|", "\|")
sFilter = Replace(sFilter, ";", "|\b")
sFilter = Replace(sFilter, " ", "|\b")
sFilter = Replace(sFilter, "{", "\{")
sFilter = Replace(sFilter, "}", "\}")
sFilter = Replace(sFilter, "*", ".+")
sFilter = Replace(sFilter, "?", ".{1}")
sFilter = Replace(sFilter, "(", "\(")
sFilter = Replace(sFilter, ")", "\)")
sFilter = Replace(sFilter, "^", "\^")
sFilter = Replace(sFilter, "$", "\$")
sFilter = Replace(sFilter, "[", "\[")
sFilter = Replace(sFilter, "[", "\]")
Do While InStr(sFilter, "|\b|\b")
sFilter = Replace$(sFilter, "|\b|\b", "|\b")
Loop
ReplaceFilter = "^(" & sFilter & ")$|(" & sFilter & ".+)"
End Function
Public Function GetAllDriveFixed() As String
Dim sBuff As String * 255
Dim arrDrive() As String
Dim i As Long
i = GetLogicalDriveStrings(255, sBuff)
arrDrive = Split(Left$(sBuff, i - 1), Chr$(0))
For i = 0 To UBound(arrDrive)
If GetDriveType(arrDrive(i)) = DRIVE_FIXED Then
GetAllDriveFixed = GetAllDriveFixed & arrDrive(i) & "; "
End If
Next
GetAllDriveFixed = Left(GetAllDriveFixed, Len(GetAllDriveFixed) - 2)
End Function
Private Sub Class_Initialize()
Dim i As Long
For i = 0 To 255: aUChars(i) = i: Next
CharUpperBuffA aUChars(0), 256
m_WindowsDir = Environ("windir")
NormalizePath m_WindowsDir
m_SearchInSysFolder = True
m_SearchInSubFolder = True
m_SearchHidePath = False
m_IgnoreCase = True
m_sPath = GetAllDriveFixed
End Sub
Private Sub Class_Terminate()
c_bCancel = True
Set c_cFolders = Nothing
Set c_cFiles = Nothing
Set oRegExp = Nothing
Set objShell = Nothing
End Sub
Módulo para mostrar una ventanita notificadora al estilo MSN Messenger entre otros, su uso es muy sencillo, sólo basta con tomar un formulario decorarlo a gusto y luego llamar a la función ShowFormNotify con los parámetros que doy a conocer en el ejemplo a descargar, donde también he puesto algunos ejemplos de cómo hacer un MsgBox no modal.
Módulo Clase para mostrar barras de progreso en un ListView, anteriormente ya había publicado este módulo, pero le he implementado algunas reformas tales como poder utilizar los temas de Windows, y reducir notablemente el parpadeo de este al repintarse. Si miran el ejemplo para descargar notarán que la modificación del texto de los SubItem lo hago mediante funciones del módulo que utilizan Apis, ya que es una forma más óptima porque no produce el repintado total del ListView, además no hace que el ScrollBar de este vuelva a 0, esto más que nada es para cuando se muestren progresos muy frecuentes tal como lo hace el ejemplo. Las tolerancias que maneja es de 0 a 100, pero cualquiera es libre de modificar el código e implementarle el Mínimo y Máximo.
Este es un Módulo Clase que realicé hace un tiempo atrás pero los link de descarga se habían perdido, le he realizado algunas reformas para optimizar su uso, esta clase sirve para poder crear un tipo de ranking (sistema de votos) dentro de un ListView, puede servir para catalogar archivos de música, video, juegos o relacionarlo de alguna forma con una base de datos. La puntuación es sólo de uno a cinco, estos valores deben ser cargados en el SubItem donde quieran que aparezca la gráfica, cuando el usuario hace click para realizar su votación la clase dispara un evento con el número de items y el nuevo valor, las imágenes de la gráfica se deben cargar en un ImageList, son tres imágenes las cuales representan una imágen seleccionada, una resaltada y otra en escala de grises.
Este es un módulo que nos permitirá poner un formulario MDI en modo FullScreen cuando está maximizado, la ventaja de esto es ganarle un poco más de espacio al monitor, y sobre todo cuando el software tiene un papel protagónico en el PC que lo ejecuta.
Código del módulo bas «MdiFullScreen»
Option Explicit
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal ID As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal ID As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Const HWND_TOPMOST As Long = -1
Private Const HWND_NOTOPMOST As Long = -2
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_SHOWWINDOW As Long = &H40
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_CAPTION As Long = &HC00000
Private Const SC_RESTORE As Long = &HF120&
Private Const WM_ACTIVATEAPP As Long = &H1C
Private Const WM_HOTKEY As Long = &H312
Private Const WM_SYSCOMMAND As Long = &H112
Private Const GWL_STYLE As Long = (-16)
Private Const GWL_WNDPROC As Long = (-4)
Const MyHotKey As Long = &H1000
Dim WndStyle As Long
Dim bFullScreen As Boolean
Dim PrevProc As Long
Public Sub ShowFullScreen(hwnd As Long)
If Not bFullScreen Then
bFullScreen = True
Call RegisterHotKey(hwnd, MyHotKey, 0, vbKeyEscape)
WndStyle = GetWindowLong(hwnd, GWL_STYLE)
SetWindowLong hwnd, GWL_STYLE, WndStyle And Not WS_MAXIMIZEBOX And Not WS_MINIMIZEBOX And Not WS_THICKFRAME And Not WS_CAPTION
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, Screen.Width / 15, Screen.Height / 15, SWP_NOACTIVATE
PrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End If
End Sub
Public Sub EndFullScreen(hwnd)
If bFullScreen Then
bFullScreen = False
SetWindowLong hwnd, GWL_STYLE, WndStyle
SendMessage hwnd, WM_SYSCOMMAND, SC_RESTORE, ByVal 0&
SetWindowLong hwnd, GWL_WNDPROC, PrevProc
Call UnregisterHotKey(hwnd, MyHotKey)
End If
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = WM_ACTIVATEAPP Then
EndFullScreen hwnd
End If
If uMsg = WM_HOTKEY Then
If wParam = MyHotKey Then
EndFullScreen hwnd
End If
End If
End Function
Código en el Formulario MDI»
Option Explicit
Private Sub MDIForm_Load()
Form1.Show
End Sub
Private Sub MDIForm_Resize()
If Me.WindowState = vbMaximized Then
ShowFullScreen Me.hwnd
Else
EndFullScreen Me.hwnd
End If
Este es un módulo para trabajar con los Socket de Windows, vendría a ser un reemplazo del WinSock.ocx, en este me he basado en el módulo de KPD-Team y lo reformé a mi gusto. Su uso creo, es muy sencillo y práctico, especialmente a la hora de trabajar con múltiples conexiones, si lo utilizan tal vez puedan encontrarse con algunas diferencias con respecto a la forma convencional de trabajo de como se utiliza con el WinSock.ocx.
A continuación voy a dejar dos ejemplos de uso, en el cual expliqué detalladamente, para su fácil entendimiento:
El primero trata de una conexión Cliente-Servidor de tipo Chat donde el Servidor puede escuchar en distintos puertos a la vez y aceptar varias conexiones al mismo tiempo, para la parte Cliente también puede realizar más de una conexión y en diferentes puertos a la vez.
El segundo se trata de una conexión Cliente-Servidor para Transferir Archivos.
Una cosa para resaltar, si es que lo van a usar, es que deben agregar manualmente las subrutinas comentadas en el final del módulo al formulario o módulo clase que llame a la función InitWinSock Me del módulo WinSock32.
No lo he probado a full, pero creo que está funcionando perfectamente, cualquier inquietud, sugerencia o error pueden utilizar el sistema de comentarios.
Option Explicit
' --------------------------------------------------------------------
' Autor: Leandro Ascierto
' WEB: www.leandroascierto.com.ar
' Fecha: 09/07/2009
' Adaptado a mi gusto :)
' Basado en el módulo de KPD-Team http://www.allapi.net/
'----------------------------------------------------------------------
Private Declare Function accept Lib "wsock32.dll" (ByVal s As Long, addr As SOCKADDR, addrlen As Long) As Long
Private Declare Function bind Lib "wsock32.dll" (ByVal s As Long, addr As SOCKADDR, ByVal namelen As Long) As Long
Private Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Private Declare Function Connect Lib "wsock32.dll" Alias "connect" (ByVal s As Long, addr As SOCKADDR, ByVal namelen As Long) As Long
Private Declare Function htonl Lib "wsock32.dll" (ByVal hostlong As Long) As Long
Private Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
Private Declare Function Listen Lib "wsock32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
Private Declare Function Send Lib "wsock32.dll" Alias "send" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
Private Declare Function Socket Lib "wsock32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As String) As Long
Private Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Long) 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
Private Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
Private Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Declare Sub CopyMemoryIP Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long)
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Type WSADataType
wVersion As Integer
wHighVersion As Integer
szDescription As String * 257
szSystemStatus As String * 129
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type HostEnt
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type SOCKADDR
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero As String * 8
End Type
Private Const WINSOCK_MESSAGE As Long = 1025
Private Const INADDR_NONE As Long = &HFFFF
Private Const INADDR_ANY As Long = &H0
Private Const IPPROTO_TCP As Long = 6
Private Const INVALID_SOCKET As Long = -1
Private Const SOCKET_ERROR As Long = -1
Private Const SOCK_STREAM As Long = 1
Private Const AF_INET As Long = 2
Private Const PF_INET As Long = 2
Private Const FD_READ As Long = &H1&
Private Const FD_WRITE As Long = &H2&
Private Const FD_OOB As Long = &H4&
Private Const FD_ACCEPT As Long = &H8&
Private Const FD_CONNECT As Long = &H10&
Private Const FD_CLOSE As Long = &H20&
Private Const GWL_WNDPROC As Long = (-4)
Private PrevProc As Long
Private bIsInit As Boolean
Private hWin As Long
Private m_ObjectHost As Object
Private TimeOut As Long
Public PortOpen As Collection ' Colección de los puertos abiertos, tiene como key el ID/Sesión de los puertos Abiertos.
Public PortSesion As Collection ' Colección de los ID/Sesión de los puertos Abiertos.
Public Sockets As Collection ' Colección de el ID/Sesión de las Conexiones establecidas.
Public IPAddresses As Collection ' Colección de las IP de las Conexiones establecidas, tiene como key el ID/Sesión.
Public PortConection As Collection ' Colección de los Puertos de las Conexiones establecidas, tiene como key el ID/Sesión.
Public CurrentSocketHandle As Long ' ID de la última sesión activa.
' Esta función inicializa los Socket, debe hallarse al comienzo, y ObjectHost es el formulario o módulo clase que recibirá los Eventos/Mensajes
' En ese formulario o módulo clase deberán ir las líneas comentadas que se encuentran al final de este módulo.
Public Function InitWinSock(ObjectHost As Object) As Boolean
Dim StartupData As WSADataType
Set Sockets = New Collection
Set IPAddresses = New Collection
Set PortOpen = New Collection
Set PortSesion = New Collection
Set PortConection = New Collection
Set m_ObjectHost = ObjectHost
If Not bIsInit Then
If Not WSAStartup(&H101, StartupData) Then
bIsInit = True
hWin = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
PrevProc = SetWindowLong(hWin, GWL_WNDPROC, AddressOf WindowProc)
Else
bIsInit = False
End If
End If
InitWinSock = bIsInit
End Function
' Esta función es importante llamarla cuando se descarga el formulario, nunca cerrar el Visual Basic desde el Stop
' Sino no se ejecutara esta rutina, el IDE de Visual Basic se cerrará automáticamente dando lugar a no guardar los cambios.
Public Sub TerminateWinSock()
Dim Ret As Long
Dim Cnt As Long
For Cnt = 1 To Sockets.Count
WsClose Sockets.Item(1)
Next
For Cnt = 1 To PortSesion.Count
closesocket PortSesion.Item(1)
PortSesion.Remove (1)
PortOpen.Remove (1)
Next
If WSAIsBlocking Then WSACancelBlockingCall
Call WSACleanup
bIsInit = False
SetWindowLong hWin, GWL_WNDPROC, PrevProc
DestroyWindow hWin
Set Sockets = Nothing
Set IPAddresses = Nothing
Set PortConection = Nothing
Set PortSesion = Nothing
Set PortOpen = Nothing
End Sub
' Función para conectar, Host es la ip o el dsn a que se quiera conectar, y port el puerto.
' Si conecta la función retorna el ID de la sesión del Socket, de lo contrario 0.
Public Function WsConnect(ByVal Host As String, ByVal Port As Long) As Long
Dim s As Long
Dim Sockin As SOCKADDR
Sockin.sin_family = AF_INET
Sockin.sin_port = htons(Port)
If Sockin.sin_port = INVALID_SOCKET Then Exit Function
Sockin.sin_addr = GetHostByNameAlias(Host$)
If Sockin.sin_addr = INADDR_NONE Then Exit Function
s = Socket(PF_INET, SOCK_STREAM, IPPROTO_TCP)
If s < 0 Then Exit Function
If Connect(s, Sockin, 16) <> 0 Then
If s Then closesocket s
Exit Function
End If
If WSAAsyncSelect(s, hWin, ByVal WINSOCK_MESSAGE, ByVal FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE) Then
closesocket s
Else
IPAddresses.Add GetAscIp(Sockin.sin_addr), CStr(s)
Sockets.Add s, CStr(s)
PortConection.Add Port, CStr(s)
CurrentSocketHandle = s
WsConnect = s
End If
End Function
' Función para poner a la escucha en determinado puerto.
' Si no ocurre ningún error y el puerto está disponible, la función retorna el ID de la sesión del Socket, de lo contrario 0.
Public Function WsListenInPort(ByVal Port As Long) As Long
Dim s As Long
Dim Sockin As SOCKADDR
Sockin.sin_family = AF_INET
Sockin.sin_port = htons(Port)
If Sockin.sin_port = INVALID_SOCKET Then Exit Function
Sockin.sin_addr = htonl(INADDR_ANY)
If Sockin.sin_addr = INADDR_NONE Then Exit Function
s = Socket(PF_INET, SOCK_STREAM, 0)
If s < 0 Then Exit Function If bind(s, Sockin, 16) Then closesocket s Exit Function End If If WSAAsyncSelect(s, hWin, ByVal WINSOCK_MESSAGE, ByVal FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT) Then closesocket s Exit Function End If If Listen(s, 1) Then closesocket s Else WsListenInPort = s PortOpen.Add Port, CStr(s) PortSesion.Add s, CStr(s) End If End Function ' Esta función Cierra un puerto previamente abierto, si se afirma ForceCloseConection, cerrará todas las conexiones establecidas en ese puerto ' de lo contrario, las conexiones que ya estaban establecidas permanecen y pueden seguir enviando mensajes, pero no se podrá hacer una nueva conexión a ese puerto ' si todo sale bien la funcion retorna True. Public Function WsClosePort(ByVal Port As Long, Optional ForceCloseConection As Boolean) As Boolean On Error GoTo ErrOut Dim s As Long Dim Cnt As Long For Cnt = 1 To PortOpen.Count If PortOpen(Cnt) = Port Then s = PortSesion(Cnt) Exit For End If Next If s = 0 Then Exit Function closesocket s PortSesion.Remove CStr(s) PortOpen.Remove CStr(s) If ForceCloseConection Then For Cnt = Sockets.Count To 1 Step -1 If PortConection(Cnt) = Port Then WsClose Sockets(Cnt) End If Next End If WsClosePort = True Exit Function ErrOut: WsClosePort = False End Function ' Esta función envía datos al servidor, el primer parámetro es el ID de la sesión, la cual la podemos obtener de Sockets(index) ' o con CurrentSocketHandle que es el último ID de sesión activa. ' El segundo parámetro la data a enviar. ' Si el mensaje se envió con éxito la función devuelve True Public Function SendData(Socket As Long, Data As Variant) As Boolean Dim Ret As Long Dim TheMsg() As Byte, sTemp$ TheMsg = "" Select Case VarType(Data) Case 8209 'byte array sTemp = Data TheMsg = sTemp Case 8 'String sTemp = StrConv(Data, vbFromUnicode) Case Else sTemp = CStr(Data) sTemp = StrConv(Data, vbFromUnicode) End Select TheMsg = sTemp If UBound(TheMsg) > -1 Then
Ret = Send(Socket, TheMsg(0), (UBound(TheMsg) - LBound(TheMsg) + 1), 0)
If Ret = SOCKET_ERROR Then
TimeOut = GetTickCount + 5000
Do While Ret = SOCKET_ERROR
Ret = Send(Socket, TheMsg(0), (UBound(TheMsg) - LBound(TheMsg) + 1), 0)
DoEvents
Sleep 10
If TimeOut < GetTickCount Then Exit Do
Loop
End If
SendData = Ret <> SOCKET_ERROR
End If
End Function
' Esta función cierra la conexión indicada mediante el ID de sesión que se pase como parámetro
' el ID lo obtenemos de Sockets(index) o con CurrentSocketHandle que es el último ID de sesión activa.
' si todo sale bien la función retorna True.
Public Function WsClose(ByVal s As Long) As Boolean
On Local Error Resume Next
WsClose = closesocket(s)
IPAddresses.Remove CStr(s)
Sockets.Remove CStr(s)
PortConection.Remove CStr(s)
End Function
' Función que retorna la IP Local.
Public Function GetLocalIp() As String
Dim sHostName As String * 256
Dim lpHost As Long
Dim Host As HostEnt
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
lpHost = gethostbyname(sHostName)
CopyMemoryIP Host, lpHost, Len(Host)
CopyMemoryIP dwIPAddr, Host.hAddrList, 4
ReDim tmpIPAddr(1 To Host.hLen)
CopyMemoryIP tmpIPAddr(1), dwIPAddr, Host.hLen
For i = 1 To Host.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetLocalIp = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
End Function
' Función que retorna el Nombre de Host Local.
Public Function LocalHostName() As String
Dim sHostName As String * 256
If gethostname(sHostName, 256) <> INVALID_SOCKET Then
LocalHostName = Trim$(sHostName)
End If
End Function
' Función Privada del módulo.
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Local Error Resume Next
If uMsg = WINSOCK_MESSAGE Then
Dim mIP As String
Dim mPuerto As String
CurrentSocketHandle = wParam
Select Case lParam
Case FD_ACCEPT
Dim s As Long, tempAddr As SOCKADDR
s = accept(wParam, tempAddr, Len(tempAddr))
mIP = GetAscIp(tempAddr.sin_addr)
mPuerto = PortOpen(CStr(wParam))
IPAddresses.Add mIP, CStr(s)
Sockets.Add s, CStr(s)
PortConection.Add mPuerto, CStr(s)
Call m_ObjectHost.Socket_Conect(s, mIP, mPuerto)
Case FD_CONNECT
'Debug.Print "FD_CONNECT"
Case FD_WRITE
'Debug.Print "FD_WRITE"
Case FD_READ
Dim sTemp As String, lRet As Long, szBuf As String
Do
szBuf = String(1024, 0)
lRet = recv(wParam, ByVal szBuf, Len(szBuf), 0)
If lRet > 0 Then sTemp = sTemp + Left$(szBuf, lRet)
Loop Until lRet 0 Then
mIP = IPAddresses(CStr(wParam))
mPuerto = PortConection(CStr(wParam))
Call m_ObjectHost.Socket_DataArrival(wParam, mIP, mPuerto, sTemp)
End If
Case Else 'FD_CLOSE
mPuerto = PortConection(CStr(wParam))
mIP = IPAddresses(CStr(wParam))
WsClose wParam
Call m_ObjectHost.Socket_Close(wParam, mIP, mPuerto)
End Select
Else
WindowProc = CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
End If
End Function
' Función Privada del módulo.
Private Function GetHostByNameAlias(ByVal HostName As String) As Long
On Error Resume Next
Err.Clear
Dim heDestHost As HostEnt
Dim addrList As Long
Dim retIP As Long
Dim phe As Long
retIP = inet_addr(HostName)
If retIP = INADDR_NONE Then
phe = gethostbyname(HostName)
If phe <> 0 Then
MemCopy heDestHost, ByVal phe, 16
MemCopy addrList, ByVal heDestHost.hAddrList, 4
MemCopy retIP, ByVal addrList, heDestHost.hLen
Else
retIP = INADDR_NONE
End If
End If
GetHostByNameAlias = retIP
If Err Then GetHostByNameAlias = INADDR_NONE
End Function
'Funcion Privada del módulo
Private Function GetAscIp(ByVal inn As Long) As String
On Error Resume Next
Dim lpStr&
Dim nStr&
Dim retString$
retString = String(32, 0)
lpStr = inet_ntoa(inn)
If lpStr = 0 Then
GetAscIp = "255.255.255.255"
Exit Function
End If
nStr = lstrlen(lpStr)
If nStr > 32 Then nStr = 32
MemCopy ByVal retString, ByVal lpStr, nStr
retString = Left(retString, nStr)
GetAscIp = retString
If Err Then GetAscIp = "255.255.255.255"
End Function
'*=====================ATENCION=====ATENCION======ATENCION=======================*
'*===============================================================================*
'*===============================================================================*
'ESTAS LINEAS DEBEN IR EN EL FORMULARIO O MODULO CLASE DONDE RECIBIRAN LOS EVENTOS
'*===============================================================================*
'*===============================================================================*
'_________________________________________________________________________________________________
'Public Sub Socket_Conect(ID As Long, IP As String, Puerto As String)
'End Sub
'_________________________________________________________________________________________________
'Public Sub Socket_DataArrival(ID As Long, IP As String, Puerto As String, Data As String)
'End Sub
'_________________________________________________________________________________________________
'Public Sub Socket_Close(ID As Long, IP As String, Puerto As String)
'End Sub
'_________________________________________________________________________________________________
Ejemplo: Cliente – Servidor (Chat)
Ejemplo: Cliente – Servidor (Transferencia de archivos)
Este es un módulo clase para utilizar el traductor de google, el cual trabaja con la API AJAX de idiomas para traducción y detección, para mas información sobre esta api puedes consultar aquí.
Cuenta con cuarenta y un lenguajes, y una función para auto-detectar el idioma, el módulo es más lento que las traducciones de la página de google ya que por lo que pude interpretar en la guía de ayuda, sólo trabaja con métodos GET y ésta sólo se limita a un máximo de 2000 caracteres por consulta, entonces si el texto a traducir es mayor a esta cantidad el módulo enviará más de una petición para traducir todo el texto, quizás algunos se preguntarán por qué no obtener el texto directamente de la web de google, y la respuesta es que la web con el tiempo puede cambiar su contenido HTML, dando como resultado un módulo obsoleto.
Otra cosa a tener en cuenta es la traducción a idiomas que utilicen una codificación de caracteres especiales como el «chino» que no se mostrará correctamente en un TextBox.
Su uso es muy sencillo y lo pueden ver en el siguiente ejemplo.
Este es un módulo bas que sirve para que nuestra aplicación se inicie junto con Windows, no es nada novedoso, modifica las claves del registro mediante Apis.
Cuenta con dos funciones:
– SetAutoRun: Con un parámetro Boolean, si éste es verdadero ancla nuestra aplicación al inicio, de lo contrario la quita, la función debería retornarnos un valor verdadero si es que todo salió bien.
– IsAutoRun: Devuelve «true» si nuestra aplicación ya está en el inicio
Option Explicit
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 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
Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private 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
Private 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
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)
Private Const RAMA_RUN_WINDOWS As String = "SOFTWARE\Microsoft\Windows\CurrentVersion\Run"
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const REG_SZ As Long = 1
Private Const KEY_ALL_ACCESS = &H3F
Public Function SetAutoRun(Value As Boolean) As Boolean
Dim Path As String
Dim Handle As Long
Path = Chr(34) & App.Path & "\" & App.EXEName & ".exe" & Chr(34)
RegOpenKeyEx HKEY_CURRENT_USER, RAMA_RUN_WINDOWS, 0, KEY_ALL_ACCESS, Handle
If Value Then
SetAutoRun = RegSetValueExString(Handle, App.Title, 0&, REG_SZ, Path, Len(Path)) = 0
Else
SetAutoRun = RegDeleteValue(Handle, App.Title) = 0
End If
RegCloseKey Handle
End Function
Public Function IsAutoRun() As Boolean
Dim Path As String
Dim Handle As Long
Dim Data As String
Dim cch As Long
Path = Chr(34) & App.Path & "\" & App.EXEName & ".exe" & Chr(34)
RegOpenKeyEx HKEY_CURRENT_USER, RAMA_RUN_WINDOWS, 0, KEY_ALL_ACCESS, Handle
RegQueryValueExNULL Handle, App.Title, 0&, 0&, 0&, cch
If cch > 0 Then
Data = String(cch - 1, 0)
RegQueryValueExString Handle, App.Title, 0&, 0&, Data, cch
IsAutoRun = Path = Data
End If
RegCloseKey Handle
End Function
Este es un módulo con una función para implementar los diferentes gráficos de la Api Google Char en Visual Basic, quizás no tenga mucho sentido ya que dependemos de una conexión a internet y descargamos la imágen desde una web, lo cual ya requiere de un cierto tiempo, pero bueno siempre puede llegar a ser útil en estos casos.
Junto al proyecto de descarga hay cinco ejemplos muy sencillos y un editor en Flash que nos podrá ayudar mucho, primeramente a entender esta api y luego cómo manejar sus parámetros.
Para saber más acerca de cómo utilizar esta api pueden visitar esta Web, donde explica en detalle cada uno de los parámetros.
Los gráficos a continuación son directamente generados por Google Char.
En realidad este no es un módulo, sino un formulario, el cual utiliza las Apis de Google SpellCheck, cuenta con varios idiomas y su uso es muy sencillo, sólo basta con una línea de código, en este proyecto/código no utilicé ninguna api, sólo la creación de algunos objetos (estos objetos ya están por defecto en Windows, por lo tanto no hay dependencias), obviamente requerimos de conexión a internet para que funcione.
Básicamente lo que hace es crear un XML y dentro del contenido de éste, el texto a corregir, se lo envía a Google en una petición de tipo POST y éste nos devuelve otro XML con las posibles sugerencias, del resto se encarga este formulario que va listando las sugerencias, reemplazando u omitiendo.
También cuenta con la posibilidad de agregar palabras a un diccionario, este no es más que un archivo de texto plano en el que se irán almacenando todas las palabras que agreguemos.
