COMO AJUSTAR O TAMANHO DO FORM DE ACORDO COM A RES
Oi pessoal eu queria saber como eu faço pra ajustar o tamanho do do form e seus controles de acordo com a resolução de video. Ex. Fiz um programa, utilizando a resolução 1024x768, só que qdo eu rodo ele em outro computador com uma resolução menor os controles não aparecem.
Public Const GWL_WNDPROC = (-4)
Public Const WM_DISPLAYCHANGE = &H7E
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
Public Const DISP_CHANGE_FAILED = -1
Public Const DISP_CHANGE_BADMODE = -2
Public Const DISP_CHANGE_NOTUPDATED = -3
Public Const DISP_CHANGE_BADFLAGS = -4
Public Const DISP_CHANGE_BADPARAM = -5
Public Const CDS_UPDATEREGISTRY = 1
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSHEIGHT = &H100000
Public Const DM_PELSWIDTH = &H80000
Public Type DevMode
dmDeviceName As String * 32
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 * 32
dmLogPixels As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long Rem Windows 95 only
dmICMIntent As Long Rem Windows 95 only
dmMediaType As Long Rem Windows 95 only
dmDitherType As Long Rem Windows 95 only
dmICCManufacturer As Long Rem Windows 95 only
dmICCModel As Long Rem Windows 95 only
dmPanningWidth As Long Rem Windows 95 only
dmPanningHeight As Long Rem Windows 95 only
End Type
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As DevMode, ByVal dwFlags As Long) As Long
Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DevMode) As Long
Rem ----------------------------------------------------------
Rem Procedure For Enum the supported resolutions
Rem ----------------------------------------------------------
Private Sub EnumRes()
Dim utDevMode As DevMode, fEnd As Boolean
Dim sDeviceName As String, iMode As Long
Dim oItem As New ListItem
utDevMode.dmSize = Len(utDevMode)
iMode = 0
Do
fEnd = EnumDisplaySettings(sDeviceName, iMode, utDevMode)
Rem Do sth With the utDevMode structure
Rem The fields dmPelsWidth, dmPelsHeight, dmBitsPerPel are most useful
iMode = iMode + 1
Loop Until Not fEnd
End Sub
Rem ----------------------------------------------------------
Rem Code For changing display resolution
Rem ----------------------------------------------------------
Private Sub ChangeIt(lPelsWidth As Long, lPelsHeight As Long, lBitsPerPel As Long)
Dim utDevMode As DevMode
Dim iRes As Long
Dim sMsg As String
Dim oItem As ListItem
If lvSettings.SelectedItem Is Nothing Then Exit Sub
With utDevMode
.dmSize = Len(utDevMode)
.dmPelsWidth = lPelsWidth
.dmPelsHeight = lPelsHeight
.dmBitsPerPel = lBitsPerPel
.dmFields = DM_BITSPERPEL Or DM_PELSHEIGHT Or DM_PELSWIDTH
End With
iRes = ChangeDisplaySettings(utDevMode, CDS_UPDATEREGISTRY)
Select Case iRes
Case Is = DISP_CHANGE_SUCCESSFUL
sMsg = "Display setting has been changed successfully."
Case Is = DISP_CHANGE_RESTART
sMsg = "You have to restart your computer in order to carry out the new setting."
Case Is = DISP_CHANGE_FAILED
sMsg = "Sorry, failed to change the display setting."
End Select
If sMsg <> vbNullString Then MsgBox sMsg, , "Display"
End Sub
Rem ----------------------------------------------------------
Rem To detect the change notification of display resolution
Rem from Windows, Put the code below into a module, except
Rem Hook & Unhook In a form.
Rem To begin To capture the notification, Call Hook
Rem To End capturing the notification, Call Unhook
Rem ----------------------------------------------------------
Public lPreWndProc As Long
Public Type TLoHiLong
lo As Integer
hi As Integer
End Type
Public Type TAllLong
all As Long
End Type
Rem ----------------------------------------------------------
Rem Procedure For Subclassing
Rem ----------------------------------------------------------
Public Function MyWndProc (ByVal hwnd As Long, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsg = WM_DISPLAYCHANGE Then
Debug.Print "DisplayChange"
Debug.Print "BitsPerPel: ", wParam
Debug.Print "lParam: ", lParam
Debug.Print "loword of lParam: ", LoWord(lParam)
Debug.Print "HiWord of lParam: ", HiWord(lParam)
End If
MyWndProc = CallWindowProc(lPreWndProc, hwnd, lMsg, wParam, lParam)
End Function
Public Function LoWord(dw As Long) As Integer
Dim lohi As TLoHiLong
Dim all As TAllLong
all.all = dw
LSet lohi = all
LoWord = lohi.lo
End Function
Public Function HiWord(dw As Long) As Integer
Dim lohi As TLoHiLong
Dim all As TAllLong
all.all = dw
LSet lohi = all
HiWord = lohi.hi
End Function
Rem ----------------------------------------------------------
Rem Code For Subclassing
Rem ----------------------------------------------------------
Private Sub Hook()
lPreWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf MyWndProc)
End Sub
Private Sub Unhook()
Call SetWindowLong(Me.hwnd, GWL_WNDPROC, lPreWndProc)
End Sub
Espero ter ajudado
Créditos a Celso Capella
Public Const WM_DISPLAYCHANGE = &H7E
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
Public Const DISP_CHANGE_FAILED = -1
Public Const DISP_CHANGE_BADMODE = -2
Public Const DISP_CHANGE_NOTUPDATED = -3
Public Const DISP_CHANGE_BADFLAGS = -4
Public Const DISP_CHANGE_BADPARAM = -5
Public Const CDS_UPDATEREGISTRY = 1
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSHEIGHT = &H100000
Public Const DM_PELSWIDTH = &H80000
Public Type DevMode
dmDeviceName As String * 32
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 * 32
dmLogPixels As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long Rem Windows 95 only
dmICMIntent As Long Rem Windows 95 only
dmMediaType As Long Rem Windows 95 only
dmDitherType As Long Rem Windows 95 only
dmICCManufacturer As Long Rem Windows 95 only
dmICCModel As Long Rem Windows 95 only
dmPanningWidth As Long Rem Windows 95 only
dmPanningHeight As Long Rem Windows 95 only
End Type
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As DevMode, ByVal dwFlags As Long) As Long
Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DevMode) As Long
Rem ----------------------------------------------------------
Rem Procedure For Enum the supported resolutions
Rem ----------------------------------------------------------
Private Sub EnumRes()
Dim utDevMode As DevMode, fEnd As Boolean
Dim sDeviceName As String, iMode As Long
Dim oItem As New ListItem
utDevMode.dmSize = Len(utDevMode)
iMode = 0
Do
fEnd = EnumDisplaySettings(sDeviceName, iMode, utDevMode)
Rem Do sth With the utDevMode structure
Rem The fields dmPelsWidth, dmPelsHeight, dmBitsPerPel are most useful
iMode = iMode + 1
Loop Until Not fEnd
End Sub
Rem ----------------------------------------------------------
Rem Code For changing display resolution
Rem ----------------------------------------------------------
Private Sub ChangeIt(lPelsWidth As Long, lPelsHeight As Long, lBitsPerPel As Long)
Dim utDevMode As DevMode
Dim iRes As Long
Dim sMsg As String
Dim oItem As ListItem
If lvSettings.SelectedItem Is Nothing Then Exit Sub
With utDevMode
.dmSize = Len(utDevMode)
.dmPelsWidth = lPelsWidth
.dmPelsHeight = lPelsHeight
.dmBitsPerPel = lBitsPerPel
.dmFields = DM_BITSPERPEL Or DM_PELSHEIGHT Or DM_PELSWIDTH
End With
iRes = ChangeDisplaySettings(utDevMode, CDS_UPDATEREGISTRY)
Select Case iRes
Case Is = DISP_CHANGE_SUCCESSFUL
sMsg = "Display setting has been changed successfully."
Case Is = DISP_CHANGE_RESTART
sMsg = "You have to restart your computer in order to carry out the new setting."
Case Is = DISP_CHANGE_FAILED
sMsg = "Sorry, failed to change the display setting."
End Select
If sMsg <> vbNullString Then MsgBox sMsg, , "Display"
End Sub
Rem ----------------------------------------------------------
Rem To detect the change notification of display resolution
Rem from Windows, Put the code below into a module, except
Rem Hook & Unhook In a form.
Rem To begin To capture the notification, Call Hook
Rem To End capturing the notification, Call Unhook
Rem ----------------------------------------------------------
Public lPreWndProc As Long
Public Type TLoHiLong
lo As Integer
hi As Integer
End Type
Public Type TAllLong
all As Long
End Type
Rem ----------------------------------------------------------
Rem Procedure For Subclassing
Rem ----------------------------------------------------------
Public Function MyWndProc (ByVal hwnd As Long, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsg = WM_DISPLAYCHANGE Then
Debug.Print "DisplayChange"
Debug.Print "BitsPerPel: ", wParam
Debug.Print "lParam: ", lParam
Debug.Print "loword of lParam: ", LoWord(lParam)
Debug.Print "HiWord of lParam: ", HiWord(lParam)
End If
MyWndProc = CallWindowProc(lPreWndProc, hwnd, lMsg, wParam, lParam)
End Function
Public Function LoWord(dw As Long) As Integer
Dim lohi As TLoHiLong
Dim all As TAllLong
all.all = dw
LSet lohi = all
LoWord = lohi.lo
End Function
Public Function HiWord(dw As Long) As Integer
Dim lohi As TLoHiLong
Dim all As TAllLong
all.all = dw
LSet lohi = all
HiWord = lohi.hi
End Function
Rem ----------------------------------------------------------
Rem Code For Subclassing
Rem ----------------------------------------------------------
Private Sub Hook()
lPreWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf MyWndProc)
End Sub
Private Sub Unhook()
Call SetWindowLong(Me.hwnd, GWL_WNDPROC, lPreWndProc)
End Sub
Espero ter ajudado
Créditos a Celso Capella
Tente isto:
Public Sub MudaResolucao()
Dim t As Boolean
Dim s As Boolean
Dim r As RECT
t = True
s = True
' Neste ponto coloque a resolução que você deseja para seu programa. Se ele for diferente, ele vai chamar a rotina para alterar...
ResX = 800
ResY = 600
Call GetClipCursor(r)
OldX = r.Right
OldY = r.Bottom
If test = False Then
'Vai testar agora se a resolução está correta ou se precisa ser alterada
If OldX <> ResX And OldY <> ResY Then
troq = MsgBox("Este programa está otimizado para computadores com resolução de vÃdeo de " & ResX & " X " & ResY & "." & vbNewLine & "Talvez não seja possÃvel alterá-lo. Quer tentar alterar as resoluções agora?", vbQuestion + vbYesNo, "NeoSoft - Aviso de resolução")
test = True
If troq = vbYes Then
resolucao = True
Call ChangeRes(ResX, ResY)
Else
resolucao = False
End If
Else
resolucao = False
End If
End If
End Sub
Falou!
Public Sub MudaResolucao()
Dim t As Boolean
Dim s As Boolean
Dim r As RECT
t = True
s = True
' Neste ponto coloque a resolução que você deseja para seu programa. Se ele for diferente, ele vai chamar a rotina para alterar...
ResX = 800
ResY = 600
Call GetClipCursor(r)
OldX = r.Right
OldY = r.Bottom
If test = False Then
'Vai testar agora se a resolução está correta ou se precisa ser alterada
If OldX <> ResX And OldY <> ResY Then
troq = MsgBox("Este programa está otimizado para computadores com resolução de vÃdeo de " & ResX & " X " & ResY & "." & vbNewLine & "Talvez não seja possÃvel alterá-lo. Quer tentar alterar as resoluções agora?", vbQuestion + vbYesNo, "NeoSoft - Aviso de resolução")
test = True
If troq = vbYes Then
resolucao = True
Call ChangeRes(ResX, ResY)
Else
resolucao = False
End If
Else
resolucao = False
End If
End If
End Sub
Falou!
Tópico encerrado , respostas não são mais permitidas