'************************************** ' Name: Windows 10: Obtaining Screen Res ' olution ' Description:This VBScript attempts fou ' r ways to obtain the Screen Resolution f ' rom the Windows Management Instrumentati ' on Object and a HTA application. ' By: A_X_O ' ' ' Inputs:None ' ' Returns:None ' 'Assumes:None ' 'Side Effects:None '************************************** ' '--------------------------------------- ' ---------------------------------------- ' '+++++++++++++++++++++++++++++++++++++++ ' ++++++++++++++++++++++++++++++++++++++++ ' ' Demonstration: Windows 10, Obtaining ' Desktop Resolution ' '+++++++++++++++++++++++++++++++++++++++ ' ++++++++++++++++++++++++++++++++++++++++ ' ' ' ' Purpose : Demonstrates WMI & Or HTA S ' creen Resolution ' ' -------------------------------------- ' --------------------------------- ' ' Creation Date : 30/04/2019 [dd/mm/yyyy ' ] ' ' Version : 1:2 ' ' Designer : Fabian ' ' ' '####################################### ' ######################################## ' ' MODIFICATION HISTORY ' '--------------------------------------- ' ---------------------------------------- ' ' ' ' Version : 1:0 30/04/2019 Create the S ' ample ' ' : 1:1 07/05/2019 Add HTA Code ' ' : 1:2 16/05/2019 Fix missing I/O Con ' st 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 be ' low shouldn't be removed. | '======================================= ' ======================================== ' ================================= ' '<%START%> '<htm><head><title>ScreenResolution</tit ' le></head> '<p><font face="Courier New" size="2" co ' lor="#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()" BGCol ' or=Black TopMargin=0 LeftMargin=0> ' '<p><font face="Courier New" size="2" co ' lor="#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 Resoluti ' on" ' 'Public Const ForWriting = 2 ' 'Dim FSO 'Dim WshShell ' 'Dim IntHorizontal 'Dim IntVertical ' 'Set FSO = CreateObject("Scripting.FileS ' ystemObject") 'Set WshShell = CreateObject("Wscript.Sh ' ell") ' '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 & M ' BOXfe2, VbExclamation+VbSystemModal+VbYe ' sNoCancel, 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((R ' esFullPath), True) ' 'With ObjDataFile ' ' .Write ((IntHorizontal) & "$" & (IntVe ' rtical)) ' .Close ' 'End With ' 'Document.body.insertAdjacentHTML "Befor ' eEnd", "<p><font face=""Courier New"" si ' ze=""2"" color=""#FFFFFF"">Completed the ' screen resolution script.</font></p>" ' ' Window.setTimeout "VBScript:SubTermina ' te()", 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%>