Display Setting By ChangeDisplaySettings Function

'UserForm1

'A) VBProject References List

'Name: VBA, Description: Visual Basic For Applications, Full Path: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'Name: Excel, Description: Microsoft Excel 11.0 Object Library, Full Path: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'Name: stdole, Description: OLE Automation, Full Path: C:\WINDOWS\system32\stdole2.tlb
'Name: Office, Description: Microsoft Office 11.0 Object Library, Full Path: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'Name: MSForms, Description: Microsoft Forms 2.0 Object Library, Full Path: C:\WINDOWS\system32\FM20.DLL

'B) Addition Tools on UserForm1

'Image1, Label1, Label2
'CommandButton1, ListBox1, Label3

Option Explicit
Private Const CDS_UPDATEREGISTRY = &H1
Private Const CDS_TEST = &H2
Private Const CDS_FULLSCREEN = &H4
Private Const CDS_GLOBAL = &H8
Private Const CDS_SET_PRIMARY = &H10
Private Const CDS_RESET = &H40000000
Private Const CDS_SETRECT = &H20000000
Private Const CDS_NORESET = &H10000000
Private Const DISP_CHANGE_SUCCESSFUL = 0
Private Const DISP_CHANGE_RESTART = 1
Private Const DISP_CHANGE_FAILED = -1
Private Const DISP_CHANGE_BADMODE = -2
Private Const DISP_CHANGE_NOTUPDATED = -3
Private Const DISP_CHANGE_BADFLAGS = -4
Private Const DISP_CHANGE_BADPARAM = -5
Private Const ENUM_CURRENT_SETTINGS = -1
Private Const ENUM_REGISTRY_SETTINGS = -2
Private 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
dmUnusedPadding As Integer
dmBitsPerPixel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
' The following only appear in Windows 95, 98, 2000
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
' The following only appear in Windows 2000
dmPanningWidth As Long
dmPanningHeight As Long

End Type
Private DisplayDM As DEVMODE
Private Declare Function EnumDisplaySettings Lib "user32.dll" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DEVMODE) As Long
Private Declare Function ChangeDisplaySettings Lib "user32.dll" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Private Tercih As Long
Private En As Double, Boy As Double, No As Double, Eni As Double, Boyu As Double
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Display Setting By ChangeDisplaySettings Function"
Application.Visible = False
DisplayDM.dmSize = Len(DisplayDM)
Tercih = EnumDisplaySettings(vbNullString, ENUM_CURRENT_SETTINGS, DisplayDM)
En = DisplayDM.dmPelsWidth
Boy = DisplayDM.dmPelsHeight
Call EkranDüzenle

End Sub
Private Sub UserForm_Activate()

On Error Resume Next
Me.StartUpPosition = 2

End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

On Error Resume Next
Application.Visible = True

End Sub
Private Sub CommandButton1_Click() 'Default Options

On Error Resume Next
Call DisplaySetting(En, Boy)

End Sub
Private Sub ListBox1_Change() 'Change Options

On Error Resume Next
No = ListBox1.ListIndex
Eni = ListBox1.List(No, 0)
Boyu = ListBox1.List(No, 1)
Call DisplaySetting(Eni, Boyu)
Me.Left = 0
Me.Top = 0

End Sub
Private Sub DisplaySetting(Eni As Double, Boyu As Double) 'Change Display Setting

On Error Resume Next
DisplayDM.dmPelsWidth = Eni
DisplayDM.dmPelsHeight = Boyu
Tercih = ChangeDisplaySettings(DisplayDM, CDS_TEST)
If Tercih = DISP_CHANGE_SUCCESSFUL Then

Tercih = ChangeDisplaySettings(DisplayDM, CDS_UPDATEREGISTRY)
Select Case Tercih

Case DISP_CHANGE_SUCCESSFUL: Label3.Caption = "DISP_CHANGE_SUCCESSFUL"
Case DISP_CHANGE_RESTART: Label3.Caption = "DISP_CHANGE_RESTART"
Case Else: Label3.Caption = "UNABLE RESOLUTION"

End Select

Else

Debug.Print "Cannot change to that resolution!"

End If

End Sub
Private Sub EkranDüzenle()

On Error Resume Next
With Me

.Height = 246
.Width = 234
'.Picture = LoadPicture("C:\Documents and Settings\Administrator\Belgelerim\Mustafa ULUSARAÇ\VectorBackround.jpg")
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.BackColor = vbWhite
With Image1

.Left = 6
.Top = 6
.Height = 24
.Width = 24
.BorderColor = &HFFFFFF
.BorderStyle = fmBorderStyleSingle
.BackStyle = fmBackStyleTransparent
'.Picture = LoadPicture("C:\Documents and Settings\Administrator\Belgelerim\Mustafa ULUSARAÇ\PBİD.ico")
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False

End With
With Label1

.Top = 6
.Left = 36
.Height = 12
.Width = 186
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Caption = "Mustafa ULUSARAÇ"
.Font.Bold = True
.ForeColor = &H808000
.SpecialEffect = fmSpecialEffectFlat
.TextAlign = fmTextAlignLeft

End With
With Label2

.Top = 18
.Left = 36
.Height = 12
.Width = 186
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Caption = "01ulusarac@superonline.com"
.Font.Bold = True
.ForeColor = &H808000
.SpecialEffect = fmSpecialEffectFlat
.TextAlign = fmTextAlignLeft

End With
With CommandButton1

.Left = 6
.Top = 36
.Height = 24
.Width = 216
.Caption = "Default Setting [Width: " & En & " - Height: " & Boy & "]"
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.ForeColor = &H404000

End With
With ListBox1

.Left = 6
.Top = 66
.Height = 133.5
.Width = 216
.SpecialEffect = fmSpecialEffectEtched
.BackColor = vbWhite
.Font.Bold = True
.ForeColor = &H404000
.AddItem "800": ListBox1.List(0, 1) = "600"
.AddItem "960": ListBox1.List(1, 1) = "600"
.AddItem "1024": ListBox1.List(2, 1) = "768"
.AddItem "1088": ListBox1.List(3, 1) = "612"
.AddItem "1052": ListBox1.List(4, 1) = "864"
.AddItem "1280": ListBox1.List(5, 1) = "720"
.AddItem "1280": ListBox1.List(6, 1) = "768"
.AddItem "1280": ListBox1.List(7, 1) = "800"
.AddItem "1280": ListBox1.List(8, 1) = "960"
.AddItem "1280": ListBox1.List(9, 1) = "1024"
.AddItem "1360": ListBox1.List(10, 1) = "768"
.AddItem "1440": ListBox1.List(11, 1) = "900"
.AddItem "1600": ListBox1.List(12, 1) = "900"
.AddItem "1600": ListBox1.List(13, 1) = "1024"
.AddItem "1680": ListBox1.List(14, 1) = "1050"
.AddItem "1920": ListBox1.List(15, 1) = "1080"
.AddItem "3840": ListBox1.List(16, 1) = "2160"

End With
With Label3

.Top = 204
.Left = 6
.Height = 12
.Width = 216
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Caption = ""
.Font.Bold = True
.ForeColor = &H404000
.SpecialEffect = fmSpecialEffectEtched
.TextAlign = fmTextAlignLeft

End With

End With

End Sub

'Module1

Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" 'It may take a few seconds, please wait.
Public URL As String
Public Const URL1 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg" 'Microsoft Office Excel® Kod Kılavuzu [UserFormBackround]
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD Icon]
Sub FormAç() 'Open UserForm

On Error Resume Next
UserForm1.Show 0

End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...

On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim

End Function
'Sub ReferecesList()

' Dim Eleman, ElemanNo
' Sheets("ReferencesList").Select
' ElemanNo = 1
' For Each Eleman In ThisWorkbook.VBProject.References

' Cells(ElemanNo, 1) = "Name: "
' Cells(ElemanNo, 2) = Eleman.Name
' Cells(ElemanNo, 3) = ", Description: "
' Cells(ElemanNo, 4) = Eleman.Description
' Cells(ElemanNo, 5) = ", FullPath: "
' Cells(ElemanNo, 6) = Eleman.FullPath
' Cells(ElemanNo, 7) = ", Guid: "
' Cells(ElemanNo, 8) = Eleman.GUID
' Cells(ElemanNo, 9) = ", Major: "
' Cells(ElemanNo, 10) = Eleman.major
' Cells(ElemanNo, 11) = ", Minor: "
' Cells(ElemanNo, 12) = Eleman.minor
' ElemanNo = ElemanNo + 1

' Next Eleman

'End Sub