Clase resize forms y objects

[AngelMiguel]

Saludos,

Ayer confeccioné una clase para cambiar el tamaño de formularios y objetos en formularios.

Cuando abres la base de datos de ejemplo , verifica la estructura (medidas) de la pantalla y almacenas las mediciones en una propiedad personalizada.
Luego, creé una variable tempVar para indicar si hay que cambiar el tamaño de los formularios.
Cuando se llama a un formulario, se lee la variable de tempvar para aplicar o no la nueva resolución del monitor, se llama a la clase para guardar y cambiar el tamaño, si es necesario de las medidas, la posición de los objetos y el color de fondo del formulario.

Se está mejorando, se puede probar

aprecio Feed-Back

Corregido enlace
https://drive.google.com/file/d/1SWyycX ... sp=sharing

[AngelMiguel]

Saludos,

Acabo de terminar una revisión bastante exhaustiva de la clResize forms y objects, ya que la anterior contenia errores y no funcionaba de la manera que la he soñado.

Esta versión, para ms access 2016 contiene algunas sorpresas que os seran agradables:

- ToolTips , finalizado.
- Menú, pendiente de efectuar la pantalla de configuración
- Resize forms y objects con memoria , finalizado creo )
- Capacidad de modificación de color del formulario y tipo de letra en función del tipo de control seleccionado ( en curso).
y todo simple y centralizado.

... y algunas otras cosillas a nivel de código.

La selección de fuentes esta basada en el control comDlg32.ocx, que sustituiré por código totalmente en un futuro próximo.

Sigo trabajando en ello, ya que hay algunas cuestiones que no me acaban de convencer, luego la cosa esta en curso.

Ojo: Codigos de otros insertados y referenciados.... algunas veces.

Espero que os guste esta nueva versión.

El iletrado admite preguntas faciles )

AngelMiguel

la cosa aqui....
https://drive.google.com/file/d/1cvg8ko ... sp=sharing

[AngelMiguel]

Saludos,

Acabo de sacar de la cocina la nueva versión de ClResizeObjects versión 08C

LLena de cosas que hacen cosas, espero que os guste...

esta en curso ...Ojo

Revisad las referencias, abrid con "Mayusculas" para ver las cosas

Funciona, a mi me funciona, en Ms Access 2016

Cualquier cosa al iletrado

AngelMiguel

enlace: https://drive.google.com/file/d/1KYoSiW ... sp=sharing

Nota de descargo: He procurado dentro de la cabe referenciar los códigos de "otros", es posible que se haya escapado alguna cosa o varias o muchísimas, por ello si ves alguna cosilla tuya que le tengas un gran cariño y no lo haya referenciado, pues te agradecería me lo comunicases para poder nombrarte.

[AngelMiguel]

Acabo de sacar de la cocina la nueva versión de ClResizeObjects : versión 09B

La estructura de directorios y bases la puedes bajar de la anterior dirección, aqui sólo la base principal, algunas cosillas no acababan de funcionar como deseo, otras estan en desarrollo.

Bonus:
Importación de presupuestos de construcción ( en curso...)
Aplicar Skins a los forms ( no me acaba de funcionar)


LLena de cosas que hacen cosas, espero que os guste...
esta en curso ...Ojo

Revisad las referencias, abrid con "Mayusculas" para ver las cosas

Funciona, a mi me funciona, en Ms Access 2016

Cualquier cosa al iletrado

AngelMiguel

enlace: https://drive.google.com/file/d/17Ovt9a ... sp=sharing

Nota de descargo: He procurado dentro de la cabe referenciar los códigos de "otros", es posible que se haya escapado alguna cosa o varias o muchísimas, por ello si ves alguna cosilla tuya que le tengas un gran cariño y no lo haya referenciado, pues te agradecería me lo comunicases para poder nombrarte.

[bryger]

amigo el ultimo me da error ocx

[AngelMiguel]

Pues lamento que te de error cosa que no me pasa en mi ordenador , pero ante tal escasez de datos poco puedo decirte salvo animarte a repasar el código y las referencias, eso tal vez te ayude.
Ánimo

[AngelMiguel]

Hey...

ejemplo obsoleto....https://drive.google.com/file/d/17Ovt9a ... sp=sharing

Actualización clase..... clResizeObjects

Option Compare Database
Option Explicit

'*************************************************************
' Class module: clResizeObjects
' basado en una idea de
' https://stackoverflow.com/questions/133 ... orm-resize
' https://codereview.stackexchange.com/qu ... ynamically
' https://www.dreamincode.net/forums/topi ... -size-vb6/
' https://docs.microsoft.com/en-us/office ... ontroltype
'http://www.dbwiki.net/wiki/Datei:AccSampleFormScreenPos.zip
' entre otros muchos
' 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

