[Access] Risoluzione Schermo

Question

Salve a tutti,

in access 2003 ho la necesstià di modificare la risoluzione dello schermo attraverso codice Vba, all'apertura di un database e riprisrtinarla alla  la chiusura.

Ringrazio anticipatamente chi mi volesse aiutare.

Answer 1

Ciao Cinzia,

Grazie mille per l'aiuto.

Leggo sempre i consigli che dai,  devo proprio dire che sei  in gamba.

Ciao alla prossima

Answer 2

Ciao Claudio,

vedi se questo link http://www.freevbcode.com/ShowCode.asp?ID=4187  può esserti utile.

---

Cinzia

---

Sito RIO

Il mio Blog

Answer 3

Ciao Cinzia

L'altro codice l'ho copiato in un modulo di classe ma mi continua a dare sempre lo stesso errore.

Grazie 

Li riassumo:

Nella maschera**********************************************************

Private Sub Form_Load()

    'KPD-Team 1999

    'URL: http://www.allapi.net/

    'E-Mail: ******@Allapi.net

    Dim nDC As Long

    Dim sMyString As String

    Dim bReturn As Boolean

    Dim bFound As Boolean

    Dim lX As Long

    Dim iY As Integer       'resrved for the ordinal ubound of apossible

    Dim iz As Integer

    Dim DevM As DEVMODE

    sMyString = "The current list" + vbCrLf + vbCrLf

    sMyString = sMyString + "Screen Width:" + Str(Screen.width) + vbCrLf

    sMyString = sMyString + "Screen Height:" + Str(Screen.height) + vbCrLf

    sMyString = sMyString + "Screen TwipsPerPixelX:" + Str(Screen.TwipsPerPixelX) + vbCrLf

    sMyString = sMyString + "Screen TwipsPerPixelY:" + Str(Screen.TwipsPerPixelY) + vbCrLf

    'retrieve the screen's resolution

    OldX = Screen.width / Screen.TwipsPerPixelX

    OldY = Screen.height / Screen.TwipsPerPixelY

    sMyString = sMyString + "X resolution:" + Str(OldX) + vbCrLf

    sMyString = sMyString + "Y resolution:" + Str(OldY) + vbCrLf

'   MsgBox sMyString

'   Text2.Text = Trim$(Str(OldX))

'   Text3.Text = Trim$(Str(OldY))

    ReDim aPossible(1)

    aPossible(0) = Trim$(Str$(OldX)) + " x " + Trim$(Str$(OldY))

    Text4.Text = aPossible(0)

'   MsgBox aPossible(0)

    sMyString = ""

    lX = 0

    iY = 0

    'Create a device context, compatible with the screen

    nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)

    bReturn = True

    While bReturn

            bReturn = EnumDisplaySettings(0&, lX, DevM)

            If bReturn Then     'ie. a valid entry

'               sMyString = sMyString + Trim$(Str$(DevM.dmBitsPerPel)) + ":" + Trim$(Str$(DevM.dmPelsWidth)) + ":" + Trim$(Str$(DevM.dmPelsHeight)) + ":" + Str(lX) + vbCrLf

                sMyString = Trim$(Str$(DevM.dmPelsWidth)) + " x " + Trim$(Str$(DevM.dmPelsHeight))

                bFound = False

                For iz = 0 To iY

                    If sMyString = aPossible(iz) Then

                        bFound = True

                        Exit For

                    End If

                Next

                If Not bFound Then

                    iY = iY + 1

                    ReDim Preserve aPossible(iY)

                    aPossible(iY) = sMyString

                End If

                lX = lX + 1 'Dont forget this

            End If

    Wend

    sMyString = ""

    For iz = 1 To iY

        List1.AddItem aPossible(iz)

    Next

'   MsgBox sMyString

    'Change the screen's resolution

'   ChangeRes 640, 480, GetDeviceCaps(nDC, BITSPIXEL)

'    Unload Me

End Sub

Nel modulo*****************************************************************************************

Option Explicit

Const WM_DISPLAYCHANGE = &H7E

Const HWND_BROADCAST = &HFFFF&

Const EWX_LOGOFF = 0

Const EWX_SHUTDOWN = 1

Const EWX_REBOOT = 2

Const EWX_FORCE = 4

Const CCDEVICENAME = 32

