Considero "un poco grosero" cambiarle la resolución al cliente; los motivos
creo que no hay que explicarlos.
Te adjunto una rutina que te escala el tamaño del formulario y los
controles.
No está del todo desarrollada; de hecho en vez de filtrar por tipos de
control utiliza una solución "chapuzas" de saltarse el error si un control
no tiene determinada propiedad que se pretende cambiar.
Ajusta la anchura, altura, posición y fuente de los controles y secciones
del formulario que se pasa como parámetro, a la escala que se indica.
Por ejemplo:
Escalar Me, 1.5
aumentará las secciones y los controles en un 50 %.
Para ver la resolución de pantalla actual adjunto las funciones
PantallaX y PantallaY, que, como su nombre indica, da el tamaño en
pixeles de la configuración actual de pantalla.
Si se usa varias veces consecutivas el procedimiento Escalar , aumentando y
reduciendo, acaba desconfigurando la posición y tamaño de los controles.
Esto es porque usa valores enteros.
Podría usarse un procedimiento que en el momento de arrancar el formulario
guardase los valores como doubles, y no se producirían estos desajustes.
Pero para un uso "normal" funciona.
Si tenéis alguna duda ó comentario, estoy a vuestra disposición.
Eduardo Olaz
_________________________________
Public Declare Function GetSystemMetrics _
Lib "User32" ( _
ByVal nIndex As Long) _
As Long
Public Function PantallaX() As Long
PantallaX = GetSystemMetrics(0)
End Function
Public Function PantallaY() As Long
PantallaY = GetSystemMetrics(1)
End Function
Public Sub Escalar(ByVal Formulario As Form, ByVal Escala As Single)
' Este procedimiento escala los controles y las secciones
' del formulario que se pasa como parámetro
' Eduardo Olaz, 8/9/2002
' eduardo@olaz.net
If Escala < 0.1 Or Escala > 10 Then
MsgBox "Escala inadecuada"
Exit Sub
End If
Dim intSeccion As Integer
Dim i As Integer
Dim ctlControl As Control
Dim sctSeccion As Section
' para el cuadro combinado y cuadro de lista
Dim intDesde As Integer
Dim intHasta As Integer
Dim strAnchoColumna As String
Dim strWidths As String
Dim strWidthsNuevo As String
On Error Resume Next
' Primero ajustamos la altura de las secciones
' si no existe la sección obviará el error y
' saltará a la siguiente (Resume Next)
For intSeccion = acDetail To acPageFooter
Set sctSeccion = Formulario.Section(intSeccion)
sctSeccion.Height = Escala * sctSeccion.Height
Next intSeccion
Set sctSeccion = Nothing
For Each ctlControl In Formulario
With ctlControl
' algunos controles no tienen estas propiedades
' pero no "petará por el Resume Next"
.Left = Escala * (.Left + .Width / 2) - .Width / 2
.Top = Escala * (.Top + .Height / 2) - .Height / 2
.Width = .Width * Escala
.Height = .Height * Escala
.FontSize = .FontSize * Escala
.BorderWidth = .BorderWidth * Escala
Select Case ctlControl.ControlType
' Aquí habría que desarrollar rutinas particulares
' para algunos tipos de control
' por ejemplo Cuadros cobinados y cuadros de lista
' en los que hay que ajustar el ancho de las columnas
Case acListBox, acComboBox
strWidths = .ColumnWidths
Debug.Print strWidths
strWidths = strWidths & ";"
If Len(strWidths) > 1 Then
For i = 1 To .ColumnCount
intHasta = InStr(intDesde + 1, strWidths, ";")
If intHasta > 0 Then
strAnchoColumna = Mid(strWidths, intDesde + 1,intHasta - intDesde - 1)
If Len(strAnchoColumna) > 0 Then
strAnchoColumna = CStr(CDbl(Escala * Val(strAnchoColumna)))
End If
Else
strAnchoColumna = ""
End If
strWidthsNuevo = strWidthsNuevo & strAnchoColumna & ";"
Debug.Print strAnchoColumna
intDesde = intHasta
Next i
strWidthsNuevo = Left$(strWidthsNuevo,Len(strWidthsNuevo) - 1)
End If
.Width = Escala * .Width
.Height = Escala * .Height
.FontSize = Escala * .FontSize
.ColumnWidths = strWidthsNuevo
End Select
End With
Next ctlControl
End Sub
_________________________________
(
geocities.com/es/ensolva/Descargas) (
geocities.com/es/ensolva) (
geocities.com/es)