While running the agent, I am getting infinite loop error. This agent will get the values of documents. one of the value is request date and another one is response date. If the difference between these two is mre than 3, I need to pick that document and mail to one person. please help me out how to do that.
Sub Initialize
On Error GoTo ErrorOut
Dim sess As NotesSession
Dim db As NotesDatabase
Dim vwSearchRequests As NotesView
Dim reqNumColl As NotesDocumentCollection
Dim doc, searchDoc, reqNumDoc As NotesDocument
Dim body As NotesMIMEEntity
Dim header As NotesMIMEHeader
Dim stream As NotesStream
Dim reqPanelRes As Variant
Dim reqNum, totalNoRes, reqNumCount, total As Integer
Dim reqDate, reqDate1, reqDate2, firstresponse, reqSerLine, reqSerArea, reqIntType, response As String
Dim MailsendTime As New NotesDateTime("")
Dim CurDate As New NotesDateTime("")
Dim diff As Long
Dim diff1 As Long
Set sess = New NotesSession
Set db = sess.CurrentDatabase
Set vwSearchRequests = db.GetView("RequestDocConsolidated")
Set searchDoc = vwSearchRequests.GetFirstDocument
MsgBox "hello"
Set stream = sess.CreateStream
'sess.ConvertMIME = False ' Do not convert MIME to rich text
Set doc = db.CreateDocument
doc.Form = "Memo"
Set body = doc.CreateMIMEEntity
Set header = body.CreateHeader("Subject")
Call header.SetHeaderVal("myHire - Consolidated Report")
Set header = body.CreateHeader("To")
Call header.SetHeaderVal("Ashutosh Das/India/IBM#IBMIN")
Call stream.writetext(|<HTML>|)
Call stream.writetext(|<head>|)
Call stream.writetext(|<style>|)
Call stream.writetext(|table.gridtable{border-width: 1px; border-color: #666666; border-collapse: collapse; width: 95%;}|)
Call stream.writetext(|table.gridtable th{font-family: verdana,arial,sans-serif; font-size: 11px; color: #FFFFFF; border-width: 1px; padding: 4px; border-style: solid; border-color: #666666; background-color: #09092a;}|)
Call stream.writetext(|table.gridtable td{font-family: verdana,arial,sans-serif; font-size: 11px; color: #000000; border-width: 1px; padding: 4px; border-style: solid; border-color: #666666; background-color: #ffffff;}|)
Call stream.writetext(|</style>|)
Call stream.writetext(|</head>|)
Call stream.writetext(|<body bgcolor="white">|)
'Call stream.writetext(|<img src="\myHire_Header.jpg" alt="myHire">|)
Call stream.writetext(|<font style="font-family: verdana,arial,sans-serif; font-size: 13px; color: #333333;"><br><br>Report to show list of second line escalations gone out SL vise<br><br></font>|)
Call stream.writetext(|<table class="gridtable">|)
Call stream.writetext(|<tr>|)
Call stream.writetext(|<th>Service Line</th><th>Service Area</th><th>Date of Notification</th><th>Panel Name</th><th>Tech/PDM</th><th>Panel Manager</th><th>Date Escalation mail was sent</th><th>Manager response to first escalation</th><th>Date second escalation mail was sent</th><th>Manager response to second escalation</th>|)
Call stream.writetext(|</tr>|)
While Not searchDoc Is Nothing
reqNum = searchDoc.PS_RequestNo(0)
reqSerLine = searchDoc.PS_Service_Line(0)
reqSerArea = searchDoc.PS_Service_Area(0)
reqDate = CStr(Format(searchDoc.RequestSendDate(0),"dd/mm/yyyy hh:mm:ss"))
PanelId = searchDoc.PANELID(0)
PanelType = searchDoc.Panel_Type(0)
PeM_ID = searchDoc.PeM_NotesID(0)
PanelResponsedate = searchDoc.PanelResponsedate(0)
total = 0
MsgBox "Hi1"
Set reqNumColl = vwSearchRequests.GetAllDocumentsByKey(searchDoc.PS_RequestNo(0))
Set reqNumDoc = reqNumColl.GetFirstDocument
reqNumCount = reqNumColl.Count
For i = 1 To reqNumCount
If Not reqNumDoc.GetFirstItem("PanelResponse") Is Nothing Then
reqPanelRes = reqNumDoc.GetItemValue("PanelResponse")
Set MailsendTime = New NotesDateTime(searchDoc.REQUESTDATE(0))
Set CurDate = New NotesDateTime(Today)
diff = CurDate.TimeDifference(MailsendTime)
diff1 = CurDate.TimeDifference(searchDoc.PanelResponsedate(0))
NoDays = Int(diff/86400)
NoDays1 = Int(diff1/86400)
MsgBox "Hi2"
If CStr(reqPanelRes(0)) = "Accepted" Then
response = "Yes"
End If
If CStr(reqPanelRes(0)) = "Rejected" Then
response = "Yes"
End If
If CStr(reqPanelRes(0)) = "OOO" Then
response = "Yes"
End If
Else
response = "No"
End If
total = total + 1
reqDate1 = CStr(searchDoc.RequestSendDate(0)+ 2 )
reqDate2 = CStr(searchDoc.RequestSendDate(0)+ 3 )
Set reqNumDoc = reqNumColl.GetNextDocument(reqNumDoc)
MsgBox "Hi3"
If total = reqNumCount Then
Call stream.writetext(|<tr>|)
Call stream.writetext(|<td>| & reqSerLine & |</td><td>| & reqSerArea & |</td><td>| & reqdate & |</td><td>| & PanelId & |</td><td>| & PanelType & |</td><td>| & PeM_ID & |</td><td align=right>| & reqDate1 & |</td><td align=right>| & firstresponse & |</td><td align=right>| & reqdate2 & |</td><td align=right>| & CStr(response) & |</td>|)
Call stream.writetext(|</tr>|)
End If
Set searchDoc = vwSearchRequests.GetNextDocument(searchDoc)
Next
Wend
MsgBox "Hi4"
Call stream.writetext(|</table>|)
user$ = sess.CommonUserName 'if scheduled agent this returns the name of the server
'Below uses the ampersand (&) to concatenate user$
Call stream.writetext(|<br>|)
Call stream.writetext(|<font style="font-family: verdana,arial,sans-serif; font-size: 13px; color: #333333;">Thank you.<br><br>Regards,<br><br><b>myHire Team</b>.</font>|)
Call stream.writetext(|</body>|)
Call stream.writetext(|</html>|)
Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT)
Call doc.Send(False)
sess.ConvertMIME = True ' Restore conversion - very important
Exit Sub
ErrorOut:
Print "Error ocurred - Agent: agMailSendDailyReport; Error Line: " & Erl & "; Error: " & Error & "."
Exit Sub
End Sub
Your code line
Set searchDoc = vwSearchRequests.GetNextDocument(searchDoc)
should be after code line Next.
Otherwise, variable reqNumCount is at least for one document 0 and searchDoc stays the same for ever...
Related
This question already has answers here:
Inputbox() function in vbs
(2 answers)
Closed 2 months ago.
I need to change icon on left corner to atts.ico.
I tried
message=InputBox("ATTS","atts.ico","Enter text to speech.")
But it didn't work...
Refer to this link Multiline inputbox via HTA written by omegastripes
Just change the path to your icon in this line on this vbscript below : %windir%\system32\notepad.exe and give a test for it
dim completed,INPUT
INPUT=inputboxml("Enter text:", "Multiline inputbox via HTA", "default" & vbcrlf & vbtab & "multiline" & vbcrlf & "text")
CreateObject("SAPI.spVoice").speak INPUT
function inputboxml(prompt, title, defval)
set window = createwindow()
completed = 0
defval = replace(replace(replace(defval, "&", "&"), "<", "<"), ">", ">")
with window
with .document
.title = title
.body.style.background = "buttonface"
.body.style.fontfamily = "consolas, courier new"
.body.style.fontsize = "8pt"
.body.innerhtml = "<div><center><nobr>" & prompt & "</nobr><br><br></center><textarea id='hta_textarea' style='font-family: consolas, courier new; width: 100%; height: 580px;'>" & defval & "</textarea><br><button id='hta_cancel' style='font-family: consolas, courier new; width: 85px; margin: 10px; padding: 3px; float: right;'>Cancel</button><button id='hta_ok' style='font-family: consolas, courier new; width: 85px; margin: 10px; padding: 3px; float: right;'>OK</button></div>"
end with
.resizeto 700, 700
.moveto 300, 50
end with
window.hta_textarea.focus
set window.hta_cancel.onclick = getref("hta_cancel")
set window.hta_ok.onclick = getref("hta_ok")
set window.document.body.onunload = getref("hta_onunload")
do until completed > 0
wscript.sleep 10
loop
select case completed
case 1
inputboxml = ""
case 2
inputboxml = ""
window.close
case 3
inputboxml = window.hta_textarea.value
window.close
end select
end function
function createwindow()
rem source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
dim signature, shellwnd, proc
on error resume next
signature = left(createobject("Scriptlet.TypeLib").guid, 38)
do
set proc = createobject("WScript.Shell").exec("mshta ""about:<head><script>moveTo(-32000,-32000);</script><hta:application id=app border=dialog minimizebutton=no maximizebutton=no scroll=no showintaskbar=yes contextmenu=no selection=yes innerborder=no icon=""%windir%\system32\notepad.exe""/><object id='shellwindow' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shellwindow.putproperty('" & signature & "',document.parentWindow);</script></head>""")
do
if proc.status > 0 then exit do
for each shellwnd in createobject("Shell.Application").windows
set createwindow = shellwnd.getproperty(signature)
if err.number = 0 then exit function
err.clear
next
loop
loop
end function
sub hta_onunload
completed = 1
end sub
sub hta_cancel
completed = 2
end sub
sub hta_ok
completed = 3
end sub
I have a VBS script which I am using for Automation.
Every week it pulls most recent information from a database (most recent data is queried in database) I have the queries that get the most recent data sets (there are 2 of them), I have a function which creates the email, The only problem is that the output from the function that returns an array of the data is not outputting in a type, therefore I get a type error.
Script file and sample database are in hyperlinks at bottom of post.
Below is my code:
Class Email
Private toccbcc
Private ttl
Private htmlb1,htmlb2,htmlb3
Private Sub Class_Initialize()
toccbcc="aaaa#bbbb.com
htmlb1= "<html><body><p>" & _
"<table cellspacing=""0"" cellpadding=""0"" width=""630"" align=""left"" border=""0"" style=""border-collapse:collapse"">" & _
"<font size=""6""> <tr><td rowspan=""2"" style=""text-align:center; border:1px solid #000000; border-bottom:3px solid #000000;"" width=""105"">Type</td><td colspan=""2"" style=""text-align:center; border:1px solid #000000; border-bottom:line-height=1.8em, solid #000000;"" width=""105"">v2</td><td colspan=""2"" style=""text-align:center; border:1px solid #000000; border-bottom:line-height=1.8em solid #000000;"" width=""105"">v2</td></tr></font>"
htmlb3="<br><br>Thank you,<br>Name</p></body></html>"
ttl = DateValue(CStr(Now())) & " => " & DateValue(CStr(Now() + 6)) & " Type Pricing"
htmlb2=""
End Sub
Private Sub Class_Terminate()
End Sub
Public Sub SetHTMLTableBody(tmp)
For i=0 To UBound(tmp)
If I = 0 Then
htmlb2 = htmlb2 & "<font size=""4"">"
End If
For j=0 To UBound(tmp,2)
If (TMP(I,J) <> "") Then
If (I = 1) Then
htmlb2 = htmlb2 & "<td style=""text-align:center; border:1px solid #000000; border-bottom:3px solid #000000;"" width=""105"">"
Else
htmlb2 = htmlb2 & "<td style=""text-align:center; border:1px solid #000000; border-bottom:line-height=1.8em"" width=""105"">"
End If
If (I = 0) Then
htmlb2 = htmlb2 & "<b>" & TMP(I,J) & "</b>"
Else
htmlb2 = htmlb2 & TMP(I,J)
End If
htmlb2 = htmlb2 & "</td>"
End If
Next
If I = 1 Then
htmlb2 = htmlb2 & "</font>"
End If
htmlb2 = htmlb2 & "</tr>"
Next
End sub
Public Property Get HTMLBODY()
htmlbody=htmlb1&htmlb2&htmlb3
End Property
Public Property Get ToCC()
ToCC=toccbcc
End Property
Public Property Get Title()
Title=ttl
End property
End Class
Class Emailer
Dim objoutlook
Dim tmpmi
Dim eml
'Dim WshShell
Private Sub Class_Initialize()
'Set WshShell=WScript.CreateObject("WScript.shell")
'WshShell.Run "Outlook.exe"
Set objoutlook=CreateObject("Outlook.application")
WScript.Sleep 2000
End Sub
Private Sub Class_Terminate()
objoutlook.Quit
Set objoutlook=Nothing
Set eml=Nothing
Set tmpmi=Nothing
End Sub
Public Property Set Email(em)
Set eml=em
End Property
Public Sub SendEmail()
Set tmpmi=objoutlook.CreateItem(0)
With tmpmi
.To=eml.ToCC()
.Subject=eml.Title()
.HTMLBody=eml.HTMLBODY()
.ReadReceiptRequested = False
.Send
End with
End Sub
End Class
Public Sub RunEmailer()
Dim objaccess
Dim objoutlook
Dim WshShell
'Set WshShell=WScript.CreateObject("WScript.shell")
'WshShell.Run "Outlook.exe"
'WScript.Sleep 2000
Set objaccess=CreateObject("Access.Application")
objaccess.Visible=False
objaccess.OpenCurrentDatabase("...\SampleDatabase.accdb")
Dim eml
Dim emlr
Set emlr=New emailer
Set eml = New Email
Set emlr.Email=eml
eml.SetHTMLTableBody objaccess.Run("GetURV")
WScript.Sleep 2000
objaccess.CloseCurrentDatabase
objaccess.Quit
Set objaccess=Nothing
'Set emlr.Email=eml
'emlr.SendEmail
Set eml=Nothing
Set emlr=Nothing
End Sub
RunEmailer()
The problem is with the tmp() in SetHTMLTableBody(tmp) The first error I found, which prevents continuing is fount at the line If (TMP(I,J) <> "") Then. It considers what ever is returned to be an invalid data type. I have tried casting and nothing. whatever type it is being read as needs to be converted to a string because it will eventually go into an html body.
I have a version that is currently working, but it is not really efficient, and occasionally stops. My current process is below
The reason for wanting to send the message through vbs and not access is because outlook is closed through vbs, not access, therefore if the message isn't sent when when script tells outlook to close, Outlook brings up error message.
Also to lower CPU Usage (only one program open at a time).
The reason for using outlook is because this message is being sent to someone on the same email server.
Below are files that can be grabbed to test with.
Sample Database Here
VBS File Here
I came to the conclusion that the best way to do this was to have access create and return the html string because returning an array was not working, and then using CDONTS send the email.
I am trying to make multiple inputbox in one userform using vbscript instead of displaying one inputbox at a time i want to show multiple inputbox at once and then take entry from all of them but was unable to find any solution on internet too.
In my code second input box is coming after taking input from first inputbox and vice versa instead i want to take all the inputs at once using vbscript only not vba
sInput = InputBox("Enter your name")
MsgBox ("You entered:" & sInput)
sInput1 = InputBox("Enter your Age")
MsgBox ("You entered:" & sInput1)
sInput2 = InputBox("Enter email id you want to send")
sInput3 = InputBox("Enter Subject")
sInput4 = InputBox("Enter Email Body")
I found a vbscript code from #omegastripes multiline_inputbox_via_hta.vbs
I don't know if this answer can give you an idea or not?
dim completed
msgbox inputboxml("Enter text:", "Multiline inputbox via HTA", "Enter your name : " & vbcrlf & "Enter your Age : " & vbcrlf &_
"Enter email id you want to send : " & vbcrlf & "Enter Subject : " & vbcrlf & "Enter Email Body : " )
function inputboxml(prompt, title, defval)
set window = createwindow()
completed = 0
defval = replace(replace(replace(defval, "&", "&"), "<", "<"), ">", ">")
with window
with .document
.title = title
.body.style.background = "buttonface"
.body.style.fontfamily = "consolas, courier new"
.body.style.fontsize = "8pt"
.body.innerhtml = "<div><center><nobr>" & prompt & "</nobr><br><br></center><textarea id='hta_textarea' style='font-family: consolas, courier new; width: 100%; height: 400px;'>" & defval & "</textarea><br><button id='hta_cancel' style='font-family: consolas, courier new; width: 85px; margin: 10px; padding: 3px; float: right;'>Cancel</button><button id='hta_ok' style='font-family: consolas, courier new; width: 85px; margin: 10px; padding: 3px; float: right;'>OK</button></div>"
end with
.resizeto 550, 550
.moveto 100, 100
end with
window.hta_textarea.focus
set window.hta_cancel.onclick = getref("hta_cancel")
set window.hta_ok.onclick = getref("hta_ok")
set window.document.body.onunload = getref("hta_onunload")
do until completed > 0
wscript.sleep 10
loop
select case completed
case 1
inputboxml = ""
case 2
inputboxml = ""
window.close
case 3
inputboxml = window.hta_textarea.value
window.close
end select
end function
function createwindow()
rem source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
dim signature, shellwnd, proc
on error resume next
signature = left(createobject("Scriptlet.TypeLib").guid, 38)
do
set proc = createobject("WScript.Shell").exec("mshta ""about:<head><script>moveTo(-32000,-32000);</script><hta:application id=app border=dialog minimizebutton=no maximizebutton=no scroll=no showintaskbar=yes contextmenu=no selection=yes innerborder=no icon=""%windir%\system32\notepad.exe""/><object id='shellwindow' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shellwindow.putproperty('" & signature & "',document.parentWindow);</script></head>""")
do
if proc.status > 0 then exit do
for each shellwnd in createobject("Shell.Application").windows
set createwindow = shellwnd.getproperty(signature)
if err.number = 0 then exit function
err.clear
next
loop
loop
end function
sub hta_onunload
completed = 1
end sub
sub hta_cancel
completed = 2
end sub
sub hta_ok
completed = 3
end sub
Hello i have implemented my vbscript code in hta and it is working fine i am sharing my full code for future reference kindly paste it in notepad and save the notepad with .hta extension
(for your reference using vbscript i am trying to take input from user store it in excel with password protection and then send that excel file through outlook to the email id which user has provided --kindly note your outlook needs to be open and running before running this code and kindly provide some different excel path i have given my file path)
<HEAD>
<TITLE>Send Status of Task</TITLE>
<hta:application
applicationname="HTA Sample"
scroll="yes"
singleinstance'"yes"
>
</HEAD>
<SCRIPT language="vbscript">
Sub RunThisSubroutine
str1 = TextBox1.Value
str2 = TextBox2.Value
str3 = TextBox3.Value
str4 = TextBox4.Value
str5 = TextBox5.Value
msgBox str1 & ", " & str2 & ", " & str3 &"," & str4&"," & str5
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\saurabh.ad.sharma\Desktop\rrr.xlsx")
objExcel.Application.Visible = True
objExcel.Sheets(1).unprotect "saurabh"
Set rg = objExcel.Sheets(1).Range("A1")
lr = rg.CurrentRegion.Rows.Count
With rg
.Offset(lr, 0).Value = str1
.Offset(lr, 1).Value = str2
End With
objExcel.ActiveWorkbook.Save
objExcel.Sheets(1).protect "saurabh"
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
objMailItem.Display
strEmailAddr = str3
objMailItem.Recipients.Add strEmailAddr
objMailItem.Subject=str4
objMailItem.Body = str5
objMailItem.Attachments.Add "C:\Users\saurabh.ad.sharma\Desktop\rrr.xlsx"
objMailItem.Send
Set objMailItem = nothing
Set objOutl = nothing
End Sub
</SCRIPT>
<BODY STYLE="FONT:10 pt verdana; COLOR:black; filter:progid:DXImageTransform.Microsoft.Gradient(GradientType=0, StartColorStr='#FFCC66', EndColorStr='#FFFFFF')">
Hyper Text Applications make it easy to add user inputs: <BR>
<label for="Name ">Name:</label>
<input type="text" name="TextBox1" size="30"><BR><BR>
<label for="Age">Age :</label>
<input type="text" name="TextBox2" size="30"><BR><BR>
<label for="Send Email to">Send Email to:</label>
<input type="text" name="TextBox3" size="30" ><BR><BR>
<label for="Subject ">Subject:</label>
<input type="text" name="TextBox4" size="30" ><BR><BR>
<label for="Body">Body:</label>
<input type="text" name="TextBox5" size="30" ><BR><BR>
<input id=runbutton class= "button" type="button" value="Run" name="button1" onClick="RunThisSubroutine">
</BODY>
I dynamically create two columns in a table with column 1 having a bunch of buttons (to install apps on a remote PC) and column 2 being a multiple select box showing apps installed. I decided to add a span below the multiple select box showing the status of apps being installed or uninstalled via UninstallStatusArea.InnerText and weirdly the buttons in column 1 move down a line feed when UninstallStatusArea.InnerText contains characters, and then they move back up to their original location when UninstallStatusArea.InnerText = "".
Why is that, or asked another way, how can I make the two columns completely independent of one another? It's actually not a huge deal, rather just an academic exercise that bothers the heck out of me.
<html>
<head>
<title>Get System Information</title>
<HTA:APPLICATION
APPLICATIONNAME="Get System Information"
ID="GetPCInfo"
border="thin"
MAXIMIZEBUTTON="no"
SCROLL="NO"/>
</head>
<script language="VBScript">
Public ApplicationList()
Sub Window_OnLoad
document.body.bgColor = "Silver"
document.body.style.fontFamily = "Calibri"
document.body.style.fontSize = "12 pt"
document.body.style.color = "black"
window.offscreenBuffering = True 'helps window refresh sometimes
window.resizeTo 1100,720 'width,height
window.moveTo (screen.width - document.body.clientwidth)/2, (screen.availheight - document.body.clientheight)/2
Tab1.InnerText = "Applications"
strComputer = "."
Panel1.InnerHTML = "<hr color=""black""><TABLE align=""center"" border=""0"" cellspacing=""1"" width=""80%"">" &_
"<TR id=""Applications""><TD align=""left"">" &_
"<button name=""InstallFF"" id=""InstallFF"" Title=""Clicking on this button will install FireFox."" value=""Install FF"" style=""background-color:orange; color:black; border: 1pt ridge black"">Install FireFox</button>" &_
"<BR><BR><button name=""InstallChrome"" id=""InstallChrome"" Title=""Clicking on this button will install Chrome."" value=""Install Chrome"" style=""background-color:orange; color:black; border: 1pt ridge black"">Install Chrome</button>" &_
"<BR><BR><BR><BR><button name=""UninstallApps"" id=""UninstallApps"" Title=""Clicking on this button will uninstall applications."" value=""Uninstall Apps""" &_
" style=""background-color:red; color:black; border: 1pt ridge black"" onclick=""OnClickUninstallApps"">Uninstall Applications </button><BR><span id = ""DataArea_Applications""></span>" &_
"<input id=""DontPromptBox"" type=""checkbox"">Don't prompt, just do it!</TD>" &_
"<TD align=""left"">" &_
"<div style=""overflow:auto; width:550x;"">" &_
"<select multiple size=""25"" name=""applistbox""></select></div><span id=""UninstallStatusArea"" font style=color:red;font-weight=bold;></span></TD></TR></Table>"
UninstallStatusArea.InnerText = ""
DontPromptBox.checked = True
Call Get_Applications(strComputer)
End Sub
'===================================
'== SUB GET APPLICATION LIST =====
'===================================
Sub Get_Applications(strComputerName)
Dim UnInstallList(), InstallDateList(), InstallRegList()
Dim strTemp, strTemp2, strTemp3, strValue1, strValue2, strValue3, strValue4, temp, temp2, temp3, temp4
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
strEntry1 = "DisplayName"
strEntry2 = "DisplayVersion"
strEntry3 = "UninstallString"
strEntry4 = "InstallDate"
Set objReg = GetObject("winmgmts://" & strComputerName & "/root/default:StdRegProv")
objReg.EnumKey HKLM, strKey, arrSubkeys
i = 0
For Each strSubkey In arrSubkeys
strTemp = "" : strTemp2 = "" : strTemp3 = ""
strValue1 = "" : strValue2 = "" : strValue3 = "" : strValue4 = ""
intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, strEntry1, strValue1)
If intRet1 <> 0 Then objReg.GetStringValue HKLM, strKey & strSubkey, strEntry1, strValue1
If strValue1 <> "" Then strTemp = strValue1
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry2, strValue2
If strValue2 <> "" Then strTemp = strTemp & " Version: " & strValue2
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry3, strValue3
If strValue3 <> "" Then strTemp2 = strValue3
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry4, strValue4
If strValue4 <> "" Then strTemp3 = strValue4
ReDim Preserve ApplicationList(i)
ReDim Preserve UnInstallList(i)
ReDim Preserve InstallDateList(i)
ReDim Preserve InstallRegList(i)
If Len(strTemp) > 8 Then
If Len(strTemp2) > 8 Then
ApplicationList(i) = strTemp
UnInstallList(i) = strTemp2
InstallDateList(i) = strTemp3
InstallRegList(i) = strKey & strSubkey
i = i + 1
End If
End if
Next
'now look at x64 keys
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputerName & "\root\cimv2")
Set colOS = objWMIService.ExecQuery ("Select * From Win32_OperatingSystem")
For Each objItem In colOS
strArch = objItem.OSArchitecture
Next
If InStr(strArch,"64") Then
strKey = "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall\"
objReg.EnumKey HKLM, strKey, arrSubkeys
For Each strSubkey In arrSubkeys
strTemp = ""
strTemp2 = ""
strTemp3 = ""
strValue1 = ""
strValue2 = ""
strValue3 = ""
strValue4 = ""
intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, strEntry1, strValue1)
If intRet1 <> 0 Then objReg.GetStringValue HKLM, strKey & strSubkey, strEntry1, strValue1
If strValue1 <> "" Then strTemp = strValue1
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry2, strValue2
If strValue2 <> "" Then strTemp = strTemp & " Version: " & strValue2
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry3, strValue3
If strValue3 <> "" Then strTemp2 = strValue3
objReg.GetStringValue HKLM, strKey & strSubkey, strEntry4, strValue4
If strValue3 <> "" Then strTemp3 = strValue4
ReDim Preserve ApplicationList(i)
ReDim Preserve UnInstallList(i)
ReDim Preserve InstallDateList(i)
ReDim Preserve InstallRegList(i)
If Len(strTemp) > 8 Then
If Len(strTemp2) > 8 Then
ApplicationList(i) = strTemp
UnInstallList(i) = strTemp2
InstallDateList(i) = strTemp3
InstallRegList(i) = strKey & strSubkey
i = i + 1
End If
End if
Next
End If
'alphabatize the array for easier readability
For a = UBound(ApplicationList) - 1 To 0 Step -1
For j = 0 to a
If LCase(ApplicationList(j)) > LCase(ApplicationList(j+1)) then
temp = ApplicationList(j+1)
temp2 = UnInstallList(j+1)
temp3 = InstallDateList(j+1)
temp4 = InstallRegList(j+1)
ApplicationList(j+1) = ApplicationList(j)
UnInstallList(j+1) = UnInstallList(j)
InstallDateList(j+1) = InstallDateList(j)
InstallRegList(j+1) = InstallRegList(j)
ApplicationList(j) = temp
UnInstallList(j) = temp2
InstallDateList(j) = temp3
InstallRegList(j) = temp4
End If
Next
Next
'create the listbox from the array
For j = 0 To UBound(ApplicationList)
Set objOption = Document.createElement("OPTION")
objOption.Text = ApplicationList(j)
If Len(InstallDateList(j)) > 0 then objOption.Text = objOption.Text & ", Install Date: " & InstallDateList(j)
objOption.Value = UnInstallList(j)
objOption.title = "Uninstall details found in Registry key:" & vbCrLf & InstallRegList(j)
objOption.style.backgroundcolor = "#D4E5B3"
applistbox.Add(objOption)
Next
End Sub
'==================================
'== SUB UNINSTALL APPLICATIONS ==
'==================================
Sub OnClickUninstallApps()
Dim i, j, iFind, UninstallString, UninstallRegString, strTemp23, strResults, iSelect, strComputerName
Dim objShell : set objShell = CreateObject("WScript.Shell")
strComputerName = "."
ShowCommand = 0
PSExec = "c:\pstools\psexec.exe -s -h \\"
strResults = ""
iSelect = 0
For i = 0 To applistbox.length - 1
If applistbox(i).selected Then
iSelect = 1
UninstallStatusArea.InnerText = "Currently uninstalling " & applistbox(i).Text
Call SleepWait(2) 'rather than uninstall, display the text for troubleshooting purposes
UninstallStatusArea.InnerText = " "
SleepWait(1)
strResults = strResults & applistbox(i).Text & vbCrLf & vbCrLf
End If
Next
If iSelect = 1 Then
Call ClearAppListbox()
Call Get_Applications(strComputerName)
set objShell = CreateObject("WScript.Shell")
objShell.Popup strResults,0,strComputerName & " - Uninstall Results"
Else
MsgBox "No applications selected to uninstall.",vbOKOnly,"I did nothing"
End If
End Sub
'===============================
'== SUB CLEAR APP LISTBOX ====
'===============================
Sub ClearAppListbox()
For Each objOption in applistbox.Options
objOption.RemoveNode
Next
End Sub
'========================================
'= SleepWait - Momentary pause ==========
'========================================
Sub SleepWait(timeinseconds) 'Allows application to wait, if needed.
If timeinseconds = 0 Then timeinseconds = 0.2
With CreateObject("WScript.Shell")
.run "timeout " & timeinseconds, 0, True
End With
End Sub
</script>
<!--
===================================
== JAVASCRIPT =====================
===================================
-->
<script type="text/javascript">
var panels = new Array("","panel1","panel2");
function panel(tab) {
for (i=1; i<panels.length; i++) {
if (i == tab) {
document.getElementById("tab"+i).className = "tabs tabs1";
document.getElementById("panel"+i).style.display = "block";
} else {
document.getElementById("tab"+i).className = "tabs tabs0";
document.getElementById("panel"+i).style.display = "none";
}
}
}
</script>
<style type="text/css">
body,td,th { font-family:Calibri }
.head { font-size:110%; font-weight:bold }
.panel {
background-color: skyblue;
border: solid 1px black;
height: 480px;
padding: 5px;
position: relative;
width: 1000px;
z-index: 0;
}
.tabs {
border-collapse: collapse;
color: black;
cursor: pointer;
cursor: hand;
font-family: calibri;
font-size: 9pt;
font-weight: bold;
margin-top: 4px;
padding: 2px 4px 0px 4px;
position: relative;
text-align: center;
text-decoration: none;
z-index: 1;
}
.tabs0 {
background-color: wheat;
border: solid 1px black;
}
.tabs1 {
background-color: skyblue;
border-color: black black silver black;
border-style: solid solid solid solid;
border-width: 1px 1px 1px 1px;
}
hr {
border: 1;
width: 99%;
background-color: #0000FF;
height: 3px;
}
button {
color: white;
background-color: #4F7BA6;
border: 1px solid darkblue;
}
</style>
</head>
<body>
<table align="center" border="0" cellpadding="0" cellspacing="0" width="1000">
<tr valign="top">
<td colspan="2">
<span class="tabs tabs1" id="tab1" onclick="panel(1)">Tab1</span>
<span class="tabs tabs0" id="tab2" onclick="panel(2)">Tab2</span>
<div class="panel" id="panel1" style="display:block">
</div>
<div class="panel" id="panel2" style="display:none">
</div>
</td>
</tr>
</table>
</body>
</html>
To see what is happening, highlight a few apps and click on the red button (it actually does nothing now but bounce things up & down).
You put a nested table into your panel, with a 2-column layout like this:
+------------------------------------------------------------+
| +-------------------+ +----------------------------------+ |
| | | | +------------------------------+ | |
| | | | | Listbox | | |
| | | | | | | |
| | Buttons | | | | | |
| | | | | | | |
| | | | | | | |
| | | | +------------------------------+ | |
| | | | =============[span]============= | |
| +-------------------+ +----------------------------------+ |
+------------------------------------------------------------+
The left cell contains your buttons, the right cell your listbox. Below the listbox you put an empty <span> (with the ID UninstallStatusArea). Whenever you put text into that <span> element it changes the height of the right cell and thus of the entire row, including the left cell. Changing the height of that cell is what moves the buttons, because they're vertically centered, so they'll shift whenever the cell's vertical size changes.
There are several ways how you could deal with this issue, for instance:
Change the vertical alignment of the cells to top so they stick to the top rather than "float" in the middle:
<style type="text/css">
body,td,th { font-family:Calibri; }
td { vertical-align: top; }
...
Set a height for the <span> element:
<span id="UninstallStatusArea" style="color:red;...;height:40px;">
Move the span to a second table row:
...
</tr>
<tr>
<td> </td>
<td><span id="UninstallStatusArea" ...></td>
</tr>
</table>
Remove the table(s) and switch to a completely <div> and CSS based layout.
I have a working vbscript form with some parts based on hta code.
The form is intended to open a incident in a ticketing tool. This is also working as expected.
I intend to do some adjustments, specially adding a background wallpaper or changing color, and also adding a logo (in jpg ou png) on the top left corner of the form. I think this can be changed on the hta part of the script but I tried to apply some modifications, so far without success.
Below is the code. Any clue? Thank you very much.
Sub GetParams(sTitle, sPrompt, oParams, bAccepted, iWidth, iHeight)
Dim oWnd, sContent, aKeys, i
sContent = "<div style='font: 8pt tahoma;'>"
aKeys = oParams.Keys
For i = 0 To oParams.Count - 1
sContent = sContent & "<span style='margin: 4px;'>" & HtmlSafe(aKeys(i)) & "</span><br>"
sContent = sContent & "<input id=textbox" & i & " value='" & HtmlSafe(oParams.Item(aKeys(i))) & "' type='textbox' style='font: 8pt tahoma; width: 100%; margin: 4px;'/><br>"
Next
sContent = sContent & "<br><input onclick='window.accepted=true;' type='button' value='Criar' style='font: 8pt tahoma; width: 75px; height: 21px; float: right; margin-right: 20px;'/></div>"
Set oWnd = CreateWindow()
With oWnd
With .Document
.Title = sTitle
.Body.Style.Background = "buttonface"
.Body.InnerHtml = sContent
End With
.ResizeTo iWidth, iHeight
.MoveTo CInt((.Screen.AvailWidth - iWidth) / 2), CInt((.Screen.AvailHeight - iHeight) / 2)
End With
oWnd.ExecScript "var accepted=false;"
On Error Resume Next
Do
bAccepted = oWnd.Accepted
If bAccepted Then Exit Do
If Err.Number <> 0 Then
bAccepted = False
Exit Sub
End If
WScript.Sleep 10
Loop
For i = 0 To oParams.Count - 1
oParams(aKeys(i)) = oWnd.Document.GetElementById("textbox" & i).Value
Next
oWnd.Close
End Sub
Function HtmlSafe(sText)
HtmlSafe = Replace(Replace(Replace(Replace(sText, "&", "&"), "<", "<"), ">", ">"), vbCrLf, "<br>")
End Function
Function CreateWindow()
Dim sSignature, oShellWnd, oProc
sSignature = Left(CreateObject("Scriptlet.TypeLib").Guid, 38)
Set oProc = CreateObject("WScript.Shell").Exec("mshta ""about:<html><head><script>moveTo(-32000,-32000);document.title=' '</script><hta:application id=app border=thick minimizebutton=no maximizebutton=no scroll=no showintaskbar=yes contextmenu=no selection=no innerborder=no icon=""""/><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head></html>""")
Do
If oProc.Status > 0 Then
Set CreateWindow = Nothing
Exit Function
End If
For Each oShellWnd In CreateObject("Shell.Application").Windows
On Error Resume Next
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
On Error Goto 0
Next
Loop
End Function
I suppose you want to include the image with your script, not reference one that already exists on disk. You can use CSS for that. Define the background-image property with a data URI like this:
background-image: url(data:image/png;base64,<base64-encoded image>);
Example data URI for a red 1px PNG image:
background-image: url(data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAIAAACQd1PeAAAACXBIWXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH3goaER0v2K3gpwAAABl0RVh0Q29tbWVudABDcmVhdGVkIHdpdGggR0lNUFeBDhcAAAAMSURBVAjXY/jPwAAAAwEBABjdjbAAAAAASUVORK5CYII=);
If you don't have a tool for converting stuff to base64 you can use an online converter.
Repetition of images is controlled via the background-repeat property. For including a logo you could make the logo the background of a <div> with repetition set to no-repeat.
If you define the style in a <style></style> block you need to specify a selector, e.g.:
<style>
body {
background-image: url(data:image/png;base64,iVBORw0K...);
}
</style>
Otherwise you'll have to put it in the style attribute of a tag, e.g.:
<body style="background-image: url(data:image/png;base64,iVBORw0K...);">