Set Extended Desktop in VBA

See more:

VBA

Can somebody help me out the codes below to set Extended Desktop in VBA?

I downloaded these codes from internet. I have also download some example from The Code Project - they are VB, C++ or C#. They all works fine with my dual monitors. However, when I tried to put into VBA, it doesn't work.

the codes (SetExtDeskTop) below, the ChangeDisplaySettingsEx returns successful result (0), but my monitors are not set right. Why? thanks a lot in advance!

'Option Compare Database
Option Explicit
'Constants
Public Const DD_Desktop = &H1
Public Const DD_MultiDriver = &H2
Public Const DD_Primary = &H4
Public Const DD_Mirror = &H8
Public Const DD_VGA = &H10
Public Const DD_Removable = &H20
Public Const DD_ModeSpruned = &H8000000
Public Const DD_Remote = &H4000000
Public Const DD_Disconnect = &H2000000
 
Public Const DD_Active = &H1
Public Const DD_Attached = &H2
 
Public Const CCHDEVICENAME = 32
Public Const CCHFORMNAME = 32
 
Public Const ENUM_CURRENT_SETTINGS = -1
Public Const ENUM_REGISTRY_SETTINGS = -2
 
Public Const MONITOR_DEFAULTTONULL = 0
Public Const MONITOR_DEFAULTTOPRIMARY = 1
Public Const MONITOR_DEFAULTTONEAREST = 2
 
'User Defined Types
Private Type DisplayDevice
cb As Long
DeviceName As String * 32
DeviceString As String * 128
StateFlags As Long
DeviceID As String * 128
DeviceKey As String * 128
End Type
 
Private Type POINTL
x As Long
y As Long
End Type
 
Private Type DEVMODE
DeviceName As String * CCHDEVICENAME
SpecVersion As Integer
DriverVersion As Integer
Size As Integer
DriverExtra As Integer
Fields As Long
Position As POINTL
Scale As Integer
Copies As Integer
DefaultSource As Integer
PrintQuality As Integer
Color As Integer
Duplex As Integer
YResolution As Integer
TTOption As Integer
Collate As Integer
FormName As String * CCHFORMNAME
LogPixels As Integer
BitsPerPel As Long
PelsWidth As Long
PelsHeight As Long
DisplayFlags As Long
DisplayFrequency As Long
End Type
 
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
 
Private Type MonitorInfo
cbSize As Long
rcMonitor As RECT
rcWork As RECT
dwFlags As Long
End Type
 
'Declares
Public Declare Function EnumDisplayDevices Lib "user32" Alias "EnumDisplayDevicesA" (ByVal lpDevice As String, _
ByVal iDevNum As Long, lpDisplayDevice As DisplayDevice, dwFlags As Long) As Long
Public Declare Function EnumDisplaySettingsEx Lib "user32" Alias "EnumDisplaySettingsExA" (ByVal lpszDeviceName As String, _
ByVal iModeNum As Long, lpDevMode As DEVMODE, dwFlags As Long) As Long
Public Declare Function MonitorFromPoint Lib "user32" (ByVal ptY As Long, ByVal ptX As Long, ByVal dwFlags As Long) As Long
Public Declare Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, lpmi As MonitorInfo) As Long
Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Public Declare Function ChangeDisplaySettingsEx Lib "user32" Alias "ChangeDisplaySettingsExA" (lpszDeviceName As Any, _
lpDevMode As Any, ByVal hWnd As Long, ByVal dwFlags As Long, lParam As Any) As Long
 
 
'Public Parts that will be used
Public Type Monitors
Name As String
Handle As Long
x As Long
y As Long
Width As Long
Height As Long
DevString As String
Detected As Boolean
End Type
Public PrimaryMon As Monitors
Public SecondaryMon As Monitors
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'Declare Function GetSystemMetrics16 Lib "user" _
    'Alias "GetSystemMetrics" (ByVal nIndex As Integer) As Integer
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
 
