Need: Start or stop the Onedrive sync client via VBA
Reason: Running a procedure that looped through files and made some changes caused Excel to crash while Onedrive sync client was running
Couldn't find a more "elegant" way to do it, but it works
Adjust the program files folder if you're using 32bit version
' Credits: https://stackoverflow.com/questions/49652606/wscript-shell-to-run-a-script-with-spaces-in-path-and-arguments-from-vba
Private Sub ManageOnedriveSync(ByVal action As Integer)
Dim shell As Object
Set shell = VBA.CreateObject("WScript.Shell")
Dim waitTillComplete As Boolean: waitTillComplete = False
Dim style As Integer: style = 1
Dim errorcode As Integer
Dim path As String
Dim commandAction As String
Select Case action
Case 1
commandAction = "/shutdown"
End Select
path = Chr(34) & "%programfiles%\Microsoft OneDrive\Onedrive.exe" & Chr(34) & " " & commandAction
errorcode = shell.Run(path, style, waitTillComplete)
End Sub
Shutdown:
ManageOnedriveSync 1
Start:
ManageOnedriveSync 0
Related
I have a piece of code that checks if an excel file opened or not by someone and display that user's username if it is opened. It was working fine, but recently it is throwing some error as shown in picture. But the error occurs only sometimes and not always. Anyone knows why?
Sub TestFileOpened()
Dim Folder As String
Dim FName As String
Dim fileOpenedOrNot As String
fileOpenedOrNot = "\\122.00.00.000\shared\Admin Confidential\Admin_Planner Database\Admin\Templates and Files\~$Running Numbers and ComboBox Lists.xlsx"
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(fileOpenedOrNot) Then
fileInUse = True
MsgBox "Database is opened and using by " & GetFileOwner(fileOpenedOrNot) & ". Please wait a few seconds and try again", vbInformation, "Database in Use"
Else
fileInUse = False
End If
End Sub
Function GetFileOwner(strFileName)
Set objWMIService = GetObject("winmgmts:")
Set objFileSecuritySettings = _
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & strFileName & "'")
intRetVal = objFileSecuritySettings.GetSecurityDescriptor(objSD)
If intRetVal = 0 Then
GetFileOwner = objSD.Owner.Name
Else
GetFileOwner = "Unknown"
End If
End Function
The following is the line that throwing error
objWMIService.Get("Win32_LogicalFileSecuritySetting='" & strFileName & "'")
Update 1
After further checks, I noticed there were no temp file ~$Running Numbers and ComboBox Lists.xlsx created although that file is opened. Basically objFSO.FileExists(fileOpenedOrNot) setting to true and going into that if condition. But when it calls the GetFileOwner function, it is not seeing the file and probably that is why have the error.
Like I mentioned, this code was working earlier without issues, but all of a sudden having such problem. Anyone knows why there is no such temp file created?
Check if this method works for you. Looks like it works for me better than yours but still it throws me Predefined\Administrators as owner on the network instead of the correct user name.
Option Explicit
Public Sub test()
Const fileOpenedOrNot As String = "\\122.00.00.000\shared\Admin Confidential\Admin_Planner Database\Admin\Templates and Files\~$Running Numbers and ComboBox Lists.xlsx"
Dim objFSO As FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(fileOpenedOrNot) Then
Dim objFile As Object
Set objFile = objFSO.GetFile(fileOpenedOrNot)
MsgBox GetFileOwner(objFile.ParentFolder & "\", objFile.Name)
End If
End Sub
Public Function GetFileOwner(ByVal fileDir As String, ByVal fileName As String) As String
Dim securityUtility As Object
Set securityUtility = CreateObject("ADsSecurityUtility")
Dim securityDescriptor As Object
Set securityDescriptor = securityUtility.GetSecurityDescriptor(fileDir & fileName, 1, 1)
GetFileOwner = securityDescriptor.Owner
End Function
I have been successfully running my r script in Excel 2010 & Windows 7 using vba for a long time. Then I had to use another computer which has Excel 2013 & Windows 8 installed. It gets me the following error:
Method 'Run' of object 'IWshShell3' failed
This is the code that runs in Excel 2010:
Dim shell As Object
Set shell = VBA.CreateObject("WScript.Shell")
Dim waitTillComplete As Boolean: waitTillComplete = True
Dim style As Integer: style = 0
Dim errorCode As Integer
Dim var1 As String
Dim PATH As String
var1 = Replace(Replace(ThisWorkbook.PATH, "\", "/") & "/", " ", "_z9z_")
PATH = "C:\PROGRA~1\R_App\bin\x64\RScript """ & "C:\JF\Code A\dvlp.R"" " & var1 & " " & 2500
errorCode = shell.Run(PATH, style, waitTillComplete)
This same code doesn't run in the other computer I mentioned.
I have gone through other questions in stackoverflow stating the same issue, but the solutions there hasn't helped me. For example, I already use double quotes and I have tried getting rid of them.
Any ideas?
Consider a cleaner build of command line Rscript call that can handle spaces in names which may be the issue here. Below also integrates proper error handling.
Sub Run_R_Script()
On Error Goto ErrHandle
Dim shell As Object
Dim waitTillComplete As Boolean: waitTillComplete = True
Dim style As Integer: style = 0
Dim errorCode As Integer
Dim args(0 To 3) As String
Dim rCommand As String
Dim i As Integer
args(0) = "C:\PROGRA~1\R_App\bin\x64\RScript"
'args(0) = "Rscript.exe" ' IF R BIN FOLDER IN PATH ENV VARIABLE
args(1) = "C:\JF\Code A\dvlp.R"
args(2) = Replace(Replace(ThisWorkbook.PATH, "\", "/") & "/", " ", "_z9z_")
args(3) = 2500
rCommand = args(0)
For i = 1 To UBound(args)
rCommand = rCommand & " """ & args(i) & """"
Next i
Debug.Print rCommand ' CHECK COMMAND LINE CALL
Set shell = VBA.CreateObject("WScript.Shell")
errorCode = shell.Run(rCommand, style, waitTillComplete)
ExitHandle:
Set shell = Nothing ' RELEASE ALL set OBJECTS
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical
Resume ExitHandle
End Sub
I have an Excel VBA script that takes two files and performs a Relace function on one column. This all works fine if i step through it slowly. But if i run it without any breaks then it produces a file that still contains the characters that i replaced ?
I have added "Kill" file commands to ensure that i am creating new files, even my output file i am using a datestamp to ensure its a unique file then renaming it. But i then upload it to an FTP server as part of the script and when viewing what i have uploaded, it has the characters i removed ? even though when i view my output file before uploading, it doesnt ?????
Private Sub OutputFile()
Dim strNowDifferentiator As String
Dim strPath As String
Dim AgentStr As String
Dim AccessTypeLong As Long
Dim ProxyNameStr As String
Dim ProxyBypassStr As String
Dim FlagsLong As Long
Dim InternetSessionLong As Long
Dim ServiceLong As Long
Dim ContextLong As Long
Dim FTPSessionLong As Long
Dim FailIfExistsBool As Boolean
Dim FlagsAndAttributesLong As Long
Dim SomeThingLong As Long
Dim MyInternetHandleLong As Long
Dim MyFTPHandleLong As Long
Dim SomeInteger As Integer
Dim FTPSuccessBool As Boolean ' Did the FTP download work?
AgentStr = "GreenTreeTest" ' can be whatever
AccessTypeLong = 0 ' zero appears to work fine
ProxyNameStr = "" ' nul works fine here
ProxyBypassStr = "" ' nul works fine here
FlagsLong = 0 ' zero appears to work fine
MyInternetHandleLong = InternetOpen(AgentStr, AccessTypeLong, ProxyNameStr, ProxyBypassStr, FlagsLong)
' MsgBox MyInternetHandleLong
'MyInternetHandleLong is obtained above
ServiceLong = 1 ' this for the FTP service (2 = gopher, 3 = http)
FlagsLong = 0 ' 0 appears to work fine here
ContextLong = 0 ' 0 appears to work fine here
MyFTPHandleLong = InternetConnect(MyInternetHandleLong, "mercury.ingrammicro.com", 21, "CDW_PRICEFILE", "XXXXX", ServiceLong, FlagsLong, ContextLong)
strNowDifferentiator = Replace(Replace(Now(), "/", " "), ":", "")
strPath = "\\Sov-fs3\Departmental\Supply Chain\Feeds\"
Application.DisplayAlerts = False
Call subUpdateProgressLabel("Producing the output file...")
'DeleteFile ("C:\temp\CDWFeed.csv")
DeleteFile (strPath & "CDWFeed.csv")
ThisWorkbook.Sheets("Output").Copy
'ActiveWorkbook.SaveAs Filename:="C:\temp\CDWFeed.csv", FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.SaveAs Filename:=strPath & "CDWFeed" & strNowDifferentiator & ".csv", FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close SaveChanges:=False
Name strPath & "CDWFeed" & strNowDifferentiator & ".csv" As strPath & "CDWFeed.csv"
Call FtpDeleteFile(MyFTPHandleLong, "CDWFeed.csv")
Application.DisplayAlerts = True
Sheets("Output").Cells.Clear
Call subUpdateProgressLabel("Uploading file to Ingram fTP...")
'removed SHELL as doesnt work well within CITRIX
'Shell ("ftp -s:" & Chr(34) & "\\Sov-fs3\Departmental\Supply Chain\Feeds\script.txt" & Chr(34) & " mercury.ingrammicro.com")
Call FtpUpload("\\Sov-fs3\Departmental\Supply Chain\Feeds\CDWFeed.csv", "CDWFeed.csv", "mercury.ingrammicro.com", 21, "CDW_PRICEFILE", "XXXXXX")
End Sub
I have an Excel workbook that has an active data connection to a SharePoint list on a company server. The SP list is just a listing of all the files in an SP document library at that point in time. I have a VBA subroutine that is responsible for refreshing this data connection to see what is in the library at that time and then move some info from the list (document name, document author, submission timestamp, etc.) to a different workbook.
The SharePoint site uses Active Directory credentials to authenticate and the SharePoint is also mapped as a network drive on the PC running the code. But even so, refreshing this data connection sometimes results in a credential prompt that looks just like the image at the end of my post. If I manually enter the same AD credentials again, the connection request is authenticated and the list updates in Excel.
My question is this: how can I account for this in my code? Ideally, I would like for this to trigger an email alert or something, but the thing is that the line of code (ThisWorkbook.RefreshAll) that performs the connection refresh does not run to completion until the credential prompt is dealt with, so I can't set up any handlers in the lines of code that follow. I can't have this refresh potentially resulting in code that just hangs on this line until someone happens to notice something is wrong (it is running on an unattended PC). Anyone know anything that could help deal with my issue?
Since the drive is locally mapped, you should be able to just go directly to the file and manipulate it however you need, importing it, instead of having an active data connection. It would allow you more flexibility than a more rigid data connection.
This website has a good example showing how to do what you're looking for, but the way I'm imagining would be more efficient considering the circumstances.
This really depends on how you are doing your connection and in some instances it is not possible, but you can append Username and Password to a URL to pass your credentials, such as defined here (for other languages but you get the gist):
https://www.connectionstrings.com/sharepoint/
Now the reality is, you probably aren't doing a REST connection and you might have to as discussed here: https://www.experts-exchange.com/questions/28628642/Excel-VBA-code-using-authentication-to-SharePoint.html
They recommended:
Public Sub CopyToSharePoint()
On Error GoTo err_Copy
Dim xmlhttp
Dim sharepointUrl
Dim sharepointFileName
Dim tsIn
Dim sBody
Dim LlFileLength As Long
Dim Lvarbin() As Byte
Dim LobjXML As Object
Dim LstrFileName As String
Dim LvarBinData As Variant
Dim PstrFullfileName As String
Dim PstrTargetURL As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fldr As Folder
Dim f As File
Dim pw As String
Dim UserName As String
Dim RetVal
Dim I As Integer
Dim totFiles As Integer
Dim Start As Date, Finish As Date
UserName = InputBox(Username?") pw = InputBox("Password?")
sharepointUrl = "[http path to server]/[server folder to write to]"
Set LobjXML = CreateObject("Microsoft.XMLHTTP")
Set fldr = fso.GetFolder(CurrentProject.Path & "\[folder with files to
upload]\") totFiles = fldr.Files.Count
For Each f In fldr.Files
sharepointFileName = sharepointUrl & f.Name
'**************************** Upload text files
**************************************************
If Not sharepointFileName Like "*.gif" And Not sharepointFileName
Like "*.xls" And Not sharepointFileName Like "*.mpp" Then
Set tsIn = f.OpenAsTextStream
sBody = tsIn.ReadAll
tsIn.Close
Set xmlhttp = CreateObject("MSXML2.XMLHTTP.4.0")
xmlhttp.Open "PUT", sharepointFileName, False, UserName, Password
xmlhttp.Send sBody
Else
'**************************** Upload binary files
**************************************************
PstrFullfileName = CurrentProject.Path & "\[folder with files to upload]\" & f.Name
LlFileLength = FileLen(PstrFullfileName) - 1
' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1
' Convert to variant to PUT.
LvarBinData = Lvarbin
PstrTargetURL = sharepointUrl & f.Name
' Put the data to the server, false means synchronous.
LobjXML.Open "PUT", PstrTargetURL, False, Username, Password
' Send the file in.
LobjXML.Send LvarBinData
End If
I = I + 1 RetVal = SysCmd(acSysCmdSetStatus, "File " & I & " of " & totFiles & " copied...") Next f
RetVal = SysCmd(acSysCmdClearStatus) Set LobjXML = Nothing Set
fso = Nothing
err_Copy: If Err <> 0 Then MsgBox Err & " " & Err.Description End If
End Sub
Realistically, I think this answer may get you going down the right road: https://sharepoint.stackexchange.com/questions/255264/sharepoint-api-and-vba-access-denied
Regardless, this is a problem and good luck. I had better luck using MS Access to link the list as a table and then using Excel to just call Access and get what I needed.
Private Sub cmdSyncSP_Click()
On Error GoTo ErrorCode
Application.Cursor = xlWait
Dim app As New Access.Application
'Set app = CreateObject("Application.Access")
app.OpenCurrentDatabase Application.ActiveWorkbook.Path & "\SP_Sync.accdb"
app.Visible = False
app.Run "doManualCheck"
app.CloseCurrentDatabase
Set app = Nothing
MsgBox "Sync has finished. Refresh and proceed to copy your data.", vbInformation + vbOKOnly, "Success"
ExitCode:
On Error Resume Next
Application.Cursor = xlDefault
Exit Sub
ErrorCode:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Sync Error"
Resume ExitCode
End Sub
I would like to write a function to would allow me to use Print #Debug, "text" throughout my future modules to collect debug statements.
Sub output_debug()
Dim WshShell As Object
Dim Desktop As String
Dim Debug As Integer
Debug = FreeFile()
Set WshShell = CreateObject("WScript.shell")
Desktop = WshShell.specialfolders("Desktop")
Open Desktop & "\VBA_output.txt" For Output As #Debug
Print #Debug, "test"
Close #Debug
End Sub
How can I move from the above, to defining a function that would allow me to use call output_debug() in a module so all my Print #Debug, would print to that file ? I would imagine I need to create another function called close_output() that has close #Debug
I did something like this in the past. Here is what I came up with. It relies on having a reference to Microsoft Scripting Runtime in any project that uses it. You can store the following subs in a module e.g. DebugLogger (which is what I use) that can be first exported then imported into any module that you want to have this functionality. It mimics the behavior of Debug.Print but sends the output to a file whose name is a function of the workbook's name. I toyed with the idea of time-stamping individual entries but rejected the idea as being too far from the functionality of Debug.Print (I do, however, time stamp the date of creation). Once you import the module and establish the right reference then you can just use DebugLog anywhere you would have used DebugPrint. As a default it also prints to the debug window. You can drop that part of the code entirely or switch what the default is.
Function GetFullDebugName() As String
'This function returns a string of the form
'*xldebug.txt, where *.* is the full name of the workbook
Dim MyName As String
Dim NameParts As Variant
MyName = ThisWorkbook.FullName
NameParts = Split(MyName, ".")
GetFullDebugName = NameParts(0) & "xldebug.txt"
End Function
Sub CreateDebugFile()
'file created in same directory as
'calling workbook
Dim DebugName As String
Dim fso As FileSystemObject
Dim MyStream As TextStream
Set fso = New FileSystemObject
DebugName = GetFullDebugName
Set MyStream = fso.CreateTextFile(DebugName)
MyStream.WriteLine "This debug file was created " _
& FormatDateTime(Date) _
& " at " & FormatDateTime(Time)
MyStream.Close
End Sub
Sub DebugLog(DebugItem As Variant, Optional ToImmediate As Boolean = True)
Dim DebugName As String
Dim fso As FileSystemObject
Dim MyStream As TextStream
Set fso = New FileSystemObject
DebugName = GetFullDebugName
'check to see if DebugFile exist
'if not, create it:
If Not fso.FileExists(DebugName) Then CreateDebugFile
Set MyStream = fso.OpenTextFile(DebugName, ForAppending)
MyStream.WriteLine DebugItem
MyStream.Close
If ToImmediate Then Debug.Print DebugItem
End Sub
Try a subroutine like this...
It will log text to a text file with a date stamp, so new file new day.
You have an option to pass it the ERR object if you trap the error in your code and it will log the error message with a highlight.
call debuglog("my log entry")
call debuglog("my log entry",err)
Public Sub DebugLog(sLogEntry As String, Optional ByVal oErr As Object)
' write debug information to a log file
Dim iFile As Integer
Dim sDirectory As String
Dim errNumber, errDescription As Variant
Dim l As Integer
If Not oErr Is Nothing Then
errNumber = oErr.Number
errDescription = oErr.Description
l = IIf(Len(errDescription) > Len(sLogEntry), Len(errDescription), Len(sLogEntry))
End If
On Error GoTo bail
sfilename = VBA.Environ("Homedrive") & VBA.Environ("Homepath") & "\My Documents\Debuglog" & "\debuglog" & Format$(Now, "YYMMDD") & ".txt"
iFile = FreeFile
Open sfilename For Append As iFile
If Not oErr Is Nothing Then
sLogEntry = "/" & String(5 + (l - Len(sLogEntry)), "-") & " " & sLogEntry & " " & String(5 + (l - Len(sLogEntry)), "-") & "\"
Print #iFile, Now; " "; sLogEntry
Print #iFile, Now; " "; errNumber
Print #iFile, Now; " "; errDescription
Print #iFile, Now; " "; "\" & String(Len(sLogEntry) - 2, "-") & "/"
Else
Print #iFile, Now; " "; sLogEntry
End If
bail:
Close iFile
End Sub
example logfile output
27/03/2015 10:44:27 -- COMIT Form Initialize - Complete
27/03/2015 10:44:27 - COMIT Active
27/03/2015 10:44:34 /----- -- Error Populating Opportunity Form: frmBluesheet.PopulateForm() -----\
27/03/2015 10:44:34 381
27/03/2015 10:44:34 Could not get the Column property. Invalid property array index.
27/03/2015 10:44:34 \-----------------------------------------------------------------------------/