Tamaño de fuente
Sample Code
'** TYPES **
Type TEXTMETRIC
tmHeight As Integer
tmAscent As Integer
tmDescent As Integer
tmInternalLeading As Integer
tmExternalLeading As Integer
tmAveCharWidth As Integer
tmMaxCharWidth As Integer
tmWeight As Integer
tmItalic As String * 1
tmUnderlined As String * 1
tmStruckOut As String * 1
tmFirstChar As String * 1
tmLastChar As String * 1
tmDefaultChar As String * 1
tmBreakChar As String * 1
tmPitchAndFamily As String * 1
tmCharSet As String * 1
tmOverhang As Integer
tmDigitizedAspectX As Integer
tmDigitizedAspectY As Integer
End Type
'** Win32 API DECLARATIONS **
Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
'** CONSTANTS **
Global Const MM_TEXT = 1
'** Function **
Public Function gbl_GetFontRes$()
Dim hdc, hwnd, PrevMapMode As Long
Dim tm As TEXTMETRIC
gbl_GetFontRes$ = "VGA"
hwnd = GetDesktopWindow()
hdc = GetWindowDC(hwnd)
If hdc Then
PrevMapMode = SetMapMode(hdc, MM_TEXT)
GetTextMetrics hdc, tm
PrevMapMode = SetMapMode(hdc, PrevMapMode)
ReleaseDC hwnd, hdc
If tm.tmHeight > 16 Then gbl_GetFontRes$ = "8514"
End If
End Function

Cargar BLOB en un string
Dim data() As Byte
Open "filename" For Binary As #1
ReDim data(LOF(1)) As Byte
Get #1, , data()
Close #1

Pintar un icono en el titulo de una ventana
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const SM_CXBORDER = 5
Private Const SM_CXFRAME = 32
Private Const SM_CYBORDER = 6
Private Const SM_CYFRAME = 33
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31
Private Const DI_NORMAL = 3
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long,lpRect As RECT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Sub Form_Paint()
Dim lpRect As RECT
Dim hdc As Long
Dim hIcon As Long
Dim fbx As Long
Dim fby As Long
Dim cx As Long
Dim cy As Long
If Left(Me.Caption, 6) <> " " Then
Me.Caption = " " & Me.Caption
End If
Call GetWindowRect(Me.hwnd, lpRect)
hdc = GetWindowDC(Me.hwnd)
hIcon = ExtractIcon(App.hInstance, "c:\winnt\notepad.exe", -1)
fbx = GetSystemMetrics(SM_CXBORDER) + GetSystemMetrics(SM_CXFRAME)
fby = GetSystemMetrics(SM_CXBORDER) + GetSystemMetrics(SM_CYFRAME)
cx = GetSystemMetrics(SM_CXSIZE) - GetSystemMetrics(SM_CXBORDER)
cy = GetSystemMetrics(SM_CYSIZE) - GetSystemMetrics(SM_CXBORDER)
Call DrawIconEx(hdc, fbx, fby, hIcon, cx, cy, 0, 0, DI_NORMAL)
Call DestroyIcon(hIcon)
Call ReleaseDC(Me.hwnd, hdc)
End Sub

