Conexiones visibles en una red

Declare Function WNetAddConnection Lib "mpr.dll" Alias "WNetAddConnectionA" (ByVal lpszNetPath As String, ByVal lpszPassword As String, ByVal lpszLocalName As String) As Long
Declare Function WNetCancelConnection Lib "mpr.dll" Alias "WNetCancelConnectionA" (ByVal lpszName As String, ByVal bForce As Long) As Long
Function IsServerActive(sServName As String) As Boolean
Dim sRemote As String
sRemote = "\\" & sServName & "\NETLOGON"
If WNetAddConnection(sRemote, vbNullString, vbNullString) = NO_ERROR then
WNetCancelConnection sRemote, False
IsServerActive = True
Exit Function
End If
IsServerActive = False
End Function

Copiar archivos pór FTP
Private Sub Command1_Click()
Inet1.AccessType = icUseDefault
Dim b() As Byte
Dim strURL As String
Dim FileString As String
strURL1 = ftp://[username]:[psswd]@[IP addr of server]
If Text1 = "" Or Text2 = "" Or Text3 = "" Or Text4 = "" Then
MsgBox ":)", 64, ""
Exit Sub
End If
strURL = "ftp://" & Text1 & ":" & Text2 & "@" & Text3 & "/" & Text4
FileString = "d:\FtpTest\" & Text4
b() = Inet1.OpenURL(strURL, icByteArray)
Open FileString For Binary Access Write As #1
Put #1, , b()
Close #1
MsgBox "Done"
End Sub

Mover mouse desde codigo
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Private Declare Function PostMessageBynum Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 'enviar mensajes al control
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long 'posicionar el puntero del ratón
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long,lpRect As RECT) As Long 'obtener la posición del control
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Y ahora el proceso :
Dim l As Long, PosX As Long, PosY As Long, PosXY As Long
Dim lpRect As RECT
l = GetWindowRect(Command1.hwnd, lpRect)
'colocar el ratón sobre el centro del botón
PosX = lpRect.Left + ((lpRect.Right - lpRect.Left) / 2)
PosY = lpRect.Top + ((lpRect.Bottom - lpRect.Top) / 2)
l = SetCursorPos(PosX, PosY)
PosXY = (PosY - lpRect.Top) * 65536 + (PosX - lpRect.Left)
'simular el click del ratón
l = PostMessageBynum(Command1.hwnd, WM_LBUTTONDOWN, 0&, PosXY)
l = PostMessageBynum(Command1.hwnd, WM_LBUTTONUP, 0&, PosXY)

Numero serie de HD
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Dim A As String
Dim VolumeNameBuffer As String
Dim tamaVolume As Long
Dim SerieNum As Long
Dim Maximo As Long
Dim Band As Long
Dim SystemaBuf As Long
Dim TamNameSize As Long
Dim V As Long
Dim Etiqueta As String
Etiqueta = "XXXX-XXXX"
A = "C:\"
V = GetVolumeInformation(A, VolumeNameBuffer, tamaVolume, SerieNum, Maximo,
Band, SystemaBuf, TamNameSize)
If (Left(Hex(SerieNum), 4) & "-" & Right(Hex(SerieNum), 4)) <> Etiqueta Then
Mensaje$ = "Número de serie incorrecto"
respuesta = MsgBox(Mensaje$, vbCritical)
End
End If

Control de Speaker en VB
Private Declare Function MsgBeep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
dwFreq = frequency in Hz, dwDuration in msec.

Cambiar Caps/Num/Scroll en VB32
Option Explicit
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Const VK_NUMLOCK = &H90
Private Const VK_CAPITAL = &H14
Private Const VK_SCROLL = &H91
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Private Sub SetState(fOn As Boolean, nVK As Integer, nScan As Integer, Optional fExtended As Boolean)
Dim lFlag As Long
If fExtended Then lFlag = KEYEVENTF_EXTENDEDKEY
If (GetKeyState(nVK) And 1) = 1 Xor fOn Then
keybd_event nVK, nScan, lFlag, 0
keybd_event nVK, nScan, lFlag Or KEYEVENTF_KEYUP, 0
End If
End Sub
Public Sub SetNumLock(fOn As Boolean)
SetState fOn, VK_NUMLOCK, &H45, True
End Sub
Public Sub SetCapsLock(fOn As Boolean)
SetState fOn, VK_CAPITAL, &H3A
End Sub
Public Sub SetScrollLock(fOn As Boolean)
SetState fOn, VK_SCROLL, &H46
End Sub

Hacer que se active un elemento de un control (p.e. listbox) al pasar el mouse sobre este:
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 Const LB_ITEMFROMPOINT = &H1A9
Dim lIndex As Long
Dim lXPoint As Long
Dim lYPoint As Long
If Button = 0 Then ' si no hay ningún botón presionado
lXPoint = CLng(X / Screen.TwipsPerPixelX)
lYPoint = CLng(Y / Screen.TwipsPerPixelY)
With List1
lIndex = SendMessage(.hwnd, LB_ITEMFROMPOINT, 0, ByVal ((lYPoint *65536) + lXPoint))
.ListIndex = lIndex
End With
End If