Friend Sub P_InitGetCurrentPositions(ByVal Sfrm As Access.Form)
On Error GoTo P_InitGetCurrentPositions_Error
Dim subsFrm As SubForm
Dim Subsctl As Access.Control
Erase m_KObjectList()
m_KintObjectNumber = 0
m_KintFormObjectNumber = 0
p_KintReferenceHeight = Sfrm.InsideHeight
p_KintReferenceWidth = Sfrm.InsideWidth
For Each m_Kcontrol In Sfrm.Controls
ReDim Preserve m_KObjectList(m_KintObjectNumber)
With m_KObjectList(m_KintObjectNumber)
.ControlName = m_Kcontrol.Name
.ControlType = m_Kcontrol.ControlType
.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
'Debug.Print m_KintObjectNumber
On Error GoTo 0
err.Clear
Exit Sub
P_InitGetCurrentPositions_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure P_InitGetCurrentPositions, line " & Erl & "."
End Sub

Friend Sub p_InitAutoScale(ByVal Sfrm As Access.Form, Optional sKintFormObjectNamber As String)
On Error GoTo p_InitAutoScale_Error
Dim subsFrm As SubForm
Dim Subsctl As Access.Control
Dim m_KdblXMultiplier As Double
Dim m_KdblYMultiplier As Double
Dim m_KintObjectNumber As Integer
Dim Subm_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_Kcontrol.Name = m_KObjectList(m_KintObjectNumber).ControlName Then
With m_Kcontrol
'If Int(m_KdblXMultiplier) > 0 Then
m_KintFontSize = Int(m_KdblXMultiplier * 8)
Select Case m_Kcontrol.ControlType
Case acTabCtl
GoTo 100
Case acLabel, acCommandButton, acTextBox, acComboBox, acListBox, acToggleButton
Select Case m_Kcontrol.fontsize
Case Is > 15
m_Kcontrol.fontsize = 8
Case Else
m_Kcontrol.fontsize = 8 'm_KintFontSize
End Select
Case acSubform
Select Case m_Kcontrol.Name
Case "Lista1"
Call AjustarvistaGeneral(Sfrm.Name, m_Kcontrol.Name, m_Kcontrol.Form.DatasheetFontName, m_KintFontSize)
Case "MiniMenuVerticalDer", "sfrDatasheet", "lista10", "Secundario0", "sfmKlassengenerator"
''''
Case Else
m_Kcontrol.fontsize = 8 'm_KintFontSize
End Select
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
100
Next m_Kcontrol
Next m_KintObjectNumber
Exit Sub
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


Clase .... modScaleForm

Option Compare Database
Option Explicit
' Basado en modScaleForm Version : 2008-03-10 ' Author : Markus Gruber (markus.gruber@gruber.cc)

Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String)

err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc

End Sub

Private Sub UpdateWindowRect()
'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow.

Dim ptCorner As POINTAPI

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates.

If Not Me.Parent Is Nothing Then
'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates.
With ptCorner
.X = m_rctWindow.Left
.Y = m_rctWindow.Top
End With

apiScreenToClient Me.Parent.hwnd, ptCorner

With m_rctWindow
.Left = ptCorner.X
.Top = ptCorner.Y
End With

'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates.
With ptCorner
.X = m_rctWindow.Right
.Y = m_rctWindow.Bottom
End With

apiScreenToClient Me.Parent.hwnd, ptCorner

With m_rctWindow
.Right = ptCorner.X
.Bottom = ptCorner.Y
End With
End If
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Sub

Public Property Get hwnd() As Long

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
hwnd = m_hWnd
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property

Public Property Let hwnd(ByVal lngNewValue As Long)

If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then
m_hWnd = lngNewValue
Else
RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle."
End If

End Property

Public Property Get Left() As Long

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
Left = m_rctWindow.Left
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property


Public Property Let Left(ByVal lngNewValue As Long)

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property

Public Property Get Top() As Long

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
Top = m_rctWindow.Top
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property

Public Property Let Top(ByVal lngNewValue As Long)

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property

Public Property Get Width() As Long

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
Width = .Right - .Left
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property

Public Property Let Width(ByVal lngNewValue As Long)

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property

Public Property Get Height() As Long

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
Height = .Bottom - .Top
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property

Public Property Let Height(ByVal lngNewValue As Long)

If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

End Property

Public Property Get Parent() As clFormWindow

Dim fwParent As New clFormWindow
Dim lngHWnd As Long

If m_hWnd = 0 Then
Set Parent = Nothing
ElseIf apiIsWindow(m_hWnd) Then
lngHWnd = apiGetParent(m_hWnd)
fwParent.hwnd = lngHWnd
Set Parent = fwParent
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If

Set fwParent = Nothing

End Property





Modulo... MdlResize

Option Compare Database
Option Explicit

Public Sub ScaleFormWindow(ByVal frm As Access.Form, Optional DoNotCenter As Boolean)
'https://github.com/GruberMarkus/modScaleForm/blob/master/modScaleForm.bas
' Basado en modScaleForm Version : 2008-03-10 ' Author : Markus Gruber (markus.gruber@gruber.cc)
Dim NewForm As New clFormWindow
Dim rectWindow As RECT
On Error Resume Next
DoCmd.RunCommand acCmdSizeToFitForm
Call apiGetWindowRect(frm.hwnd, rectWindow)
NewForm.hwnd = frm.hwnd
With NewForm
.Height = Round((rectWindow.Bottom - rectWindow.Top) * 1, 0)
.Width = Round((rectWindow.Right - rectWindow.Left) * 1, 0)
If Not DoNotCenter Then
.Top = (.Parent.Height - .Height) / 2
.Left = (.Parent.Width - .Width) / 2
End If
End With
Set NewForm = Nothing
End Sub

Public Function RestorePositionForm(frm As Access.Form, Optional ByVal OpcionesControles As Variant)
'https://www.ms-office-forum.net/forum/archive/index.php?t-198819.html
Dim tmp As Variant
Dim hwnd As Long
Dim WPL As WINDOWPLACEMENT
Dim retval As Long
On Error Resume Next
Select Case err.Number
Case 0 'existe y aplicamos
With WPL
hwnd = frm.hwnd
tmp = CurrentDb.Properties(frm.Name).Value
.rcNormalPosition.Left = ConvLong(StrPart(tmp, 4, ";")) ' izquierda
.rcNormalPosition.Top = ConvLong(StrPart(tmp, 5, ";"))
.rcNormalPosition.Right = ConvLong(StrPart(tmp, 6, ";")) ' derecha
.rcNormalPosition.Bottom = ConvLong(StrPart(tmp, 7, ";"))
.Length = 44
retval = SetWindowPlacement(hwnd, WPL)
End With
frm.Section(acDetail).BackColor = ConvLong(StrPart(tmp, 8, ";"))
Call AplicaDatosControlesForm(frm, OpcionesControles)
If ControlExists("btnRojo", frm) = True Then
Select Case StrPart(tmp, 27, ";")
Case "BtnRojo"
frm!btnRojo.Visible = True
frm!btnVerde.Visible = False
Case "BtnVerde"
frm!btnRojo.Visible = False
frm!btnVerde.Visible = True
End Select
End If
Case 3270
' no existe, la creamos primero y ejecutamos de nuevo
SavePositionForm (frm)
RestorePositionForm (frm)
Case Else
MsgBox err.Description, vbExclamation, "Error " & err.Number
End Select
Ex:
On Error Resume Next
err.Clear
Exit Function
Er:
err.Clear
'MsgBox "RestorePosition:" & err.Description
Resume Ex
End Function

Public Function AplicaDatosControlesForm(frm As Access.Form, ByVal OpcionesControles As Variant)
Dim ctl As Access.Control
Dim Sbctl As Access.Control
Dim sbFrm As SubForm
Dim AplicaLabel As Variant
Dim aplicaTexBox As Variant
Dim AplicaCommandButton As Variant
AplicaLabel = OpcionesControles
aplicaTexBox = OpcionesControles
AplicaCommandButton = OpcionesControles
For Each ctl In frm.Controls
With ctl
'acSubform 'For Each ctlSub in ctl.Form.Controls
Select Case ctl.ControlType
Case acLabel
.FontName = Nz(StrPart(AplicaLabel, 9, ";"), "Segoe Ui")
.fontsize = IIf(ConvLong(StrPart(aplicaTexBox, 10, ";")) < 7, 7, ConvLong(StrPart(aplicaTexBox, 10, ";")))
.FontBold = ConvLong(StrPart(AplicaLabel, 11, ";"))
.FontItalic = ConvLong(StrPart(AplicaLabel, 12, ";"))
.FontUnderline = ConvLong(StrPart(AplicaLabel, 13, ";"))
.ForeColor = ConvLong(StrPart(AplicaLabel, 14, ";"))
Case acTextBox
.FontName = Nz(StrPart(aplicaTexBox, 15, ";"), "Segoe Ui")
.fontsize = IIf(ConvLong(StrPart(aplicaTexBox, 16, ";")) < 7, 7, ConvLong(StrPart(aplicaTexBox, 16, ";")))
.FontBold = ConvLong(StrPart(aplicaTexBox, 17, ";"))
.FontItalic = ConvLong(StrPart(aplicaTexBox, 18, ";"))
.FontUnderline = ConvLong(StrPart(aplicaTexBox, 19, ";"))
.ForeColor = ConvLong(StrPart(aplicaTexBox, 20, ";"))
Case acCommandButton, acComboBox, acListBox, acTabCtl ', acToggleButton
.FontName = Nz(StrPart(AplicaCommandButton, 21, ";"), "Segoe Ui")
.fontsize = IIf(ConvLong(StrPart(aplicaTexBox, 22, ";")) < 7, 7, ConvLong(StrPart(aplicaTexBox, 22, ";")))
.FontBold = ConvLong(StrPart(AplicaCommandButton, 23, ";"))
.FontItalic = ConvLong(StrPart(AplicaCommandButton, 24, ";"))
.FontUnderline = ConvLong(StrPart(AplicaCommandButton, 25, ";"))
.ForeColor = ConvLong(StrPart(AplicaCommandButton, 26, ";"))
Case acSubform
Set sbFrm = ctl
Debug.Print sbFrm.Name
For Each Sbctl In sbFrm.Controls
If ctl.ControlType = acTextBox Then
.FontName = Nz(StrPart(aplicaTexBox, 27, ";"), "Segoe Ui")
.fontsize = IIf(ConvLong(StrPart(aplicaTexBox, 28, ";")) < 7, 7, ConvLong(StrPart(aplicaTexBox, 28, ";")))
.FontBold = ConvLong(StrPart(aplicaTexBox, 29, ";"))
.FontItalic = ConvLong(StrPart(aplicaTexBox, 30, ";"))
.FontUnderline = ConvLong(StrPart(aplicaTexBox, 31, ";"))
.ForeColor = ConvLong(StrPart(aplicaTexBox, 32, ";"))
End If
Next
Set sbFrm = Nothing
End Select
End With
Next
End Function

Public Function SavePositionForm(frm As Form, Optional ByVal StPantallaInicial As String, Optional StcolorSeccionForm As Long, Optional ByVal StControles As String, Optional btnColor As String)
'https://www.ms-office-forum.net/forum/archive/index.php?t-198819.html
On Error GoTo Er
Dim hwnd As Long
Dim WPL As WINDOWPLACEMENT
Dim retval As Long
Dim stDatosNumericos As String
Dim OtrosDatos As String
On Error Resume Next
hwnd = frm.hwnd
WPL.Length = 44
retval = GetWindowPlacement(hwnd, WPL)
''' OBTENEMOS
stDatosNumericos = StPantallaInicial
stDatosNumericos = stDatosNumericos & WPL.rcNormalPosition.Left & ";"
stDatosNumericos = stDatosNumericos & WPL.rcNormalPosition.Top & ";"
stDatosNumericos = stDatosNumericos & WPL.rcNormalPosition.Right & ";"
stDatosNumericos = stDatosNumericos & WPL.rcNormalPosition.Bottom & ";"
stDatosNumericos = stDatosNumericos & StcolorSeccionForm & ";"
stDatosNumericos = stDatosNumericos & Nz(StControles, " ")
If ControlExists("btnRojo", frm) = True Then
If frm!btnRojo.Visible = True Then
stDatosNumericos = stDatosNumericos & "btnRojo" & ";"
Else
stDatosNumericos = stDatosNumericos & "btnVerde" & ";"
End If
Else
stDatosNumericos = stDatosNumericos & "BtnVerde" & ";"
End If
DeleteProperty (frm.Name)
RT_PropiedadStringWR frm.Name, stDatosNumericos
Ex:
On Error Resume Next
Exit Function
Er:
MsgBox "SavePosition:" & err.Description
Resume Ex
End Function

