Executing string as property to set values in SAP with VBS - vbscript

I'm trying to automate a list of property set commands in SAP GUI 740, for example, to set the "text" property of a field to "12345" as shown below.
If Not IsObject(application) Then
Set SapGuiAuto = GetObject("SAPGUI")
Set application = SapGuiAuto.GetScriptingEngine
End If
If Not IsObject(connection) Then
Set connection = application.Children(0)
End If
If Not IsObject(session) Then
Set session = connection.Children(0)
End If
If IsObject(WScript) Then
WScript.ConnectObject session, "on"
WScript.ConnectObject application, "on"
End If
Function Overall()
session.findById("wnd[0]/tbar[0]/okcd").text = "12345"
end function
call Overall
That works fine, as does:
Function Overall()
set control = session.findById("wnd[0]/tbar[0]/okcd")
control.text = "12345"
end function
And so does:
Function Overall()
set control = session.findById("wnd[0]/tbar[0]/okcd")
with control
.text = "12345"
end with
end function
What I need to figure out is how to pass such a function the property name and value as strings and have it set those. For instance:
Function Desired(Input)
GUI_ID = Input(0)
Property_to_change = Input(1)
Value_to_change = Input(2)
session.findById(GUI_ID).Property_to_change = Value_to_change
end function
The best option seems to be CallByName, such as below, but I get a type mismatch error.
Function Desired(Input)
GUI_ID = Input(0)
Property_to_change = Input(1)
Value_to_change = Input(2)
set control = session.findById(GUI_ID)
CallByName control, Property_to_change, vbSet, Value_to_change
end function
And the error:
Microsoft VBScript runtime error: Type mismatch: 'callbyname'
I don't know if this is a simple syntax issue, or if I am using this completely wrong. I'm also not invested in CallByName, so if there is a better or easier way, I'm all for it :)
Thank you everyone!

In a VB script, the task could be solved as follows.
for example:
Function Desired(Input_0, Input_1, Input_2)
GUI_ID = Input_0
Property_to_change = Input_1
Value_to_change = Input_2
set control = session.findById(GUI_ID)
if Property_to_change = "text" then
with control
.text = Value_to_change
end with
session.findById("wnd[0]").sendVKey 0
end if
if Property_to_change = "setFocus" then
with control
.setFocus
end with
end if
'etc.
end function
If Not IsObject(application) Then
Set SapGuiAuto = GetObject("SAPGUI")
Set application = SapGuiAuto.GetScriptingEngine
End If
If Not IsObject(connection) Then
Set connection = application.Children(0)
End If
If Not IsObject(session) Then
Set session = connection.Children(0)
End If
If IsObject(WScript) Then
WScript.ConnectObject session, "on"
WScript.ConnectObject application, "on"
End If
session.findById("wnd[0]").maximize
call Desired("wnd[0]/tbar[0]/okcd", "text", "12345")

Related

Need advice with outlook vbs rule to read header and assign category

Found this great script that can add a rule to Outlook but I would like to create the following rule and would like some help modifying
Outlook Rule:
Apply this rule after the message arrives
with external in the message header
assign it to the EXTERNAL category
Const RULE_NAME = "test"
Const olRuleReceive = 0
Const olFolderSentMail = 5
Dim olkApp, olkSes, olkCol, olkRul, olkCD1, olkCD2, olkMRA
On Error Resume Next
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon olkApp.DefaultProfileName
Set olkCol = olkSes.DefaultStore.GetRules()
Set olkRul = olkCol.Item(RULE_NAME)
If Typename(olkRul) = "Empty" Then
Set olkRul = olkCol.Create(RULE_NAME, olRuleReceive)
Set olkCD1 = olkRul.Conditions.From
With olkCD1
.Enabled = True
.Recipients.Add olkSes.CurrentUser.Address
.Recipients.ResolveAll
End With
Set olkCD2 = olkRul.Exceptions.ToOrCc
With olkCD2
.Enabled = True
End With
Set olkMRA = olkRul.Actions.MoveToFolder
With olkMRA
.Enabled = True
Set .Folder = olkSes.GetDefaultFolder(olFolderSentMail)
End With
olkCol.Save False
End If
olkSes.Logoff
olkApp.Quit
Set olkMRA = Nothing
Set olkCD2 = Nothing
Set olkCD1 = Nothing
Set olkRul = Nothing
Set olkCol = Nothing
Set olkSes = Nothing
Set olkApp = Nothing
WScript.Quit

How can we check if local Object exist in test script developed in QTP through vbscript?

