Variable from VBA to VBScript - vba

I am working on VBA, from which I have to call a vbscript by passing some values.
Here is the code:
''VBA
'Below values are on different cells of Excel file which I am reading
'into a global variable then pass it to vbscript.
'SFilename = VBscript file path
'QClogin = "abc"
'QCpassword = "abc"
'sDomain = "xyz"
'sProject = "xyz123"
'testPathALM = "Subject\xyz - Use it!\xyz_abc"
'QCurl = "http://xxx_yyy_zzz/qcbin/"
Set wshShell = CreateObject("Wscript.Shell")
Set proc = wshShell.exec("wscript " & SFilename & " " & QClogin & _
" " & "" & QCpassword & " " & "" & sDomain & " " & "" & sProject & _
" " & "" & testPathALM & " " & "" & QCurl & "")
''VBscript on some location
Dim strUserName, strPassword, strServer
strUserName = WScript.Arguments(0) '"abc"
Msgbox "strUserName : " & strUserName
strPassword = WScript.Arguments(1) '"abc"
Msgbox "strPassword : " & strPassword
strServer = WScript.Arguments(5) '"http://xxx_yyy_zzz/qcbin/"
Msgbox "strServer : " & strServer
Dim strDomain, strProject, strRootNode
strDomain = WScript.Arguments(2) '"xyz"
Msgbox "strDomain: " & strDomain
strProject = WScript.Arguments(3) '"xyz123"
Msgbox "strProject: " & strProject
strRootNode = WScript.Arguments(4) '"Subject\xyz - Use it!\xyz_abc"
Msgbox "strRootNode: " & strRootNode
Now, when I running the code, it is passing below values properly to vbscript:
QClogin = "abc"
QCpassword = "abc"
sDomain = "xyz"
sProject = "xyz123"
It is having issues with these:
testPathALM = "Subject\xyz - Use it!\xyz_abc"
QCurl = "http://xxx_yyy_zzz/qcbin/"
Now, wierd thing for me is, if I keep a cell empty for "testPathALM" which is having "Subject\xyz - Use it!\xyz_abc" as value, I am getting "QCurl" value properly in vbscript.
But, if I keep value "Subject\xyz - Use it!\xyz_abc" for "testPathALM", then I am getting "-" for strServer which suppose to be "QCurl" value and "Subject\xyz" for "strRootNode" which supposed to be "Subject\xyz - Use it!\xyz_abc".
I am unable to understand what is the issue here.
Thanks a ton in advance.