'------------------------------------------------------------------------
Public vidwidth As Integer
Public vidheight As Integer
Dim Msg
Dim ans
Dim msg1
Public Originalvidwidth As Integer 'stores original screen setting to use to restore later
Public Originalvidheight As Integer 'stores original screen setting to use to restore later
Public ResetScreen As Boolean
 
 
Public Sub GetDisplays()
Dim DispDev As DisplayDevice, MonDev As DisplayDevice 'holds device info/monitor info
Dim DispDevInd As Long, MonDevInd As Long 'Index for the devices
Dim MonMode As DEVMODE 'holds mode information for each monitor
Dim hMonitor As Long 'holds handle to the correct monitor context
Dim MonInfo As MonitorInfo
 
'initialisations
DispDev.cb = Len(DispDev)
MonDev.cb = Len(MonDev)
DispDevInd = 0: MonDevInd = 0
PrimaryMon.Detected = False
SecondaryMon.Detected = False
 
Do While EnumDisplayDevices(vbNullString, DispDevInd, DispDev, 0) <> 0 'enumerate the graphics cards
    If Not CBool(DispDev.StateFlags And DD_Mirror) Then
        'if it is real
        Do While EnumDisplayDevices(DispDev.DeviceName, MonDevInd, MonDev, 0) <> 0 'iterate to the correct MonDev
            If CBool(MonDev.StateFlags And DD_Active) Then Exit Do
            MonDevInd = MonDevInd + 1
        Loop
        'if the device string is empty then its a default monitor
        If cCstr(MonDev.DeviceString) = "" Then
            EnumDisplayDevices DispDev.DeviceName, 0, MonDev, 0
            If cCstr(MonDev.DeviceString) = "" Then MonDev.DeviceString = "Default Monitor"
        End If
        'get information about the display's position and the current display mode
 
        MonMode.Size = Len(MonMode)
        If EnumDisplaySettingsEx(DispDev.DeviceName, ENUM_CURRENT_SETTINGS, MonMode, 0) = 0 Then
            EnumDisplaySettingsEx DispDev.DeviceName, ENUM_REGISTRY_SETTINGS, MonMode, 0
        End If
 
        'get the monitor handle and workspace
 
        MonInfo.cbSize = Len(MonInfo)
        If CBool(DispDev.StateFlags And DD_Desktop) Then
        'display is enabled. only enabled displays have a monitor handle
        hMonitor = MonitorFromPoint(MonMode.Position.x, MonMode.Position.y, MONITOR_DEFAULTTONULL)
            If hMonitor <> 0 Then
                GetMonitorInfo hMonitor, MonInfo
            End If
        End If
    End If
If CBool(DispDev.StateFlags And DD_Desktop) Then 'if it is an active monitor
        If CBool(DispDev.StateFlags And DD_Primary) Then 'if itis the primary
            With PrimaryMon
                If MonDev.DeviceName <> "" Then .Name = cCstr(MonDev.DeviceName) Else .Name = cCstr(DispDev.DeviceName)
                MsgBox "1: " & .Name
                .Detected = True
                .Handle = hMonitor
                .DevString = cCstr(MonDev.DeviceString) & " on " & cCstr(DispDev.DeviceString)
                MsgBox .DevString
                .x = MonMode.Position.x
                .y = MonMode.Position.y
                .Width = MonMode.PelsWidth
                .Height = MonMode.PelsHeight
            End With
        Else
            If Not SecondaryMon.Detected Then 'if it is a secondary (only do one)
                With SecondaryMon
                    If MonDev.DeviceName <> "" Then .Name = cCstr(MonDev.DeviceName) Else .Name = cCstr(DispDev.DeviceName)
                    MsgBox "2: " & .Name
                    .Detected = True
                    .Handle = hMonitor
                    .DevString = cCstr(MonDev.DeviceString) & " on " & cCstr(DispDev.DeviceString)
                    MsgBox .DevString
                    .x = MonMode.Position.x
                    .y = MonMode.Position.y
                    .Width = MonMode.PelsWidth
                    .Height = MonMode.PelsHeight
                End With
            End If
        End If
    End If
    DispDevInd = DispDevInd + 1 'next graphics card
