VB icon

Windows 10: Obtaining Screen Resolution

Email
Submitted on: 5/16/2019 11:29:33 AM
By: A_X_O 
Level: Beginner
User Rating: Unrated
Compatibility: VbScript (browser/client side)
Views: 1440
 
     This VBScript attempts four ways to obtain the Screen Resolution from the Windows Management Instrumentation Object and a HTA application.

 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
				
'**************************************
' Name: Windows 10: Obtaining Screen Resolution
' Description:This VBScript attempts four ways to obtain the Screen Resolution from the Windows Management Instrumentation Object and a HTA application.
' By: A_X_O
'**************************************

'
'-------------------------------------------------------------------------------'
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
'		Demonstration: Windows 10, Obtaining Desktop Resolution 	'
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
'										'
'	Purpose		: Demonstrates WMI & Or HTA Screen Resolution		'
'	-----------------------------------------------------------------------	'
'	Creation Date	: 30/04/2019 [dd/mm/yyyy]				'
'	Version		: 1:2							'
'	Designer	: Fabian						'
'										'
'###############################################################################'
'			MODIFICATION HISTORY					'
'-------------------------------------------------------------------------------'
'										'
'	Version		: 1:0	30/04/2019	Create the Sample		'
'			: 1:1	07/05/2019	Add HTA Code			'
'			: 1:2	16/05/2019	Fix missing I/O Const in HTA	'
'										'
'-------------------------------------------------------------------------------'		
'
Public Const gResFail01 = "WMI: Cannot get the resolution from your machine"
Public Const gResFail02 = "Create an HTA application to get it ?"
Public Const gResFail03 = "WMI Failure"
'
Public Const ScrnHoriz = "Screen Horizontal Pixels: "
Public Const ScrnVerti = "Screen Vertical Pixels: "
Public Const ScrnRestn = "Screen Resolution"
'
Dim ObjWMIService
'
Dim IntHorizontal
Dim IntVertical
'
Dim g1_ObjItems
Dim g2_ObjItems
Dim g3_ObjItems
'
Dim FSO
Dim WshShell
Dim StrDesktopPath
Dim HTApath
'
Public Const IntPause = 1000
'
Public Const ForReading = 1
Public Const ForWriting = 2
'
Public Const HTAobj = "\ScreenResolution.hta"
'
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = Wscript.CreateObject("Wscript.Shell")
'
Set ObjWMIService = GetObject("Winmgmts:\\.\ROOT\CIMV2")
'
Set g1_ObjItems = ObjWMIService.ExecQuery("SELECT * FROM Win32_DesktopMonitor WHERE DeviceID = 'DesktopMonitor1'", ,0)
Set g2_ObjItems = ObjWMIService.ExecQuery("SELECT * FROM Win32_DesktopMonitor", ,48)
Set g3_ObjItems = ObjWMIService.ExecQuery("SELECT * FROM Win32_VideoController", ,48)
'
Public Sub GUIHTApp()
On Error Resume Next
'
Dim ObjHTA
Dim ResourceFile
Dim HTAdata
Dim StrSTART
Dim StrSTOP
Dim HTAstr
'
	StrDesktopPath = WshShell.SpecialFolders("Desktop")
	HTApath = ((StrDesktopPath) & (HTAobj))
'
Set ResourceFile = FSO.OpenTextFile((Wscript.ScriptFullName), ForReading)
'
 	HTAdata = ResourceFile.ReadAll
'
If InStr(1, (HTAdata), Chr(39), 1) Then
'
	HTAdata = Replace((HTAdata), Chr(39), Chr(32))
'
End If
'
	StrSTART = InstrRev(HTAdata, "<%START%>", -1, 1)
'
	StrSTOP = InstrRev(HTAdata, "<%STOP%>", -1, 1)
'
	HTAstr = Mid((HTAdata), ((StrSTART)+9), ((StrSTOP)-9)-(StrSTART))
'
Set ObjHTA = FSO.CreateTextFile((HTApath), True)
'
With ObjHTA
'
	.Write (HTAstr)
	.Close
'
End With
'
End Sub
'
Public Sub ReadDataFile()
On Error Resume Next
'
Dim ExtractData
Dim DatFileLocation
Dim FileHere
Dim HTAScreenRes
Dim MyArray
'
	DatFileLocation = ((StrDesktopPath) & "\ScreenRes.dat")
'
If FSO.FileExists(DatFileLocation) = False Then
'
	FileHere = False
'
While FileHere = False
'
If FSO.FileExists(DatFileLocation) = True Then
'
	FileHere = True
'
Set ExtractData = FSO.OpenTextFile((DatFileLocation), ForReading)
'
	WScript.Sleep ((IntPause)*2)
'
	DataFromDatFile = ExtractData.ReadLine
'
	ExtractData.Close
'
	HTAScreenRes = Split((DataFromDatFile), "$", -1, 1)
'
	IntHorizontal = Trim(HTAScreenRes(0))
	IntVertical = Trim(HTAScreenRes(1))
'
	Msgbox ScrnHoriz & VbTab & IntHorizontal & VbCrLf & ScrnVerti & VbTab & IntVertical,VbSystemModal+VbExclamation+VbOkOnly,ScrnRestn
'
	WScript.Sleep ((IntPause)*3)
'
If FSO.FileExists(DatFileLocation) Then
'
	FSO.DeleteFile(DatFileLocation)
	FSO.DeleteFile(HTApath)
