Boa noite!!

Leia:
http://www.vbaexpress.com/kb/getarticle.php?kb_id=32

Tente também:...Não testado!!!

Option Explicit
Private Declare Function GetSystemMetrics Lib _
"User32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1

Public Function ScreenHeight() As Long
ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
End Function

Public Function ScreenWidth() As Long
ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function

Att

Alexandre, boa noite! 23/07/2014 20:15

Gostei muito do exemplo apresentado no link sugestionado por você, mas, afim de atender a minha necessidade,eu fiz algumas adaptações nele, veja abaixo:

Private Sub UserForm_Initialize()

Call VerifyScreenResolution

end

sub

Sub VerifyScreenResolution(Optional Dummy As Integer)

Dim x As Long
Dim y As Long
Dim MyMessage As String
Dim MyResponse As VbMsgBoxResult

x = GetSystemMetrics(SM_CXSCREEN)
y = GetSystemMetrics(SM_CYSCREEN)
If x >= 1280 And y >= 1024 Then

Exit Sub

End If

If x < 1280 And y < 1024 Then

MyMessage = "Sua resolução de tela atual é " & x & " X " & y & vbCrLf & "O Sistema Lorenzon Despesas Pessoais " & _
"foi desenvolvido para ser executado com uma resolução de tela de, no mínimo, 1024 X 768 e pode não funcionar corretamente " & _
"com as configurações atuais." & vbCrLf & "Gostaria de mudar a resolução da tela?"
MyResponse = MsgBox(MyMessage, vbExclamation + vbYesNo, "Resolução de tela")
End If
If MyResponse = vbYes Then

Call ChangeRes(1280, 720)

End If

End Sub

Observações:

Além de ter traduzido a mensagem, eu modifiquei os IF's. O meu projeto, para obter uma ótima apresentação das suas uferms, listview e demais comandos, a resolução do Windows precisa estar, no mínimo, em 1280 x 1024 e, por este motivo, eu coloquei esta condição:

If x < 1280 And y < 1024 Then e, se de fato for menor, ele fará a seguinte pergunta:

MyMessage = "Sua resolução de tela atual é " & x & " X " & y & vbCrLf & "O Sistema Lorenzon Despesas Pessoais " & _
"foi desenvolvido para ser executado com uma resolução de tela de, no mínimo, 1024 X 768 e pode não funcionar corretamente " & _
"com as configurações atuais." & vbCrLf & "Gostaria de mudar a resolução da tela?"
MyResponse = MsgBox(MyMessage, vbExclamation + vbYesNo, "Resolução de tela")
End If
If MyResponse = vbYes Then

Call ChangeRes(1280, 1024)
'este código é o que eu já utilizava.

End If

End Sub

Até ai tudo bem, ficou show! Mas o que acontece é que, caso o computador estiver com a resolução menor a de 1280 x 1024 e não tiver esta resolução disponível, o código não consegue alterar a resolução do computador e executa a userform com a resolução que ele já estiver, fazendo com que o projeto fica mal apresentado.

Para evitar isso, quero que, nestes casos, o código verifique se o computador possui resoluções de telas que sejam maiores que a necessária e, se não houver, o usuário receba um mensagem informado-o que não será possível executar o projeto, pois o computador não atende os requisitos necessários.

Como farei isto?

Creio que a utilização de umas CASE's resolva, mas não obtive exito!

=/

fiz uma pequena alteração.. já ajudou muito!

Sub VerifyScreenResolution(Optional Dummy As Integer)

Dim x As Long
Dim y As Long
Dim MyMessage As String
Dim MyResponse As VbMsgBoxResult

x = GetSystemMetrics(SM_CXSCREEN)
y = GetSystemMetrics(SM_CYSCREEN)
If x >= 1280 And y >= 768 Then

Exit Sub

End If

Call ChangeRes(1280, 768)

Call ChangeRes(1280, 1024)

End Sub

Veja se esta rotina ajuda, ela não altera a Resolução e sim o Zoom da Janela:

Fonte: VBA : Screen resolution
http://www.ozgrid.com/forum/showthread.php?t=19051

Option Explicit
Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
'' NOTE: The following declare statements are case sensitive.
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, rectangle As RECT) As Long

'' FUNCTION: GetScreenResolution()
'' PURPOSE:
'' To determine the current screen size or resolution.
'' 1024 x 768
Private Function GetScreenResolution() As String
Dim r As RECT
Dim hWnd As Long
Dim RetVal As Long
hWnd = GetDesktopWindow()
RetVal = GetWindowRect(hWnd, r)
GetScreenResolution = (r.x2 - r.x1) & " X " & (r.y2 - r.y1)
End Function


Sub ScreenSize()
Dim ScreenZoom As Integer
Dim ScreenDimension As String
Dim resp As Integer
Dim fixme As Boolean


ScreenZoom = 100
ScreenDimension = GetScreenResolution()
Select Case ScreenDimension
Case "1920 X 1080"
ScreenZoom = 110
Case "1680 X 1050"
ScreenZoom = 120
Case "1440 X 900"
ScreenZoom = 100
Case "1280 X 1040"
ScreenZoom = 91
Case "1280 X 1024"
ScreenZoom = 90
Case "1280 X 960"
ScreenZoom = 90
Case "1280 X 800"
ScreenZoom = 90
Case "1280 X 720"
ScreenZoom = 83
Case "1152 X 864"
ScreenZoom = 83
Case "1024 X 768"
ScreenZoom = 75
Case "800 X 600"
ScreenZoom = 58
Case Else
ScreenZoom = 50
End Select

ActiveWindow.Zoom = ScreenZoom

End Sub