Public Function obtenDatosControlesForm(frm As Access.Form)
On Error GoTo obtenDatosControlesForm_Error
Dim ctl As Access.Control
Dim Sbctl As Access.Control
Dim sbFrm As SubForm
Dim ListameDatosCtlE, ListameDatosCtlC, ListameDatosCtlD As String
Dim ListameDatosCtlZ As String
Dim NoacSubform As String
Dim NoAclabel, NoacTextBox, NoacCommandButton, NoacSubTextBox As Boolean

NoAclabel = True: NoacTextBox = True: NoacCommandButton = True
NoacSubform = True: NoacSubTextBox = True
ListameDatosCtlE = "": ListameDatosCtlC = "": ListameDatosCtlD = ""
ListameDatosCtlZ = ""

For Each ctl In frm.Controls
With ctl
'acSubform 'For Each ctlSub in ctl.Form.Controls
Select Case ctl.ControlType
Case acLabel
If NoAclabel Then
ListameDatosCtlE = ListameDatosCtlE & Nz(.FontName, "Segoe UI") & ";"
ListameDatosCtlE = ListameDatosCtlE & Nz(.fontsize, 8) & ";"
ListameDatosCtlE = ListameDatosCtlE & Nz(.FontBold, -1) & ";"
ListameDatosCtlE = ListameDatosCtlE & Nz(.FontItalic, 0) & ";"
ListameDatosCtlE = ListameDatosCtlE & Nz(.FontUnderline, -1) & ";"
ListameDatosCtlE = ListameDatosCtlE & Nz(.ForeColor, 0) & ";"
NoAclabel = False
End If
Case acTextBox
If NoacTextBox Then
ListameDatosCtlC = ListameDatosCtlC & Nz(.FontName, "Segoe UI") & ";"
ListameDatosCtlC = ListameDatosCtlC & Nz(.fontsize, 8) & ";"
ListameDatosCtlC = ListameDatosCtlC & Nz(.FontBold, -1) & ";"
ListameDatosCtlC = ListameDatosCtlC & Nz(.FontItalic, 0) & ";"
ListameDatosCtlC = ListameDatosCtlC & Nz(.FontUnderline, -1) & ";"
ListameDatosCtlC = ListameDatosCtlC & Nz(.ForeColor, 0) & ";"
NoacTextBox = False
End If
Case acCommandButton, acComboBox, acListBox, acTabCtl ', acToggleButton
If NoacCommandButton Then
ListameDatosCtlD = ListameDatosCtlD & Nz(.FontName, "Segoe UI") & ";"
ListameDatosCtlD = ListameDatosCtlD & Nz(.fontsize, 8) & ";"
ListameDatosCtlD = ListameDatosCtlD & Nz(.FontBold, -1) & ";"
ListameDatosCtlD = ListameDatosCtlD & Nz(.FontItalic, 0) & ";"
ListameDatosCtlD = ListameDatosCtlD & Nz(.FontUnderline, -1) & ";"
ListameDatosCtlD = ListameDatosCtlD & Nz(.ForeColor, 0) & ";"
NoacCommandButton = False
End If
Case acSubform
If NoacSubform Then
Set sbFrm = ctl
If Len(ctl.SourceObject) > 0 Then
For Each Sbctl In sbFrm.Controls
If Sbctl.ControlType = acTextBox Then
If NoacSubTextBox Then
ListameDatosCtlZ = ListameDatosCtlZ & Nz(Sbctl.FontName, "Segoe UI") & ";"
ListameDatosCtlZ = ListameDatosCtlZ & Nz(Sbctl.fontsize, 8) & ";"
ListameDatosCtlZ = ListameDatosCtlZ & Nz(Sbctl.FontBold, -1) & ";"
ListameDatosCtlZ = ListameDatosCtlZ & Nz(Sbctl.FontItalic, 0) & ";"
ListameDatosCtlZ = ListameDatosCtlZ & Nz(Sbctl.FontUnderline, -1) & ";"
ListameDatosCtlZ = ListameDatosCtlZ & Nz(Sbctl.ForeColor, 0) & ";"
NoacSubTextBox = False
End If
End If
Next
End If
Set sbFrm = Nothing
NoacSubform = False
End If
End Select
End With
Next
obtenDatosControlesForm = ListameDatosCtlE + ListameDatosCtlC + ListameDatosCtlD + ListameDatosCtlZ

