Mover ventana arrastrandola desde cualquier parte
Declaramos las funciones a utilizar :
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
'en el evento MouseDown del formulario :
ReleaseCapture
SendMessage Me.hWnd, &HA1, 2, 0&
'Esta función sirve también para mover cualquier control que tenga la propiedad hWnd dentro de un formulario.

Boton cerrar inhabilitado
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public Const SC_CLOSE = &HF060&
Public Const MF_BYCOMMAND = &H0&
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(hwnd, False)
RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND

Conocer mi direccion IP
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type

Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type

Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Public Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function
Public Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function

Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
'MsgBox "The 32-bit Windows Socket is not responding."
SocketsInitialize = False
Exit Function
End If
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
'MsgBox "This application requires a minimum of " & ' CStr(MIN_SOCKETS_REQD) & " supported sockets."
SocketsInitialize = False
Exit Function
End If
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
sHiByte = CStr(HiByte(WSAD.wVersion))
sLoByte = CStr(LoByte(WSAD.wVersion))
'MsgBox "Sockets version " & sLoByte & "." & sHiByte & ' " is not supported by 32-bit Windows Sockets."
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
'MsgBox "Socket error occurred in Cleanup."
End If
End Sub
Public Function GetIPAddress() 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
If Not SocketsInitialize() Then
GetIPAddress = ""
Exit Function
End If
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPAddress = ""
'MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & ' " has occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
sHostName = Trim$(sHostName)
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
GetIPAddress = ""
'MsgBox "Windows Sockets are not responding. " & ' "Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup
End Function
La función GetIPAddress nos devuelve un string con la dirección IP.

LEER UN BMP DESDE UN RECURSO (DLL)
temp=DrawBMP(Form1,101)
Public Function DrawBMP(ByRef Form As Form, ByVal BMP_ID As Long, Optional ByVal x As Long = 0, Optional ByVal y As Long = 0)
Dim desDC, memDC, hRESBMP, hMEMBMP As Long
desDC = Form.hdc
memDC = CreateCompatibleDC(desDC)
hRESBMP = LoadBitmapBynum(App.hInstance, BMP_ID)
hMEMBMP = CreateCompatibleBitmap(memDC, 0, 0)
mb = SelectObject(memDC, hRESBMP)
bi = BitBlt(desDC, x, y, Form1.ScaleWidth, Form1.ScaleHeight, memDC, 0, 0,SRCCOPY)
End Function

GRABAR/OBTENER ARCHIVOS BINARIOS EN UNA BD
Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As

Long, ByVal lpTempFileName As String) As Long
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Function SaveBinary(sFileName As String, F As Field) As Boolean
Dim i As Long
Dim iFileNbr As Integer
Dim nChunkSize As Long
Dim nLenLeft As Long
Dim nPos As Long
Dim sBuffer As String
Dim FileName As String
FileName = GetFileName
FileCopy sFileName, FileName
iFileNbr = FreeFile
Open FileName For Binary As #iFileNbr
nChunkSize = 16380
nLenLeft = LOF(iFileNbr)
If nLenLeft < nChunkSize Then
nChunkSize = nLenLeft
End If
nPos = 1
Do
sBuffer = Space(nChunkSize)
Get #iFileNbr, nPos, sBuffer
F.AppendChunk sBuffer
nPos = nPos + nChunkSize
nLenLeft = nLenLeft - nChunkSize
If nLenLeft < nChunkSize Then
nChunkSize = nLenLeft
End If
Loop Until nLenLeft <= 0
Close #iFileNbr
Kill FileName
SaveBinary = True
End Function
Public Function GetBinary(F As Field, sSndFile As String)
Dim iFileNbr As Integer
'Dim sSndFile As String
Dim nChunkSize As Long
Dim nLenLeft As Long
Dim nPos As Long
Dim sBuffer As String
'//sSndFile = GetFileName()
If Len(sSndFile) = 0 Then
GetBinary = ""
Exit Function
Else
iFileNbr = FreeFile
Open sSndFile For Binary As #iFileNbr
End If
nLenLeft = F.FieldSize
nChunkSize = 16380
If nLenLeft < nChunkSize Then
nChunkSize = nLenLeft
End If
nPos = 0
Do
sBuffer = Space(nChunkSize)
sBuffer = F.GetChunk(nPos, nChunkSize)
Put #iFileNbr, , sBuffer
nPos = nPos + nChunkSize
nLenLeft = nLenLeft - nChunkSize
If nLenLeft < nChunkSize Then
nChunkSize = nLenLeft
End If
Loop Until nLenLeft <= 0
GetBinary = sSndFile
Close #iFileNbr
End Function
Public Function GetFileName() As String
Dim sTempPath As String
Dim nReturn As Long
Dim sFileName As String
sTempPath = Space(255)
sFileName = Space(255)
nReturn = GetTempPath(Len(sTempPath), sTempPath)
If nReturn <> 0 Then '// Don't do anything if they don't have PATH set
sTempPath = Left(sTempPath, nReturn) '// Trim extra characters off
nReturn = GetTempFileName(sTempPath, "SOS", 0, sFileName)
If nReturn <> 0 Then
GetFileName = Left(sFileName, InStr(sFileName, Chr$(0)) - 1)
End If
End If
End Function

