I am currently working on a game launcher and have working code borrowed from the Internet to be able to parse an INI. All is working excellently save for one issue.
It cannot parse inline comments on the ini file.
Example:
[Window]
Width=800
Is parsed fine and without issue, great.
[Window]
Width=800 ; width in pixels
But the above is not, I need it to be able to stop reading the line at detecting a ; if possible.
Here is my full HTA code:
<Html>
<Head>
<Title>Installer</Title>
<Meta Http-Equiv="x-ua-compatible" Content="ie=9">
<Link Rel="stylesheet" Type="text/css" Href="image/appStyles.css" Media="screen" />
<Script Language="VBScript" Type="Text/VBScript">
'-- Scripts to be carried out before the installer loads in.
'-- Functions --'
Function ReadIni( myFilePath, mySection, myKey )
' This function returns a value read from an INI file
' Examples
' ReadIni( "settings.config", "Section1", "Keyname1" )
' ReadIni( "settings.config", "Section1", "Keyname2" )
' ReadIni( "settings.config", "Section2", "Keyname1" )
' ReadIni( "settings.config", "Section4", "Keyname2" )
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Dim intEqualPos
Dim objFSO, objIniFile
Dim strFilePath, strKey, strLeftString, strLine, strSection
Set objFSO = CreateObject( "Scripting.FileSystemObject" )
ReadIni = ""
strFilePath = Trim( myFilePath )
strSection = Trim( mySection )
strKey = Trim( myKey )
If objFSO.FileExists( strFilePath ) Then
Set objIniFile = objFSO.OpenTextFile( strFilePath, ForReading, False )
Do While objIniFile.AtEndOfStream = False
strLine = Trim( objIniFile.ReadLine )
' Check if section is found in the current line
If LCase( strLine ) = "[" & LCase( strSection ) & "]" Then
strLine = Trim( objIniFile.ReadLine )
' Parse lines until the next section is reached
Do While Left( strLine, 1 ) <> "["
' Find position of equal sign in the line
intEqualPos = InStr( 1, strLine, "=", 1 )
If intEqualPos > 0 Then
strLeftString = Trim( Left( strLine, intEqualPos - 1 ) )
' Check if item is found in the current line
If LCase( strLeftString ) = LCase( strKey ) Then
ReadIni = Trim( Mid( strLine, intEqualPos + 1 ) )
' In case the item exists but value is blank
If ReadIni = "" Then
ReadIni = " "
End If
' Abort loop when item is found
Exit Do
End If
End If
' Abort if the end of the INI file is reached
If objIniFile.AtEndOfStream Then Exit Do
' Continue with next line
strLine = Trim( objIniFile.ReadLine )
Loop
Exit Do
End If
Loop
objIniFile.Close
Else
' WScript.Echo strFilePath & " doesn't exists. Exiting..."
' Wscript.Quit 1
End If
End Function
'-- Subroutines --'
'-- Resize & move app to center
Sub SetWindow( WidthX,HeightY )
Self.ResizeTo WidthX, HeightY
Self.MoveTo (screen.Width - WidthX)/2, (screen.Height - HeightY)/2
End Sub
'-- Close app
Sub WinClose
Self.Close
End Sub
'-- Startup --'
'-- Read the configuration settings.
IniFile = "settings.config"
WinWidth = ReadIni( IniFile, "Window", "Width" )
WinHeight = ReadIni( IniFile, "Window", "Height" )
'-- Set Window size
SetWindow WinWidth, WinHeight
</Script>
<Hta:Application Id="Installer" ApplicationName="Installer" Version="0.1"
SingleInstance="Yes"
Icon="image/appIcon.ico"
Caption="No"
Border="None"
InnerBorder="No"
ContextMenu="No"
SysMenu="None"
Scroll="No"
Selection="No"
/>
</Head>
<Body>
<Div Id="status">Hello</Div>
<Script Language="VBScript" Type="Text/VBScript">
'-- Scripts that require access to the DOM...
'-- Startup
document.getElementById("status").InnerHTML = "Idle"
document.title = ReadIni( IniFile, "App", "Title" )
</Script>
<Script Type="Text/Javascript">
//-- Javascripts that require access to the DOM...
window.onload = function() {
var a = document.getElementsByTagName("img");
a.ondragstart = function() { return false; }
}
</Script>
</Body>
</Html>
Any help you guys could provide would be great, thank you!
WinWidth = Trim(Split(ReadIni( IniFile, "Window", "Width" ), ";")(0))
Split the value using the semicolon, take the first element in the list and remove start/end spaces if present
Related
I've been trying to figure out this issue for 3 days now and I want to hurt myself.
I built a little utility to download files from a server. The script simply loops through a list of user-entered serials and appends each into the file url. It seems to perform fine for the most part until it hits a large file. "Large" being the third serial which is the one and only test case of 500mb I've encountered. The first two are less than 20mb. The smaller files download fine, but the larger file throws a "Not enough memory resources are available to complete this operation." error. I have 16gb of ram (barely utilized) and more than enough storage space.
Here's the really strange part, if I only attempt to download the 500mb file (enter only the last serial), sometimes it works. I cannot conclude what the cause is.
I've included a heavily stripped version of my code. I thought pulling pieces out might resolve the issue or at least shed some light, but it persists. I'd be grateful to anyone that can help me resolve this.
To recreate, copy my script below into a text file and rename extension from .txt to .hta. To use, enter the 3 serials below (including commas) into the text box and click download. The script creates the directory "C:\Downloads" and places downloaded files within:
Serials:
BLES01294,BCES00510,BLUS30109
My hta script:
<!DOCTYPE html>
<!-- saved from url=(0014)about:internet -->
<html style="display: inline-block;" id="mainHTML">
<head>
<meta http-equiv="x-ua-compatible" content="ie=9"/>
<title>Download Tool</title>
<!--Styles defined for doc (end)-->
<!--Scripts to control app window size, position, and behavior (start)-->
<script language="VBScript">
window.resizeTo 500,300
screenWidth = document.parentwindow.screen.availwidth
screenHeight = document.parentwindow.screen.availheight
posLeft = (screenWidth - 800) / 2
posTop = (screenHeight - 600) / 2
window.moveTo posLeft, posTop
</script>
<!--Scripts to control app window size, position, and behavior (end)-->
<!--Features of app window (start)-->
<HTA:APPLICATION ID="download tool"
APPLICATIONNAME="download tool
version="ver.2020.4.13"
CAPTION="yes"
BORDER="thin"
BORDERSTYLE="none"
ICON=""
CONTEXTMENU="yes"
MAXIMIZEBUTTON="no"
MINIMIZEBUTTON="yes"
NAVIGABLE="no"
SCROLL="no"
SCROLLFLAT="no"
SELECTION="no"
SHOWINTASKBAR="yes"
SINGLEINSTANCE="yes"
SYSMENU="yes"
WINDOWSTATE="normal">
</head>
<!--Features of app window (end)-->
<body style="display: inline-block;" id="mainBody" >
<div id="Menu" style="display: inline;"><br>
<center>
<span style="display:inline-block;" id="Span_APIText">
<center>
<Span style="display: inline-block;">
<span >
<textarea style="width:70%;" class="apitextarea" name="txtPS3SerialEntry" rows=6 id="txtPS3SerialEntry"/></textarea>
</span>
<span id="Span_Buttons2" style="display: inline-block;">
<br><br><button id="GetGameDataBtn" title="Browse for download directory" onclick="dataValidation()"><br>Download</button>
</span>
</span>
</center>
</span>
</center>
</div>
</div>
</body>
</html>
<script language="VBScript">
'=================================================
Function dataValidation()
'on error resume next
noBlanks = ""
EntryTest = trim(ucase(document.getelementbyID("txtPS3SerialEntry").value))
if EntryTest = "" then
alert "No valid API numbers found in list"
exit function
elseif EntryTest <> "" then
document.getelementbyID("txtPS3SerialEntry").value = replace(EntryTest,",",vblf)
chkBlankLines = split(document.getelementbyID("txtPS3SerialEntry").value,vblf)
else
chkBlankLines = split(document.getelementbyID("txtPS3SerialEntry").value,vblf)
end if
for i = 0 to Ubound(chkBlankLines)
If Len(trim(chkBlankLines(i))) > 0 then
noBlanks = noBlanks & chkBlankLines(i) & vbcrlf
End If
Next
if noBlanks = "" then
alert "No valid API numbers found in list"
exit function
Else
document.getelementbyID("txtPS3SerialEntry").value = trim(noBlanks)
End If
chkNumeric = split(document.getelementbyID("txtPS3SerialEntry").value,vblf)
call getFiles()
end function
'========================================================
Sub ccSleep(seconds)
set oShell = CreateObject("Wscript.Shell")
cmd = "%COMSPEC% /c ping -n " & 1 + seconds & " 127.0.0.1>nul"
oShell.Run cmd,0,1
End Sub
'============================================================
Function ConvertSize(byteSize)
dim Size
Size = byteSize
Do While InStr(Size,",") 'Remove commas from size
CommaLocate = InStr(Size,",")
Size = Mid(Size,1,CommaLocate - 1) & _
Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate)
Loop
Suffix = " Bytes"
If Size >= 1024 Then suffix = " KB"
If Size >= 1048576 Then suffix = " MB"
If Size >= 1073741824 Then suffix = " GB"
If Size >= 1099511627776 Then suffix = " TB"
Select Case Suffix
Case " KB" Size = Round(Size / 1024, 1)
Case " MB" Size = Round(Size / 1048576, 1)
Case " GB" Size = Round(Size / 1073741824, 1)
Case " TB" Size = Round(Size / 1099511627776, 1)
End Select
ConvertSize = Size & Suffix
End Function
'========================================================================
'Main Function Start
'========================================================================
function GetFiles()
'on error resume next
Set fso = CreateObject("Scripting.FileSystemObject")
path = "c:\Downloads" 'fso.BuildPath("c:\Downloads","")
If NOT fso.FolderExists(path & "\") then
fso.CreateFolder(path & "\")
end if
arrStr = split(ucase(document.getelementbyID("txtPS3SerialEntry").value),vbLf)
APICount = Ubound(arrStr)
for i = 0 to Ubound(arrStr)
API = trim(arrStr(i))
if API <> "" then
Set IE = CreateObject("internetexplorer.application")
IE.Visible = false
IE.Navigate replace("https://a0.ww.np.dl.playstation.net/tpl/np/{game_id}/{game_id}-ver.xml","{game_id}",API)
Do While IE.Busy or IE.ReadyState <> 4: ccSleep(1): Loop
Do Until IE.Document.ReadyState = "complete": ccSleep(1): Loop
on error resume next
ie.document.getelementbyid("overridelink").click
on error goto 0
Do While IE.Busy or IE.ReadyState <> 4: ccSleep(1): Loop
Do Until IE.Document.ReadyState = "complete": ccSleep(1): Loop
'============================================================
id = API
'============================================================
'Grab xml elements from site
for each a in ie.document.getelementsbytagname("package")
ps3ver = a.getattribute("ps3_system_ver")
url = a.getattribute("url")
strFileSize = convertsize(a.getattribute("size"))
ver = a.getattribute("version")
strFileName = mid(url,instrrev(url,"/")+1)
'============================================================
filename = "c:\Downloads\" & strFileName
msgbox "Getting file: " & strFileName & " (" & strFileSize & ")"
Set xHttp = createobject("Microsoft.XMLHTTP")
Set bStrm = createobject("Adodb.Stream")
xHttp.Open "GET", url, false
xHttp.Send
'on error resume next
with bStrm
.type = 1 '//binary
.open
.write xHttp.responseBody
.savetofile filename, 2 '//overwrite
.close
end with
'on error goto 0
'----------------------------------------------------------------
Next
end if
Next 'APICount
ie.quit
end function
'========================================================================
</script>
I have this script that launches an HTA which needs to be started with admin rights.
Set objShell = CreateObject("Wscript.Shell")
isLocal = MsgBox("Launch app for a local configuration ?", vbYesNo + vbQuestion, "Settings")
If isLocal = vbYes Then
objShell.Run "src\Configurator.hta"
Else
'This code doesn't matter here
End If
This script runs fine when started normally, but when I execute the VBS as Administrator (via context menu), I get a File Not Found error for the objShell.Run "src\Configurator.hta" line.
When I add the following code, it gives the same result for both executionning methods (gives the directory where the script is executed).
scriptdir = CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName)
MsgBox scriptdir
Any help or explanation on this issue would be greatly appreciated.
You can take a look at this : Procedure to run HTA elevated
<html>
<head>
<title>HTA Helpomatic</title>
<HTA:APPLICATION
ID="oHTA"
APPLICATIONNAME="HTAHelpomatic"
SCROLL="yes"
SINGLEINSTANCE="yes"
>
<!-- ID="objHTAHelpomatic" -->
<!-- WINDOWSTATE="maximize" -->
</head>
<SCRIPT Language="VBScript">
If HTAElevate() = True Then
CreateObject("WScript.Shell").Run "mmc.exe compmgmt.msc", , True
Call Main()
End If
Sub Main()
MsgBox "HTA-Ende", 4096
End Sub
'*** v13.3 *** www.dieseyer.de *****************************
Function HTAElevate()
'***********************************************************
' Unter Windows x64 laufen VBS' nach einem Doppelklick in der x64-Umgebung
' mit %WinDi%\System32\wscript.exe oder mit %WinDi%\System32\cscript.exe.
' In der x64-Umgebung laufen VBS aber nicht (richtig). Die Prozedur
' HTAElevate() erkennt dies und startet ggf. das VBS in der
Const Elev = " /elevated"
' MsgBox oHTA.commandLine, , "5016 :: "
' Trace32Log "5018 :: oHTA.commandLine: ==" & oHTA.commandLine & "==", 1
HTAElevate = True
' If InStr( LCase( oHTA.commandLine ), Elev) > 0 then MsgBox oHTA.commandLine, , "5022 :: "
If InStr( LCase( oHTA.commandLine ), Elev) > 0 then Exit Function
On Error Resume Next
window.resizeto 750, 10 ' : window.moveto screen.width / 2, screen.height / 2
On Error GoTo 0
' MsgBox oHTA.commandLine, , "5030 :: "
createobject("Shell.Application").ShellExecute "mshta.exe", oHTA.commandLine & Elev, "", "runas", 1
HTAElevate = False
self.close
End Function ' HTAElevate()
</SCRIPT>
<body>
</body>
</html>
I am having trouble displaying a log file in the TextArea of a HTA while a robocopy script is running.
The script is simple enough, the user has one button to press to start the process, selects where they want to back up their data to, a Robocopy runs in the background and logs the work.
I cannot get the .log file to display live during the process and am always hit with an error 800A01B6.
Code below:
<html>
<head>
<title>Backup Script</title>
<HTA:APPLICATION
ID="Backup Script"
APPLICATIONNAME="Backup Script"
BORDER="thin"
SCROLL="no"
SINGLEINSTANCE="yes"
WINDOWSTATE="normal"
>
</head>
<SCRIPT Language="VBScript">
Sub Window_OnLoad
intWidth = 800
intHeight = 800
Me.ResizeTo intWidth, intHeight
Me.MoveTo ((Screen.Width / 2) - (intWidth / 2)),((Screen.Height / 2) - (intHeight / 2))
End Sub
Sub run_Backup_Script
Set WshShell = CreateObject("WScript.Shell")
Set WshNetwork = CreateObject("WScript.Network")
Dim NetSharedFolder, TargetLocalFolder, Settings
'Delete Log File bigger than 10MB
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FileExists("D:\Public\Backup.log") Then
Set file = oFSO.GetFile("D:\Public\Backup.log")
if file.Size >= 10485760 Then
oFSO.DeleteFile("D:\Public\Backup.log")
End If
End If
'Set Settings
Settings = " /MIR /FFT /R:3 /LOG+:D:\Public\Backup.log"
NetSharedFolder = "D:\LocalData\" & WshNetwork.UserName
'Select Target Folder
TargetLocalFolder = BrowseFolder( "Desktop", True , "Select a destination folder")
'Backup starts
objExecute = "RoboCopy.exe " & chr(34) & NetSharedFolder & chr(34) & " " & Chr(34) & TargetLocalFolder & chr(34) & " " & Settings & chr(34)
WshShell.Run objExecute, 0, True
DisplayOutput "D:\Public\Backup.log"
End Sub
'------------------------------------------------------------------------
Sub DisplayOutput(strFileName)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(strFileName, 1, False)
BasicTextArea.Text = BasicTextArea.Text & VbCrLf & objFile.ReadAll
objFile.Close
End Sub
'------------------------------------------------------------------------
Function BrowseFolder( myStartLocation, blnSimpleDialog, myMessage )
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0 ' Must ALWAYS be 0
Dim numOptions, objFolder, objFolderItem
Dim objPath, objShell, strPath, strPrompt
' Set the options for the dialog window
strPrompt = myMessage
If blnSimpleDialog = True Then
numOptions = 0 ' Simple dialog
Else
numOptions = &H10& ' Additional text field to type folder path
End If
' Create a Windows Shell object
Set objShell = CreateObject( "Shell.Application" )
' If specified, convert "My Computer" to a valid
' path for the Windows Shell's BrowseFolder method
If UCase( myStartLocation ) = "MY COMPUTER" Then
Set objFolder = objShell.Namespace( MY_COMPUTER )
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Else
strPath = myStartLocation
End If
Set objFolder = objShell.BrowseForFolder( WINDOW_HANDLE, strPrompt, _
numOptions, strPath )
' Quit if no folder was selected
If objFolder Is Nothing Then
BrowseFolder = ""
Exit Function
End If
' Retrieve the path of the selected folder
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
' Return the path of the selected folder
BrowseFolder = objPath
End Function
</SCRIPT>
'------------------------------------------------------------------------
<body STYLE="font:14 pt arial; color:white;filter:progid:DXImageTransform.Microsoft.Gradient
(GradientType=1, StartColorStr='#000033', EndColorStr='#0000FF')" onkeypress='vbs:Default_Buttons'>
<table width='90%' height = '50%' align='center' border='0'>
<tr>
<td align='center' colspan="4">
<h3>Backup Script</h3><br>
</td>
</tr
<tr>
<td align='center' colspan="2">
<table border="1">
<tr>
<td>
<input id="bt_Backup" type="button" value="Run Now" name="Run Now" onClick="vbs:run_Backup_Script">
</td>
</tr>
</table>
</body>
</br></br>
<textarea id="BasicTextArea" name="BasicTextArea" rows="5" cols="75"></textarea>
</html>
Can anyone see where I am going wrong?
Just wondering how i could have a MSgbox that displays the value of a variable as it constantly changes. Basically a number has one added to it everytime it loops. I want to display that in a MSGbox that doesnt have to open a million windows
A workaround would be to use PopUp
Set objShell = WScript.CreateObject("WScript.Shell")
For i = 1 To 3
objShell.Popup i, 1, "AutoClose MsgBox Simulation", vbInformation+vbOKOnly
Next
This will "autoclose" the MsgBox lookalike after 1 second
You can't do this with the default VBScript dialog elements, like MsgBox, WScript.Echo or Popup. You need to build a custom dialog using the Internet Explorer COM object:
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "about:blank"
While ie.ReadyState <> 4 : WScript.Sleep 100 : Wend
ie.ToolBar = False
ie.StatusBar = False
ie.Width = 300
ie.Height = 200
ie.document.body.innerHTML = "<p id='msg'>0</p>"
Set style = ie.document.CreateStyleSheet
style.AddRule "p", "text-align: center;"
ie.Visible = True
i = 1
Do
ie.document.getElementById("msg").innerText = i
i = i + 1
WScript.Sleep 2000
Loop Until i > 10
or use an HTA instead of plain VBScript:
<head>
<title>Test</title>
<HTA:APPLICATION ID="oHTA"
APPLICATIONNAME="Test"
SCROLL="no"
>
</head>
<style type="text/css">
p {text-align: center;}
</style>
<script language="VBScript">
window.resizeTo 300, 200
Set sh = CreateObject("WScript.Shell")
Sub Window_onLoad
For i = 1 To 10
msg.innerText = i
Sleep 2
Next
End Sub
Sub Sleep(t)
sh.Run "ping -n " & (t+1) & " 127.0.0.1", 0, True
End Sub
</script>
<body>
<p id="msg">0</p>
</body>
One more solution, uses HTA window, without temp files:
dim window, i
set window = createwindow()
window.document.write "<html><body bgcolor=buttonface>Current loop is: <span id='output'></span></body></html>"
window.document.title = "Processing..."
window.resizeto 300, 150
window.moveto 200, 200
for i = 0 to 32767
show i
' your code here
next
window.close
function show(value)
on error resume next
window.output.innerhtml = value
if err then wscript.quit
end function
function createwindow()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
dim signature, shellwnd, proc
on error resume next
set createwindow = nothing
signature = left(createobject("Scriptlet.TypeLib").guid, 38)
set proc = createobject("WScript.Shell").exec("mshta about:""<script>moveTo(-32000,-32000);</script><hta:application id=app border=dialog minimizebutton=no maximizebutton=no scroll=no showintaskbar=yes contextmenu=no selection=no innerborder=no /><object id='shellwindow' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shellwindow.putproperty('" & signature & "',document.parentWindow);</script>""")
do
if proc.status > 0 then exit function
for each shellwnd in createobject("Shell.Application").windows
set createwindow = shellwnd.getproperty(signature)
if err.number = 0 then exit function
err.clear
next
loop
end function
This script will display how many loops it took and the value of a variable during the loop, and display the results in 1 message box after the loop is complete.
Dim RateOfChange, roc, watchvariable : roc = 1 : watchvariable = 1
for i=1 to 25
watchvariable = (watchvariable * i) * 16
RateOfChange = RateOfChange & "Iteration[" & roc & "]" & " - Value[" & watchvariable & "]" & vbcrlf
roc = roc + 1
next
'NOTE uncomment this below to activate msgbox.
'msgbox rateofchange
wscript.echo rateofchange
So far I have:
Set objShell = WScript.CreateObject("WScript.Shell")
objShell.Run("""C:\Server01.rdp""")
But when I run it, nothing happens. Is it even possible to run an RDP file with VBScript? If so, then what am I doing wrong?
try calling mstsc.exe with the .rdp file name passed in:
objShell.Run(""mstsc C:\server01.rdp"")
I think you need to run mstsc.exe and pass the rdp file in as an argument.
http://technet.microsoft.com/en-us/library/cc753907%28WS.10%29.aspx
This will work: (In PHP with VBSCRIPT):
<script type="text/vbscript" language="vbscript">
<!--
const L_FullScreenWarn1_Text = "Your current security settings do not allow automatically switching to fullscreen mode."
const L_FullScreenWarn2_Text = "You can use ctrl-alt-pause to toggle your remote desktop session to fullscreen mode"
const L_FullScreenTitle_Text = "Remote Desktop Web Connection "
const L_ErrMsg_Text = "Error connecting to remote computer: "
const L_ClientNotSupportedWarning_Text = "Remote Desktop 6.0 does not support CredSSP over TSWeb."
const L_RemoteDesktopCaption_ErrorMessage = "Remote Desktop Connection"
const L_InvalidServerName_ErrorMessage = "An invalid server name was specified."
sub window_onload()
if not autoConnect() then
msgbox("VB")
end if
end sub
function autoConnect()
Dim sServer
Dim iFS, iAutoConnect
sServer = getQS ("Server")
iAutoConnect = getQS ("AutoConnect")
iFS = getQS ("FS")
if NOT IsNumeric ( iFS ) then
iFS = 0
else
iFS = CInt ( iFS )
end if
if iAutoConnect <> 1 then
autoConnect = false
exit function
else
if IsNull ( sServer ) or sServer = "" then
sServer = window.location.hostname
end if
btnConnect ()
autoConnect = true
end if
end function
function getQS ( sKey )
Dim iKeyPos, iDelimPos, iEndPos
Dim sURL, sRetVal
iKeyPos = iDelimPos = iEndPos = 0
sURL = window.location.href
if sKey = "" Or Len(sKey) < 1 then
getQS = ""
exit function
end if
iKeyPos = InStr ( 1, sURL, sKey )
if iKeyPos = 0 then
sRetVal = ""
exit function
end if
iDelimPos = InStr ( iKeyPos, sURL, "=" )
iEndPos = InStr ( iDelimPos, sURL, "&" )
if iEndPos = 0 then
sRetVal = Mid ( sURL, iDelimPos + 1 )
else
sRetVal = Mid ( sURL, iDelimPos + 1, iEndPos - iDelimPos - 1 )
end if
getQS = sRetVal
end function
sub OnControlLoadError
Msgbox("You wont be able to connect trough Remote Desktop")
end sub
sub OnControlLoad
set Control = Document.getElementById("MsRdpClient")
if Not Control is Nothing then
if Control.readyState = 4 then
BtnConnect()
else
Msgbox("You wont be able to connect trough Remote Desktop")
end if
else
Msgbox("You wont be able to connect trough Remote Desktop")
end if
end sub
sub BtnConnect
Dim serverName
serverName = "<?=$_POST["RDserver"]?>"
serverName = trim(serverName)
On Error Resume Next
MsRdpClient.server = serverName
If Err then
msgbox
L_InvalidServerName_ErrorMessage,0,L_RemoteDesktopCaption_ErrorMessage
Err.Clear
exit sub
end if
On Error Goto 0
Dim ClientUserName
ClientUserName = "<?=trim($_POST["RDuser"])?>"
MsRdpClient.UserName = ClientUserName
MsRdpClient.AdvancedSettings.ClearTextPassword = "<?=trim($_POST["RDpass"])?>"
MsRdpClient.FullScreen = TRUE
resWidth = screen.width
resHeight = screen.height
MsRdpClient.DesktopWidth = resWidth
MsRdpClient.DesktopHeight = resHeight
MsRdpClient.Width = resWidth
MsRdpClient.Height = resHeight
MsRdpClient.AdvancedSettings2.RedirectDrives = FALSE
MsRdpClient.AdvancedSettings2.RedirectPrinters = FALSE
MsRdpClient.AdvancedSettings2.RedirectPorts = FALSE
MsRdpClient.AdvancedSettings2.RedirectSmartCards = FALSE
MsRdpClient.FullScreenTitle = L_FullScreenTitle_Text & "-" & serverName & "-"
MsRdpClient.Connect
end sub
-->
</script>
<object id="MsRdpClient" language="vbscript" onreadystatechange="OnControlLoad" onerror="OnControlLoadError" classid="CLSID:4eb89ff4-7f78-4a0f-8b8d-2bf02e94e4b2" width="800" height="600"></object>
<script language="VBScript">
<!--
sub ReturnToConnectPage()
me.close
end sub
sub MsRdpClient_OnConnected()
end sub
sub MsRdpClient_OnDisconnected(disconnectCode)
extendedDiscReason = MsRdpClient.ExtendedDisconnectReason
majorDiscReason = disconnectCode And &hFF
if (disconnectCode = &hB08 or majorDiscReason = 2 or majorDiscReason = 1) and not (extendedDiscReason = 5) then
ReturnToConnectPage
exit sub
end if
errMsgText = MsRdpClient.GetErrorDescription(disconnectCode, extendedDiscReason)
if not errMsgText = "" then
msgbox errMsgText,0,L_RemoteDesktopCaption_ErrorMessage
end if
ReturnToConnectPage
end sub
-->
</script>
The problem is, that only works in IE, still looking for Firefox / Safari... any luck??