On Error GoTo 0
Exit Function
obtenDatosControlesForm_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure obtenDatosControlesForm, line " & Erl & "."
End Function

Function StrPart(S, Optional cnt = 1, Optional Sep = ";")
'https://www.ms-office-forum.net/forum/archive/index.php?t-198819.html
' Funktionswert: Liefert den -ten durch getrennten Teilstring zurück
' StrPart - Encuentra una parte de una cadena
Dim i As Long, J As Long, K As Long, res As String
On Error GoTo Er

If IsNull(S) Then StrPart = Null: Exit Function
StrPart = ""
If Not IsNumeric(cnt) Then Exit Function
res = ""
J = 1
For i = 1 To cnt
K = InStr(J, S, Sep)
If K = 0 Then K = 32000
If i = cnt Then res = Mid(S, J, K - J)
J = K + Len(Sep)
If J > 30000 Then Exit For
Next i
StrPart = res

Ex:
Exit Function

Er:
MsgBox "StrPart:" & err.Description
Resume Ex
End Function

Function ConvLong(IVal)
'ConvLong - Konvertiert numerischen Wert ' in Variant Typ 3 (Long Integer) ' Null und nichtnumerische Werte --> 0
'ConvLong - Convierte valor numérico 'en la variante de tipo 3 (entero largo)' cero y no numéricos valores -> 0
'https://www.ms-office-forum.net/forum/archive/index.php?t-198819.html
Dim tmp As Long
On Error GoTo Er

