MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

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

    Compartilhe

    RafaelaAbra17
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Feminino
    Localização : Brasil
    Mensagens : 1
    Registrado : 09/06/2017

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

    Mensagem  RafaelaAbra17 em 9/6/2017, 23:26


    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


      Data/hora atual: 21/10/2018, 11:41