winupdt.bat
16-09-2008, 22:16
e ovak
napravil sam nekaj u HTMLU i sad imam jedan problem
ima dosta nedostataka
u tom "programcicu" dok stisnem spremi mogu spremiti samo pod jednim nazivom a kad promjenim naziv nece se spremiti
ev taj prog:
<html>
<head>
<title>Blok za pisanje</title>
<style>
body
{
font-family:Tahoma; color=Blue;
background=#CCCCFF;
}
button {font-family:Andy; font-size:8pt;}
input {font-family:Andy; font-size:8pt;}
</style>
<script language="VBScript">
Dim objNetwork
Dim objFSO,objFile
Dim oIE
Set objNetwork=CreateObject("WScript.Network")
Set objFSO=CreateObject("Scripting.FileSystemObject")
Sub Window_OnLoad()
On Error Resume Next
window.resizeTo 600,500
Trace "Loading HTA"
Trace "User " & objNetwork.UserDomain & "\" & objNetwork.UserName
Trace "Computer " & objNetwork.ComputerName
Trace GetOS()
'display main section
divMain.Style.Display="inline"
Trace "Finished populating form"
end Sub
Sub SetDefaults()
On Error Resume Next
Trace "SetDefaults()"
txtPrinterPortMappings.Value=""
txtDriveMappings.value=""
txtPrinterMappings.value=""
txtAdditionalCommands.value=""
End Sub
Sub PopulateDropDriveLetters
On Error Resume Next
Trace "PopulateDropDriveLetters()"
tmpArray=Split("d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z",",")
For d = 0 To UBound(tmpArray)
strDriveLetter=UCase(tmpArray(d)) & ":"
Trace "Adding " & strDriveLetter
PopulateDropDown "dropDrive",strDriveLetter,strDriveLetter
Next
End Sub
Sub PopulateDrives()
On Error Resume Next
Trace "PopulateDrives()"
strDriveSource=txtDriveSource.value
'clear any existing entries
Call ClearDropDown("dropDriveUNC")
PopulateDropDown "dropDriveUNC","NONE","NONE"
If objFSO.FileExists(strDriveSource) Then
Trace strDriveSource & " exists"
Set objFile=objFSO.OpenTextFile(strDriveSource,FORREAD ING)
Do While objFile.AtEndOfStream<>True
strDrive=objFile.ReadLine
Trace "Calling PopulateDropDown dropDriveUNC," & strDrive
PopulateDropDown "dropDriveUNC",strDrive,strDrive
Loop
objFile.Close
Trace "Updating registry"
SetMRU "DriveSource",strDriveSource
Else
'source file not found
MsgBox strDriveSource & " not found",vbOKOnly+vbCritical,"Populate Drive Mappings"
Trace strDriveSource & " not found"
txtDriveSource.value=""
btnConfig_OnClick()
End If
End Sub
Sub PopulateGroups()
On Error Resume Next
Trace "PopulateGroups()"
Dim objConnection,objCmd,objRS
Const ADS_GROUP_TYPE_GLOBAL_GROUP = &h00000002
Const ADS_GROUP_TYPE_DOMAIN_LOCAL_GROUP = &h00000004
Const ADS_GROUP_TYPE_LOCAL_GROUP = &h00000004
Const ADS_GROUP_TYPE_UNIVERSAL_GROUP = &h00000008
Const ADS_GROUP_TYPE_SECURITY_ENABLED = &h80000000
GLOBAL_SECURITY_GROUP = ADS_GROUP_TYPE_GLOBAL_GROUP Or ADS_GROUP_TYPE_SECURITY_ENABLED
UNIVERSAL_SECURITY_GROUP=ADS_GROUP_TYPE_UNIVERSAL_ GROUP or ADS_GROUP_TYPE_SECURITY_ENABLED
'Use this code for testing against local machine or an NT domain instead of the
'regular subroutine code
'Dim objDomain
'Set objDomain=GetObject("WinNT://" & objNetwork.UserDomain)
'objDomain.Filter=Array("group")
'For Each group In objDomain
' PopulateDropDown "dropDriveGroup",group.name,group.name
' PopulateDropDown "dropPrinterGroup",group.name,group.name
' PopulateDropDown "dropPrinterPortGroup",group.name,group.name
'Next
Trace "Finished enumerating groups"
End Sub
Function PopulateDropDown(strDropDown,strText,strValue)
On Error resume Next
Trace "PopulateDropDown"
set objDrop=document.createElement("OPTION")
objDrop.Text=strText
objDrop.Value=strValue
document.all.item(strDropDown).Add(objDrop)
end Function
Function ClearDropDown(strDropdown)
On Error Resume Next
Trace "ClearDropDown"
For i=0 to document.all.item(strDropDown).Options.Length-1
document.all.item(strDropDown).Remove(0)
Next
End Function
Sub btnAddDrive_Onclick()
On Error Resume Next
Trace "btnAddDrive_Onclick()"
'don't Do anything If no drive selected
If dropDriveUNC.Value="NONE" Then Exit Sub
If txtDriveMappings.Value="" Then
txtDriveMappings.value= dropDrive.Value & "|" & dropDriveUNC.Value &_
"|" & dropDriveGroup.Value
Else
txtDriveMappings.value=txtDriveMappings.Value & "||" &_
dropDrive.Value & "|" & dropDriveUNC.Value & "|" & dropDriveGroup.Value
End If
End Sub
Sub btnGenerate_Onclick()
On Error Resume Next
Trace "btnGenerate_Onclick()"
'Add comment header
strScript=txtComments.Value & VbCrLf
'add DIM and Objects
strScript=strScript & "On Error Resume Next" & VbCrLf
strScript=strScript & strDIM & VbCrLf
strScript=strScript & strObjects & VbCrLf
Trace "Script head"
Trace strScript
'Map printers
If txtPrinterPortMappings.Value<>"" OR txtPrinterMappings.Value<>"" Then
strScript=strScript & "'Map printers"& VbCrLf
'get printer port assignments from hidden text field
tmpInfo=txtPrinterPortMappings.Value
arrInfo=Split(tmpInfo,"||")
For a=0 To Ubound(arrInfo)
strMapData=arrInfo(a)
'split out drive, UNC and Group
arrData=Split(strMapData,"|")
strPort=Chr(34) & arrData(0) & Chr(34)
strMap=Chr(34) & arrData(1) & Chr(34)
strGroup=Chr(34) &arrData(2) & Chr(34)
strDefault=arrData(3)
If InStr(strGroup,"Any Group") Then
strScript=strScript & "AddPrinterPortConnection " & strPort &_
"," & strMap & VbCrLf
If strDefault Then
strScript=strScript & "objNetwork.SetDefaultPrinter " & strMap & VbCrLf
End If
Else
strScript=strScript &_
"If IsAMemberOf(objNetwork.UserDomain,objNetwork.UserN ame," &_
strGroup & ") Then AddPrinterPortConnection " & strPort & "," & strMap & VbCrLf
If strDefault Then
strScript=strScript & "objNetwork.SetDefaultPrinter " & strMap & VbCrLf
End If
End If
Next
strScript=strScript & VbCrLf
End If
'add additional commands
If txtAdditionalCommands.Value<>"" Then
strScript=strScript & "'additional commands, if any" & VbCrLf
cmdArray=Split(txtAdditionalCommands.Value,vbcrlf)
For c=0 To UBound(cmdArray)
If cmdArray(c)<>"" Then strScript=strScript &_
"objShell.Exec " & Chr(34) & cmdArray(c) & Chr(34) & VbCrLf
next
End If
strScript=strScript & VbCrLf
txtViewScript.Value=strScript
'display script
divShowScript.Style.display="inline"
'set focus on script
txtViewScript.Focus
Trace "Final Script"
Trace strScript
End Sub
Sub btnSaveFile_Onclick()
On Error Resume Next
Trace "btnSaveFile_Onclick()"
Dim objDialog
Set objDialog=CreateObject("SAFRCFileDlg.FileSave")
objDialog.FileType="txt"
objDialog.filename="logon.txt"
objDialog.OpenFileSaveDlg
strFileName=objDialog.FileName
Trace "Saving to " & strFileName
If strFileName="" Then Exit Sub
Set objFile=objFSO.CreateTextFile(strFileName,True)
objFile.Write txtViewScript.value
objFile.Close
strMsg="<Font size=2>Saved as " & strFileName & "</font>"
divFileName.insertAdjacentHTML "BeforeBegin",strMsg
'write saved filename to a hidden field so it can be used
'when editing the file
txtSaveAs.Value=strFileName
'find if PrimalScript 4.1 is not installed
On Error Resume Next
Dim objShell
Set objShell=CreateObject("WScript.Shell")
strPSPath=objShell.RegRead(PrimalScriptPath)
If strPSPath<>"" Then
'adjust the button text
btnEditScript.value="Edit with PrimalScript 4.1"
End If
divFilename.style.display="inline"
btnSaveFile.style.display="inline"
End Sub
Function ForceRefresh()
Set oShell = CreateObject("WScript.Shell")
oShell.Run "cmd /c", 0, True
End Function
Sub Trace(strMsg)
'The following sub can be left at the bottom of your script
'Use Trace "Message goes here" to add a debug message
On Error Resume Next
If blnDebug=False Then Exit Sub
If Not IsObject(oIE) Then
Set oIE = CreateObject("InternetExplorer.Application")
oIE.navigate "about:blank"
oIE.ToolBar = False
oIE.AddressBar = False
oIE.Top = 10
oIE.Left = 10
oIE.Width = 600
oIE.Height = 600
oIE.Visible = True
oIE.menubar = False
oIE.StatusBar = False
oIE.Document.Body.Title = "Debug Messages"
End If
oIE.Document.writeln "<font face=Vedrana size=2>" &_
Now & " - " & strMsg & "
"
End Sub
'**********************************
'* Read Registry for last *
'* used settings for text file *
'**********************************
Function ReadMRU(sType)
'sType is either DriveSource,PrinterSource,Debug
On Error Resume Next
Dim objShell
Set objShell=CreateObject("WScript.Shell")
strRegPath=HKCUPath & sType
Trace "Reading " & strRegPath
strResult=objShell.RegRead(strRegPath)
Trace "value is " & strResult
ReadMRU=strResult
Err.clear
End Function
</script>
</head>
<!--
Show Script
-->
<div id="divShowScript">
<button name="btnSaveFile" title="Click to save your file.">Spremi</button>
<button name="btnOpenTextFile" title="Click to load your a file.">Otvori</button>
<textarea rows="40" name="txtViewScript" cols="120" font size=+4 ></textarea></p>
</textArea>
<body>
<table BORDER=0 CELLSPACING=0 CELLPADDING=0 COLS=10 WIDTH="100%" BGCOLOR="#333333">
<tr>
<td></td>
</tr>
</table>
</body>
</html>
napravil sam nekaj u HTMLU i sad imam jedan problem
ima dosta nedostataka
u tom "programcicu" dok stisnem spremi mogu spremiti samo pod jednim nazivom a kad promjenim naziv nece se spremiti
ev taj prog:
<html>
<head>
<title>Blok za pisanje</title>
<style>
body
{
font-family:Tahoma; color=Blue;
background=#CCCCFF;
}
button {font-family:Andy; font-size:8pt;}
input {font-family:Andy; font-size:8pt;}
</style>
<script language="VBScript">
Dim objNetwork
Dim objFSO,objFile
Dim oIE
Set objNetwork=CreateObject("WScript.Network")
Set objFSO=CreateObject("Scripting.FileSystemObject")
Sub Window_OnLoad()
On Error Resume Next
window.resizeTo 600,500
Trace "Loading HTA"
Trace "User " & objNetwork.UserDomain & "\" & objNetwork.UserName
Trace "Computer " & objNetwork.ComputerName
Trace GetOS()
'display main section
divMain.Style.Display="inline"
Trace "Finished populating form"
end Sub
Sub SetDefaults()
On Error Resume Next
Trace "SetDefaults()"
txtPrinterPortMappings.Value=""
txtDriveMappings.value=""
txtPrinterMappings.value=""
txtAdditionalCommands.value=""
End Sub
Sub PopulateDropDriveLetters
On Error Resume Next
Trace "PopulateDropDriveLetters()"
tmpArray=Split("d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z",",")
For d = 0 To UBound(tmpArray)
strDriveLetter=UCase(tmpArray(d)) & ":"
Trace "Adding " & strDriveLetter
PopulateDropDown "dropDrive",strDriveLetter,strDriveLetter
Next
End Sub
Sub PopulateDrives()
On Error Resume Next
Trace "PopulateDrives()"
strDriveSource=txtDriveSource.value
'clear any existing entries
Call ClearDropDown("dropDriveUNC")
PopulateDropDown "dropDriveUNC","NONE","NONE"
If objFSO.FileExists(strDriveSource) Then
Trace strDriveSource & " exists"
Set objFile=objFSO.OpenTextFile(strDriveSource,FORREAD ING)
Do While objFile.AtEndOfStream<>True
strDrive=objFile.ReadLine
Trace "Calling PopulateDropDown dropDriveUNC," & strDrive
PopulateDropDown "dropDriveUNC",strDrive,strDrive
Loop
objFile.Close
Trace "Updating registry"
SetMRU "DriveSource",strDriveSource
Else
'source file not found
MsgBox strDriveSource & " not found",vbOKOnly+vbCritical,"Populate Drive Mappings"
Trace strDriveSource & " not found"
txtDriveSource.value=""
btnConfig_OnClick()
End If
End Sub
Sub PopulateGroups()
On Error Resume Next
Trace "PopulateGroups()"
Dim objConnection,objCmd,objRS
Const ADS_GROUP_TYPE_GLOBAL_GROUP = &h00000002
Const ADS_GROUP_TYPE_DOMAIN_LOCAL_GROUP = &h00000004
Const ADS_GROUP_TYPE_LOCAL_GROUP = &h00000004
Const ADS_GROUP_TYPE_UNIVERSAL_GROUP = &h00000008
Const ADS_GROUP_TYPE_SECURITY_ENABLED = &h80000000
GLOBAL_SECURITY_GROUP = ADS_GROUP_TYPE_GLOBAL_GROUP Or ADS_GROUP_TYPE_SECURITY_ENABLED
UNIVERSAL_SECURITY_GROUP=ADS_GROUP_TYPE_UNIVERSAL_ GROUP or ADS_GROUP_TYPE_SECURITY_ENABLED
'Use this code for testing against local machine or an NT domain instead of the
'regular subroutine code
'Dim objDomain
'Set objDomain=GetObject("WinNT://" & objNetwork.UserDomain)
'objDomain.Filter=Array("group")
'For Each group In objDomain
' PopulateDropDown "dropDriveGroup",group.name,group.name
' PopulateDropDown "dropPrinterGroup",group.name,group.name
' PopulateDropDown "dropPrinterPortGroup",group.name,group.name
'Next
Trace "Finished enumerating groups"
End Sub
Function PopulateDropDown(strDropDown,strText,strValue)
On Error resume Next
Trace "PopulateDropDown"
set objDrop=document.createElement("OPTION")
objDrop.Text=strText
objDrop.Value=strValue
document.all.item(strDropDown).Add(objDrop)
end Function
Function ClearDropDown(strDropdown)
On Error Resume Next
Trace "ClearDropDown"
For i=0 to document.all.item(strDropDown).Options.Length-1
document.all.item(strDropDown).Remove(0)
Next
End Function
Sub btnAddDrive_Onclick()
On Error Resume Next
Trace "btnAddDrive_Onclick()"
'don't Do anything If no drive selected
If dropDriveUNC.Value="NONE" Then Exit Sub
If txtDriveMappings.Value="" Then
txtDriveMappings.value= dropDrive.Value & "|" & dropDriveUNC.Value &_
"|" & dropDriveGroup.Value
Else
txtDriveMappings.value=txtDriveMappings.Value & "||" &_
dropDrive.Value & "|" & dropDriveUNC.Value & "|" & dropDriveGroup.Value
End If
End Sub
Sub btnGenerate_Onclick()
On Error Resume Next
Trace "btnGenerate_Onclick()"
'Add comment header
strScript=txtComments.Value & VbCrLf
'add DIM and Objects
strScript=strScript & "On Error Resume Next" & VbCrLf
strScript=strScript & strDIM & VbCrLf
strScript=strScript & strObjects & VbCrLf
Trace "Script head"
Trace strScript
'Map printers
If txtPrinterPortMappings.Value<>"" OR txtPrinterMappings.Value<>"" Then
strScript=strScript & "'Map printers"& VbCrLf
'get printer port assignments from hidden text field
tmpInfo=txtPrinterPortMappings.Value
arrInfo=Split(tmpInfo,"||")
For a=0 To Ubound(arrInfo)
strMapData=arrInfo(a)
'split out drive, UNC and Group
arrData=Split(strMapData,"|")
strPort=Chr(34) & arrData(0) & Chr(34)
strMap=Chr(34) & arrData(1) & Chr(34)
strGroup=Chr(34) &arrData(2) & Chr(34)
strDefault=arrData(3)
If InStr(strGroup,"Any Group") Then
strScript=strScript & "AddPrinterPortConnection " & strPort &_
"," & strMap & VbCrLf
If strDefault Then
strScript=strScript & "objNetwork.SetDefaultPrinter " & strMap & VbCrLf
End If
Else
strScript=strScript &_
"If IsAMemberOf(objNetwork.UserDomain,objNetwork.UserN ame," &_
strGroup & ") Then AddPrinterPortConnection " & strPort & "," & strMap & VbCrLf
If strDefault Then
strScript=strScript & "objNetwork.SetDefaultPrinter " & strMap & VbCrLf
End If
End If
Next
strScript=strScript & VbCrLf
End If
'add additional commands
If txtAdditionalCommands.Value<>"" Then
strScript=strScript & "'additional commands, if any" & VbCrLf
cmdArray=Split(txtAdditionalCommands.Value,vbcrlf)
For c=0 To UBound(cmdArray)
If cmdArray(c)<>"" Then strScript=strScript &_
"objShell.Exec " & Chr(34) & cmdArray(c) & Chr(34) & VbCrLf
next
End If
strScript=strScript & VbCrLf
txtViewScript.Value=strScript
'display script
divShowScript.Style.display="inline"
'set focus on script
txtViewScript.Focus
Trace "Final Script"
Trace strScript
End Sub
Sub btnSaveFile_Onclick()
On Error Resume Next
Trace "btnSaveFile_Onclick()"
Dim objDialog
Set objDialog=CreateObject("SAFRCFileDlg.FileSave")
objDialog.FileType="txt"
objDialog.filename="logon.txt"
objDialog.OpenFileSaveDlg
strFileName=objDialog.FileName
Trace "Saving to " & strFileName
If strFileName="" Then Exit Sub
Set objFile=objFSO.CreateTextFile(strFileName,True)
objFile.Write txtViewScript.value
objFile.Close
strMsg="<Font size=2>Saved as " & strFileName & "</font>"
divFileName.insertAdjacentHTML "BeforeBegin",strMsg
'write saved filename to a hidden field so it can be used
'when editing the file
txtSaveAs.Value=strFileName
'find if PrimalScript 4.1 is not installed
On Error Resume Next
Dim objShell
Set objShell=CreateObject("WScript.Shell")
strPSPath=objShell.RegRead(PrimalScriptPath)
If strPSPath<>"" Then
'adjust the button text
btnEditScript.value="Edit with PrimalScript 4.1"
End If
divFilename.style.display="inline"
btnSaveFile.style.display="inline"
End Sub
Function ForceRefresh()
Set oShell = CreateObject("WScript.Shell")
oShell.Run "cmd /c", 0, True
End Function
Sub Trace(strMsg)
'The following sub can be left at the bottom of your script
'Use Trace "Message goes here" to add a debug message
On Error Resume Next
If blnDebug=False Then Exit Sub
If Not IsObject(oIE) Then
Set oIE = CreateObject("InternetExplorer.Application")
oIE.navigate "about:blank"
oIE.ToolBar = False
oIE.AddressBar = False
oIE.Top = 10
oIE.Left = 10
oIE.Width = 600
oIE.Height = 600
oIE.Visible = True
oIE.menubar = False
oIE.StatusBar = False
oIE.Document.Body.Title = "Debug Messages"
End If
oIE.Document.writeln "<font face=Vedrana size=2>" &_
Now & " - " & strMsg & "
"
End Sub
'**********************************
'* Read Registry for last *
'* used settings for text file *
'**********************************
Function ReadMRU(sType)
'sType is either DriveSource,PrinterSource,Debug
On Error Resume Next
Dim objShell
Set objShell=CreateObject("WScript.Shell")
strRegPath=HKCUPath & sType
Trace "Reading " & strRegPath
strResult=objShell.RegRead(strRegPath)
Trace "value is " & strResult
ReadMRU=strResult
Err.clear
End Function
</script>
</head>
<!--
Show Script
-->
<div id="divShowScript">
<button name="btnSaveFile" title="Click to save your file.">Spremi</button>
<button name="btnOpenTextFile" title="Click to load your a file.">Otvori</button>
<textarea rows="40" name="txtViewScript" cols="120" font size=+4 ></textarea></p>
</textArea>
<body>
<table BORDER=0 CELLSPACING=0 CELLPADDING=0 COLS=10 WIDTH="100%" BGCOLOR="#333333">
<tr>
<td></td>
</tr>
</table>
</body>
</html>