'
End If
'
End If
'
Wend
'
End If
'
End Sub
'
For Each g1_ObjItem in g1_ObjItems
'
With g1_ObjItem
'
	IntHorizontal = .ScreenWidth
	IntVertical = .ScreenHeight
'
End With
'
Next
'
If IsNull(intHorizontal) = True Or IsNull(IntVertical) = True Then
'
For Each g2_ObjItem in g2_ObjItems
'
With g2_ObjItem
'
	IntHorizontal = .ScreenWidth
	IntVertical = .ScreenHeight
'
End With
'
Next
'
End If
'
If IsNull(intHorizontal) = True Or IsNull(IntVertical) = True Then
'
For Each g3_ObjItem in g3_ObjItems
'
With g3_ObjItem
'
	IntHorizontal = .CurrentHorizontalResolution
	IntVertical = .CurrentVerticalResolution
'
End With
'
Next
'
End If 
'
If IntVertical = VbNullString Or IntVertical = " " Or IntVertical < 1 Or _
	IntHorizontal = VbNullString Or IntHorizontal = " " Or IntHorizontal < 1 Then
'
	HTAquestion = Msgbox(gResFail01 & VbCrLf & gResFail02, VbApplicationModal+VbExclamation+VbYesNo, gResFail03)
'
Select Case HTAquestion
'
Case VbYes:
'
Call GUIHTApp()
'
	WScript.Sleep ((IntPause)*2)
'
	WshShell.Run (HTApath)
'
Call ReadDataFile()
'
Case VbNo:
Wscript.Quit
'
End Select
'
Else
'
	Msgbox ScrnHoriz & VbTab & IntHorizontal & VbCrLf & ScrnVerti & VbTab & IntVertical, _
		VbSystemModal+VbExclamation+VbOkOnly, ScrnRestn
'
End If
'
'================================================================================================================
'			The "commented-out" lines of code below shouldn't be removed. 				|
'================================================================================================================
'
'<%START%>
'<htm><head><title>ScreenResolution</title></head>
'<p><font face="Courier New" size="2" color="#FFFFFF">Please wait while the data is being collected</font></p>
'
'<
'	HTA:APPLICATION 
'
'	ID=			"g_ScreenRes"
'	APPLICATIONNAME=	"g_ScreenRes"
'	CAPTION=		"ScreenResolution"
'	BORDER=			"Thin"
'	CONTEXTMENU=		"Yes"
'	ICON=			"NONE" 
'	MAXIMIZEBUTTON=		"No"
'	MINIMIZEBUTTON=		"No"
'	RESIZE=			"No"
'	SCROLL=			"No"
'	SINGLEINSTANCE=		"Yes"
'	WINDOWSTATE=		"Normal" 
'/>
'
'<Body Onload="VBScript:SubMain()" BGColor=Black TopMargin=0 LeftMargin=0>
'
'<p><font face="Courier New" size="2" color="#FFFFFF">Starting the VBScript...</font></p>
'
'<Script Language = "VBScript">
'
'Public Const ResFile = "\ScreenRes.dat"
'
'Public Const MBOXfe1 = "The resolution file already exists."
'Public Const MBOXfe2 = "Do you want to delete it now ?"
'Public Const MBOXfe3 = "Screen Resolution"
'
'Public Const ForWriting = 2
'
'Dim FSO
'Dim WshShell
'
'Dim IntHorizontal
'Dim IntVertical
'
'Set FSO = CreateObject("Scripting.FileSystemObject")
'Set WshShell = CreateObject("Wscript.Shell")
'
'Dim StrDesktop
'Dim ObjDataFile
'
'Public Sub SubMain()
'On Error Resume Next
'
'Dim Question
'
'	IntHorizontal = Screen.AvailWidth
'	IntVertical = Screen.AvailHeight
'
'	StrDesktop = WshShell.SpecialFolders("Desktop")
'
'	ResFullPath = StrDesktop & ResFile
'
'If FSO.FileExists(ResFullPath) Then
'
'	Question = Msgbox(MBOXfe1 & VbCrLf & MBOXfe2, VbExclamation+VbSystemModal+VbYesNoCancel, MBOXfe3)
'
'Select Case Question
'
'Case VbYes
'
' 	FSO.DeleteFile(ResFullPath)
'
'Call SubMain()
'
'Case VbNo
'
'	Window.Close()
'
'Case VbCancel
'
'	Window.Close()
'
'End Select
'
'Else
'
'Set ObjDataFile = FSO.CreateTextFile((ResFullPath), True)
'
'With ObjDataFile
'
'	.Write ((IntHorizontal) & "$" & (IntVertical))
' 	.Close
'
'End With
'
'Document.body.insertAdjacentHTML "BeforeEnd", "<p><font face=""Courier New"" size=""2"" color=""#FFFFFF"">Completed the screen resolution script.</font></p>"
'
'	Window.setTimeout "VBScript:SubTerminate()", 1000
'
'End If
'
'End Sub
'
'Public Sub SubTerminate()
'On Error GoTo 0
'
'Set FSO = Nothing
'Set WshShell = Nothing
'
'	Window.Close()
'
'End Sub
'
'</Script></Body></htm>
'
'<%STOP%>


Other 18 submission(s) by this author

 


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this code (in the Beginner category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.