APIs

Ejecutar una aplicación

Flashear una ventana

Obtener el directorio del sistema

Cambiar la propidad check del menu por un circulo

'Función del módulo

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 

Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 

Public Const WM_CLOSE = &H10 

'Y para el formulario:

Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "Calculadora")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "Error enviando mensaje."
End If
Else
MsgBox "La Calculadora no está abierta."
End If

'Código para el Modulo
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long,_ ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal_ lpDirectory As String, ByVal nShowCmd As Long) As Long
'Código para el procedimiento
'Definimos las variables
Dim CadenaResultante As Long

'Abre un nuevo correo electrónico
CadenaResultante = ShellExecute(hwnd, "open",_ "mailto:programador@bcn.casarramona.com?subject=API's para Visual Basic", "", "", 1)

'Abre una página Web en el navegador por defecto del sistema
CadenaResultante = ShellExecute(hwnd, "open", "http://www.lawebdelprogramador.com", "", "", 1)

'Abre una hoja de calculo, en este caso del Excel de Microsoft
CadenaResultante = ShellExecute(hwnd, "open", "nombre_directorio.xls", "", "", 1)

'Escribimos en el proyecto

Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long)_ As Long

Private Sub tmrFlash_Timer()
FlashWindow frmFlash.hwnd, 1
End Sub

Private Sub cmdFlash_Click()
FlashWindow frmFlash.hwnd, 1
tmrFlash.Enabled = Not tmrFlash.Enabled
If tmrFlash.Enabled Then
    cmdFlash.Caption = "&Stop"
Else
    cmdFlash.Caption = "&Flash Window"
End If
End Sub

'En el módulo
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal_ lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal_ lpBuffer As String, ByVal nSize As Long) As Long

'En un botón

Dim Car As String * 128
Dim Longitud, Es As Integer
Dim Camino As String
Longitud = 128
Es = GetWindowsDirectory(Car, Longitud)
Camino = RTrim$(LCase$(Left$(Car, Es)))
Label1.Caption = Camino
Es = GetSystemDirectory(Car, Longitud)
Camino = RTrim$(LCase$(Left$(Car, Es)))
Label2.Caption = Camino

'Código para el Modulo 
Public Const HWND_BOTTOM = 1 'Coloca la venta al final de la lista 
Public Const HWND_TOP = 0 'Coloca la ventana al inicio del orden 
Public Const HWND_TOPMOST = -1 'Coloca la ventana al inicio del orden por encima de todo 
Public Const HWND_NOTOPMOST = -2 'Coloca la ventana al inicio del orden detras de las ventanas de nivel superior 
Public Const SWP_HIDEWINDOW = &H80 'Esconde la ventana 
Public Const SWP_NOACTIVATE = &H10 'No activa la ventana 
Public Const SWP_NOMOVE = &H2 'Mantiene la posición Actual 
Public Const SWP_NOREDRAW = &H8 'La ventana No se redibuja automáticamente 
Public Const SWP_NOSIZE = &H1 'Mantiene el tamaño vigente 
Public Const SWP_NOZORDER = &H4 'Mantiene la posición vigente en la lista de ventanas 
Public Const SWP_SHOWWINDOW = &H40 'Presenta en pantalla la ventana 

'Para mantenerlo siempre visible, podeis utilizar estas opciones 
Public Const SWP_FLAGS = SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_NOACTIVATE 

Declare Function SetWindowPos Lib "User32" (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 

'Código para el evento 'Load' del Formulario 
'Definimos la variable 
Dim CadenaResultante As Long 

CadenaResultante = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_FLAGS) 
'CadenaResultante = Devuelve cero en caso de error. 

'NOTA: Para finalizar la posición de siempre visible, cambiar HWND_TOPMOST por HWND_NOTOPMOST 

'Código para el Modulo 
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS) 
Type MEMORYSTATUS 
dwLength As Long 
dwMemoryLoad As Long 'porcentaje de memoria en Uso 
dwTotalPhys As Long 'Total Bytes de memoria física 
dwAvailPhys As Long 'Memoria física libre en bytes 
dwTotalPageFile As Long 
dwAvailPageFile As Long 
dwTotalVirtual As Long 
dwAvailVirtual As Long 
End Type 

Global Memoria As MEMORYSTATUS 

'Código para el procedimiento 
Memoria.dwLength = Len(Memoria) 

GlobalMemoryStatus Memoria 

'mostramos el resultado 
Print "Memoria fisica total : " & Format(Memoria.dwTotalPhys, "#,##0") 
Print "Memoria física disponible : " & Format(Memoria.dwAvailPhys, "#,##0") 
Print "Porcentaje de Memoria Utilizada : " & Memoria.dwMemoryLoad & "%" 
Print "Porcentaje de Memoria Disponible : " & 100 - Memoria.dwMemoryLoad & "%" 

'Código para el Modulo 
Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long 
'Código para el procedimiento 
Dim CadenaResultante As Integer 
CadenaResultante = waveOutGetNumDevs() 
If CadenaResultante > 0 Then 
MsgBox "Posee tarjeta de sonido" 
Else 
MsgBox "No Posee tarjeta de sonido" 
End If

'Código para el Modulo 
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long 
'lpBuffer = Area intermedia donde se cargará el nombre del usuario 
'nsize = Longitud real del nombre del ordenador 
'Código para el Procedimiento 
'Definimos las variables 
Dim Texto As String * 255 
Dim Longitud As Long 
Dim CadenaResultante As Long 

'Inicializamos las variables 
Longitud = Len(Texto) 

CadenaResultante = GetUserName(Texto, Longitud) 
'CadenaResultante = Devuelve cero en caso de error. 

'mostramos el resultado 
NombreUsuario.Caption = Left(Texto, Longitud) 

'Código para el módulo

Public Const MIIM_STATE = &H1
Public Const MIIM_ID = &H2
Public Const MIIM_SUBMENU = &H4
Public Const MIIM_CHECKMARKS = &H8
Public Const MIIM_TYPE = &H10
Public Const MIIM_DATA = &H20
Public Const MFT_RADIOCHECK = &H200&

Public Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type

Public Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, _
ByVal fByPosition As Long, lpmii As MENUITEMINFO) As Long

Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
'Código para el Formulario

Private Sub Form_Load()
SetRadioMenuChecks mnuOptions(0), 0
SetRadioMenuChecks mnuOptions(1), 1
SetRadioMenuChecks mnuOptions(2), 2
End Sub
Private Sub SetRadioMenuChecks(Mnu As Menu, ByVal mnuItem&)
Dim hMenu&
Dim mInfo As MENUITEMINFO
hMenu& = GetSubMenu(GetMenu(Mnu.Parent.hwnd), 0)
mInfo.cbSize = Len(mInfo)
mInfo.fType = MFT_RADIOCHECK
mInfo.fMask = MIIM_TYPE
mInfo.dwTypeData = Mnu.Caption & Chr$(0)
SetMenuItemInfo hMenu&, mnuItem&, 1, mInfo
End Sub
Private Sub mnuOptions_Click(Index As Integer)
Static prevSelection As Integer
mnuOptions(prevSelection).Checked = False
mnuOptions(Index).Checked = True
prevSelection = Index
End Sub

'Código para el módulo
Option Explicit
Public Function CreateDir(path As String) As Boolean
Static start, pos As Integer
Static directory As String
Static result As Boolean
result = True

On Error GoTo errCreation

If path = "" Then Err.Raise vbObjectError + 1
If start = Empty Then
start = 1
Else
start = pos + 1
End If
pos = InStr(start, path, Chr$(92))

If (pos <> 0) Then
directory = directory + Mid$(path, start, pos - start) + Chr$(92)
If InStr(1, Mid$(path, start, pos - start), Chr$(58)) = 0 And Dir(directory, vbDirectory) = "" Then
MkDir Mid$(directory, 1, Len(directory) - 1)
End If
result = CreateDir(path)
ElseIf (pos = 0) Then
directory = directory + Mid$(path, start, Len(path) - start + 1)
MkDir Mid$(directory, 1, Len(directory))
directory = ""
End If

CreateDir = result

Exit Function

errCreation:
Err.Clear
result = False
CreateDir = result

End Function

'Código para el Formulario


Option Explicit
Public result As Boolean

Private Sub cmdOk_Click()
If IO.CreateDir(txtPathSpec) Then
optionSuccess = True
Else
optionFailure = True
End If
End Sub

'En el módulo

Option Explicit

Declare Function GetVersionEx& Lib "kernel32.dll" Alias "GetVersionExA" (lpStruct As OsVersionInfo)
Declare Function AbortSystemShutdown& Lib "advapi32.dll" Alias "AbortSystemShutdownA" (ByVal lpMachineName$)
Declare Function ExitWindowsEx& Lib "user32" (ByVal uFlags&, ByVal dwReserved&)
Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Any) As Long

Type OsVersionInfo
dwVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatform As Long
szCSDVersion As String * 128
End Type

Private OsVer As OsVersionInfo
Global Const VER_PLATFORM_WIN32_WINDOWS = 1
Global Const VER_PLATFORM_WIN32_NT = 2
Global Const EWX_FORCE = 4
Global Const EWX_LOGOFF = 0
Global Const EWX_REBOOT = 2
Global Const EWX_SHUTDOWN = 1

Global Const HELP_QUIT = 2
Global Const HELP_INDEX = 3
Global Const HELP_HELPONHELP = 4
Global Const HELP_PARTIALKEY = &H105

'En el formulario

Function FileExists(Filename As String) As Boolean
Dim TempAttr As Integer
On Error GoTo ErrorFileExist
TempAttr = GetAttr(Filename)
FileExists = ((TempAttr And vbDirectory) = 0)
GoTo ExitFileExist
ErrorFileExist:
FileExists = False
Resume ExitFileExist
ExitFileExist:
On Error GoTo 0
End Function

Private Sub Form_Load()
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2 'centre the form on the screen
End Sub

Private Sub Help_Click()
Dim lRtn As Long
lRtn = WinHelp(Me.hwnd, "C:\windows\help\windows.hlp", HELP_PARTIALKEY, "Apagar el sistema")
End Sub