Para crear una base de datos:
Dim MiBaseDeDatos as Database, MiWorkspace as Workspace
Dim Mitabla as TableDef
Dim MisCampos(1) ' 2 campos MisCampos(0) y MisCampos(1)
Para crear una nueva base de datos:
Set MiWorkspace = DBEngine.Workspaces(0)
Set MiBaseDeDatos =MiWorkspace.CreateDatabase("C:\MiDirectorio\Nombre.mdb", dbLangGeneral, dbVersion30)
Creamos una tabla:
Set MiTabla = MiBaseDeDatos.CreateTableDef("Tabla1")
Set MisCampos(0) = MiTabla.CreateField("Nombre", dbText)
MisCampos(0).Size = 30
Set MisCampos(1) = MiTabla.CreateField("Apellidos", dbText)
MisCampos(1).Size = 50
MiTabla.Fields.Append Miscampos(0)
MiTabla.Fields.Append Miscampos(1)
MiBaseDeDatos.TableDefs.Append MiTabla

Rotar texto en impresora
Sub RotText(I%)
Dim hFont As Integer, hOldFont As Integer
Dim Font As LOGFONT
Dim nValue%, SomeText$, szFaceName$, RetVal%, nChars%
nValue = GetDeviceCaps(Printer.hDC, TEXTCAPS)
Font.lfHeight = 50 '-- 24 point size
Font.lfWidth = 0 '-- let Windows figure out the appropriate width based on the height
Font.lfEscapement = 900 '-- rotate 270 degrees (bottom to top)
Font.lfOrientation = 900 '-- normal character orientation (straight up)
Font.lfPitchAndFamily = Chr$(VARIABLE_PITCH Or FF_MODERN)
Font.lfCharSet = Chr$(OEM_CHARSET) '-- this is important!
Font.lfQuality = Chr$(PROOF_QUALITY)
Font.lfWeight = FW_NORMAL * 10
Font.lfFaceName = "Arial" '-- Windows' "Modern" font
hFont = CreateFontIndirect(Font)
hOldFont = SelectObject(Printer.hDC, hFont)
szFaceName$ = Space$(80)
RetVal% = GetTextFace(Printer.hDC, 79, szFaceName$)
SomeText = "Texto rotado1"
If Not I Then
Printer.CurrentX = Margen + 2
Printer.CurrentY = MargenSup + Alto - 29
Printer.Print SomeText;
Printer.CurrentX = Tab7
Printer.CurrentY = MargenSup + Alto - 65
Printer.Print "Texto Rotado2";
Else
Printer.CurrentX = Margen + 2
Printer.CurrentY = MargenSup + Alto - 29 - 110 - 17
Printer.Print SomeText;
Printer.CurrentX = Tab7
Printer.CurrentY = MargenSup + Alto - 65 - 110 - 17
Printer.Print "Texto Rotado3";
End If
DeleteObject hFont
End Sub

ADO para acceso a db
Public Sub ConnectionStringX()
Dim cnn1 As ADODB.Connection
Dim cnn2 As ADODB.Connection
Dim cnn3 As ADODB.Connection
Dim cnn4 As ADODB.Connection
Set cnn1 = New ADODB.Connection
cnn1.ConnectionString = "driver={SQL Server};" & "server=bigsmile;uid=sa;pwd=pwd;database=pubs"
cnn1.ConnectionTimeout = 30
cnn1.Open
' Open a connection using a DSN and ODBC tags.
Set cnn2 = New ADODB.Connection
cnn2.ConnectionString = "DSN=Pubs;UID=sa;PWD=pwd;"
cnn2.Open
' Open a connection using a DSN and OLE DB tags.
Set cnn3 = New ADODB.Connection
cnn3.ConnectionString = "Data Source=Pubs;User ID=sa;Password=pwd;"
cnn3.Open
' Open a connection using a DSN and individual arguments instead of a connection string.
Set cnn4 = New ADODB.Connection
cnn4.Open "Pubs", "sa", "pwd"
' Display the state of the connections.
MsgBox "cnn1 state: " & GetState(cnn1.State) & vbCr & "cnn2 state: " & GetState(cnn1.State) & vbCr & "cnn3 state: " & GetState(cnn1.State) & vbCr & "cnn4 state: " & GetState(cnn1.State)
cnn4.Close
cnn3.Close
cnn2.Close
cnn1.Close
End Sub
Public Function GetState(intState As Integer) As String
Select Case intState
Case adStateClosed
GetState = "adStateClosed"
Case adStateOpen
GetState = "adStateOpen"
End Select
End Function