Safer to quote all of your parameters:
Set wshShell = CreateObject("Wscript.Shell")
Set proc = wshShell.exec("wscript """ & SFilename & """ """ & _
QClogin & """ """ & QCpassword & """ """ & _
sDomain & """ """ & sProject & """ """ & _
testPathALM & """ """ & QCurl & """")
Try a debug.print to make sure it looks as it should...

Related

MS Access if statement on click event

I am using Ms Access forms and I have created an on click event that locates a folder location but now I want to locate the folder location based on different criteria but when I add the if statement it expects a sub,function or property. Below is some demo code. I really hope someone can explain what is missing?
Private Sub Open_Email_Click()
Dim stAppName As String
Dim stAppNameA As String
Dim stAppNameB As String
stAppName = "C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & " DEMO\B " & Me.BC & " " & Me.UC & "\"
stAppNameA = "C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & " DEMO\A\B " & Me.BC & " " & Me.UC & "\"
stAppNameB = "C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & " DEMO\B\B " & Me.BC & " " & Me.UC & "\"
If (Me.BC = "60") And Me.UC Like "REF123*" Then stAppNameA
ElseIf (Me.BC = "60") And Not Me.UC Like "REF123*" Then stAppNameB
Else: stAppName
End If
Call Shell(stAppName, 1)
End Sub
I think the logic of your function could be reduced to the following, which may be more readable with fewer repeating expressions:
Private Sub Open_Email_Click()
Dim strTmp As String
If Me.BC = "60" Then
If Me.UC Like "REF123*" Then
strTmp = " DEMO\A\B "
Else
strTmp = " DEMO\B\B "
End If
Else
strTmp = " DEMO\B "
End If
Call Shell("C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & strTmp & Me.BC & " " & Me.UC & "\", 1)
End Sub
Alternatively, using a Select Case statement:
Private Sub Open_Email_Click()
Dim strTmp As String
Select Case True
Case Me.BC <> "60"
strTmp = " DEMO\B "
Case Me.UC Like "REF123*"
strTmp = " DEMO\A\B "
Case Else
strTmp = " DEMO\B\B "
End Select
Call Shell("C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & strTmp & Me.BC & " " & Me.UC & "\", 1)
End Sub
To test the resulting path, change:
Call Shell("C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & strTmp & Me.BC & " " & Me.UC & "\", 1)
To:
Debug.Print "C:\Windows\explorer.exe C:\DEMO\TEST\" & Me.Office & strTmp & Me.BC & " " & Me.UC & "\"
I think your If block is just a bit messy in terms of where you have newlines, and continuation characters (:). Try reformatting your code like this:
If (Me.BC = "60") And Me.UC Like "REF123*" Then
stAppName =stAppNameA
ElseIf (Me.BC = "60") And Not Me.UC Like "REF123*" Then
stAppName = stAppNameB
Else
stAppName =stAppName
End If
Call Shell(stAppName, 1)

Invalid qualifier Error Message in vba code

This code is designed to detect the columns of start and finish of a shape which is used and displayed onto the caption of the shape itself. The following code is the problematic code:
Sub Take_Baseline()
Dim forcast_weeksStart() As String
Dim forcast_weeksEnd() As String
Dim forcastDate As String
Dim shp As Shape
Dim split_text() As String
'cycle through all the shapes in the worsheet and enter the forcast date for all the projects into their respective boxes
For Each shp In ActiveSheet.Shapes
'initialize forcast date by parsing
forcast_weeksStart = Split(shp.TopLeftCell.Column.Text, " ")
forcast_weeksEnd = Split(shp.BottomRightCell.Column.Text, " ")
forcastDate = forcast_weeksStart(1) & "-" & forcast_weeksEnd(1)
temp = shp.OLEFormat.Object.Object.Caption
If InStr(temp, "/-/") > 0 & InStr(temp, "In Prog") Then
split_text = Split(shp.OLEFormat.Object.Caption, " ")
For i = 0 To (i = 3)
shp.TextFrame.Characters.Caption = split_text(i) & vbNewLine
Next i
ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption = ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption & vbNewLine & ActiveSheet.Cells(4, AShape.TopLeftCell.Column).Text & " - " & ActiveSheet.Cells(4, AShape.BottomRightCell.Column).Text & vbNewLine & "dates: " & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & "/" & "actualDate"
' ElseIf InStr(temp, "/-/") > 0 & InStr(temp, "In Prog") = 0 Then
'split_text = Split(shp.OLEFormat.Object.Object.Caption, " ")
' For i = 0 To (i = 2)
' shp.OLEFormat.Object.Caption = split_text(i) & vbNewLine
' Next i
'ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption = ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption & vbNewLine & "In Prog" & vbNewLine & ActiveSheet.Cells(4, AShape.TopLeftCell.Column).Text & " - " & ActiveSheet.Cells(4, AShape.BottomRightCell.Column).Text & vbNewLine & "dates: " & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & "actualDate"
End If
Next shp
'For testing purposes
Sheet4.Range("A20").Value = forcast_weeksStart(1)
Sheet4.Range("A21").Value = forcast_weeksEnd(1) End Sub
The error is an
"invalid qualifier"
message which occurs on line
forcast_weeksStart = Split(shp.TopLeftCell.Column.Text, " ")
Right on the "column" word. I don't get why this is happening since the actual drop down menu has the column operation which i can select. I have tried everything from changing it to the OLEformat.Object.Caption etc etc. But nothing has worked. I am still relatively new to vba so any help will be appreciated. Thanks

How to change font color for updated Access data in Outlook mail

In Access 2010 I have tables, e.g. Employee(Pracownicy). I can update the data in the table using the subform and the update button.
Updating the data in the subform automatically generates an Outlook mail containing the data in the updated record.
I need to change font color for updated data in the mail body.
The code to update the data and generate e-mail:
Private Sub cmdUpdate2_Click()
CurrentDb.Execute "update Pracownicy" & _
" SET Identyfikator='" & Me.txtID & "'" & _
", Imie='" & Me.txtImie & "'" & _
", Nazwisko ='" & Me.txtNazwisko & "'" & _
", Wiek ='" & Me.txtWiek & "'" & _
", Data_urodzenia ='" & Me.txtData & "'" & _
", Miejsce_urodzenia ='" & Me.txtMiejsce & "'" & _
", Miejscowosc ='" & Me.txtMiejscowosc & "'" & _
", Plec ='" & Me.txtPlec & "'" & _
" where Identyfikator='" & Me.txtID & "'"
'------------------------------------SEND EMAIL----------------------
'Dim varName As Variant
'Dim strUCC As String
Dim varSubject As Variant
Dim varBody As Variant
Dim Poczta As Object
Dim MojMail As Object
On Error Resume Next
'varName = ""
varSubject = "Employer List "
varBody = "Hello" & _
"<br><br>Employer List: " & _
"<br><br><B>Identyfikator:</B> " & Me.txtID & " " & _
"<br><B>Imie:</B> " & Me.txtImie & " " & _
"<br><B>Nazwisko:</B> " & Me.txtNazwisko & " " & _
"<br><B>Wiek:</B> " & Me.txtWiek & " " & _
"<br><B>Data urodzenia:</B> " & Me.txtData & " " & _
"<br><B>Miejsce urodzenia:</B> " & Me.txtMiejsce & " " & _
"<br><B>Miejscowosc:</B> " & Me.txtMiejscowosc & " " & _
"<br><B>Plec:</B> " & Me.txtPlec & " "
Set Poczta = CreateObject("outlook.application")
Set MojMail = Poczta.createitem(0)
With MojMail
'.To =
'.BCC =
.subject = varSubject
'.ReadReceiptRequested = True
'.originatorDeliveryReportRequested = True
.htmlbody = varBody & "<br>"
.display
'.send
End With
Set Poczta = Nothing
Set MojMail = Nothing
If Err.Number <> 0 Then
MsgBox ("Atention")
End If
On Error GoTo 0
'------------------------------------------------------------------------
DoCmd.Close
MsgBox ("End Update")
End Sub
I think this becomes more of an HTML question rather than VBA. Try adding a FONT tag to the following line and see if that works for you.
"<br><br><B><font color="red">Identyfikator:</font></B> " & Me.txtID & " " & _

VBA how to check if download files from Server has success?

I'm able to use the below code to download files from server. However, this does tell me whether the files are downloaded successfully.
Sub DownloadFirstRunFilesPart2()
Application.StatusBar = "Downloading files..."
Dim wsh As Object
Dim errorcode4 As Integer
Dim cmd5 As Variant
Dim FirstRunFiles(5) As Variant
Dim var As Variant
FirstRunFiles(0) = ProN & "_KSParameter_UserInput.xlsx"
FirstRunFiles(1) = ProN & "_KSParameter_SysOutput.xlsx"
FirstRunFiles(2) = ProN & "_ModelParameter_UserInput.xlsx"
FirstRunFiles(3) = ProN & "_ModelParameter_SysOutput.xlsx"
FirstRunFiles(4) = ProN & "_VarClusParameter_UserInput.xlsx"
FirstRunFiles(5) = ProN & "_VarClusParameter_SysOutput.xlsx"
For Each var In FirstRunFiles
cmd5 = Chr(34) & "C:\Program Files (x86)" & "\PuTTY\pscp.exe" & Chr(34) & " -sftp -l " & pUser & " -pw " & pPass & _
" " & " " & pHost & ":" & ServerPath & "/" & var & " " & LocalPath & "\"
Set wsh = CreateObject("wscript.shell")
errorcode4 = wsh.Run(cmd5, vbHide)
'If errorcode4 = 0 Then MsgBox ("Error occurs. Fail to download " & var)
Next var
Application.StatusBar = "Download complete"
MsgBox ("Downloading process complete.")
End Sub
My error code always equals 0 no matter the file exists or not. How should I change this program?
Thanks in advance!
Update:
The new code that I tried:
Sub test()
Dim wsh As Object
Dim WshShellExec As Variant
Dim cmd3 As String
Dim pFirstRunFile1 As String
Const WshFinished = 1
Const WshFailed = 2
pFirstRunFile1 = "this_proj_name.txt"
cmd3 = Chr(34) & "C:\Program Files (x86)" & "\PuTTY\pscp.exe" & Chr(34) & " -sftp -l " & pUser & " -pw " & pPass & _
" " & " " & pHost & ":" & ServerPath & "/WOE/" & pFirstRunFile1 & " " & LocalPath & "\WOE"
Set wsh = CreateObject("wscript.shell")
WshShellExec = wsh.Exec(cmd3)
Select Case WshShellExec.Status
Case WshFinished
strOutput = WshShellExec.StdOut.ReadAll
Case WshFailed
strOutput = WshShellExec.StdErr.ReadAll
End Select
MsgBox strOutput 'write results in a message box
End Sub
However I'm getting error on this line:
WshShellExec = wsh.Exec(cmd3)
The error message says "Object does not support this property or method". Any ideas?

Send mail using VB Script?

I have the following code to monitor a drive. Now I an getting Echo for each file creation or deletion event.
Is there and way to modify the WScript.Echo to send a mail notification?
strDrive = "c"
arrFolders(0) = strDrive & "\\\\"
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
'Loop throught the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & "(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * FROM __InstanceOperationEvent WITHIN 1 " & "WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" & " and TargetInstance.GroupComponent = " & "'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & VbCrLf & vbTab & "Wscript.Echo objObject.TargetInstance.PartComponent" & VbCrLf & "End Sub"
WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
Next
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Instead of Echoing like below:
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & VbCrLf & vbTab & "Wscript.Echo objObject.TargetInstance.PartComponent" & VbCrLf & "End Sub"
I want to send a mail like this:
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & VbCrLf & vbTab & "
Set outobj = CreateObject("Outlook.Application")
Set mailobj = outobj.CreateItem(0)
With mailobj
.To = toAddress
.Subject = Subject
.HTMLBody = strHTML
.Send
End With
" & VbCrLf & "End Sub"
Is it possible or is there an other way to do this..?
I don't know what server do you use, but on Windows 2003 and 2008 e.g. you can use CDO object to create a email. You might use a smart host to send your email to.
Check this link: http://www.paulsadowski.com/wsh/cdo.htm
Also you can choose any free email component to create a email and use a smtp server to send your email. Or check this side where you can use a component including many examples how to do it: http://www.chilkatsoft.com/email-activex.asp.
** UPDATED **
This Script checks and send a email as you requestted:
strDrive = "d:"
Dim arrFolders(0) : arrFolders(0) = strDrive & "\\\\"
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
'Loop throught the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
WScript.Echo "setup for folder: " & strFolder & vbLf
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & "(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * " _
& "FROM __InstanceOperationEvent " _
& "WITHIN 1 " _
& "WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" _
& " AND TargetInstance.GroupComponent = " & "'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & vbLf _
& " Wscript.Echo objObject.TargetInstance.PartComponent" & vbLf _
& " SendMail(objObject.TargetInstance.PartComponent)" & vbLf _
& "End Sub"
'WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
Next
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Function SendMail(vBody)
Dim oMail : Set oMail = CreateObject("CDO.Message")
'Name or IP of Remote SMTP Server
oMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "your.smtp.server"
oMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
oMail.Configuration.Fields.Update
oMail.Subject = "Email Watch Info Message"
oMail.From = "alert#yourdomain.net"
oMail.To = "target#yourdomain.net"
oMail.TextBody = vBody
oMail.Send
End Function
Correct the settings in the send mail function and your are fine.
In theory, the VBSendMail DLL should be able to do what you want.