Prezado... eu retirei um modelo creio que do colega Dilson... e tem esse modulo nele..
nao fiz o teste no meu sistema, pois meu not onde esta o sistema pifou a tela...
mas fiz um teste usando um bd semelhante e parece que vai dar certo com esse codigo...
Olhe ai... e se puder me fale qual a melhor solucao... depois vou testar a sua e dou retorno aqui...
e com relacao ao assunto das imagens... mesmo que o sistema seja relativamente simples, creio que a melhor solucao sempre sera separar o front do back end, inclusive para a maior protecao dos registros, que ficam mais vulneraveis a erros quando estao juntos com a aplicacao...
Eu sempre trabalho com a BD separada do front.. isso separa os dados da aplicacao melhorando a performance e salvarguadando sobremaneira os registros... nao sei se pensa assim...
Option Compare Database
Option Explicit
Private Const DESIGN_HORZRES As Long = 1024
Private Const DESIGN_VERTRES As Long = 768
Private Const DESIGN_PIXELS As Long = 96
Private Const WM_HORZRES As Long = 8
Private Const WM_VERTRES As Long = 10
Private Const WM_LOGPIXELSX As Long = 88
Private Const TITLEBAR_PIXELS As Long = 18
Private Const COMMANDBAR_PIXELS As Long = 26
Private Const COMMANDBAR_LEFT As Long = 0
Private Const COMMANDBAR_TOP As Long = 1
Private OrigWindow As tWindow
Private Type tRect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type tDisplay
Height As Long
Width As Long
DPI As Long
End Type
Private Type tWindow
Height As Long
Width As Long
End Type
Private Type tControl
Name As String
Height As Long
Width As Long
Top As Long
Left As Long
End Type
Private Declare Function WM_apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function WM_apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" _
() As Long
Private Declare Function WM_apiGetDC Lib "user32" Alias "GetDC" _
(ByVal hWnd As Long) As Long
Private Declare Function WM_apiReleaseDC Lib "user32" Alias "ReleaseDC" _
(ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function WM_apiGetWindowRect Lib "user32.dll" Alias "GetWindowRect" _
(ByVal hWnd As Long, lpRect As tRect) As Long
Private Declare Function WM_apiMoveWindow Lib "user32.dll" Alias "MoveWindow" _
(ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function WM_apiIsZoomed Lib "user32.dll" Alias "IsZoomed" _
(ByVal hWnd As Long) As Long
Private Function getScreenResolution() As tDisplay
Dim hDCcaps As Long
Dim lngRtn As Long
On Error Resume Next
hDCcaps = WM_apiGetDC(0)
With getScreenResolution
.Height = WM_apiGetDeviceCaps(hDCcaps, WM_VERTRES)
.Width = WM_apiGetDeviceCaps(hDCcaps, WM_HORZRES)
.DPI = WM_apiGetDeviceCaps(hDCcaps, WM_LOGPIXELSX)
End With
lngRtn = WM_apiReleaseDC(0, hDCcaps)
End Function
Private Function getFactor(blnVert As Boolean) As Single
Dim sngFactorP As Single
On Error Resume Next
If getScreenResolution.DPI <> 0 Then
sngFactorP = DESIGN_PIXELS / getScreenResolution.DPI
Else
sngFactorP = 1
End If
If blnVert Then
getFactor = (getScreenResolution.Height / DESIGN_VERTRES) * sngFactorP
Else
getFactor = (getScreenResolution.Width / DESIGN_HORZRES) * sngFactorP
End If
End Function
Public Sub ReSizeForm(ByVal frm As Access.Form)
Dim rectWindow As tRect
Dim lngWidth As Long
Dim lngHeight As Long
Dim sngVertFactor As Single
Dim sngHorzFactor As Single
On Error Resume Next
sngVertFactor = getFactor(True)
sngHorzFactor = getFactor(False)
Resize sngVertFactor, sngHorzFactor, frm
If WM_apiIsZoomed(frm.hWnd) = 0 Then
Access.DoCmd.RunCommand acCmdAppMaximize
Call WM_apiGetWindowRect(frm.hWnd, rectWindow)
With rectWindow
lngWidth = .Right - .Left
lngHeight = .Bottom - .Top
End With
If frm.Parent.Name = VBA.vbNullString Then
Call WM_apiMoveWindow(frm.hWnd, ((getScreenResolution.Width - _
(sngHorzFactor * lngWidth)) / 2) - getLeftOffset, _
((getScreenResolution.Height - (sngVertFactor * lngHeight)) / 2) - _
getTopOffset, lngWidth * sngHorzFactor, lngHeight * sngVertFactor, 1)
End If
End If
Set frm = Nothing
End Sub
Private Sub Resize(sngVertFactor As Single, sngHorzFactor As Single, ByVal frm As Access.Form)
Dim ctl As Access.Control
Dim arrCtls() As tControl
Dim lngI As Long
Dim lngJ As Long
Dim lngWidth As Long
Dim lngHeaderHeight As Long
Dim lngDetailHeight As Long
Dim lngFooterHeight As Long
Dim blnHeaderVisible As Boolean
Dim blnDetailVisible As Boolean
Dim blnFooterVisible As Boolean
Const FORM_MAX As Long = 31680
On Error Resume Next
With frm
.Painting = False
lngWidth = .Width * sngHorzFactor
lngHeaderHeight = .Section(Access.acHeader).Height * sngVertFactor
lngDetailHeight = .Section(Access.acDetail).Height * sngVertFactor
lngFooterHeight = .Section(Access.acFooter).Height * sngVertFactor
.Width = FORM_MAX
.Section(Access.acHeader).Height = FORM_MAX
.Section(Access.acDetail).Height = FORM_MAX
.Section(Access.acFooter).Height = FORM_MAX
blnHeaderVisible = .Section(Access.acHeader).Visible
blnDetailVisible = .Section(Access.acDetail).Visible
blnFooterVisible = .Section(Access.acFooter).Visible
.Section(Access.acHeader).Visible = False
.Section(Access.acDetail).Visible = False
.Section(Access.acFooter).Visible = False
End With
ReDim arrCtls(0)
For Each ctl In frm.Controls
If ((ctl.ControlType = Access.acTabCtl) Or _
(ctl.ControlType = Access.acOptionGroup)) Then
With arrCtls(lngI)
.Name = ctl.Name
.Height = ctl.Height
.Width = ctl.Width
.Top = ctl.Top
.Left = ctl.Left
End With
lngI = lngI + 1
ReDim Preserve arrCtls(lngI)
End If
Next ctl
For Each ctl In frm.Controls
If ctl.ControlType <> Access.acPage Then
With ctl
.Height = .Height * sngVertFactor
.Left = .Left * sngHorzFactor
.Top = .Top * sngVertFactor
.Width = .Width * sngHorzFactor
.fontsize = .fontsize * sngVertFactor
Select Case .ControlType
Case Access.acListBox
.ColumnWidths = adjustColumnWidths(.ColumnWidths, sngHorzFactor)
Case Access.acComboBox
.ColumnWidths = adjustColumnWidths(.ColumnWidths, sngHorzFactor)
.ListWidth = .ListWidth * sngHorzFactor
Case Access.acTabCtl
.TabFixedWidth = .TabFixedWidth * sngHorzFactor
.TabFixedHeight = .TabFixedHeight * sngVertFactor
End Select
End With
End If
Next ctl
For lngJ = 0 To lngI
With frm.Controls.Item(arrCtls(lngJ).Name)
.Left = arrCtls(lngJ).Left * sngHorzFactor
.Top = arrCtls(lngJ).Top * sngVertFactor
.Height = arrCtls(lngJ).Height * sngVertFactor
.Width = arrCtls(lngJ).Width * sngHorzFactor
End With
Next lngJ
With frm
.Width = lngWidth
.Section(Access.acHeader).Height = lngHeaderHeight
.Section(Access.acDetail).Height = lngDetailHeight
.Section(Access.acFooter).Height = lngFooterHeight
.Section(Access.acHeader).Visible = blnHeaderVisible
.Section(Access.acDetail).Visible = blnDetailVisible
.Section(Access.acFooter).Visible = blnFooterVisible
.Painting = True
End With
Erase arrCtls
Set ctl = Nothing
End Sub
Private Function getTopOffset() As Long
Dim cmdBar As Object
Dim lngI As Long
On Error GoTo err
For Each cmdBar In Application.CommandBars
If ((cmdBar.Visible = True) And (cmdBar.position = COMMANDBAR_TOP)) Then
lngI = lngI + 1
End If
Next cmdBar
getTopOffset = (TITLEBAR_PIXELS + (lngI * COMMANDBAR_PIXELS))
exit_fun:
Exit Function
err:
getTopOffset = TITLEBAR_PIXELS + COMMANDBAR_PIXELS
Resume exit_fun
End Function
Private Function getLeftOffset() As Long
Dim cmdBar As Object
Dim lngI As Long
On Error GoTo err
For Each cmdBar In Application.CommandBars
If ((cmdBar.Visible = True) And (cmdBar.position = COMMANDBAR_LEFT)) Then
lngI = lngI + 1
End If
Next cmdBar
getLeftOffset = (lngI * COMMANDBAR_PIXELS)
exit_fun:
Exit Function
err:
getLeftOffset = 0
Resume exit_fun
End Function
Private Function adjustColumnWidths(strColumnWidths As String, sngFactor As Single) _
As String
Dim astrColumnWidths() As String
Dim strTemp As String
Dim lngI As Long
Dim lngJ As Long
ReDim astrColumnWidths(0)
For lngI = 1 To VBA.Len(strColumnWidths)
Select Case VBA.Mid(strColumnWidths, lngI, 1)
Case Is <> ";"
astrColumnWidths(lngJ) = astrColumnWidths(lngJ) & VBA.Mid( _
strColumnWidths, lngI, 1)
Case ";"
lngJ = lngJ + 1
ReDim Preserve astrColumnWidths(lngJ)
End Select
Next lngI
lngI = 0
Do Until lngI > UBound(astrColumnWidths)
strTemp = strTemp & CSng(astrColumnWidths(lngI)) * sngFactor & ";"
lngI = lngI + 1
Loop
adjustColumnWidths = strTemp
Erase astrColumnWidths
End Function
Public Sub getOrigWindow(frm As Access.Form)
On Error Resume Next
OrigWindow.Height = frm.WindowHeight
OrigWindow.Width = frm.WindowWidth
End Sub
Public Sub RestoreWindow()
On Error Resume Next
Access.DoCmd.MoveSize , , OrigWindow.Width, OrigWindow.Height
Access.DoCmd.Save
End Sub
Início
![[Resolvido]Ribbon ou menu tradicional 2003, qual melhor para resolução Empty](https://2img.net/i/empty.gif)
Convidado 23/4/2011, 17:58
