PROGRAMA 34: LA API DE WINDOWS 1:
Vista del programa en ejecución
Vista diseño del formulario:
Se crea una aplicación *.exe, y se introducen estos botones, un list, un combo y un textbox
En el código del programa introduciremos los siguiente:
Option Explicit
' Esta variable registra el control que se ha
seleccionado en último lugar.
Dim ActControl As
Control
' Estas variables se utilizan para recordar las
coordenadas del ratón
' cuando el ratón se mantiene sobre el control
List1
Dim mouseButton
As Integer, mouseX As Long, mouseY
As Long
Sub Form_Load()
' Rellena los cuadros de lista y combinado con los nombres
de los meses.
Dim i As
Integer
For i = 1 To 12
List1.AddItem MonthName(i) & vbTab &
"1999"
Combo1.AddItem MonthName(i)
Next
' Agrega un elemento muy largo
List1.AddItem "Un elemento que es más largo que la anchura
actual"
Combo1.AddItem "Un elemento que es más largo que la anchura
actual"
' Define el espacio inicial entre tabuladores.
Dim tabs(1 To 2) As Long
tabs(1) = 40:
tabs(2) = 55
SetTabStops
List1, tabs()
List1.ListIndex = 0
Combo1.ListIndex = 0
End Sub
Sub SetButtonState()
' Recuerda el control
activo.
Set ActControl = ActiveControl
' Muestra un fondo amarillo para el control activo
List1.BackColor = vbWindowBackground
Combo1.BackColor = vbWindowBackground
ActControl.BackColor = vbYellow
' Activa/desactiva botones que se aplican a un único
control.
cmdGetHorizExt.Enabled = (ActControl Is List1)
cmdSetHorizExt.Enabled
= (ActControl Is List1)
cmdSelectAll(0).Enabled = (ActControl Is
List1)
cmdSelectAll(1).Enabled = (ActControl Is
List1)
cmdSetTabStops.Enabled
= (ActControl Is List1)
cmdGetSelItems.Enabled
= (ActControl Is List1)
cmdVisibleItems.Enabled
= (ActControl Is List1)
cmdShowList.Enabled
= (ActControl Is Combo1)
cmdGetDropWidth.Enabled
= (ActControl Is Combo1)
cmdSetDropWidth.Enabled
= (ActControl Is Combo1)
End Sub
Private Sub List1_GotFocus()
SetButtonState
End Sub
Private Sub Combo1_GotFocus()
SetButtonState
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single,
Y As Single)
List1_MouseMove Button, Shift, X, Y
End Sub
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single,
Y As Single)
' Recuerda el estado del
botón del ratón y las coordenadas del mismo.
mouseButton = Button
mouseX
= ScaleX(X, vbTwips, vbPixels)
mouseY
= ScaleY(Y, vbTwips, vbPixels)
End Sub
Private Sub cmdFind_Click()
Dim search As String, startIndex As Long, found As Long
search = InputBox("Escriba la cadena que desee buscar")
If search = "" Then Exit Sub
ActControl.SetFocus
startIndex
= ActControl.ListIndex
found = FindString(ActControl, search, startIndex)
If found = -1 Then
MsgBox "Elemento no encontrado", vbInformation
Else
ActControl.ListIndex = found
MsgBox "Elemento encontrado en la posición "
& found, vbInformation
End If
End Sub
Private Sub cmdFindExact_Click()
Dim search As String, startIndex As Long, found As Long
search = InputBox("Escriba la cadena que desea buscar"
& vbCrLf & "(es preferible que utilice
esta rutina con el control ComboBox)")
If search = "" Then Exit Sub
ActControl.SetFocus
startIndex
= ActControl.ListIndex
found = FindString(ActControl, search, startIndex, True)
If found = -1 Then
MsgBox "Elemento no encontrado", vbInformation
Else
ActControl.ListIndex
= found
MsgBox "Elemento encontrado en la posición "
& found, vbInformation
End If
End Sub
Private Sub cmdGetHorizExt_Click()
MsgBox "Extensión horizontal = " & GetHorizontalExtent(ActControl) & " píxeles.",
vbInformation
End Sub
Private Sub cmdSetHorizExt_Click()
Dim newWidth As String
newWidth = InputBox$("Introduzca el nuevo valor de la longitud
horizontal (en píxeles)")
If newWidth = ""
Then Exit Sub
SetHorizontalExtent
ActControl, CLng(newWidth)
End Sub
Private Sub cmdGetItemHeight_Click()
MsgBox "Altura
End Sub
Private Sub cmdSetItemHeight_Click()
Dim newHeight As String
newHeight = InputBox$("Introduzca la nueva altura del elemento en
píxeles (la altura actual es " & GetItemHeight(ActControl) & ")")
If newHeight = ""
Then Exit Sub
SetItemHeight ActControl, newHeight
End Sub
Private Sub cmdSelectAll_Click(Index As Integer)
SelItemRange ActControl, (Index = 0)
End Sub
Private Sub cmdSetTabStops_Click()
Dim tabs(1 To 2)
As Long
tabs(1) = 60:
tabs(2) = 100
SetTabStops ActControl, tabs()
ActControl.SetFocus
End Sub
Private Sub cmdGetSelItems_Click()
Dim result() As
Long, msg As String, i As
Long
If ActControl.selCount = 0 Then
MsgBox "No hay elementos seleccionados", vbExclamation
Else
result() = GetSelItems(ActControl)
For i = LBound(result)
To UBound(result)
msg = msg & ActControl.List(result(i)) & vbCrLf
Next
MsgBox msg, vbInformation
End If
End Sub
Private Sub cmdVisibleItems_Click()
MsgBox "Elementos visibles = " &
VisibleItems(ActControl)
End Sub
Private Sub cmdShowList_Click()
ShowDropDown ActControl
End Sub
Private Sub cmdGetDropWidth_Click()
MsgBox "GetDroppedWidth = " & GetDroppedWidth(ActControl) & " píxeles",
vbInformation
End Sub
Private Sub cmdSetDropWidth_Click()
Dim newWidth As String
newWidth = InputBox("Escriba
la anchura mínima para la lista desplegable")
If newWidth = ""
Then Exit Sub
SetDroppedWidth ActControl, newWidth
End Sub
Private Sub Timer1_Timer()
Dim itemIndex As Long
If ActControl Is
List1 Then
If (mouseButton And 2) = 0 Then
lblStatus
= "Pulse el botón derecho sobre un elemento del ListBox"
Else
itemIndex = ItemFromPoint(ActControl, mouseX, mouseY)
If itemIndex >= 0 Then
lblStatus = "El elemento ListBox situado bajo el puntero del ratón = " & itemIndex
Else
lblStatus = "El puntero del
ratón no está situado sobre ningún elemento del ListBox"
End If
End If
Else
' Mostrar el estado del control combobox.
lblStatus = "El área desplegable se encuentra " & IIf(GetDroppedState(ActControl),
"visible", "invisible")
End If
End Sub
Añadimos al programa un módulo con el siguiente código:
Option
Explicit
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 SendMessageByVal Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessageString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any,
dest As Any, ByVal numBytes As Long)
Private Declare Function GetClientRect Lib "user32" (ByVal
hwnd As Long, lpRect As
RECT) As Long
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Const LB_FINDSTRING = &H18F
Const LB_FINDSTRINGEXACT =
&H1A2
Const LB_GETHORIZONTALEXTENT =
&H193
Const LB_GETITEMHEIGHT =
&H1A1
Const LB_GETITEMRECT =
&H198
Const LB_GETSELCOUNT =
&H190
Const LB_GETSELITEMS =
&H191
Const LB_SELITEMRANGE =
&H19B
Const LB_SETHORIZONTALEXTENT =
&H194
Const LB_SETITEMHEIGHT =
&H1A0
Const LB_SETTABSTOPS =
&H192
Const LB_ITEMFROMPOINT =
&H1A9
Const CB_FINDSTRING =
&H14C
Const CB_FINDSTRINGEXACT =
&H158
Const CB_GETDROPPEDCONTROLRECT
= &H152
Const CB_GETDROPPEDSTATE =
&H157
Const CB_GETITEMHEIGHT =
&H154
Const CB_SETITEMHEIGHT =
&H153
Const CB_SHOWDROPDOWN =
&H14F
Const CB_GETHORIZONTALEXTENT =
&H15D
Const CB_SETHORIZONTALEXTENT =
&H15E
Const CB_GETDROPPEDWIDTH =
&H15F
Const CB_SETDROPPEDWIDTH =
&H160
Const CB_LIMITTEXT
= &H141
' Encontrar una cadena en el control.
' El tercer argumento es el índice *después*
del cuál hay que comenzar la búsqueda
' (se omite el primer elemento). si el cuarto argumento es True
realizará una
' búsqueda exacta. Devuelve el índice de la
coincidencia ó -1 si no se encuentra ninguna.
Function FindString(ctrl As Control, ByVal search As String, Optional startIndex
As Long = -1, Optional ExactMatch As Boolean) As Long
Dim uMsg As Long
If TypeOf ctrl Is
ListBox Then
uMsg
= IIf(ExactMatch,
LB_FINDSTRINGEXACT, LB_FINDSTRING)
ElseIf TypeOf ctrl Is ComboBox Then
uMsg
= IIf(ExactMatch,
CB_FINDSTRINGEXACT, CB_FINDSTRING)
Else
Exit Function
End If
FindString = SendMessageString(ctrl.hwnd, uMsg,
startIndex, search)
End Function
' Devuelve la altura de cada entrada contenida en
el control (en píxeles).
Function GetItemHeight(ctrl As
Control) As Long
Dim uMsg As Long
If TypeOf ctrl Is
ListBox Then
uMsg
= LB_GETITEMHEIGHT
ElseIf TypeOf ctrl Is ComboBox Then
uMsg
= CB_GETITEMHEIGHT
Else
Exit Function
End If
GetItemHeight = SendMessageByVal(ctrl.hwnd, uMsg, 0, 0)
End Function
' Define la altura en píxeles de cada entrada
contenida en el control.
Sub SetItemHeight(ctrl As
Control, ByVal newHeight As
Long)
Dim uMsg As Long
If TypeOf ctrl Is
ListBox Then
uMsg
= LB_SETITEMHEIGHT
ElseIf TypeOf ctrl Is ComboBox Then
uMsg
= CB_SETITEMHEIGHT
Else
Exit Sub
End If
' (sólo se puede utilizar la palabra de orden inferior de lParam.)
SendMessageByVal ctrl.hwnd, uMsg, 0, (newHeight And &HFFFF&)
' Es necesario
actualizar manualmente el control.
ctrl.Refresh
End Sub
'--------------------------------------------------
' Rutinas específicas de ListBox
'--------------------------------------------------
' Proporciona el tamaño horizontal del control (en
píxeles).
Function GetHorizontalExtent(lb As ListBox) As Long
GetHorizontalExtent
= SendMessageByVal(lb.hwnd, LB_GETHORIZONTALEXTENT,
0, 0)
End Function
' Define la extensión horizontal del control (en
píxeles).
' Si este valor es mayor que la anchura real
del control aparecerá
' una barra de desplazamiento horizontal.
Sub SetHorizontalExtent(lb As ListBox, ByVal newWidth As Long)
SendMessageByVal lb.hwnd, LB_SETHORIZONTALEXTENT, newWidth,
0
End Sub
' Seleccionar o deseleccionar todos los elementos
contenidos en un rango.
Sub SelItemRange(lb As ListBox, ByVal newState As Boolean, Optional firstItem
As Long, Optional lastItem As Long = -1)
Dim lParam As Long
' tiene en cuenta el argumento lastItem
omitido.
If lastItem < 0 Then lastItem = lb.ListCount - 1
' lParam debe contener el índice del primer elemento y su
palabra de nivel inferior
' y el índice del último elemento en su palabra de nivel
superior.
' Necesitamos este método para evitar un desbordamiento.
CopyMemory lParam, firstItem,
2
CopyMemory ByVal VarPtr(lParam) + 2, lastItem,
2
SendMessageByVal lb.hwnd, LB_SELITEMRANGE, newState,
lParam
End Sub
' Define los saltos del tabulador. Cada elemento
del array viene expresado en unidades de de diálogo,
' donde cada unidad de diálogo es 1/4 es la
anchura media de un carácter.
Sub SetTabStops(lb As ListBox, tabStops() As Long)
Dim numEls As Long
numEls
= UBound(tabStops) - LBound(tabStops) + 1
SendMessage lb.hwnd, LB_SETTABSTOPS, numEls, tabStops(LBound(tabStops))
End Sub
' Devuelve un array con
los índices de todos los elementos seleccionados.
Function GetSelItems(lb As ListBox) As Long()
Dim selCount As Long
' Recupera el número de los elementos seleccionados (igual
que la propiedad SelCount)
selCount = SendMessageByVal(lb.hwnd, LB_GETSELCOUNT, 0, 0)
' Si no se ha
seleccionado ningún elemento, devuelve un array no
inicializado
If selCount = 0 Then Exit
Function
ReDim result(1 To selCount) As Long
SendMessage lb.hwnd, LB_GETSELITEMS, selCount,
result(1)
GetSelItems = result()
End Function
' Devuelve el índice del elemento situado en las
coordenadas especificadas.
Function ItemFromPoint(lb As ListBox, ByVal X As Long, ByVal Y As Long) As Long
Dim lParam As Long
' lParam debe contener X en su
palabra de nivel inferior
' e Y en su palabra de nivel superior.
' hay que utilizar este método para evitar el desbordamiento.
CopyMemory lParam, X, 2
CopyMemory ByVal VarPtr(lParam) + 2, Y, 2
ItemFromPoint = SendMessageByVal(lb.hwnd, LB_ITEMFROMPOINT, 0, lParam)
End Function
' Devuelve el número de elementos visibles.
Function VisibleItems(lb As ListBox) As Long
Dim lpRect As RECT, itemHeight As Long
' Obtiene el área
cliente del rectángulo.
GetClientRect lb.hwnd, lpRect
' Obtiene la altura de cada elemento.
itemHeight = SendMessageByVal(lb.hwnd, LB_GETITEMHEIGHT, 0, 0)
' Realiza
la división.
VisibleItems = (lpRect.Bottom - lpRect.Top) \ itemHeight
End Function
'--------------------------------------------------
' Rutinas específicas del ComboBox
'--------------------------------------------------
' Muestra u oculta la lista desplegable.
Sub ShowDropDown(cb As ComboBox, Optional ByVal showIt As Boolean = True)
SendMessageByVal cb.hwnd, CB_SHOWDROPDOWN, showIt,
0
End Sub
' Devuelve el estado.
Function GetDroppedState(cb As ComboBox) As Boolean
GetDroppedState =
SendMessageByVal(cb.hwnd, CB_GETDROPPEDSTATE, 0,
0)
End Function
' Proporciona la dimensión del rectángulo de lista desplegable.
Sub GetDroppedControlRect(cb As ComboBox, Left As Long, Top
As Long, Right As Long, Bottom As Long)
Dim lpRect As RECT
SendMessage cb.hwnd, CB_GETDROPPEDCONTROLRECT, 0, lpRect
Left = lpRect.Left
Top = lpRect.Top
Right = lpRect.Right
Bottom = lpRect.Bottom
End Sub
' Devuelve la anchura mínima de la porción de
lista desplegable.
Function GetDroppedWidth(cb As ComboBox) As Long
GetDroppedWidth =
SendMessageByVal(cb.hwnd, CB_GETDROPPEDWIDTH, 0,
0)
End Function
' Define la anchura mínima de la porción de
lista desplegable.
Sub SetDroppedWidth(cb As ComboBox, ByVal newWidth As Long)
SendMessageByVal cb.hwnd, CB_SETDROPPEDWIDTH, newWidth,
0
End Sub
' Define el número máximo de caracteres
contenidos en el control.
' (similar a la propiedad MaxLength)
Sub SetMaxLength(cb As ComboBox, ByVal MaxLength As Long)
SendMessageByVal cb.hwnd, CB_LIMITTEXT, MaxLength,
0
End Sub