Loop
 
End Sub
 
Private Function cCstr(str As String) As String
    Dim i As Long
    Dim char As String
    Dim Returned As String
     
    For i = 1 To Len(str)
        char = Mid(str, i, 1)
        If char <> vbNullChar And char <> vbNullString Then
            Returned = Returned & char
        End If
    Next
     
    cCstr = Returned
 
End Function
Public Sub DetectDualMonitor()
    GetDisplays
        vidwidth = GetSystemMetrics(SM_CXSCREEN)
        vidheight = GetSystemMetrics(SM_CYSCREEN)
    If SecondaryMon.Detected = True Then
        If vidwidth = 1024 And vidheight = 768 Then
            Exit Sub
        Else
                    ans = MsgBox("A secondary monitor connection has been detected." & vbCrLf & _
                    "If this is for a presentation projector, would you like this program" & vbCrLf & _
                    "to change your screen resolution to 1024 x 768 so that the" & vbCrLf & _
                    "Issue Sheet and TTM plans will fill a standard projection screen?", vbYesNo)
        End If
    End If
     
    If ans = vbYes Then
            'Replace '1024,768,32,75' with the resolution you want to switch to.
            'You can change the color pallete by changing the '32' below with '16' ect...
            'You can also change refresh rate
            Originalvidwidth = vidwidth
            Originalvidheight = vidheight
            ResetScreen = True
'            ChangeScreenSettings 1024, 768, 32, 60
        '    DoCmd.Close acForm, "frmMainEntryMenu", acSaveNo
        '    DoCmd.OpenForm "frmMainEntryMenu"
        '    Forms!frmMainEntryMenu!LblRestore.Visible = True
        '    Forms!frmMainEntryMenu!btnRestoreScreen.Visible = True
        '    Forms!frmMainEntryMenu!btnSet1024x768.Visible = False
        '    Forms!frmMainEntryMenu!LblPresentation.Visible = False
    Else
        '            Forms!frmMainEntryMenu!LblRestore.Visible = False
        '            Forms!frmMainEntryMenu!btnRestoreScreen.Visible = False
        '            Forms!frmMainEntryMenu!btnSet1024x768.Visible = True
        '            Forms!frmMainEntryMenu!LblPresentation.Visible = True
                    Exit Sub
    End If
       
End Sub
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'Private Const DISP_CHANGE_SUCESSFUL As Long = 0
'Private Const DISP_CHANGE_RESTART As Long = 1
'Private Const DISP_CHANGE_FAILED As Long = -1
'Private Const DISP_CHANGE_BADMODE As Long = -2
'Private Const DISP_CHANGE_NOTUPDATED As Long = -3
'Private Const DISP_CHANGE_BADFLAGS As Long = -4
'Private Const DISP_CHANGE_BADPARAM As Long = -5
Public Sub SetExtDeskTop()
    Dim dmPrimary As DEVMODE
    Dim dmSecondary As DEVMODE
    Dim dmTemp As DEVMODE
'    const DMBITSPERPEL AS Long =0x00040000
    
    Const szPrimaryDisplay As String = "\\.\DISPLAY1"
    Const szSecondaryDisplay As String = "\\.\DISPLAY2"
    Const CDS_UPDATEREGISTRY As Long = &H1
    Const CDS_NORESET As Long = &H10000000
    Const CDS_RESET As Long = &H40000000
    Const DM_BITSPERPEL As Long = &H40000
    Const DM_PELSWIDTH As Long = &H80000
    Const DM_PELSHEIGHT As Long = &H100000
    Const DM_POSITION As Long = &H20
    Const DM_DISPLAYFREQUENCY As Long = &H400000
    
    Dim lngExtSucc As Long
    
'    dmPrimary.Size = Len(dmPrimary)
'    dmTemp.Size = Len(dmTemp)
'    dmSecondary.Size = Len(dmSecondary)
    
    If EnumDisplaySettings(szPrimaryDisplay, ENUM_CURRENT_SETTINGS, dmTemp) = False Then
        MsgBox "Primary Settings couldn't be enumerated."
    Else