tmp = 0
If IsNull(IVal) Then
tmp = 0
ElseIf VarType(IVal) >= 2 And VarType(IVal) <= 5 Then
tmp = CLng(IVal)
ElseIf VarType(IVal) = 7 Then
tmp = CLng(IVal)
ElseIf IsNumeric(IVal) Then
tmp = CLng(IVal)
Else
tmp = 0
End If

Ex:
ConvLong = tmp
Exit Function

Er:
MsgBox "ConvLong:" & err.Description
Resume Ex
End Function

Public Function DamePositionForm(ByRef frm As Form) As Variant
'https://www.ms-office-forum.net/forum/archive/index.php?t-198819.html
On Error GoTo Er
Dim hwnd As Long
Dim WPL As WINDOWPLACEMENT
Dim retval As Long
Dim stDatosNumericosPosicionForm As Variant
On Error Resume Next
Debug.Print frm.Name
hwnd = frm.hwnd
WPL.Length = 44
retval = GetWindowPlacement(hwnd, WPL)
''' OBTENEMOS
stDatosNumericosPosicionForm = stDatosNumericosPosicionForm & WPL.rcNormalPosition.Left & ";"
stDatosNumericosPosicionForm = stDatosNumericosPosicionForm & WPL.rcNormalPosition.Top & ";"
stDatosNumericosPosicionForm = stDatosNumericosPosicionForm & WPL.rcNormalPosition.Right & ";"
stDatosNumericosPosicionForm = stDatosNumericosPosicionForm & WPL.rcNormalPosition.Bottom & ";"
DamePositionForm = stDatosNumericosPosicionForm
Exit Function
Ex:
On Error Resume Next
Exit Function
Er:
MsgBox "SavePosition:" & err.Description
Resume Ex
End Function

Public Function SiCierraElForm(ByRef frm As Access.Form, AlCierreActualiza As Boolean)
On Error GoTo SiCierraElForm_Error
Dim stDatosNumericos As String
Dim A, b, C, d As Variant
Dim X, Y As Integer
Dim stDatosControles As String
Dim StMedidasPantalla As String
Dim StColorControl As Long
If AlCierreActualiza Then
'' permitimos actualizar la propiedad
StMedidasPantalla = CurrentDb.Properties("MedidasPantalla").Value
stDatosControles = obtenDatosControlesForm(frm)
Call SavePositionForm(frm, StMedidasPantalla, frm.Section(acDetail).BackColor, stDatosControles)
Else
'' solo cambio parcial de la propiedad
A = CurrentDb.Properties("MedidasPantalla").Value
b = CurrentDb.Properties(frm.Name).Value
C = DamePositionForm(frm)
For X = 1 To 26
Select Case X
Case 1
d = A
Case 2, 3
'
Case 4, 5, 6, 7
d = A & C
Case Else
d = d & StrPart(b, X, ";") & ";"
End Select
Next
stDatosNumericos = d
DeleteProperty (frm.Name)
RT_PropiedadStringWR frm.Name, stDatosNumericos
End If
On Error GoTo 0
Exit Function
SiCierraElForm_Error:
If err = cErrPropertyNotFound Then
Call DameMedidasPantallaInicialAplicacion
Call SiCierraElForm(frm, False)
Exit Function
End If
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure SiCierraElForm, line " & Erl & "."
End Function


Public Sub DameMedidasPantallaInicialAplicacion()
On Error GoTo DameMedidasPantallaInicialAplicacion_Error

Dim varMedidas As String
varMedidas = WM_apiGetDeviceCaps(WM_apiGetDC(0), WM_VERTRES) & ";"
varMedidas = varMedidas & WM_apiGetDeviceCaps(WM_apiGetDC(0), WM_HORZRES) & ";"
varMedidas = varMedidas & WM_apiGetDeviceCaps(WM_apiGetDC(0), WM_LOGPIXELSX) & ";"
' actualizamos las medidas de la pantalla
RT_PropiedadString ("MedidasPantalla")
RT_PropiedadStringWR "MedidasPantalla", varMedidas
Exit Sub

On Error GoTo 0
Exit Sub
DameMedidasPantallaInicialAplicacion_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure DameMedidasPantallaInicialAplicacion, line " & Erl & "."
End Sub


Public Sub InitGetFormOpen(ByVal Sfrm As Access.Form)
On Error GoTo InitGetFormOpen_Error
Dim s_IniPantalla As String
Dim s_FormPantalla As String

s_IniPantalla = CurrentDb.Properties("MedidasPantalla").Value
s_FormPantalla = StrPart(CurrentDb.Properties(Sfrm.Name).Value, 1, ";") & ";"
s_FormPantalla = s_FormPantalla & StrPart(CurrentDb.Properties(Sfrm.Name).Value, 2, ";") & ";"
s_FormPantalla = s_FormPantalla & StrPart(CurrentDb.Properties(Sfrm.Name).Value, 3, ";") & ";"
Select Case s_IniPantalla = s_FormPantalla
Case True
''' existe la propiedad y la pantalla inicial no ha variado mantenemos todo
''' en la propiedad,medidas iniciales+ medidas y posicion del form + controles colores...etc
Sfrm.p_AlCierreActualiza (True)
Sfrm.p_NoHagasResize (False)
ScaleFormWindow Sfrm
Sfrm.Iniciame
Call RestorePositionForm(Sfrm, CurrentDb.Properties(Sfrm.Name).Value)
Sfrm.Continuame
Sfrm.p_NoHagasResize (True)
Case False
''' existe la propiedad y la pantalla inicial ha variado y queremos mantener todo el resto igual
''' en la propiedad medidas y posicion del form + controles colores...etc
''' solo cambia los datos pantalla inicial ( tres primeros campos de la propiedad)
Sfrm.p_AlCierreActualiza (False)
ScaleFormWindow Sfrm
Sfrm.p_NoHagasResize (False)
Sfrm.Iniciame
stOpenArgs = Sfrm.Name
Call SiCierraElForm(Sfrm, False)
DoCmd.Close acForm, stOpenArgs
DoEvents
DoCmd.OpenForm stOpenArgs, , , , , , stOpenArgs
Exit Sub
End Select
On Error GoTo 0
err.Clear
Exit Sub
InitGetFormOpen_Error:
If err = cErrPropertyNotFound Then
ScaleFormWindow Sfrm
Sfrm.p_NoHagasResize (False)
Sfrm.Iniciame
stOpenArgs = Sfrm.Name
Sfrm.p_AlCierreActualiza (True)
Call SiCierraElForm(Sfrm, True)
DoCmd.Close acForm, Sfrm.Name, acSaveYes
DoEvents
DoCmd.OpenForm stOpenArgs, , , , , , stOpenArgs
Exit Sub
End If
Select Case err.Number
Case 0
err.Clear
Exit Sub
Case Else
err.Clear
Exit Sub
End Select
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure P_InitGetFormOpen, line " & Erl & "."
End Sub




