** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Access y VBA
  Mensajes nuevos Mensajes nuevos RSS - convertir un sub Private en public ... resize
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoconvertir un sub Private en public ... resize

 Responder Responder
Autor
Mensaje
VayaCaló Ver desplegable
Habitual
Habitual


Unido: 16/Septiembre/2008
Localización: España
Estado: Sin conexión
Puntos: 129
Enlace directo a este mensaje Tema: convertir un sub Private en public ... resize
    Enviado: 10/Septiembre/2018 a las 12:11
Saludos,

Se trata de que al abrir un formulario obtengo el nombre y posicion de todos los controles de un formulario que almaceno de un array y recupero dichos datos para reajustar las medidas del formulario
al resize

El problema me surge cuando quiero convertir en public dichas funciones , trasladandolos a un modulo publico, y usarlas desde un solo modulo, evitando tener que que añadir cada vez en cada formulario el codigo que a continuación pego

Que hago?.... uso vb.collection, clases.... en fín, se aceptan sugerencias 




-- en un modulo

Public Type ScreenObject
    FormName As String
    Index As Integer
    ControlName As String
    Left As Integer
    Top As Integer
    Width As Integer
    Height As Integer
End Type

En un form :

Dim intReferenceHeight As Integer
Dim intReferenceWidth As Integer


Dim ObjectList() As ScreenObject


Private Sub Form_Open(Cancel As Integer)
GetCurrentPositions
end sub

- En el resize
Private Sub Form_Resize()
AutoScale
end sub

Private Sub GetCurrentPositions()
    On Error GoTo GetCurrentPositions_Error
   
Dim control As control
Dim intObjectNumber As Integer
For Each control In Me.Controls
    ReDim Preserve ObjectList(intObjectNumber)
    With ObjectList(intObjectNumber)
        .ControlName = control.Name
        .Left = control.Left
        .Top = control.Top
        .Width = control.Width
        .Height = control.Height
    End With
    intObjectNumber = intObjectNumber + 1
Next control
    intReferenceHeight = Me.InsideHeight
    intReferenceWidth = Me.InsideWidth   
    On Error GoTo 0
    Exit Sub
GetCurrentPositions_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure GetCurrentPositions, line " & Erl & "."
End Sub


Private Sub AutoScale()
    On Error GoTo AutoScale_Error
    
Dim dblXMultiplier As Double
Dim dblYMultiplier As Double
Dim intObjectNumber As Integer
Dim intFontSize As Integer
Dim control As control
dblXMultiplier = Me.InsideHeight / intReferenceHeight
dblYMultiplier = Me.InsideWidth / intReferenceWidth
For intObjectNumber = 0 To UBound(ObjectList)
    For Each control In Me.Controls
        If control.Name = ObjectList(intObjectNumber).Name Then
             With control
                If Int(dblXMultiplier) > 0 Then
                    intFontSize = Int(dblXMultiplier * 8) '+ 5)
                    Select Case control.ControlType
                    Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acTabCtl, acToggleButton
                     If .fontsize > 10 Then
                        .fontsize = 8
                        .FontName = "Segole UI"
                     Else
                        .fontsize = intFontSize
                        .FontName = "Segole UI"
                     End If
                    End Select
                End If
                .Left = ObjectList(intObjectNumber).Left * dblYMultiplier
                .Width = ObjectList(intObjectNumber).Width * dblYMultiplier
                .Height = ObjectList(intObjectNumber).Height * dblXMultiplier
                .Top = ObjectList(intObjectNumber).Top * dblXMultiplier
             End With
        End If
    Next control
Next intObjectNumber
    
    On Error GoTo 0
    Exit Sub
AutoScale_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure AutoScale, line " & Erl & "."
End Sub



Editado por VayaCaló - 10/Septiembre/2018 a las 12:53
Arriba
emiliove Ver desplegable
Moderador
Moderador


Unido: 16/Junio/2009
Localización: Mexico
Estado: Sin conexión
Puntos: 4623
Enlace directo a este mensaje Enviado: 10/Septiembre/2018 a las 15:21
Hola 

Y que has intentado, pues si colocas GetCurrentPositions y AutoScale en modulos estándar y les agregas a ambos el formulario algo como:
GetCurrentPositions(sForm As String)
Dim frm As Form
Set frm = Forms(sForm)
Y al control le pones:
For Each control In frm.Controls

Y solo los llamas en el formulario:
GetCurrentPositions(Me.Name)
AutoScale(Me.Name)

Todo esto claro sin probar. Saludos.
Arriba
VayaCaló Ver desplegable
Habitual
Habitual


Unido: 16/Septiembre/2008
Localización: España
Estado: Sin conexión
Puntos: 129
Enlace directo a este mensaje Enviado: 12/Septiembre/2018 a las 10:28
Saludos,