Suppose I have a Test script developed in qtp,and now my requirement is to check whether this particular test case has a local Object associated with it through VBscript??
The below funciton in VBScript can check if the current test has an object with a particular name in its Object Repository.
Function CheckIfObjectPresentInOR(ByVal LogicalName)
Set ObjectRepositoryUtil = CreateObject("Mercury.ObjectRepositoryUtil")
ObjectRepositoryUtil.Load "<Path of the Object Repository>"
Set TOCOllection = ObjectRepositoryUtil.GetAllObjects
booFunctionStatus = FALSE
For i = 0 To TOCollection.Count - 1
If ObjectRepositoryUtil.GetLogicalName(TOCOllection.Item(i)) = LogicalName Then
booFunctionStatus = TRUE
Exit For
End If
Next
Set ObjectRepositoryUtil = Nothing
Set TOCOllection = Nothing
CheckIfObjectPresentInOR = booFunctionStatus
End Function
EDIT:
Function CheckIfObjectPresentInOR
Set ObjectRepositoryUtil = CreateObject("Mercury.ObjectRepositoryUtil")
ObjectRepositoryUtil.Load "<Path of the Object Repository>"
booFunctionStatus = FALSE
Set TOCOllection = ObjectRepositoryUtil.GetAllObjects
If TOCOllection.Count > 0 Then
booFunctionStatus = TRUE
End If
Set ObjectRepositoryUtil = Nothing
Set TOCOllection = Nothing
CheckIfObjectPresentInOR = booFunctionStatus
End Function

Upgrading to outlook 2013 killed a a VBScript - image in table

I have cut down the script to be as simple as possible. The issue is inserting an image in a table for Outlook 2013. This script works with older versions.
1 table, 1 row, 2 columns and using the AddPicture in a cell kills the script!
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
Full script below. Any work arounds would be appreciated.
'-------------
On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FullName
strMail = objuser.mail
strLogo = "c:\1.jpg"
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objRange = objDoc.Range()
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
objDoc.Tables.Add objRange, 1, 2
Set objTable = objDoc.Tables(1)
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
objTable.Cell(1, 2).select
objSelection.TypeParagraph()
objSelection.TypeText strName
objSelection.Font.Bold = false
objSelection.TypeParagraph()
objSelection.TypeText strMail
objSignatureEntries.Add "Signature", objRange
objSignatureObject.NewMessageSignature = "Signature"
objSignatureObject.ReplyMessageSignature = "Signature"
objDoc.Saved = True
objWord.Quit
'----------------
Your error is obvious:
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)
this cannot work because you try to assign to .Text something that is not a string. Moreover: This has never worked, you just never noticed.
.AddPicture() already does all you want, just select the right spot in the document before:
objTable.Cell(1, 1).Select
objSelection.InlineShapes.AddPicture(strLogo)
Apart from this your script violates a few basic rules.
Always use Option Explicit. No exceptions, no "but", no arguments with "quick" or "only".
Never use On Error Resume Next as a global setting.
Write functions/subs to wrap up steps that can fail. On Error Resume Next has function scope, you can switch it on in a function to guard a line that can throw an error and it will be reset when the function ends.
If you can't/don't want to create an extra function, use On Error Goto 0 to end the effect of On Error Resume Next as soon as possible, but not before you've checked the Err variable to handle the error yourself.
Write functions/subs to structure your code.
A matter of preference, but I like to use With blocks.
Another matter of preference, but Hungarian notation makes no sense. By convention I use PascalCase for objects and camelCase for primitive values (strings, numbers, dates), along with speaking variable names.
Here's an improved version:
Option Explicit
Dim User, logo
Set User = GetCurrentUser
logo = "C:\1.jpg"
If Not User Is Nothing Then
CreateEmailSignature User, logo
Else
WScript.Echo "Could not retrieve user from AD."
End If
'------------------------------------------------------------------------------
Function GetCurrentUser()
Set GetCurrentUser = Nothing
On Error Resume Next
Set GetCurrentUser = GetObject("LDAP://" & CreateObject("ADSystemInfo").UserName)
End Function
'------------------------------------------------------------------------------
Sub CreateEmailSignature(ADUser, logoPath)
Dim Doc, Table
With CreateObject("Word.Application")
Set Doc = .Documents.Add
Set Table = Doc.Tables.Add(Doc.Range, 1, 2)
Table.Cell(1, 1).Select
InsertPictureFromFile .Selection, logoPath
Table.Cell(1, 2).Select
.Selection.TypeParagraph
.Selection.TypeText ADUser.FullName
.Selection.Font.Bold = False
.Selection.TypeParagraph
.Selection.TypeText ADUser.Mail
With .EmailOptions.EmailSignature
.EmailSignatureEntries.Add "Signature", Doc.Range
.NewMessageSignature = "Signature"
.ReplyMessageSignature = "Signature"
End With
Doc.Close False
.Quit False
End With
End Sub
'------------------------------------------------------------------------------
Sub InsertPictureFromFile(Selection, picturePath)
On Error Resume Next
Selection.InlineShapes.AddPicture picturePath
End Sub
'------------------------------------------------------------------------------
I found out that it is a 64 bit Office issue.
I have reinstalled on multiple pc's using 32 bit Office 2013 and everything works as it should.