Form ....


Private AlCierreActualiza As Boolean
Private NoHagasResize As Boolean
Private stDatosControles As String
Private Stfrm As String
Private fmResizeObjects As ClResizeObjects
Private m_bInLable As Boolean


Private Sub CmdSalir_Click()
On Error GoTo CmdSalir_Click_Error

Call SiCierraElForm(Me, True)
DoCmd.Close acForm, Me.Name, acSaveYes

On Error GoTo 0
Exit Sub
CmdSalir_Click_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure CmdSalir_Click, line " & Erl & "."
End Sub

Private Sub Form_Close()
On Error GoTo Form_Close_Error

Set frmMiniMenuVerticalDer = Nothing
Set fmResizeObjects = Nothing
Stfrm = Nz(StrPart(Me.OpenArgs, 3, ":"), "Panel")
If EstaAbierto(Stfrm) Then
Forms(Stfrm).Visible = True
Forms(Stfrm).SetFocus
Else
DoCmd.OpenForm "Panel"
Forms("Panel").SetFocus
End If

On Error GoTo 0
Exit Sub
Form_Close_Error:
MsgBox "Error

Private Sub Form_Open(Cancel As Integer)
On Error GoTo Form_Open_Error

If Len(Me.OpenArgs) = 0 Or IsNull(Me.OpenArgs) Then
MsgBoxEx Me.hwnd, "este formulario no se puede abrir directamente", 3, vbCritical, "Balances"
DoCmd.CancelEvent
Call CmdSalir_Click
End If
Set fmResizeObjects = New ClResizeObjects
fmResizeObjects.p_KintReferenceHeight = 0
Call InitGetFormOpen(Me)