Sin hacer ninguna prueba, creo que yo debo de tener un lio mental con el funcionamiento de los modulos estandar, si hago lo que propones, que lo haré, trasladando las funciones a un modulo estándar y obteniendo el objeto , en este caso el formulario, por referencia, si bien es cierto que la primera vez que se llame a la funcion recorre los controles de dicho formulario y almacena los datos de manera correcta, lo que sucede cuando se llama a la función por segunda vez desde otro formulario y efectua el procedimiento es: añadimos a los mismos datos ya almacenados mas datos en la misma estructura, por lo que se infiere que cuando se efectua autoescale(me.name) intentará recuperar todo lo que existe en la function GetCurrentPositions sin discriminar que datos pertenecen a uno u otro formulario.

Para que asi fuese deberia de formalizarse una clase , una coleccion o un diccionario....creo humildemente.

No se si me explico.

Gracias
 

 
Arriba
emiliove Ver desplegable
Moderador
Moderador


Unido: 16/Junio/2009
Localización: Mexico
Estado: Sin conexión
Puntos: 4623
Enlace directo a este mensaje Enviado: 12/Septiembre/2018 a las 15:51
Publicado originalmente por VayaCaló VayaCaló escribió:

lo que sucede cuando se llama a la función por segunda vez desde otro formulario y efectua el procedimiento es: añadimos a los mismos datos ya almacenados mas datos en la misma estructura, por lo que se infiere que

Pues yo diría que no, El evento Resize se produce al abrir un formulario y siempre que cambia su tamaño. Al momento de abrir el formulario, generas GetCurrentPositions y después viene el resize con AutoScale, así que cada vez que abres un formulario tomará los datos de este y se modificara en base a ello.

Un ejemplo interesante de Roger´s sobre el tema y con módulo de clase:

Saludos.
Arriba
VayaCaló Ver desplegable
Habitual
Habitual


Unido: 16/Septiembre/2008
Localización: España
Estado: Sin conexión
Puntos: 129
Enlace directo a este mensaje Enviado: 12/Septiembre/2018 a las 19:16
Al final me he decantado por un modulo de clase, que en principio parece que funciona.

Estructura basica de funcionamiento:
Al iniciarse la aplicación obtengo las medidas de la pantalla y los guardo como una propiedad personalizada, sobre esta propiedad confecciono un TempVar (CreaTempVar("RevisionMedidasPantalla", true ó False)) para saber si cada vez que abro un formulario debo de reformular las medidas del mismo, que van almacenadas en otra propiedad personalizada por cada formulario, en esta propiedad almaceno tanto  las medidas del formulario como la posición en pantalla del mismo y el color a aplicar.  :))
 
Proximamente publicare una base con la cosa

Ojo:  Como la cosa esta confeccionada rauda y veloz es posible que ocurran incidentes  y no funcione, pero la esperanza no se pierde. Os dejo la cosa por si os interesa. 
SOMETIDO A REVISION


-En el formulario:

Private fmResizeObjects As ClResizeObjects
Dim nolohagas As Boolean

Private Sub Form_Open(Cancel As Integer)
    On Error GoTo Form_Open_Error
    
    Set fmResizeObjects = New ClResizeObjects
    fmResizeObjects.p_KintReferenceHeight = 0
    If GetTempVarValue("RevisionMedidasPantalla") = False Then
        If CurrentDb.Properties(Me.Name).Value <> 0 Then
            nolohagas = False
            ScaleFormWindow Me
            Call Form_Resize
            Call RestorePositionForm(Me)
            nolohagas = True
        Else
            nolohagas = True
            ScaleFormWindow Me
        End If
    Else
        nolohagas = True
        ScaleFormWindow Me
        Call CreaTempVar("RevisionMedidasPantalla", False)
    End If
    On Error GoTo 0
    err.Clear
    Exit Sub
Form_Open_Error:
   If err = cErrPropertyNotFound Then
      fmResizeObjects.P_InitGetCurrentPositions Me, Me.Name
      stOpenArgs = Me.Name
      DoCmd.Close acForm, stOpenArgs
      DoCmd.OpenForm stOpenArgs: Exit Sub
    End If
    If err.Number = 0 Then err.Clear: Exit Sub
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Form_Open, line " & Erl & "."
End Sub

Private Sub Form_Close()
    On Error GoTo Form_Close_Error
    Set fmResizeObjects = Nothing
    On Error GoTo 0
    Exit Sub
Form_Close_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Form_Close of Documento VBA Form_Panel"
End Sub

    On Error GoTo Form_Resize_Error
    
    If fmResizeObjects.p_KintReferenceHeight = 0 Then
        fmResizeObjects.P_InitGetCurrentPositions Me, Me.Name
        Exit Sub
   Else
    If nolohagas Then
       fmResizeObjects.p_InitAutoScale Me, Me.Name
    End If
   End If
   TrabajaMenuLateral 4
    
    On Error GoTo 0
    Exit Sub
Form_Resize_Error:
    If err.Number = 2465 Then
        err.Clear
    Exit Sub
    End If
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Form_Resize of Documento VBA Form_Panel"
End Sub

