Trucos Hacer redimensionable un control   (3 artículos )

Este truco está en http://www.ethek.com/lenguajes/vb/trucos/trucos_vb.htm , la página de trucos que el Guille (http://guille.costasol.net) publica en el web de Ethek & Friends (http://www.ethek.com). No te pierdas ninguna de estas páginas.

Cualquier control que tenga un Hwnd puede hacerse "redimensionable", es decir que cuando esté en ejecución se pueda cambiar el tamaño, para ello hay que usar una serie de llamadas del API.
Veamos las declaraciones del API, así como un procedimiento genérico para hacerlo redimensionable.
Este procedimiento espera un parámetro que será el control al que se le quiere dar esa característica, en el procedimiento he puesto una rutina de detección de errores por si el control que se le pasa no soporta esta característica.

'Declaraciones del API para 32 bits
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private 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

Const GWL_STYLE = (-16)
Const WS_THICKFRAME = &H40000
Const WS_CHILD = &H40000000
Const SWP_DRAWFRAME = &H20
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4


Private Sub Dimensionable(ByVal elControl As Control)
    Dim Style As Long

    'Por si el control pasado no se puede redimensionar
    On Local Error Resume Next

    Style = GetWindowLong(elControl.hWnd, GWL_STYLE)
    Style = Style Or WS_THICKFRAME
    Style = SetWindowLong(elControl.hWnd, GWL_STYLE, Style)
    Style = SetWindowPos(elControl.hWnd, Me.hWnd, 0, 0, 0, 0, _
            SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME)

    Err = 0
    On Local Error GoTo 0
End Sub


'Para usarlo, se haría así:

Private Sub Form_Load()
    Dimensionable Picture1
    Dimensionable Text1
End Sub

Basándonos en el ejemplo anterior podemos modificar la función para que una llamada haga el control redimensionable y otra lo vuelva a dejar "normal" :

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private 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

Const GWL_STYLE = (-16)
Const WS_THICKFRAME = &H40000
Const WS_CHILD = &H40000000
Const SWP_DRAWFRAME = &H20
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4

Sub Dimensionable2(ByVal elControl As Control)
Dim Style As Long

    'Por si el control pasado no se puede redimensionar
    On Local Error Resume Next

    Style = GetWindowLong(elControl.hWnd, GWL_STYLE)
    Style = Style Xor WS_THICKFRAME
    Style = SetWindowLong(elControl.hWnd, GWL_STYLE, Style)
    Style = SetWindowPos(elControl.hWnd, Me.hWnd, 0, 0, 0, 0, _
            SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Xor SWP_DRAWFRAME)

    Err = 0
    On Local Error GoTo 0
End Sub

Podemos permitir a los usuarios que modifiquen el tamaño de un control (como hace VB en modo diseño) usando un par de sencillas llamadas al api. Podemos cambiar el tamaño a izquierda, derecha, arriba, abajo y en las diagonales. Cuando haces rangos para las coordendas del ratón (como x>0 and x<150), el evento MouseDown activa las funciones del API y cambia el tamaño del control mientras mueves el ratón. Este código asume que tienes un picturebox en el formulartio :

Private Declare Function ReleaseCapture Lib _
    "user32" () As Long
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 WM_NCLBUTTONDOWN = &HA1
' Puedes encontrar más constantes en el visor de API
' Aquí vamos a usar sólo el cambio de tamaño a izquierda y derecha
Private Const HTLEFT = 10
Private Const HTRIGHT = 11

Private Sub Picture1_MouseDown(Button As _
    Integer, Shift As Integer, X As Single, Y As Single)
    Dim nParam As Long
    With Picture1
        ' Puedes cambiar estas coordenadas lo que quieras
        If (X > 0 And X < 150) Then
            nParam = HTLEFT
        ElseIf (X > .Width - 150 And X < .Width) Then
        ' estas también
            nParam = HTRIGHT
        End If
        If nParam Then
            Call ReleaseCapture
            Call SendMessage(.hWnd, _
                WM_NCLBUTTONDOWN, nParam, 0)
        End If
    End With
End Sub

Private Sub Picture1_MouseMove(Button As _
    Integer, Shift As Integer, X As Single, Y As Single)
    Dim NewPointer As MousePointerConstants
    ' Puedes cambiar estas coordenadas lo que quieras
    If (X > 0 And X < 150) Then
        NewPointer = vbSizeWE
    ElseIf (X > Picture1.Width - 150 And X < _
        Picture1.Width) Then ' estas también
        NewPointer = vbSizeWE
    Else
        NewPointer = vbDefault
    End If
    If NewPointer <> Picture1.MousePointer Then
        Picture1.MousePointer = NewPointer
    End If
End Sub

-Fran Pregernik, Zagreb, Croatia



Trucos Trucos

Visual Basic Página de Visual Basic

Página principal Página principal

www.jrubi.com