Cambiar la configuracion regional de una PC
Public Const LOCALE_USER_DEFAULT = &H400
Public Const LOCALE_SYSTEM_DEFAULT = &H800
Public Const LOCALE_ICURRDIGITS = &H19
Public Const LOCALE_SSHORTDATE = &H1F
Public Const LOCALE_SCURRENCY = &H14
Public Const LOCALE_SDATE = &H1D
Public Const LOCALE_SDECIMAL = &HE
Public Const LOCALE_STHOUSAND = &HF
Declare Function GetLocaleInfo Lib "Kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Declare Function SetLocaleInfo Lib "Kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Long
Public Function ActualConfgRegional(lngTipo As Long) As String
Dim lngBufferLen As Long
Dim intRetorno As Integer
Dim strBuffer As String
On Error GoTo ActualConfgRegional_err
lngBufferLen = 50
strBuffer = Space$(lngBufferLen)
intRetorno = GetLocaleInfo(LOCALE_USER_DEFAULT, lngTipo, strBuffer, lngBufferLen)
ActualConfgRegional = Left$(strBuffer, InStr(strBuffer, Chr(0)) - 1)
Exit Function
ActualConfgRegional_err:
MensajeError "ActualConfgRegional", " Editando valor " & CStr(lngTipo)
End Function
Public Sub PonerConfgRegional(lngTipo As Long, strNuevoValor As String)
Dim intRetorno As Integer
On Error GoTo PonerConfgRegional_err
intRetorno = SetLocaleInfo(LOCALE_USER_DEFAULT, lngTipo, strNuevoValor)
Exit Sub
PonerConfgRegional_err:
MensajeError "PonerConfgRegional", " Estableciendo valor " & CStr(lngTipo)
End Sub
Public Function ConfgRegionalCorrecta() As Boolean
On Error GoTo ConfgRegionalCorrecta_err
ConfgRegionalCorrecta = True
If (ActualConfgRegional(LOCALE_ICURRDIGITS) <> "3") Then
ConfgRegionalCorrecta = False
Else
If (ActualConfgRegional(LOCALE_SSHORTDATE) <> "dd/MM/yyyy") Then
ConfgRegionalCorrecta = False
Else
If (ActualConfgRegional(LOCALE_SCURRENCY) <> "pts") Then
ConfgRegionalCorrecta = False
Else
If (ActualConfgRegional(LOCALE_SDATE) <> "/") Then
ConfgRegionalCorrecta = False
Else
If (ActualConfgRegional(LOCALE_SDECIMAL) <> ",") Then
ConfgRegionalCorrecta = False
Else
If (ActualConfgRegional(LOCALE_STHOUSAND) <> ".") Then
ConfgRegionalCorrecta = False
End If
End If
End If
End If
End If
End If
Exit Function
ConfgRegionalCorrecta_err:
MensajeError "ConfgRegionalCorrecta"
End Function
Public Sub AjustarConfgReg()
On Error GoTo AjustarConfgReg_err
PonerConfgRegional LOCALE_ICURRDIGITS, "3"
PonerConfgRegional LOCALE_SSHORTDATE, "dd/MM/yyyy"
PonerConfgRegional LOCALE_SCURRENCY, "pts"
PonerConfgRegional LOCALE_SDATE, "/"
PonerConfgRegional LOCALE_SDECIMAL, ","
PonerConfgRegional LOCALE_STHOUSAND, "."
Exit Sub
AjustarConfgReg_err:
MensajeError "AjustarConfgReg"
End Sub

Mostrar la ventana de mantenieminto de DSN
Call Shell("rundll32.exe shell32.dll,Control_RunDLL odbccp32.cpl", 1)

Evitar que te saquen con Ctrl-Alt-Del
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim strQuestion As String
Dim intAnswer As Integer
Dim aryMode As Variant
aryMode = Array("vbFormControlMenu", "vbFormCode", "vbAppWindows", "vbAppTaskManager", "vbFormMDIForm")
strQuestion = "Ready to unload this form?"
intAnswer = MsgBox(strQuestion, vbQuestion + vbYesNo, aryMode(UnloadMode))
If intAnswer = vbNo Then
Cancel = -1
End If
End Sub

Nombre del Logeado 95 & NT
Declare Function WNetGetUser Lib "wfwnet.drv" (ByVal szUser As String,nBufferSize As Integer) As Integer
Declare Function MNetNetworkEnum Lib "wfwnet.drv" (lphNetwork As Integer) As Integer
Declare Function MNetSetNextTarget Lib "wfwnet.drv" (ByVal hNetwork As Integer) As Integer
Sub Form_Load ()
Dim User As String
If Not MultiNetGetUser(User) Then
Label1.Caption = "Not logged on."
Else
Label1.Caption = "Logged on as " + User
End If
End Sub
Function MultiNetGetUser (UserName$) As Integer
Dim hNetDrv As Integer
Dim wRetEnum As Integer, ret As Integer
Dim wRetGetUser As Integer
Dim cb As Integer
Dim Found As Integer
Found = False
hNetDrv = 0
wRetEnum = MNetNetworkEnum(hNetDrv)
While (wRetEnum = 0) And Not Found
User$ = Space$(255)
cb = Len(User$)
ret = MNetSetNextTarget(hNetDrv)
wRetGetUser = WNetGetUser(User$, cb)
If wRetGetUser = 0 Then
UserName$ = Left$(User$, cb - 1)
Found = True
End If
' Get the next network:
wRetEnum = MNetNetworkEnum(hNetDrv)
Wend
MultiNetGetUser = Found
End Function

