UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Resize Form    
 
   
skiss
post Mar 6 2003, 02:21 PM
Post#1



Posts: 2
Joined: 6-March 03



This is a little bit of code I found some time ago. It will resize a form to correspond with the users display resolution. Just add this to a module and call the module on load.

'CREDITS:
'This modResizeForm module was created by Jamie Czernik 31st March 2000 (jsczernik@hotmail.com)
'The module was updated by Dr. Martin Dumskyj 30th January 2001 (mdumskyj@sghms.ac.uk)
'Module Declarations
Global Const DesignResolutionX = 1024
'CHANGE THE VALUE ABOVE TO THE RESOLUTION YOU DESIGNED YOUR FORM IN!
Global Const WM_HORZRES = 8
Global Const WM_VERTRES = 10
Dim Width As Integer
Dim Factor As Single 'Used as multiplier for current size properties'
Declare Function WM_apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function WM_apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long
Declare Function WM_apiGetDC Lib "user32" Alias "GetDC" (ByVal hwnd As Long) As Long
Declare Function WM_apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function WM_apiGetSystemMetrics Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Function GetScreenResolution() As String
'returns the height and width
Dim DisplayHeight As Integer
Dim DisplayWidth As Integer
Dim hDesktopWnd As Long
Dim hDCcaps As Long
Dim iRtn As Integer

'API call get current resolution
hDesktopWnd = WM_apiGetDesktopWindow() 'get handle to desktop
hDCcaps = WM_apiGetDC(hDesktopWnd) 'get display context for desktop
DisplayHeight = WM_apiGetDeviceCaps(hDCcaps, WM_VERTRES)
DisplayWidth = WM_apiGetDeviceCaps(hDCcaps, WM_HORZRES)
iRtn = WM_apiReleaseDC(hDesktopWnd, hDCcaps) 'release display context
GetScreenResolution = DisplayWidth & "x" & DisplayHeight
Width = DisplayWidth
End Function
Public Sub ReSizeForm(frm As Form)
Dim ctl As Control
'Dim i As Integer

On Error Resume Next
SetFactor 'Call to procedure SetFactor
With frm
.Width = frm.Width * Factor
End With
For Each ctl In frm.Controls
With ctl
.Height = ctl.Height * Factor
.Left = ctl.Left * Factor
.Top = ctl.Top * Factor
.Width = ctl.Width * Factor
.FontSize = .FontSize * Factor
End With
Next ctl
End Sub
Sub SetFactor()
GetScreenResolution 'Call to function GetScreenResolution
Factor = Width / DesignResolutionX
End Sub
Go to the top of the page
 
skiss
post Apr 23 2003, 07:43 AM
Post#2



Posts: 2
Joined: 6-March 03



Some people have written me stating they have had trouble using this. Just call the public sub resizeform from the on load event on the form and it will work. After reviewing the code, I realized this was not in the author's comments and I have been using it so it was obvious to me, but not to others. My aplologies to everyone who has tried it and failed, but this should solve your problem.
Go to the top of the page
 
thebaul
post Jan 4 2019, 02:43 PM
Post#3



Posts: 183
Joined: 31-May 13



So what should I enter in the argument for resizeform. The form name I want to resize is "frmFeedback".
Go to the top of the page
 
isladogs
post Jan 4 2019, 03:51 PM
Post#4


UtterAccess VIP
Posts: 1,703
Joined: 4-June 18
From: Somerset, UK


The code above is only a small part of Jamie czernik's resizing code. You need the rest of the code

I use it in all my commercial apps and many free example apps.
For example https://www.access-programmers.co.UK/forums...ad.php?t=293584
Study that in conjunction with the following comments


To use in your own apps:
1. Import the entire module modResize

2. Design all forms with dimensions that would fill your screen in a low resolution such as 800*600 or similar
Typically I use approx. 20cm * 12.5cm .
All objects will then scale up when used in higher resolutions and on larger monitors
You also need to use smaller for sizes in design view e.g. 7pt which will scale up to about 11pt when resized

3. Add the line ResizeForm Me to the Form_Load event

That's it. Very easy once you've tried it.



--------------------
Go to the top of the page
 
AngelMiguel
post Jan 25 2019, 03:39 AM
Post#5



Posts: 6
Joined: 29-September 16



Hey...

ejemplo obsoleto....https://drive.google.com/file/d/17Ovt9ajqtsnsuziAvNnFfVRvLD-wJfbs/view?usp=sharing

clase..... clResizeObjects

Option Compare Database
Option Explicit

'*************************************************************
' Class module: clResizeObjects
' basado en una idea de
' https://stackoverflow.com/questions/1333794...tic-form-resize
' https://codereview.stackexchange.com/questi...orm-dynamically
' https://www.dreamincode.net/forums/topic/34...creen-size-vb6/
' https://docs.microsoft.com/en-us/office/VBA...s.accontroltype
'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
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)
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
This post has been edited by AngelMiguel: Jan 25 2019, 04:03 AM
Go to the top of the page
 


Custom Search


RSSSearch   Top   Lo-Fi    20th October 2019 - 08:53 AM