كود رائع للتعامل مع دقة الشاشة ( قراءة وتغيير)

بســم الله الـرحمــن الرحيــم

السلام عليكــم ورحمـة الله وبركاتــه ،،

كل عام أنتم جميعا بخير

عذرا لانقطاعي عن أول صرح تعلمت فيه البرمجة نظرا لظروف خاصة

واليوم عدت لكم بكود بسيط ورائع في نفس الوقت

أحس روعته رغم أني محتاج لتفسير الإخوة المتمكنين لكيفية استخدام هذا الكود

الكود عبارة عن دالتين

الأولى لمعرفة جميع الأحجام الممكن تغيير دقة الشاشة إليها

وهذه هي التي لم أفهم طريقة استعمالها حيث أن الدالة من نوع collection الذي لم يسبق لي التعامل معه

والثانية لتغيير دقة الشاشة إلى أي حجم تريده بدلالة العرض والارتفاع

والآن مع الكود

Option Compare Database
Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000

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 apiEnumDisplaySettings Lib "user32" _
		Alias "EnumDisplaySettingsA" _
		(ByVal lpszDeviceName As Long, _
		ByVal iModeNum As Long, _
		lpDevMode As Any) _
		As Boolean

Private Declare Function apiChangeDisplaySettings Lib "user32" _
		Alias "ChangeDisplaySettingsA" _
		(lpDevMode As Any, _
		ByVal dwflags As Long) _
		As Long

Function numDisplay() As Collection
Dim collRes As Collection
Dim boolRet As Boolean
Dim tDevMode As DEVMODE
Dim lngMode As Long

	Set collRes = New Collection
	Do
		boolRet = apiEnumDisplaySettings(0&, lngMode&, tDevMode)
		With tDevMode
			collRes.Add .dmPelsWidth & "x" & _
					.dmPelsHeight & " @ " & .dmBitsPerPel & " bit", _
					lngMode & vbNullString
		End With
		lngMode = lngMode + 1
	Loop Until boolRet = False
	Set numDisplay = collRes
	Set collRes = Nothing
End Function

Function ChangeRes(intX As Integer, intY As Integer) As Boolean
Dim tDevMode As DEVMODE
Dim boolCanChange As Boolean
Dim boolRet As Boolean
Dim lngRet As Long, lngMode As Long

	On Error GoTo Err_Handler
	Do
		boolRet = apiEnumDisplaySettings(0&, lngMode&, tDevMode)
		With tDevMode
			If .dmPelsWidth = intX And .dmPelsHeight = intY Then
				boolCanChange = True
			End If
		End With
		lngMode = lngMode + 1
	Loop Until boolRet = False

	If boolCanChange Then
		With tDevMode
			.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
			.dmPelsWidth = intX
			.dmPelsHeight = intY
		End With
		lngRet = apiChangeDisplaySettings(tDevMode, 0&)
	End If
	ChangeRes = boolCanChange
exit_Handler:
	Exit Function
Err_Handler:
	ChangeRes = False
	Resume exit_Handler
End Function

بانتظار تواصل الخبراء

أخوكم

محمد صالح