Crear/eliminar DSN
Private Const ODBC_ADD_DSN = 1 ' Add data source
Private Const ODBC_CONFIG_DSN = 2 ' Configure (edit) data source
Private Const ODBC_REMOVE_DSN = 3 ' Remove data source
Private Const vbAPINull As Long = 0& ' NULL Pointer
#If Win32 Then
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
#Else
Private Declare Function SQLConfigDataSource Lib "ODBCINST.DLL" (ByVal hwndParent As Integer, ByVal fRequest As Integer, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Integer
#End If
#If Win32 Then
Dim intRet As Long
#Else
Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String
strDriver = "SQL Server"
strAttributes = "SERVER=SomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=pubs" & Chr$(0)
strAttributes = strAttributes & "UID=sa" & Chr$(0)
strAttributes = strAttributes & "PWD=" & Chr$(0)
'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver,strAttributes)
If intRet Then
MsgBox "DSN Creado"
Else
MsgBox "Fallo en la creación"
End If
Para borrarlo :
#If Win32 Then
Dim intRet As Long
#Else
Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String
strDriver = "SQL Server"
strAttributes = "DSN=DSN_TEMP" & Chr$(0)
intRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, strDriver,strAttributes)
If intRet Then
MsgBox "DSN Eliminado"
Else
MsgBox "Fallo en el borrado"
End If
Para modificarlo:
#If Win32 Then
Dim intRet As Long
#Else
Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String
strDriver = "SQL Server"
strAttributes = "SERVER=OtroSomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN modificado" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=pubs" & Chr$(0)
strAttributes = strAttributes & "UID=sa" & Chr$(0)
strAttributes = strAttributes & "PWD=" & Chr$(0)
intRet = SQLConfigDataSource(vbAPINull, ODBC_CONFIG_DSN, strDriver,strAttributes)
If intRet Then
MsgBox "DSN Modificado"
Else
MsgBox "Fallo en la modificacion"
End If

Detectar unidad de CD
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
Function StripNulls(startStrg$) As String
Dim c%, item$
c% = 1
Do
If Mid$(startStrg$, c%, 1) = Chr$(0) Then
item$ = Mid$(startStrg$, 1, c% - 1)
startStrg$ = Mid$(startStrg$, c% + 1, Len(startStrg$))
StripNulls$ = item$
Exit Function
End If
c% = c% + 1
Loop
End Function
Private Sub Form_Load()
Dim r&, allDrives$, JustOneDrive$, pos%, DriveType&
Dim CDfound As Integer
allDrives$ = Space$(64)
r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)
allDrives$ = Left$(allDrives$, r&)
Do
pos% = InStr(allDrives$, Chr$(0))
If pos% Then
JustOneDrive$ = Left$(allDrives$, pos%)
allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))
DriveType& = GetDriveType(JustOneDrive$)
If DriveType& = DRIVE_CDROM Then
CDfound% = True
Exit Do
End If
End If
Loop Until allDrives$ = "" Or DriveType& = DRIVE_CDROM
If CDfound% Then
label1.Caption = "El CD-ROM corresponde a la unidad: " &
Ucase$(JustOneDrive$)
Else
label1.Caption = "Su sistema no posee CD-ROM o unidad no encontrada."
End If
End Sub

Crear Acceso directo desde VB
Declare Function OSfCreateShellGroup Lib "VB5STKIT.DLL" Alias "fCreateShellFolder" (ByVal lpstrDirName As String) As Long
Declare Function OSfCreateShellLink Lib "VB5STKIT.DLL" Alias "fCreateShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long
Declare Function OSfRemoveShellLink Lib "VB5STKIT.DLL" Alias "fRemoveShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String) As Long
l = OSfCreateShellGroup("Grupo de prueba")
l = OSfCreateShellLink("Grupo de prueba", "Mi programa 1", "C:\WIN95\pruebade PP.EXE", "parametros")
l = OSfCreateShellLink("Grupo de prueba", "Mi programa 2", "C:\WIN95\pruebade PP.EXE", "parametros")
l = OSfRemoveShellLink("Grupo de prueba", "Mi programa 1")