Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Temmuz 2010 Cumartesi

Display Setting By ChangeDisplaySettings Function




'UserForm1

'A) VBProject References List

'Name: VBA, Description: Visual Basic For Applications
'Name: Excel, Description: Microsoft Excel 11.0 Object Library
'Name: stdole, Description: OLE Automation
'Name: Office, Description: Microsoft Office 11.0 Object Library
'Name: MSForms, Description: Microsoft Forms 2.0 Object Library
'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

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul