forked from smbx/smbx-legacy-source
-
Notifications
You must be signed in to change notification settings - Fork 0
/
modChangeRes.bas
232 lines (219 loc) · 9.65 KB
/
modChangeRes.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
Attribute VB_Name = "modChangeRes"
Option Explicit
'Thanks to KPD-Team
'For the API and variables in this module
'Visit them at http://www.allapi.net/
'===========================================================
'I take no responsibilty if this code wrecks your computer.
'Use this code at your own risk!
'===========================================================
'Version 1.3
'By Brendon Pilt
'===========================================================
'Note:
'Form should be maximised so that it fills the whole screen
'when loaded
'===========================================================
'Note:
'Color quality and screen resolution can only be changed
'if it is supported by the Graphics Card\Operating System.
'===========================================================
Const ENUM_CURRENT_SETTINGS As Long = -1& 'Get current settings
Const DM_PELSWIDTH = &H80000 'Pixels in width
Const DM_PELSHEIGHT = &H100000 'Pixels in height
Const DM_BITSPERPEL = &H40000 'Color Depth
Const DM_DISPFREQ = &H400000 'Display Frequency
Const CDS_TEST = &H4
Private Type DEVMODE
dmDeviceName As String * 32 'Name of graphics card?????
dmSpecVersion As Integer
dmDriverVersion As Integer 'graphics card driver version?????
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 'Name of form?????
dmUnusedPadding As Integer
dmBitsPerPel As Integer 'Color Quality (can be 8, 16, 24, 32 or even 4)
dmPelsWidth As Long 'Display Width in pixels
dmPelsHeight As Long 'Display height in pixels
dmDisplayFlags As Long
dmDisplayFrequency As Long 'Display frequency
dmICMMethod As Long 'NT 4.0
dmICMIntent As Long 'NT 4.0
dmMediaType As Long 'NT 4.0
dmDitherType As Long 'NT 4.0
dmReserved1 As Long 'NT 4.0
dmReserved2 As Long 'NT 4.0
dmPanningWidth As Long 'Win2000
dmPanningHeight As Long 'Win2000
End Type
Private 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
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Dim DevM As DEVMODE
Dim OldX As Integer, OldY As Integer, OldColor As Integer, OldFreq As Integer
Dim SetX As Integer, SetY As Integer, SetColor As Integer, SetFreq As Integer
Public Sub GetCurrentRes()
'=======================================================
'Call this sub in Form_Load
'=======================================================
'Save original (current) resolution
EnumDisplaySettings 0&, ENUM_CURRENT_SETTINGS, DevM 'Get current setting
OldX = DevM.dmPelsWidth 'or OldX = Screen.Width / Screen.TwipsPerPixelX
OldY = DevM.dmPelsHeight 'or OldY = Screen.Height / Screen.TwipsPerPixelY
OldColor = DevM.dmBitsPerPel
OldFreq = DevM.dmDisplayFrequency
'Apply new resolution
ChangeRes 800, 600, 16, 60
End Sub
Public Sub SetOrigRes()
'=======================================================
'Call this sub in Form_Unload
'=======================================================
'Change the display settings back to the old settings
ChangeRes OldX, OldY, OldColor, OldFreq
Do
Loop Until ShowCursor(1) >= 1
resChanged = False
End Sub
Public Sub ChangeRes(ScreenX As Integer, ScreenY As Integer, ScreenColor As Integer, ScreenFreq As Integer)
'=======================================================
'ChangeRes sub format (can be set at runtime):
'Insert a zero if you don't want to change an aspect
'eg:
'ChangeRes 800, 600, 16, 60 '800x600 pixels, 16 bit Color, 60Hz
'ChangeRes 800, 600, 16, 0 '800x600 pixels, 16 bit Color
'ChangeRes 800, 600, 0, 60 '800x600 pixels, 60Hz
'ChangeRes 0, 0, 16, 60 '16 bit Color, 60Hz
'ChangeRes 0, 0, 16, 0 '16 bit Color
'ChangeRes 800, 600, 0, 0 '800x600 pixels
'ChangeRes 0, 0, 0, 60 '60Hz
'=======================================================
'=======================================================
'The "EndIf" statement is used because if a "0" is used
'in the API call, the API considers it as an aspect that
'does not need to be changed, but is the current system
'setting.
'eg:
'ChangeRes 0, 0, 0, 0 = The current system setting
'ChangeRes 0, 0, 16, 0 = The current resolution and display frequency setting, with new color quality
'=======================================================
'Get selected resolution
If ScreenX <> 0 And ScreenY <> 0 And ScreenColor = 0 And ScreenFreq = 0 Then
DevM.dmPelsWidth = ScreenX 'Screen width
DevM.dmPelsHeight = ScreenY 'Screen height
DevM.dmBitsPerPel = SetColor 'Screen color quality
DevM.dmDisplayFrequency = SetFreq 'Screen display frequency
'SetX = ScreenX
'SetY = ScreenY
SaveIt ScreenX, ScreenY, ScreenColor, ScreenFreq, "ChangeResol"
'DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
ElseIf ScreenX = 0 And ScreenY = 0 And ScreenColor <> 0 And ScreenFreq = 0 Then
DevM.dmPelsWidth = SetX 'Screen width
DevM.dmPelsHeight = SetY 'Screen height
DevM.dmBitsPerPel = ScreenColor 'Screen color quality
DevM.dmDisplayFrequency = SetFreq 'Screen display frequency
'SetColor = ScreenColor
SaveIt ScreenX, ScreenY, ScreenColor, ScreenFreq, "ChangeColor"
'DevM.dmFields = DM_BITSPERPEL
ElseIf ScreenX = 0 And ScreenY = 0 And ScreenColor = 0 And ScreenFreq <> 0 Then
DevM.dmPelsWidth = SetX 'Screen width
DevM.dmPelsHeight = SetY 'Screen height
DevM.dmBitsPerPel = SetColor 'Screen color quality
DevM.dmDisplayFrequency = ScreenFreq 'Screen display frequency
'SetFreq = ScreenFreq
SaveIt ScreenX, ScreenY, ScreenColor, ScreenFreq, "ChangeFreq"
'DevM.dmFields = DM_DISPFREQ
ElseIf ScreenX <> 0 And ScreenY <> 0 And ScreenColor <> 0 And ScreenFreq <> 0 Then
DevM.dmPelsWidth = ScreenX 'Screen width
DevM.dmPelsHeight = ScreenY 'Screen height
DevM.dmBitsPerPel = ScreenColor 'Screen color quality
DevM.dmDisplayFrequency = ScreenFreq 'Screen display frequency
SaveIt ScreenX, ScreenY, ScreenColor, ScreenFreq, "ChangeAll"
'DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL Or DM_DISPFREQ
ElseIf ScreenX = 0 And ScreenY = 0 And ScreenColor = 0 And ScreenFreq = 0 Then
Exit Sub
End If
'we want to change the horizontal and the vertical
'resolution, the color quality, and the display
'frequency (screen refresh rate)
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL Or DM_DISPFREQ
'change the display settings
Call ChangeDisplaySettingsEx(ByVal 0&, DevM, ByVal 0&, CDS_TEST, ByVal 0&)
End Sub
Private Sub SaveIt(ScX As Integer, ScY As Integer, ScC As Integer, ScF As Integer, ScreenChanged As String)
Select Case ScreenChanged
Case "ChangeResol"
SetX = ScX 'Screen width
SetY = ScY 'Screen height
Case "ChangeColor"
SetColor = ScC 'Screen color quality
Case "ChangeFreq"
SetFreq = ScF 'Screen display frequency
Case "ChangeAll"
SetX = ScX 'Screen width
SetY = ScY 'Screen height
SetColor = ScC 'Screen color quality
SetFreq = ScF 'Screen display frequency
End Select
End Sub
'===========================================================
'Example of code for form:
'Private Sub cmdChange_Click(Index As Integer)
' Select Case Index
' Case 0
' '1024x768x16x60
' ChangeRes 1024, 768, 0, 0
' Case 1
' '800x600x32x85
' ChangeRes 800, 600, 32, 85
' Case 2
' '800x600x16x85
' ChangeRes 0, 0, 16, 0
' Case 3
' '800x600x16x60
' ChangeRes 0, 0, 0, 60
' End Select
'End Sub
'
'Private Sub Form_Load()
' GetCurrentRes
'End Sub
'
'Private Sub Form_Unload(Cancel As Integer)
' SetOrigRes
'End Sub
'===========================================================
'Common Screen Resoulutions:
'==============='
'Width Height '
'==============='
'640 480 '
'800 600 '
'1024 768 '
'1280 1024 '
'1600 1200 '
'==============='
'
'Common Color Qualities:
'==============================================================='
'Bits # colors Common Name
'==============================================================='
'4 16 16 Colors '
'8 256 256 Colors '
'16 65,536 High Color (16-Bit) '
'24 16,777,216 True Color (24-bit) '
'32 4,294,967,296 True Color (32-Bit/24bit + 8bit Alpha) '
'==============================================================='