Using VBA to open a file on Remote Desktop - excel

I am trying to automate a process which involves using VBA in Excel to open a file on a remote desktop through RDP. I have successfully managed to log into RDP but am now struggling to open the file consistently. I wrote some code relying on SendKeys that maybe works 10% of the time but am looking for something more robust.
Sub RunRDP()
Dim RetVal As Variant
Dim Target As String
Dim Sheet As Variant
'Log-in info
Target = "AAAA.com"
UserName = "BBBBBB\CCC"
Pwd = "DDDDD"
'Connect to Remote Desktop
RetVal = Shell("cmdkey /generic:""" & Target & """ /user:""" & UserName & """ /pass:""" & Pwd & """", 3)
RetVal = Shell("c:\Windows\System32\mstsc.exe /v:" & Target, 3)
'Press yes through cert errors
Do
If InStr(ActiveWinTitle, "Remote Desktop Connection") > 0 Then
Application.SendKeys "y", True
End If
Loop Until InStr(ActiveWinTitle, "AAAA") > 0
Application.Wait (Now + TimeValue("00:00:03"))
If InStr(ActiveWinTitle, "Remote Desktop Connection") > 0 Then
AppActivate "AAAAA.com - Remote Desktop Connection"
Else
AppActivate "AAAAA.com"
End If
Application.Wait (Now + TimeValue("00:00:07"))
The above code works as expected. ActiveWinTitle is a function to grab the current window's caption, see below:
Public Declare Function GetForegroundWindow Lib "user32" _
() As Long
Public Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" (ByVal HWnd As Long, _
ByVal lpString As String, ByVal cch As Long) As Long
Public Function ActiveWinTitle() As String
Dim WinText As String
Dim HWnd As Long
Dim L As Long
HWnd = GetForegroundWindow()
WinText = String(255, vbNullChar)
L = GetWindowText(HWnd, WinText, 255)
ActiveWinTitle = Left(WinText, InStr(1, WinText, vbNullChar) - 1)
End Function
The below code is what I've tried to make work for opening the file. Its explanation in English follows:
Application.SendKeys "RE", True
Application.SendKeys "~", True
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys "{F4}", True
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys "{BS}{BS}{BS}{BS}{BS}{BS}{BS}{BS}{BS}{BS}{BS}F:\[**FILEPATH HERE**]~", True
Type RE on the desktop to highlight the Recycle Bin
Press Enter to open the Recycle Bin (to get to a file explorer window)
Wait one second
Press F4 to move cursor to address bar
Wait one second
Delete "Recycle Bin" from the address bar, write in the correct filepath, and press Enter
Obviously this is extremely unreliable and is the reason I'm looking for something better.
This code is something I'm using for work and am looking to share with my colleagues - I am not able to download any programs to use instead of VBA because of this.
I have looked at these questions without much avail:
Script to Open a batch file on a remote computer
I am not familiar with WMI and am not sure if I would have to completely replace using RDP. I tried looking at the documentation for it and it's quite above my head.
Run a batch file on a remote desktop from VBA
This is an earlier thread from the same user. It has some dead links that I was unable to follow.
I've looked at a lot of threads that had the same unanswered question as mine. It may be a futile effort, but I'd like to know definitively if this is manageable or not. [EDIT: Some of the unanswered forum posts I've found in my research below]
https://www.office-forums.com/threads/vba-remote-desktop-connection-mstscax.2170171/
https://www.tek-tips.com/viewthread.cfm?qid=1582592
https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1210417-controlling-remote-desktop-from-vba
Thanks in advance for all of your help.

Would a non-programming approach help you, too?
On the remote computer, create a scheduled task which launches when someone connects to the user session.
...and simply run anything from there.
Of course, maybe you still want to reach only for advanced techniques, but sometimes they can be easily avoided only by using existing tools.

Related

Insuppressible Error when saving PowerPoint file in Excel VBA

Before this gets marked as a duplicate: It is not, as all the other saving errors seem to get a different MsgBox.
I am writing a macro that opens and closes a PowerPoint Presentation from Excel. Now I have the issue that when I am trying to save the PowerPoint file I get a pop up Message Box:
It says: "PowerPoint-Error while saving the file."
My code:
Dim pptPres As PowerPoint.Presentation
Dim pptApp As PowerPoint.Application
Set pptApp = New PowerPoint.Application
strPath = "S:\Folderxy\"
strFile = "filename.pptm"
strSave = "newFilename"
Set pptPres = pptApp.Presentations.Open(strPath & strFile, False, True, True)
Application.DisplayAlerts = False
On Error GoTo Errorhandler_tryAgain
tryAgain:
pptApp.DisplayAlerts = ppAlertsNone
strSave = "Test123"
pptPres.SaveAs strPath & strSave & ".pptx"
pptPres.Close
Exit Sub
Errorhandler_tryAgain:
Debug.Print "Errorhandler_tryAgain was opened!"
Application.Wait DateAdd("s", 1, Now) 'delay in seconds
GoTo TryAgain
First:
Even though I turned the DisplayAlerts off this one keeps popping up. However I can not easily reproduce this error. It occurs sometimes. Openening, closing and saving *.pptx files is part of a loop and surprisingly this error does not reoccur at the same file but it reoccurs about 2 times in a loop with 70 >files.
Second:
When I manually click enter the RuntimeError 70: Permission Denied is thrown. But then the VBE goes into the debug mode and my Errorhandler is not handling it. The Errohandler is an infinitive loop as I am saving the file on a server and sometimes it fails to save. However when I manually tried to save the document (both, on the server and on the desktop) I got the same "PowerPoint-Error while saving the file." MsgBox.
Now my question is how do I either get rid of the saving error (which seems to be impossible) or how to surppress that error so that my macro does not stop everytime it occurs. As I would like to run the macro overnight.
In case anyone has experienced such a thing before and can help me out I would be very happy.
Thanks in advance
Follow these two things and you should be ok...
Mention the File Format while saving. For example pptPres.SaveAs strPath & strSave & ".pptx",24 '<~~ ppSaveAsOpenXMLPresentation. Also ensure the strPath & strSave & ".pptx" is the extact name of the fiel as you wanted it. Else tweak the variables accordingly.
Always add DoEvents after you issue the save(or save as) statement and before the .Close statement so Excel can get enough time to finish it's tasks.
Application.Wait suspends all Excel activity including execution of your macro. It's not so useful for fixing timing problems. When I want to add a little time so that the program can finish I/O or clipboard tasks, Sleep is a better option. First add a declaration:
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Add error-trapping before the problem statement, including a statement to reset error handling after the problem:
TryCut1:
On Error GoTo TooFast1
objShape.TextFrame2.TextRange.Cut
On Error GoTo -1
Then add this for error handling. It waits for 10 milliseconds, then tries again:
TooFast1:
Sleep 10
Resume TryCut1

Deploying Macros as Add Ins with Custom Ribbon Buttons to the entire office

I have been searching for a way to distribute macros to my tech illiterate office in the simplest way I can.
From my research, saving the Macros into a .xlam add-in would seem to be headed in the right direction.
Is it also possible to set up a custom ribbon tab in this manner?
Thus far I have failed to find any guides and our office security may also block certain avenues.
Edit:
Using W-Hit's excellent solution, and setting up the folder structure as indicated, it definitely helps make deploying an update much easier with the DeployAddIn subroutine.
I also found it useful to put the DeployAddIn and InstallAddin subroutines into a custom ribbon tab of their own!
I ran into a problem with the InstallAddin subroutine however: how to format the XML text in VBA without running into syntax errors.
I discovered that Each Element must have mso at the start e.g. <button> becomes <mso:button> and each "speech marked section" in a line must have ""double speech marks".
Perhaps the easiest way to use this install function is to save and edit the code into an active file, then open C:\Users[username]\AppData\Local\Microsoft\Office\Excel.officeUI in Notepad++. Then simply perform a find and replace to add in the extra quotation marks and paste it into the ribbonXML = "insert your text here" section of the code, ensuring it is encapsulated by the final speech marks to mark the entire section as a text string.
I might also look into adding extra functionality here... having an inputbox or userform that allows you to paste the code in at this point rather than have you enter the VBA editor to paste it in.
I currently do this, and it's a somewhat in depth process to setup, but runs smoothly once it is.
1st step is to create a folder structure with testing and production copies of your .xlam files that you are the admin for.
2nd, in the production folder, right click all .xlam files and set the attributes in the properties to Read-only. If you don't you'll never be able to update the addin if anyone else is in it.
3rd, when you make updates to the code in the testing file, just replace the production file with the updated file, and change to Read-only again. Users will only have to close all instances of excel and reopen to have the most up-to-date copy of the add-in.
Below is an admin add-in I use to move testing files to production.
Sub DeployAddIn()
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: To deploy finished/updated add-in to a network
' location as a read only file
Dim strAddinDevelopmentPath As String
Dim strAddinPublicPath As String
Dim FSO As New FileSystemObject
'Set development path
ChDrive "R:"
ChDir "R:\addins\PROJECTS"
strAddinDevelopmentPath = Application.GetOpenFilename()
If strAddinDevelopmentPath = "False" Then
Exit Sub
ElseIf InStr(strAddinDevelopmentPath, "\PRODUCTION\") > 1 Then
If MsgBox("You've Selected a Production File To Replace a Production File. Would You Like To Continue Anyway?", vbYesNo) = vbNo Then
Exit Sub
End If
End If
'Get Desitination path
strAddinPublicPath = Replace(strAddinDevelopmentPath, "TESTING", "PRODUCTION")
'Create dir if it doesn't exist
On Error Resume Next
MkDir Left(strAddinPublicPath, InStrRev(strAddinPublicPath, "\") - 1)
On Error GoTo 0
'Turn off alert regarding overwriting existing files
Application.DisplayAlerts = False
'overwrite existing file
On Error Resume Next
SetAttr strAddinPublicPath, vbNormal
On Error GoTo 0
FSO.CopyFile strAddinDevelopmentPath, strAddinPublicPath, True
SetAttr strAddinPublicPath, vbReadOnly
'Resume alerts
Application.DisplayAlerts = True
End Sub
4th, I've also written a macro to change the custom ribbon. The below link, in addition Ron deBruin's site is useful. https://grishagin.com/vba/2017/01/11/automatic-excel-addin-installation.html
Code to automate addin install after you get the right text from the officeUI file
Sub InstallAddin()
'Adapted from https://grishagin.com/vba/2017/01/11/automatic-excel-addin-installation.html
Dim eai As Excel.AddIn
Dim alreadyinstalled As Boolean
Dim ribbonXML As String
'check if already installed
For Each eai In Application.AddIns
If eai.Name = "Main addin.xlam" Then
eai.Installed = False
Exit For
End If
Next
'add and install the addin
Set eai = Application.AddIns.Add("path to Main addin.xlam", False)
eai.Installed = True
'append quick access ribbon xml to add button
ClearCustRibbon
LoadNewRibbon
'have to close addin for it to load properly the first time
Workbooks("Main addin.xlam").Close
End Sub
Sub ClearCustRibbon()
'https://social.msdn.microsoft.com/Forums/vstudio/en-US/abddbdc1-7a24-4664-a6ff-170d787baa5b/qat-changes-lost-when-using-xml-to-modify-ribbon-excel-2016-2016?forum=exceldev
Dim hFile As Long
Dim ribbonXMLString As String
hFile = FreeFile
OfficeUIFilePath = Environ("USERPROFILE") & "\AppData\Local\Microsoft\Office\Excel.officeUI"
ribbonXMLString = "<mso:customUI xmlns:mso=""http://schemas.microsoft.com/office/2009/07/customui"">" & _
"<mso:ribbon>" & _
"<mso:qat>" & _
"<mso:sharedControls>" & _
"</mso:sharedControls>" & _
"</mso:qat>" & _
"</mso:ribbon>" & _
"</mso:customUI>"
Open OfficeUIFilePath For Output Access Write As hFile
Print #hFile, ribbonXMLString
Close hFile
End Sub
Sub LoadNewRibbon()
Dim hFile As Long
hFile = FreeFile
OfficeUIFilePath = Environ("USERPROFILE") & "\AppData\Local\Microsoft\Office\Excel.officeUI"
ribbonXML = "your ribbon text here"
Open OfficeUIFilePath For Output Access Write As hFile
Print #hFile, ribbonXML
Close hFile
End Sub
***IMPORTANT---- If you install the addin manually, make sure you select no when prompted if you want the file saved to the local machine. If you save it to the local machine, it creates a local copy, and will never update if you make changes to the network copy or need to fix an error.
There are more tips, but you'll mostly need to adapt them to fit how you operate. Hope that helps.

VBA SetForegroundWindow

I'm trying to write code that periodically puts/makes sure a program is in front of all the others. To test this I have used Notepad.
This code only seems to work if I open a new program in front of Notepad - and not if I open a program; then start to execute my code; then put the other already open program in front of notepad. In this case notepad only blinks orange in the taskbar.
Can anybody help me with this?
Sub test()
Dim vPID As Variant
vPID = Shell("notepad.exe", vbMaximizedFocus)
AppActivate vPID
'Notepad opens, I put another program in front of it
Application.Wait (Now + TimeValue("00:00:05"))
'I want Notepad back in front again:
Dim HWND As Long
Dim SetFocus As Long
HWND = FindWindow("Notepad", vbNullString)
SetFocus = SetForegroundWindow(HWND)
Application.Wait (Now + TimeValue("00:00:05"))
'Close Notepad
Call Shell("TaskKill /F /PID " & CStr(vPID), vbHide)
End Sub

Restrict number of copies to print

I have 5 computers and two printers connected by LAN. There is one particular excel document in one of the computers (not shared) for which I wish to restrict the number of copies that can be printed, to 4. Meaning the user should not be able to print more than 4 copies of that document.
I am aware of the photocopying (and more) loopholes, but i am still hopeful of print copies getting out in a controlled or limited number.
I have looked through the features of a few print control softwares, but i learnt that they all have a "quota" system with users having to pay for printing after exceeding their limit. I am afraid this wont work for me.
I also read an answer to a similar question posted here, Set number of copies per worksheet
Thankfully this answer very much helped me, except I have no clue on how am going to restrict or limit the user to take printouts beyond the specified number.
I also have read many answers saying that restricting the number of copies is next to impossible, But i still wish to look for help - maybe some solution could come up.
I dont have much deep knowledge in computer/printer programming.Though not a pro, I am a little familiar with excel vba.
Please let me know if there can be any solutions,
As soon as I find something I'll post it here.
Thanks a ton for the help.
This is a crude solution but this would add some limit on number of prints...
Place in ThisWorkbook:
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Cancel = True
If Cancel = True Then
MsgBox "Please use the print button on Sheet1."
End If
End Sub
Add a CommandButton and rename it PrintButton then insert this subroutine (and accompanying functions) into a Module
Private Sub PrintButton_Click()
On Error Resume Next
Application.EnableEvents = False
If (CanWePrint(4)) Then
ActiveSheet.PrintOut
Else
MsgBox ("Sorry this is the maximum number of prints for this document!")
End If
Application.EnableEvents = True
On Error GoTo 0
End Sub
Function CanWePrint(ByVal MaxPrintVal As Integer) As Boolean
Dim CurrentPrintCount As String, SecretFile As String
'PLEASE CHANGE TO YOUR "SECRET" TXT FILE NAME AND LOCATION!
SecretFile = "C:\Users\Matt\Documents\countPrint.txt"
CurrentPrintCount = GetCount(SecretFile)
If (CurrentPrintCount < MaxPrintVal) Then
Call UpdatePrintCount(CurrentPrintCount, SecretFile)
CanWePrint = True
Else
CanWePrint = False
End If
End Function
Function GetCount(ByVal SecretFile As String) As Integer
Dim nSourceFile As Integer
Dim sText As String
Close
nSourceFile = FreeFile
Open SecretFile For Input As #nSourceFile
sText = Input$(LOF(1), 1)
Close
GetCount = CInt(sText)
End Function
Sub UpdatePrintCount(ByVal CurrentVal As Integer, ByVal SecretFile As String)
Dim sBuf As String
Dim sTemp As String
Dim iFileNum As Integer
iFileNum = FreeFile
Open SecretFile For Input As iFileNum
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close iFileNum
sTemp = Replace(sTemp, CurrentVal, CurrentVal + 1)
iFileNum = FreeFile
Open sFileName For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
End Sub
What this does
This code will disable the standard Print option in Excel for that workbook. By adding a CommandButton you create a manual print option which will check the print count stored in a .txt file, this will mean the document can be closed and reopened and still only be printed 4 times.
What you need to do
Create a new txt file on the same machine as this document and update the path in code above in CanWePrint.
Draw Backs
Like I said this is a crude solution and there would be many ways around this:
Manually change the value in the .txt file
Save the workbook without VBA
Disabling the VBA
This is not at all crude, its very much sophisticated for me:) I am okay with the drawbacks mentioned. The code worked fine when i pasted it in sheet 1 instead of a module. Theres one catch here though, Matts code is good for one file..what i have is an empty template like file(saved as macro enabled excel workbook, but working like a template for me) which has to be filled up and printed again and again, but I need to avoid duplication, hence not more than 4 copies.
So what i have tried is,
i created a macro with a keyboard shortcut. This macro does this:
It takes 4 printouts.
It inserts a watermark into the file, (thus marking it as invalid)
It exports the selected range as pdf and saves it in my specified folder (so all saved pdfs have watermarks, and its not possible to erase it in adobe reader)
It removes the watermark, clears all entered data, thus providing a new doccument to be created next time.
This is working for me, except that anyone could print any number of copies if they did not use my shortcut.
But with the "beforeprint" code in Matts answer that will be solved.
So thanks a ton Matt!
As you mentioned, there can be more ways around this, I'll keep working,
For now this should work for me.
Please let me know if my way is good and if there are any loops..
Thank you!

Unable to connect to Access database with ADO

I need to import a bunch of tables stored in .txt files into an Access database. When they are done importing, I use an ADO connection to communicate between the database and an Excel workbook. I have the Access database set to compact and repair on close.
The problem is, when I close the database after importing the files, I am unable to connect using ADO without waiting for an arbitrary amount of time. The Access window appears to be closed when I try to connect and fail. I have found that the amount of time I have to wait is related to the size of the database after import. After importing the largest sets of files, even a 60 second wait is not enough.
Is there some way I could force the connection to open? Of failing that, how could I check if it was ready to connect?
Here is some of the code I'm using:
MDB_Address = "C:\example.mdb"
Shell "cmd /c " & Chr(34) & MDB_Address & Chr(34), vbHide
'Some code that tests if it has opened happens here
...
Set ObjAccess = GetObject("C:\example.mdb")
' Import tables here
ObjAccess.Quit
Call CloseAccess
Call Wait
mdbPath = "C:\example.mdb"
Set mdbConnection = CreateObject("ADODB.Connection")
' The line below gives a run time error. The description is "Automation error Unspecified Error"
mdbConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & mdbPath
Sub CloseAccess
' I have set up the access database to write a flag to a .txt file when a
userform closes and use this to help check if it has closed.
End Sub
Sub Wait
' Wait 5 seconds. The access window appears to be closed.
Dim nHour As Date, nMinute As Date, nSecond As Date, waitTime As Date
nHour = Hour(Now())
nMinute = Minute(Now())
nSecond = Second(Now()) + 5
waitTime = TimeSerial(nHour, nMinute, nSecond)
Application.Wait waitTime
End Sub
Here is what I have ended up doing to test if the database is closed. I use Windows API functions to get the process handle for the Access database and then get its exit status.
This seems to work pretty well. There are surely other ways of accomplishing this - I think there is an ldb file that is created in the directory and it would probably work to check for its existence.
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
'Open the data base
TaskID = Shell("cmd /c " & Chr(34) & MDB_Address & Chr(34), vbHide)
ACCESS_TYPE = &H400
hProc = OpenProcess(ACCESS_TYPE, False, TaskID)
'Some code that tests if it has opened happens here
...
Set ObjAccess = GetObject("C:\example.mdb")
' Import tables here
ObjAccess.Quit
Call CloseAccess
Sub CloseAccess()
Dim test As Long
'Test if the database has closed
Do Until lExitCode <> 259 And test <> 0
test = GetExitCodeProcess(hProc, lExitCode)
DoEvents
Loop
End Sub

Resources