Private Sub Form_Close()
    On Error GoTo Form_Close_Error

    Set fmResizeObjects = Nothing
    On Error GoTo 0
    Exit Sub
Form_Close_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Form_Close of Documento VBA Form_Panel"
End Sub






Option Compare Database
Option Explicit

'*************************************************************
' Class module: clResizeObjects
' AngelMiguel  12-09-2018
'*************-************************************************

Private m_KintReferenceHeight As Integer
Private m_KintReferenceWidth As Integer
Private m_KObjectList() As ScreenObject
Private m_Kcontrol As control
Private m_KintObjectNumber As Integer
Private m_KintFormObjectNumber As Long

Public Property Get p_KintReferenceHeight() As Integer
    p_KintReferenceHeight = m_KintReferenceHeight
End Property
 
Public Property Let p_KintReferenceHeight(sp As Integer)
    m_KintReferenceHeight = sp
End Property

Public Property Get p_KintReferenceWidth() As Integer
    p_KintReferenceWidth = m_KintReferenceWidth
End Property
 
Public Property Let p_KintReferenceWidth(sp As Integer)
    m_KintReferenceWidth = sp
End Property

Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String)
    err.Raise vbObjectError + lngErrNumber, "clResizeObjects", strErrDesc
End Sub

Public Sub P_InitGetCurrentPositions(ByVal sfrm As Access.Form, sKintFormObjectNamber As String)
    On Error GoTo P_InitGetCurrentPositions_Error
Erase m_KObjectList()
m_KintObjectNumber = 0
m_KintFormObjectNumber = 0
For Each m_Kcontrol In sfrm.Controls
    ReDim Preserve m_KObjectList(m_KintObjectNumber)
    With m_KObjectList(m_KintObjectNumber)
        .HwForm = sKintFormObjectNamber
        .Name = m_Kcontrol.Name
        .Left = m_Kcontrol.Left
        .Top = m_Kcontrol.Top
        .Width = m_Kcontrol.Width
        .Height = m_Kcontrol.Height
    End With
    m_KintObjectNumber = m_KintObjectNumber + 1
Next m_Kcontrol
    p_KintReferenceHeight = sfrm.InsideHeight
    p_KintReferenceWidth = sfrm.InsideWidth
    On Error GoTo 0
    Exit Sub
P_InitGetCurrentPositions_Error:
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure P_InitGetCurrentPositions, line " & Erl & "."
End Sub

Public Sub p_InitAutoScale(ByVal sfrm As Access.Form, sKintFormObjectNamber As String)
    On Error GoTo p_InitAutoScale_Error
Dim m_KdblXMultiplier As Double
Dim m_KdblYMultiplier As Double
Dim m_KintObjectNumber As Integer
Dim m_KintFontSize As Integer
Dim m_Kcontrol As control
m_KdblXMultiplier = sfrm.InsideHeight / p_KintReferenceHeight
m_KdblYMultiplier = sfrm.InsideWidth / p_KintReferenceWidth
For m_KintObjectNumber = 0 To UBound(m_KObjectList())
    For Each m_Kcontrol In sfrm.Controls
      'If m_KObjectList(m_KintObjectNumber).HwForm = sKintFormObjectNamber Then
        If m_Kcontrol.Name = m_KObjectList(m_KintObjectNumber).Name Then
             With m_Kcontrol
                If Int(m_KdblXMultiplier) > 0 Then
                    m_KintFontSize = Int(m_KdblXMultiplier * 8)
                    Select Case m_Kcontrol.ControlType
                    Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acTabCtl, acToggleButton
                     If .FontSize > 10 Then
                        .FontSize = 8
                        .FontName = "Segole UI"
                     Else
                        .FontSize = m_KintFontSize
                        .FontName = "Segole UI"
                     End If
                    End Select
                End If
                .Left = m_KObjectList(m_KintObjectNumber).Left * m_KdblYMultiplier
                .Width = m_KObjectList(m_KintObjectNumber).Width * m_KdblYMultiplier
                .Height = m_KObjectList(m_KintObjectNumber).Height * m_KdblXMultiplier
                .Top = m_KObjectList(m_KintObjectNumber).Top * m_KdblXMultiplier
             End With
        End If
      'End If
    Next m_Kcontrol
Next m_KintObjectNumber
    On Error GoTo 0
    err.Clear
    Exit Sub
p_InitAutoScale_Error:
   If err.Number = 2100 Then err.Clear: Exit Sub
    MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure p_InitAutoScale, line " & Erl & "."
End Sub



Editado por VayaCaló - 12/Septiembre/2018 a las 19:26
Arriba
VayaCaló Ver desplegable
Habitual
Habitual


Unido: 16/Septiembre/2008
Localización: España
Estado: Sin conexión
Puntos: 129
Enlace directo a este mensaje Enviado: 13/Septiembre/2018 a las 13:24
Saludos 

Algún administrador que cierre el hilo.

Post
cuanto tenga la base la envio, tardaré un poco


Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable