Identificando a resolução atual ! Criação JPaulo

Olá a todos,

Abro esse tópico mais na intenção de conseguir uma resposta do JPaulo que é o criador desse Código abaixo.
Ocorre que ao pesquisar sobre como identificar a resolução d atela atual, eu encontrei um tópico e até um exemplo disponibilizado pelo JPaulo aqui para que isso fosse possível, acontece que ao aplicar no meu projeto eu testei e esta acontecendo de na hora de abrir o formulário em algumas resoluções a identificação é totalmente contraria da que realmente estou usando.

Digamos assim, se eu estiver usando uma resolução 1920 x 1080 ele reconhece e me informa numa caixa de texto dentro de um formulário essa mesma resolução, agora se eu estiver usando uma resolução 1366x768 ao inves de ele me informar essa resolução que é a que estou usando na hora do teste, ele me apresenta essa resolução aqui 1708 x 960.

Como pode isso gente ? Se a resolução usada é a 1366x768 como pode ser identificada uma resolução 1708x960 ? sendo que essa resolução nem está na lista do meu monitor?

Gostaria de uma ajuda ai de vcs para descobrir o porque disso.

Segue a lista de resoluções que o código identifica e apresenta as respostas:

resolução atual identificada pelo código
1024x768 1280x960
1280x768 1600x960
1920x1080 1920x1080 a unica que identifica como certa

Testei o código no windows 8.1 32bits
Access 2013

Segue os códigos utilizados em 3 modulos e no form



modulo 1
Option Compare Database
Option Explicit
'Muda a resolução da tela
'Para chamar
'Call ChangeRes(800, 600)
'Call ChangeRes(640, 480)
'Call ChangeRes(1024, 768)

Private Declare Function EnumDisplaySettings Lib "User32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean

Private Declare Function ChangeDisplaySettings Lib "User32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000

Private Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

Dim DevM As DEVMODE
Sub ChangeRes(iWidth As Single, iHeight As Single)
Dim a As Boolean, i&
i = 0
Do
a = EnumDisplaySettings(0&, i&, DevM)
i = i + 1
Loop Until (a = False)
Dim b&
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
DevM.dmPelsWidth = iWidth
DevM.dmPelsHeight = iHeight
b = ChangeDisplaySettings(DevM, 0)
End Sub


modulo 2

Option Compare Database
Option Explicit

Declare Function ShowWindow Lib "User32" (ByVal Hwnd As Long, ByVal nCmdShow As Long) As Long
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Function GetWindowRect Lib "User32" (ByVal Hwnd As Long, rectangle As RECT) As Long
Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMAXIMIZED = 3
Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
Declare Sub SetWindowPos Lib "User32" (ByVal Hwnd&, ByVal hWndInsertAfter&, ByVal X&, ByVal Y&, ByVal cX&, ByVal cY&, ByVal wFlags&)
Public Const HWND_TOP = 0 'Move janela do Access para o topo de Z-order.
'Valores para wFlags.
Public Const SWP_NOZORDER = &H4 'Ignora hWndInsertAfter.

Function MaximizeAccess()
Dim Maxit%
Maxit% = ShowWindow(hWndAccessApp, SW_SHOWMAXIMIZED)
End Function

Function RestoreAccess()
Dim Restoreit%
Restoreit% = ShowWindow(hWndAccessApp, SW_SHOWNORMAL)
End Function

Function GetScreenResolution() As String
Dim R As RECT, Hwnd As Long, RetVal As Long
Hwnd = GetDesktopWindow()
RetVal = GetWindowRect(Hwnd, R)
GetScreenResolution = (R.x2 - R.x1) & "x" & (R.y2 - R.y1)
End Function

Function SizeAccess()
Dim cX As Long, cY As Long, cHeight As Long
Dim cWidth As Long, h As Long
'pega "handle" para o Access.
h = Application.hWndAccessApp
cX = 80: cY = 80: cWidth = 640: cHeight = 480
'Posiciona Access.
SetWindowPos h, HWND_TOP, cX, cY, cWidth, cHeight, SWP_NOZORDER
End Function

Public Sub PosicionaAplicativo()

If GetScreenResolution = "800x600" Or GetScreenResolution = "1920x1080" Then
RestoreAccess
Dim lngSize As Long
lngSize = SizeAccess
Else
MaximizeAccess
End If

End Sub

Function Muda()
'altera as prop dos form
Call Application.Run("FormPadrao.cFormPadrao", "fResolução")
End Function


modulo 3

Option Compare Database
Option Explicit

'Constantes para identificar os diversos tipos de ponteiro do mouse
Public Const IDC_APPSTARTING = 32650&
Public Const IDC_HAND = 32649&
Public Const IDC_ARROW = 32512&
Public Const IDC_CROSS = 32515&
Public Const IDC_IBEAM = 32513&
Public Const IDC_ICON = 32641&
Public Const IDC_NO = 32648&
Public Const IDC_SIZE = 32640&
Public Const IDC_SIZEALL = 32646&
Public Const IDC_SIZENESW = 32643&
Public Const IDC_SIZENS = 32645&
Public Const IDC_SIZENWSE = 32642&
Public Const IDC_SIZEWE = 32644&
Public Const IDC_UPARROW = 32516&
Public Const IDC_WAIT = 32514&

Declare Function LoadCursorBynum Lib "User32" Alias "LoadCursorA" _
(ByVal hInstance As Long, ByVal lpCursorName As Long) As Long

Declare Function SetCursor Lib "User32" _
(ByVal hCursor As Long) As Long

Function MouseCursor(CursorType As Long)
Dim lngRet As Long
lngRet = LoadCursorBynum(0&, CursorType)
lngRet = SetCursor(lngRet)
End Function

'No evento Ao mover mouse da caixa de texto, digite:
'=MouseCursor(32649) => altera para formato de mão



Formulário

Option Compare Database
Option Explicit
Private Sub Comando0_Click()
Dim h As Single, l As Single
Dim pos As Integer
If Me.combR.ListIndex = -1 Then
MsgBox "Selecione um item", , "Atenção"
Exit Sub
End If
If GetScreenResolution <> Me.combR Then
pos = InStr(1, Me.combR, ",", vbBinaryCompare)
h = Left(Me.combR, pos - 1)
l = Mid(Me.combR, pos + 1, Len(Me.combR))
Call ChangeRes(h, l)
Call Form_Load
End If
End Sub
Private Sub Comando0_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call MouseCursor(32649&)
End Sub
Private Sub Comando5_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call MouseCursor(32649&)
End Sub
Private Sub Form_Load()
Me.Texto1 = GetScreenResolution
Me.Texto15 = GetScreenResolution
End Sub
Private Sub Comando5_Click()
On Error GoTo Err_Comando5_Click

DoCmd.Close

Exit_Comando5_Click:
Exit Sub

Err_Comando5_Click:
MsgBox Err.Description
Resume Exit_Comando5_Click

End Sub
Private Sub Form_Open(Cancel As Integer)
On Error GoTo Form_Open_Err

DoCmd.MoveSize 3232, 3969, 5670, 2297

Form_Open_Exit:
Exit Sub

Form_Open_Err:
MsgBox Error$
Resume Form_Open_Exit

End Sub
Private Sub combR_AfterUpdate()
On Error GoTo combR_AfterUpdate_Err

DoCmd.SelectObject acForm, "frmMudaResolução", False
DoCmd.GoToControl "Comando0"

combR_AfterUpdate_Exit:
Exit Sub

combR_AfterUpdate_Err:
MsgBox Error$
Resume combR_AfterUpdate_Exit

End Sub



Rafaela Abrão