Private Sub No_Click()
Unload Me
End Sub

Private Sub Yes_Click()
If Shutdown.Value = True Then
lresult = ExitWindowsEx(EWX_SHUTDOWN, 0&)
ElseIf Restart.Value = True Then
lresult = ExitWindowsEx(EWX_REBOOT, 0&)
ElseIf MSDOS.Value = True Then

lresult = FileExists(WinPath + "\Exit to dos.pif")
If lresult = False Then
MsgBox "Cannot find " + WinPath + "\Exit To Dos.pif" + Chr(10) + Chr(10) + "Please make sure this file is in your Windows directory", vbCritical 'display an error message
Else
lresult = Shell(WinPath + "\Exit To Dos.pif", 1)
End If
Else
lresult = ExitWindowsEx(EWX_LOGOFF, 0&)
End If
End Sub

'En el módulo

Option Explicit

Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Option Explicit

Dim HuboError As Boolean
Private Sub VerError(ret As Long)
lblRet = ret

HuboError = True

Select Case ret
Case 0: lblMensaje = "Todo OK": HuboError = False
Case 275: lblMensaje = "No existe el archivo"
Case 263: lblMensaje = "Identificador no válido"
Case 289: lblMensaje = "El identificador ya existe"
Case 259: lblMensaje = "Comando inválido (o ruta con espacios)"
End Select
End Sub
Private Sub MCI(Comando As String)
Dim ret As Long

ret = mciSaendString(Comando, 0, 0, 0)

VerError (ret)
End Sub
Private Sub cmdAbrir_Click()
MCI "OPEN " + txtArchivo + " TYPE AviVideo ALIAS Video STYLE CHILD PARENT " + CStr(picAVI.hWnd)

If Not HuboError Then
MCI "PLAY Video FROM 0 to 0"
End If
End Sub
Private Sub cmdCerrar_Click()
MCI "CLOSE Video"
End Sub
Private Sub cmdPlay_Click()
MCI "PLAY Video FROM 0"
End Sub
Private Sub cmdSalir_Click()
MCI "STOP Video"
MCI "CLOSE Video"

End
End Sub
Private Sub cmdStop_Click()
MCI "STOP Video"
End Sub
Private Sub Form_Load()
txtArchivo = App.Path + "\cuenta.avi"
End Sub
Private Sub Form_Unload(Cancel As Integer)
cmdSalir_Click
End Sub

'En el módulo

Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SCREENSAVERRUNNING = 97&

'En el formulario

Private Sub Command1_Click()
'Desactivar
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1&, 0&, 0&)
End Sub

Private Sub Command2_Click()
'Activar
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0&, 0&, 0&)
End Sub

'En el módulo

Declare Function SystemParametersInfo& Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction&, ByVal uParam&, ByVal lpvParam As Any, ByVal fuWinIni&)
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long

Public Const REG_SZ = 1
Public Const HKEY_CURRENT_USER = &H80000001

Public Const SPIF_UPDATEINIFILE = &H1
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2
'En el formulario
Private Sub Apply_Click()
Dim rtn As Long
Dim KeyName As String
Dim Value As String
Dim hKey As Long
Dim KeyValueLength As Long

If Tile.Value = True Then
Value = 1
Else
Value = 0
End If

KeyName = "desktop\TileWallpaper"
KeyValueLength = Len(Value) + 1
rtn = RegOpenKey(HKEY_CURRENT_USER, "Control Panel\desktop", hKey)
rtn = RegSetValueEx(hKey, "TileWallpaper", 0, REG_SZ, Value, KeyValueLength)
rtn = RegCloseKey(hKey)

If Filename.Text = "" Then
rtn = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, "", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
Else
rtn = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, Dialog.Filename, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End If
End Sub
Private Sub Browse_Click()
Dialog.ShowOpen
Filename.Text = Dialog.Filename
End Sub
Private Sub Cancel_Click()
End
End Sub
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2 'centre the form on the screen
End Sub

'Código para el Modulo 
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS) 
Type MEMORYSTATUS 
dwLength As Long 
dwMemoryLoad As Long 'porcentaje de memoria en Uso 
dwTotalPhys As Long 'Total Bytes de memoria física 
dwAvailPhys As Long 'Memoria física libre en bytes 
dwTotalPageFile As Long 
dwAvailPageFile As Long 
dwTotalVirtual As Long 
dwAvailVirtual As Long 
End Type 

Global Memoria As MEMORYSTATUS 

'Código para el procedimiento 
Memoria.dwLength = Len(Memoria) 

GlobalMemoryStatus Memoria 

'mostramos el resultado 
Print "Memoria fisica total : " & Format(Memoria.dwTotalPhys, "#,##0") 
Print "Memoria fisica disponible : " & Format(Memoria.dwAvailPhys, "#,##0") 
Print "Porcentaje de Memoria Utilzada : " & Memoria.dwMemoryLoad & "%" 
Print "Porcentaje de Memoria Disponible : " & 100 - Memoria.dwMemoryLoad & "%"