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.
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 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>
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...
This is a continuation of my last post: How to read weight from scale using ethernet connection
After creating the TCP connection in vb10 - I am now trying to read the weight from the scale in iFix (vb6). The code below works if I create a breakpoint and step through: strdata takes the weight of the scale (51g at the moment). However, when i simply run the code, I get the error:
Invalid operation at current state 40020.
What i think is happening is something to do with how quickly it reads or trying to read multiple times. Any tips would be great.
TCPclient is referring to winsock, and frmclient refers to my form. The command "S" is the necessary command for the scale to grab the weight value. Thanks!
Public Sub test()
On Error GoTo errHandler
Dim strData As String
frmClient.tcpClient.LocalPort = 0
frmClient.tcpClient.Connect "192.168.0.1", 8000
'Dim i As Integer
' For i = 0 To 2000
' Debug.Print "connection status=" & frmClient.tcpClient.State
' If frmClient.tcpClient.State = 7 Then
' Exit For Next i
frmClient.tcpClient.SendData "S" & vbCrLf
frmClient.tcpClient.GetData strData
MsgBox ("weight =" & strData)
'Exit Sub
errHandler:
MsgBox Err.Description & " " & Err.Number
'Resume Next
End Sub
Use the DataArrival event of your Winsock Control.
So something like:
' ... in your "frmClient" Form ...
Private Sub tcpClient_DataArrival(ByVal bytesTotal As Long)
Dim strData As String
tcpClient.GetData strData, vbString
MsgBox ("weight =" & strData)
End Sub
*Obviously removing the GetData() call in your original test() method.
Got it working! The code is below. I created a picture sub to initialize the ports/IP at the beginning of the code execution and then to close the connection at the end. I made a timer to automatically read the weight upon stabilization, so the weight can be found by clicking the button, or simply waiting 2 seconds (2000ms). Best of luck and thanks for the help!
Public tcpC As New Winsock
Private Sub CFixPicture_Close()
tcpC.Close
End Sub
Private Sub CFixPicture_Initialize()
tcpC.LocalPort = 0
tcpC.Connect "192.168.0.1", 8000
End Sub
Private Sub CommandButton1_Click()
On Error GoTo errHandler
Dim strData As String
tcpC.SendData "S" & vbCrLf
tcpC.GetData strData
Text4.Caption = "Weight: " & strData
Exit Sub
errHandler:
MsgBox "error:" & Err.Description
End Sub
Private Sub readScale_OnTimeOut(ByVal lTimerId As Long)
Dim strData As String
tcpC.SendData "S" & vbCrLf
tcpC.GetData strData
Text4.Caption = "Weight: " & strData
Exit Sub
End Sub
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...);">