On Error GoTo 0
Exit Sub
Form_Open_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Form_Open, line " & Erl & "."
End Sub


Public Sub Iniciame()
On Error GoTo Iniciame_Error

fmResizeObjects.P_InitGetCurrentPositions Me

On Error GoTo 0
Exit Sub
Iniciame_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Iniciame, line " & Erl & "."
End Sub

Public Sub Continuame()
On Error GoTo Continuame_Error

fmResizeObjects.p_InitAutoScale Me, Me.Name

On Error GoTo 0
Exit Sub
Continuame_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Continuame, line " & Erl & "."
End Sub

Public Sub p_AlCierreActualiza(Quehacer As Boolean)
On Error GoTo p_AlCierreActualiza_Error

Select Case Quehacer
Case True
AlCierreActualiza = True
Case False
AlCierreActualiza = False
End Select

On Error GoTo 0
Exit Sub
p_AlCierreActualiza_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure p_AlCierreActualiza, line " & Erl & "."
End Sub

Public Sub p_NoHagasResize(Quehacer As Boolean)
On Error GoTo p_NoHagasResize_Error

Select Case Quehacer
Case True
NoHagasResize = True
Case False
NoHagasResize = False
End Select

On Error GoTo 0
Exit Sub
p_NoHagasResize_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure p_NoHagasResize, line " & Erl & "."
End Sub