VENTANA CON COLOR DE FILTRO
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Sub MakeTransparent(frmPass As Object, Optional tColor)
If IsMissing(tColor) Then tColor = RGB(170, 250, 250)
frmPass.AutoRedraw = True
frmPass.Hide
DoEvents
hw = GetDesktopWindow() 'Get Desktop window handle
ha = GetDC(hw) 'Get Desktop window hDC
dx1 = frmPass.Left / Screen.TwipsPerPixelX
dy1 = frmPass.Top / Screen.TwipsPerPixelY
wdth = frmPass.ScaleWidth 'width of form
higt = frmPass.ScaleHeight 'height of form
s = BitBlt(frmPass.hdc, 0, 0, wdth, higt, ha, dx1, dy1, SRCCOPY)
frmPass.Picture = frmPass.Image
frmPass.Show
Call ReleaseDC(hw, ha)
frmPass.DrawMode = 9
frmPass.ForeColor = tColor
frmPass.Line (0, 0)-(wdth, higt), , BF
End Sub

OEMTOANSI & VISCEVERSA
Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
testo_dos$ ="città, virtù, però, così, perchè"
testo_oem$ = "città, virtù, però, così, perchè"
Call OemToChar(testo_dos$, testo_oem$)
msgbox(testo_oem$)

BITMAPS TRANSPARENTES
Option Explicit
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Public Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long)As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Sub Command1_Click()
Dim R As RECT
With R
.Left = 0
.Top = 0
.Right = Picture1.ScaleWidth
.Bottom = Picture1.ScaleHeight
End With
TransparentBlt Form1.hdc, Form1.hdc, Picture1.hdc, R, 20, 20, vbWhite
End Sub
Private Sub TransparentBlt(OutDstDC As Long, DstDC As Long, SrcDC As Long, SrcRect As RECT, DstX As Integer, DstY As Integer, TransColor As Long)
Dim nRet As Long, W As Integer, H As Integer
Dim MonoMaskDC As Long, hMonoMask As Long
Dim MonoInvDC As Long, hMonoInv As Long
Dim ResultDstDC As Long, hResultDst As Long
Dim ResultSrcDC As Long, hResultSrc As Long
Dim hPrevMask As Long, hPrevInv As Long
Dim hPrevSrc As Long, hPrevDst As Long
W = SrcRect.Right - SrcRect.Left + 1
H = SrcRect.Bottom - SrcRect.Top + 1
MonoMaskDC = CreateCompatibleDC(DstDC)
MonoInvDC = CreateCompatibleDC(DstDC)
hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)
hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)
hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
hPrevInv = SelectObject(MonoInvDC, hMonoInv)
ResultDstDC = CreateCompatibleDC(DstDC)
ResultSrcDC = CreateCompatibleDC(DstDC)
hResultDst = CreateCompatibleBitmap(DstDC, W, H)
hResultSrc = CreateCompatibleBitmap(DstDC, W, H)
hPrevDst = SelectObject(ResultDstDC, hResultDst)
hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
Dim OldBC As Long
OldBC = SetBkColor(SrcDC, TransColor)
nRet = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, SrcRect.Left, SrcRect.Top, vbSrcCopy)
TransColor = SetBkColor(SrcDC, OldBC)
nRet = BitBlt(MonoInvDC, 0, 0, W, H, MonoMaskDC, 0, 0, vbNotSrcCopy)
nRet = BitBlt(ResultDstDC, 0, 0, W, H, DstDC, DstX, DstY, vbSrcCopy)
nRet = BitBlt(ResultDstDC, 0, 0, W, H, MonoMaskDC, 0, 0, vbSrcAnd)
nRet = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, SrcRect.Left, SrcRect.Top, vbSrcCopy)
nRet = BitBlt(ResultSrcDC, 0, 0, W, H, MonoInvDC, 0, 0, vbSrcAnd)
nRet = BitBlt(ResultDstDC, 0, 0, W, H, ResultSrcDC, 0, 0, vbSrcInvert)
nRet = BitBlt(OutDstDC, DstX, DstY, W, H, ResultDstDC, 0, 0, vbSrcCopy)
hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
DeleteObject hMonoMask
hMonoInv = SelectObject(MonoInvDC, hPrevInv)
DeleteObject hMonoInv
hResultDst = SelectObject(ResultDstDC, hPrevDst)
DeleteObject hResultDst
hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
DeleteObject hResultSrc
DeleteDC MonoMaskDC
DeleteDC MonoInvDC
DeleteDC ResultDstDC
DeleteDC ResultSrcDC
End Sub

