Sección de código fuente Visual basic

Ocx para hacer zoom de la pantalla como una lupa

Código fuente con un ejemplo , de un control que captura el áera de la pantalla donde está ubicado el cursor

Este ocx está basado en parte a un ejemplo que vi en la página de José Rubí

La modificación importante que le hice al ejemplo de José, fue la de reacomodar el área de la pantalla que se redibujaba en el control, ya que cuando exedía el límite del mismo se interponía la imagen.

A continuación tenés el código fuente del ocx y del formulario y al final de la página tenés el fuente en un Zip para descargar:

Nota: No están todas las propiedades implementadas y es posible que haya que agregar algunas rutinas de errores, aunque hasta donde lo probé no surgió ninguno

Vista previa

vista del ejemplo para crear el ocx que hace zoom de la pantalla

Descar el código fuente.

Pasos para crear el ocx

Código en el UserControl

Option Explicit '*************************************************************************** '* Name : Control ocx para hacer Zoom de la pantalla '* Author : Luciano LE '*************************************************************************** '*************************************************************************** 'Declaraciones Api '*************************************************************************** 'Dibuja en el UserControl el HDC de la pantalla Private Declare Function StretchBlt Lib "gdi32" ( _ ByVal hDC As Long, _ ByVal X As Long, _ ByVal Y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal hSrcDC As Long, _ ByVal xSrc As Long, _ ByVal ySrc As Long, _ ByVal nSrcWidth As Long, _ ByVal nSrcHeight As Long, _ ByVal dwRop As Long) As Long 'Devuelve el Handle del escritorio Private Declare Function GetDesktopWindow Lib "user32" () As Long 'Api que devuelve el Handle del HDC de la pantalla Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long 'Libera el HDC de pantalla Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _ ByVal hDC As Long) As Long 'Api Recupera las coordenadas del mouse Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long '*************************************************************************** 'Constantes , variables y UDT '*************************************************************************** Private Const SRCCOPY = &HCC0020 Private Const ShotRadius = 200 'pixels Private Left2 As Integer Private Top2 As Integer Private Type POINTAPI X As Long Y As Long End Type Private LastPos As POINTAPI 'Variables para el Zoom Private Const InitZoomValue = 1 Private m_ZoomValue As Single Private ScreenDC As Long Public Enum e_BorderStyleConstants [Fixed Single] = 1 [None] = 0 End Enum 'Sub que imprime en la ventana del UserControl la captura de la pantalla _ correspondiente a a la posición del Mouse '*************************************************************************** ' Eventos del usercontrol '*************************************************************************** Public Event CursorValue(ByVal X As Single, ByVal Y As Single) '*************************************************************************** ' Subrutinas y funciones '*************************************************************************** Private Sub ImprimirImagen(CenterX As Long, CenterY As Long) Dim Top As Long, Left As Long, SHeight As Long, SWidth As Long DoEvents 'Porción de la imagen ( ancho y alto ) SHeight = ScaleHeight * (1 / m_ZoomValue) SWidth = ScaleWidth * (1 / m_ZoomValue) 'Posición del cursor Top = CenterY - (ScaleHeight / (2 * m_ZoomValue)) Left = CenterX - (ScaleWidth / (2 * m_ZoomValue)) If Top <= 0 Then Top = 0 If Left <= 0 Then Left = 0 If Top >= Top2 - SHeight Then Top = Top2 - SHeight If Left >= Left2 - SWidth Then Left = Left2 - SWidth 'Dibuja en el HDC del usercontrol el área de la pantalla StretchBlt hDC, 0, 0, ScaleWidth, ScaleHeight, _ ScreenDC, Left, Top, SWidth, SHeight, SRCCOPY End Sub Private Sub Timer1_Timer() Dim NewPos As POINTAPI Dim Cambio As Boolean Cambio = False 'Nueva coordenada del mouse Call GetCursorPos(NewPos) ' Lanza el evento ( Valor y posición del cursor ) RaiseEvent CursorValue(NewPos.X, NewPos.Y) If NewPos.X <> LastPos.X Then Cambio = True If NewPos.Y <> LastPos.Y Then Cambio = True 'Si se movió el mouse ... If Cambio = True Then 'Nueva coordenada LastPos = NewPos 'Dibujamos la imagen en el UserControl Call ImprimirImagen(LastPos.X, LastPos.Y) End If End Sub 'Incrementa el valor del Zoom Public Sub ZoomIn() If m_ZoomValue < 1 Then m_ZoomValue = m_ZoomValue + 0.5 Else m_ZoomValue = m_ZoomValue + 1 End If 'Imprimimos en el UserControl la imagen pasandole la coordenada Call ImprimirImagen(LastPos.X, LastPos.Y) End Sub 'Decrementa el valor del Zoom Sub ZoomOut() If m_ZoomValue > 1 Then m_ZoomValue = m_ZoomValue - 1 Else If m_ZoomValue > 0.5 Then m_ZoomValue = m_ZoomValue - 0.5 End If End If 'Imprimimos en el UserControl la imagen pasandole la coordenada Call ImprimirImagen(LastPos.X, LastPos.Y) End Sub Private Sub UserControl_InitProperties() m_ZoomValue = 1 UserControl.BorderStyle = 1 End Sub Private Sub UserControl_Show() If Ambient.UserMode Then With UserControl ' Valor inicial del Factor de Zoom ' m_ZoomValue = InitZoomValue 'Para que el puntero no se vaya de los límites de la pantalla Left2 = Screen.Width / Screen.TwipsPerPixelX Top2 = Screen.Height / Screen.TwipsPerPixelY ' Obtiene el Hdc de la pantalla ScreenDC = GetDC(GetDesktopWindow) Timer1.Interval = 50 'Modo de escala en pixeles para el ocx .ScaleMode = vbPixels End With End If End Sub Property Get ZoomValue() As Single ZoomValue = m_ZoomValue End Property Property Let ZoomValue(Value As Single) If Value <= 0 Then MsgBox "El factor de Zoom no puede ser menor o igual" & _ "a 0. Se dejará en 1", vbCritical, " Error " m_ZoomValue = 1 Else m_ZoomValue = Value End If Call PropertyChanged("ZoomValue") End Property 'Cargar valores de propiedad desde el almacén Private Sub UserControl_ReadProperties(PropBag As PropertyBag) m_ZoomValue = PropBag.ReadProperty("zoomValue", 1) UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 1) End Sub 'Escribir valores de propiedad en el almacén Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("zoomValue", m_ZoomValue, 1) Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 1) End Sub '*************************************************************************** 'Propiedades del control ocx '*************************************************************************** Public Property Get BorderStyle() As e_BorderStyleConstants BorderStyle = UserControl.BorderStyle End Property Public Property Let BorderStyle(ByVal New_BorderStyle As e_BorderStyleConstants) UserControl.BorderStyle() = New_BorderStyle PropertyChanged "BorderStyle" End Property Public Property Get hDC() As Long hDC = UserControl.hDC End Property

Código en un formulario, con 2 Commandbutton

Option Explicit '* Código fuente en el formulario '''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Command1_Click() ' Aumenta el Zoom UserControl11.ZoomIn End Sub Private Sub Command2_Click() ' Disminuye el Zoom UserControl11.ZoomOut End Sub Private Sub Form_Load() Command1.Caption = " ZOOM + " Command2.Caption = " ZOOM - " End Sub Private Sub UserControl11_CursorValue(ByVal X As Single, ByVal Y As Single) ' Devuelve el valor de la posición del cursor Me.Caption = "Pos X: " & X & " " & "Pos Y: " & Y End Sub

Buscar en Recursos vb