Const CCFORMNAME = 32

Const DM_BITSPERPEL = &H40000

Const DM_PELSWIDTH = &H80000

Const DM_PELSHEIGHT = &H100000

Const CDS_UPDATEREGISTRY = &H1

Const CDS_TEST = &H4

Const DISP_CHANGE_SUCCESSFUL = 0

Const DISP_CHANGE_RESTART = 1

Const BITSPIXEL = 12

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

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

Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Dim OldX As Long, OldY As Long, nDC As Long

Dim OldXY As String

Public aPossible

Answer 4

Ciao Christian,

nella pagina del link  che avevo postato, sopra alla finestra con il codice che tu hai inserito nella tua maschera, c'è un'altra finestra con dell'altro codice, deve copiare anche quella!

Answer 5

Ciao Claudio,

vedi se questo link http://www.freevbcode.com/ShowCode.asp?ID=4187  può esserti utile.

---

Cinzia

---

Sito RIO

Il mio Blog

Ciao Cinzia

E da tempo che cerco di risolvere il problema risoluzione , ho letto il tuo consiglio e l'ho applicato al mio DB. Il problema che quando apro la maschera mi da errore e il codice si ferma in questa posizione.

Mi potresti dare una mano grazie.

Dim DevM As DEVMODE

Private Sub Form_Load()

    'KPD-Team 1999

    'URL: http://www.allapi.net/

    'E-Mail: ******@Allapi.net

    Dim nDC As Long

    Dim sMyString As String

    Dim bReturn As Boolean

    Dim bFound As Boolean

    Dim lX As Long

    Dim iY As Integer       'resrved for the ordinal ubound of apossible

    Dim iz As Integer

    Dim DevM As DEVMODE    'Si blocca qui

    sMyString = "The current list" + vbCrLf + vbCrLf

    sMyString = sMyString + "Screen Width:" + Str(Screen.width) + vbCrLf

    sMyString = sMyString + "Screen Height:" + Str(Screen.height) + vbCrLf

    sMyString = sMyString + "Screen TwipsPerPixelX:" + Str(Screen.TwipsPerPixelX) + vbCrLf

    sMyString = sMyString + "Screen TwipsPerPixelY:" + Str(Screen.TwipsPerPixelY) + vbCrLf

    'retrieve the screen's resolution

    OldX = Screen.width / Screen.TwipsPerPixelX

    OldY = Screen.height / Screen.TwipsPerPixelY

    sMyString = sMyString + "X resolution:" + Str(OldX) + vbCrLf

    sMyString = sMyString + "Y resolution:" + Str(OldY) + vbCrLf

'   MsgBox sMyString

'   Text2.Text = Trim$(Str(OldX))

'   Text3.Text = Trim$(Str(OldY))

    ReDim aPossible(1)

    aPossible(0) = Trim$(Str$(OldX)) + " x " + Trim$(Str$(OldY))

    Text4.Text = aPossible(0)

'   MsgBox aPossible(0)

    sMyString = ""

    lX = 0

    iY = 0

    'Create a device context, compatible with the screen

    nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)

    bReturn = True

    While bReturn

            bReturn = EnumDisplaySettings(0&, lX, DevM)

            If bReturn Then     'ie. a valid entry

'               sMyString = sMyString + Trim$(Str$(DevM.dmBitsPerPel)) + ":" + Trim$(Str$(DevM.dmPelsWidth)) + ":" + Trim$(Str$(DevM.dmPelsHeight)) + ":" + Str(lX) + vbCrLf

                sMyString = Trim$(Str$(DevM.dmPelsWidth)) + " x " + Trim$(Str$(DevM.dmPelsHeight))

                bFound = False

                For iz = 0 To iY

                    If sMyString = aPossible(iz) Then

                        bFound = True

                        Exit For

                    End If

                Next

                If Not bFound Then

                    iY = iY + 1

                    ReDim Preserve aPossible(iY)

                    aPossible(iY) = sMyString

                End If

                lX = lX + 1 'Dont forget this

            End If

    Wend

    sMyString = ""

    For iz = 1 To iY

        List1.AddItem aPossible(iz)

    Next

'   MsgBox sMyString

    'Change the screen's resolution

'   ChangeRes 640, 480, GetDeviceCaps(nDC, BITSPIXEL)

'    Unload Me

End Sub