Private Sub Form_Resize()
On Error GoTo Form_Resize_Error

Select Case NoHagasResize
Case False
Exit Sub
Case True
If fmResizeObjects.p_KintReferenceHeight = 0 Then
fmResizeObjects.P_InitGetCurrentPositions Me
Exit Sub
Else
fmResizeObjects.p_InitAutoScale Me, Me.Name
End If
End Select

On Error GoTo 0
Exit Sub
Form_Resize_Error:
MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure Form_Resize, line " & Erl & "."
End Sub

Modulo... Properties

Function RT_PropiedadString(NombrePropiedad As String) As String
'Tecsys SL
Dim Prp As DAO.Property
'** Comprueba la existencia de la propiedad y si no existe la crea
On Error GoTo Errores_Propiedad

RT_PropiedadString = CurrentDb.Properties(NombrePropiedad)

On Error GoTo 0
Exit Function

'** Tratamiento errores
Errores_Propiedad:
If err = 3270 Then 'La propiedad no está creada
Set Prp = CurrentDb.CreateProperty(NombrePropiedad, dbText, " ", False)
CurrentDb.Properties.Append Prp
RT_PropiedadString = " "
Else
MsgBox "Error de creacion de propiedad, nº : " & err, vbCritical, "xxxx"
End If
End Function

Function RT_PropiedadStringWR(ByVal NombrePropiedad As String, ByVal Valor As String)
'Tecsys SL
Dim Prp As Property
'** Asigna valor a la propiedad si no existe la crea
On Error GoTo Errores_Propiedad

CurrentDb.Properties(NombrePropiedad) = Nz(Valor, " ")

On Error GoTo 0
Exit Function
'** Tratamiento errores
Errores_Propiedad:
If err.Number = 3270 Then 'La propiedad no está creada
Set Prp = CurrentDb.CreateProperty(NombrePropiedad, dbText, Valor, False)
CurrentDb.Properties.Append Prp
Else
MsgBox "Error de creacion de propiedad, nº : " & err, vbCritical, "xxxxxx"
End If
End Function

[AngelMiguel]

Saludos chicos,

Aqui que te vá una revisión del revoltillo ese de la clase resize forms y objects, va mucho mejor, aunque considero que algún alma caritativa podria refundirlo todo en uno. Contiene algunos errores menores y es manifiestamente mejorable.

La cosa funciona, me funciona, en office 365. Revisad las referencias.

Espero que os sea útil.

https://drive.google.com/file/d/1VeQ-_3 ... sp=sharing

Saludos

[AngelMiguel]

Balances_Demandas_ResizeObjects_Ver15b.accdb

https://drive.google.com/file/d/1zdg5Bn ... sp=sharing

19-02-2019

Cambios menores.

[AngelMiguel]

Atención...

Retomando el tema después de una prolongada ausencia he comprobado un "bug" que desconozco como arreglarlo de manera adecuada, pero lo he medio solucionado de la siguiente manera provisional:

- error en la clase CtoolTip
- Instalaciones con Win10 + ms access 365 de 32 bits

Donde dice Public Function Create(ByVal ParentHwnd As Long) As Boolean
Linea de Error: If mvarStyle = TTBalloon Then lWinStyle = lWinStyle or TTS_BALLOON

sustituit por If mvarStyle = TTBalloon Then lWinStyle = lWinStyle And TTS_BALLOON