'        With dmTemp
'            Debug.Print "BitsPerPel: " & .BitsPerPel
'            Debug.Print "Collate: " & .Collate
'            Debug.Print "Color: " & .Color
'            Debug.Print "Copies: " & .Copies
'            Debug.Print "DefaultSource: " & .DefaultSource
'            Debug.Print "DeviceName: " & .DeviceName
'            Debug.Print "DisplayFlags: " & .DisplayFlags
'            Debug.Print "DisplayFrequency: " & .DisplayFrequency
'            Debug.Print "DriverExtra: " & .DriverExtra
'            Debug.Print "DriverVersion: " & .DriverVersion
'            Debug.Print "Duplex: " & .Duplex
'            Debug.Print "Fields: " & .Fields
'            Debug.Print "FormName: " & .FormName
'            Debug.Print "LogPixels: " & .LogPixels
'            Debug.Print "PelsHeight: " & .PelsHeight
'            Debug.Print "PelsWidth: " & .PelsWidth
'            Debug.Print "Position.x: " & .Position.x
'            Debug.Print "Position.y: " & .Position.y
'            Debug.Print "PrintQuality: " & .PrintQuality
'            Debug.Print "Scale: " & .Scale
'            Debug.Print "Size: " & .Size
'            Debug.Print "SpecVersion: " & .SpecVersion
'            Debug.Print "TTOption: " & .TTOption
'            Debug.Print "YResolution: " & .YResolution
'        End With
        With dmPrimary
            .BitsPerPel = dmTemp.BitsPerPel
            .PelsHeight = dmTemp.PelsHeight
            .PelsWidth = dmTemp.PelsWidth
            .DisplayFrequency = dmTemp.DisplayFrequency
            .Fields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT
            With .Position
                .x = dmTemp.Position.x
                .y = dmTemp.Position.y
            End With
            .Fields = .Fields Or DM_POSITION
        End With
        If dmPrimary.DisplayFrequency <> 0 Then _
            dmPrimary.Fields = dmPrimary.Fields Or DM_DISPLAYFREQUENCY
        With dmSecondary
            .BitsPerPel = dmPrimary.BitsPerPel
            .PelsHeight = dmPrimary.PelsHeight
            .PelsWidth = dmPrimary.PelsWidth
            .DisplayFrequency = 60
            .Fields = (DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT)
            If .DisplayFrequency <> 0 Then _
                .Fields = .Fields Or DM_DISPLAYFREQUENCY
                
            With .Position
                .x = dmPrimary.PelsWidth + 1
                .y = 0
            End With
            .Fields = .Fields Or DM_POSITION
        End With
        
'        lngExtSucc = ChangeDisplaySettingsEx(szPrimaryDisplay, _
'            dmPrimary, 0&, UPDATEREGISTRY Or NORESET, 0&)
'
'        MsgBox lngExtSucc
        
        If ChangeDisplaySettingsEx(szPrimaryDisplay, _
            dmPrimary, 0&, CDS_UPDATEREGISTRY Or CDS_NORESET, 0&) = 0 Then
            If ChangeDisplaySettingsEx(szSecondaryDisplay, _
                dmSecondary, 0&, CDS_UPDATEREGISTRY Or CDS_NORESET, 0&) = 0 Then
                If ChangeDisplaySettingsEx(vbNullString, _
                    vbNull, 0&, 0&, 0&) = 0 Then
                    lngExtSucc = ChangeDisplaySettingsEx(szPrimaryDisplay, dmPrimary, _
                        vbNull, CDS_UPDATEREGISTRY Or CDS_RESET, 0&)
                    MsgBox "Extended Desktop Set Successfully"
                Else
                    MsgBox "Final CDS call failed"
                End If
            Else
                MsgBox "Second CDS call failed"
            End If
        Else
            MsgBox "First CDS call failed"
        End If
    End If
End Sub