Find and Replace?

Does anyone know of a way to do a more complex find and replace? For example, I have many documents with merge fields. I need to be able to change the merge fields in these documents based on a list of definitions\translations. So in this example lets say I have 100 equipment leases created in M$ word saved as .dot. Each one the following merge fields exists, and I want to change them all at once to a new value as shown below.
{MERGEFIELD state} -> {MERGEFIELD ownerstate}
{MERGEFIELD city} -> {MERGEFIELD ownercity}
{MERGEFIELD zip} -> {MERGEFIELD ownerzip}
It's not so important that I be able to edit more than 1 document at a time than it is that I be able to make multiple edits at once.
OK so I was able to create a solution to my own issue. To do this I created the following code to do a find and replace based on a definition list in excel.
Option Explicit
Private MyXL As Object
Sub Test()
Dim WB As Excel.Workbook, WS As Excel.Worksheet, MyDefTbl As Excel.Range, MyRow As Excel.Range
Dim MySearchRng As Excel.Range, ReplacementRng As Excel.Range
Dim myDoc As Document
Call MyInitializeOfficeApps
'Define the Workbook that contains the Definitions
Set WB = MyXL.Workbooks.Open("E:\MailMerges\Definitions\Equip.xlsx")
'Define the Woksheet that contains the Definition list
Set WS = WB.Worksheets("Sheet1")
'Define the Range name that defines the Definition list
Set MyDefTbl = WS.Range("MyDefs")
'Define the Document to be changed
Set myDoc = ActiveDocument
For Each MyRow In MyDefTbl.Rows
Set MySearchRng = WS.Cells(MyRow.Row, 1)
Set ReplacementRng = WS.Cells(MyRow.Row, 2)
'MsgBox MySearchRng & "====>" & ReplacementRng
myDoc.Select
With Selection.Find
.Text = " MERGEFIELD " & MySearchRng.Text
.Replacement.Text = " MERGEFIELD " & ReplacementRng.Text
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next MyRow
Set MyDefTbl = Nothing
Set MyRow = Nothing
Set WS = Nothing
Set WB = Nothing
Set MyXL = Nothing
Set myDoc = Nothing
MsgBox "Complete"
End Sub
Sub MyInitializeOfficeApps()
On Error Resume Next
Set MyXL = GetObject(, "Excel.Application")
If MyXL Is Nothing Then
Set MyXL = CreateObject("Excel.Application")
End If
On Error GoTo 0
MyXL.Visible = True
End Sub

Object required of a parameter in VBScript?

I'm new to VBScript, and I have a function that allows me to pull synchronizing preferences from a preferences file, and it looks like this:
Function IsSync(SyncFolder)
If FS.FileExists(PrefFilePath) Then
Set objFile = FS.OpenTextFile(PrefFilePath, 1)
PrefLine = "start"
Do Until Prefline.Substring(0, SyncFolder.Length) = SyncFolder
PrefLine = objFile.Readline
Loop
If PrefLine.Substring(PrefLine.Length - 6) = "nosync" Then
IsSync = False
Else
IsSync = True
End If
Else
IsSync = True
End If
End Function
But when I try to run it, Windows throws me an error of "Object required: SyncFolder" whenever it gets to this function. Why is this? SyncFolder is just a parameter?
In VBScript, every variable has not some built-in methods. And if a variable has a property or method this means it's an Object. But your parameter does not seems like an object, this is why the error occurred.
So, there is no built-in methods such as SubString or another for the string variables in the VBScript.
Use Len function to get length of string instead of
.Length.
Use Mid, Left or Right functions which one if you need to istead of .SubString.
I guess you need to use -with order- Len, Left and Right functions in this case.
Consider this :
Function IsSync(SyncFolder)
If FS.FileExists(PrefFilePath) Then
Set objFile = FS.OpenTextFile(PrefFilePath, 1)
PrefLine = "start"
Do Until Left(Prefline, Len(SyncFolder)) = SyncFolder 'starts with SyncFolder
PrefLine = objFile.Readline
Loop
If Right(PrefLine, 5) = "nosync" Then 'ends with "nosync"
IsSync = False
Else
IsSync = True
End If
Else
IsSync = True
End If
End Function

Resources