Crear controles en tiempo de ejecucion
For Contador = 1 To UBound(ArrOpc, 1)
Load Label1(Label1.Count)
Label1(Contador).Font = Label1(0).Font
Label1(Contador).Top = AniGIF1.Height + (Label1(0).Font.Size * Screen.TwipsPerPixelY) * Contador + 80 * Contador
Label1(Contador).Visible = True
Next

Download (HTTP) de un JPG en VB
Private Sub cmdStart_Click()
Dim FileData() As Byte
Dim GetURL As String
Dim PutFile As String
Dim Connection As String
Dim Msg As String
Dim flag As Boolean
Dim temp As Integer
Dim FileCount As Integer
For Track = 0 To lstFiles.ListCount - 1
If lstFiles.Selected(Track) Then
flag = True
Exit For
End If
Next Track
If Not flag Then
Msg = "You've got to tell me what files to grab."
Msg = Msg + vbCrLf + "Do that be selecting files from the list."
temp = MsgBox(Msg, vbQuestion, "Help Me! Help Me! I don't know what to do")
Exit Sub
End If
lblStatus.Caption = "Gettin Ready to Grab Files"
MousePointer = vbHourglass
FileCount = 0
For Track = 0 To lstFiles.ListCount - 1
If lstFiles.Selected(Track) Then
PutFile = dirOut.Path & "\" & lstFiles.List(Track)
If Dir(PutFile) <> "" Then
Kill (PutFile)
End If
GetURL = txtURL.Text & txtDir.Text & "/" & lstFiles.List(Track)
lblStatus.Caption = "Retrieving " & GetURL
FileData() = ""
FileData() = Inet1.OpenURL(GetURL, icByteArray)
Open PutFile For Binary Access Write As #1
Put #1, , FileData()
Close #1
FileCount = FileCount + 1
lstFiles.Selected(Track) = False
DoEvents
End If ' item selected
Next Track
MousePointer = vbArrow
lblStatus.Caption = "Micah's Web File Grabber"
lblInet.Caption = FileCount & " Files retrieved and stored in " & dirOut.Path
If Err Then GoTo Problem
Exit Sub
Problem:
lblStatus.Caption = "Micah's Web File Grabber from http://tolands.com"
Close #1
MsgBox (Error(Err))
End Sub