Excel Macro to "Check-out" from OneDrive Sharepoint - excel

I'm trying to develop a macro that has to "check-out" a sharepoint excel file, open with a preset password, update with some data from an offline file, save and then "check-in" back to sharepoint.
But, I'm stuck at very first step itself that I'm unable "check-out" the file and it throws the below error.
Macro Used:
Sub ExcelUpdater()
FileSharepointLocation = Range("FileLocation").Value
ExcelFilename = "Destination File.xlsb"
FileAddress = FileSharepointLocation + "/" + ExcelFilename
If Workbooks.CanCheckOut(FileAddress) = True Then
Workbooks.CheckOut ExcelFilename
Workbooks.Open Filename:=ExcelFilename
Else
MsgBox "Unable to check out this document at this time."
End If
End Sub

I was able to fix this using the below code.
Sub ExcelUpdater()
FileSharepointLocation = Range("FileLocation").Value
ExcelFilename = "Destination File.xlsb"
FileAddress = FileSharepointLocation + "/" + ExcelFilename
If Workbooks.CanCheckOut(FileAddress) = True Then
Workbooks.Open Filename:=FileAddress
Workbooks.CheckOut FileAddress
Else
MsgBox "Unable to check out this document at this time."
End If
Workbooks(ExcelFilename).CheckIn SaveChanges:=True,Comments:="Changes in..."
End Sub

Related

Task Schedule Open Excel file, Refresh Bloomberg Data, then Save and Close File

I have tried to collect all codes I could have done and it still not work for me.
What I want to do is to Schedule Task of my Excel file and I have code "RunExcel.vbs" as attached but still not working.
Reference Link: How to set recurring schedule for xlsm file using Windows Task Scheduler
Reference Link: https://www.mrexcel.com/forum/excel-questions/794869-vb-script-refresh-bloomberg-feed-excel.html
Open file “PriceRealTIme.xlsm”(Macro-enabled workbook) which is inside “TEst folder”.
Ignore to update link
Let it “Refresh Bloomberg Data” and “wait for at 1 minutes or until it done refreshing”.
Once it’s done. I want to copy paste Value of those columns by using Macro named “CopyPaste”.
Finally, let it “Save” and “Close” file.
' a .vbs file is just a text file containing visual basic code that has the extension renamed from .txt to .vbs
'Write Excel.xls Sheet's full path here
strPath = "C:\Users\chaic\OneDrive\Desktop\TEst\PriceRealTIme.xlsm"
'Write the macro name - could try including module name
strMacro = "Sheet1.CopyPaste"
'Create an Excel instance and set visibility of the instance
Set objApp = CreateObject("Excel.Application")
objApp.Visible = True ' or False
'Open workbook; Run Bloomberg Addin; Run Macro; Save Workbook with changes; Close; Quit Excel
Set wbToRun = objApp.Workbooks.Open(strPath)
Private Const BRG_ADDIN As String = "BloombergUI.xla"
Private Const BRG_REFRESH As String = "!RefreshAllStaticData"
Private TimePassed As Integer
Sub StartAutomation()
Dim oAddin As Workbook
On Error Resume Next
Set oAddin = Workbooks(BRG_ADDIN)
On Error GoTo 0
If Not oAddin Is Nothing Then
Application.Run BRG_ADDIN & BRG_REFRESH
StartTimer
End If
End Sub
Private Sub StartTimer()
TimePassed = 10
WaitTillUpdateComplete
End Sub
Sub WaitTillUpdateComplete()
If WorksheetFunction.CountIf(ThisWorkbook.Names("BloombergDataRange").RefersToRange,"#VALUE!") = 0 Then
Application.StatusBar = "Data update used " & TimePassed & "seconds, automation started at " & Now
Else
Application.StatusBar = "Waiting for Bloomberg Data to finish updating (" & TimePassed & " seconds)..."
TimePassed = TimePassed + 1
Application.OnTime Now + TimeSerial(0, 0, 1), "WaitTillUpdateComplete"
End If
End Sub
objApp.Run strMacro ' wbToRun.Name & "!" & strMacro
wbToRun.Save
wbToRun.Close
objApp.Quit
'Leaves an onscreen message!
MsgBox strPath & " " & strMacro & " macro and .vbs successfully completed!", vbInformation
This is an old threat, but maybe this answer will help others.
The code below is working for me. The computer is set for it to never sleep or lock the screen.
The computer is using Office 365 and excel 2016.
' a .vbs file is just a text file containing visual basic code that has the extension renamed from .txt to .vbs
'Write Excel.xls Sheet's full path here
strPath = "myPath"
'Create an Excel instance and set visibility of the instance
Set objApp = CreateObject("Excel.Application")
objApp.Visible = False ' or True
Set wbToRun = objApp.Workbooks.Open(strPath)
StartAutomation
Sub StartAutomation()
Dim oAddin
Set oAddin = objApp.Workbooks.Open("C:\blp\API\Office Tools\BloombergUI.xla")
objApp.Addins("Bloomberg Excel Tools").Installed = False
objApp.Addins("Bloomberg Excel Tools").Installed = True
If Not oAddin Is Nothing Then
objApp.DisplayAlerts = False
objApp.Calculate
objApp.Run "RefreshAllStaticData"
objApp.Calculate
objApp.Run "RefreshAllStaticData"
WaitTillUpdateComplete
End If
End Sub
Dim t
t = 0
Private Sub WaitTillUpdateComplete()
objApp.Calculate
If objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#NAME?") > 0 Then
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
ElseIf objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A") > 0 Then
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
ElseIf objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A Requesting Data...") > 0 Then
If t < 5 Then
t = t+ 1
waitlonger
Else
Exit Sub
End If
Else
Exit Sub
End If
End Sub
Sub waitlonger()
Dim x
x = Now + TimeValue("00:00:40")
Do While x > Now
Loop
objApp.Calculate
End Sub
wbToRun.Save
wbToRun.Close
objApp.DisplayAlerts = False
objApp.Quit

Batch Convert TDM files to XLS

MY GOAL: Batch convert all .TDM files in a folder to .XLS using an existing add-in by adapting this macro that only works 1 file at a time. (Also open to any VBA approach.)
Using an existing add-in, a single .TDM file is converted into a single .XLS workbook with multiple sheets.
I need to, instead of using a prompt to select a single .TDM file, automatically convert all .TDM files in a folder into new .XLS workbooks.
This is part of a multi-stage process. I tried various loops, mimicking other set-ups, and merging it with other code I found on various community boards.
FYI: .TDM files hold engineering data output produced by testing equipment.
Sub GetTDM_AddIn()
'Get TDM Excel Add-In
Dim obj As COMAddIn
Set obj = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
'obj.Connect = True
'Confirm only importing "Description" properties for Root
Call obj.Object.Config.RootProperties.DeselectAll
Call obj.Object.Config.RootProperties.Select("Description")
'Show the group count as property
Call obj.Object.Config.RootProperties.Select("Groups")
'Select all the available properties for Group
Call obj.Object.Config.GroupProperties.SelectAll
'Import custom properties
obj.Object.Config.RootProperties.SelectCustomProperties = True
obj.Object.Config.GroupProperties.SelectCustomProperties = True
obj.Object.Config.ChannelProperties.SelectCustomProperties = True
'Let the user choose which file to import
Dim fileName
fileName = Application.GetOpenFilename("TDM & TDMS (*.tdm;*.tdms),*.tdm;*.tdms")
If fileName = False Then
' User selected Cancel
Exit Sub
End If
'Import the selected file
Call obj.Object.ImportFile(fileName)
'Record down the current workbook
Dim Workbook As Object
Set Workbook = ActiveWorkbook
End Sub
Below is an Excel Macro (VBA Script) I wrote to do something very similar to what you want to do. It converts a directory of .tdms files to their equivalent .csv files. It requires the ExcelTDM Add In (NITDMEXCEL_2015-0-0.exe) which I obtained at http://www.ni.com/example/27944/en/. I tested the script in Excel 2013 running on a modest Windows 7 Pro machine converting 24 TDMS files with 120,000 rows each file. It completed the conversions without error in about 2 minutes 30 seconds which is about 7 seconds per file. Please forgive my hasty error handling and poor VBA form.
Sub ConvertTDMStoCSV()
'
' ConvertTDMS Macro
'
' Acts upon all .tdms files in a "source" directory,
' loading each one using the ExcelTDM Add In,
' deleting the first sheet and saving the
' remaining stream data as one .csv file
' in a "target" directory. Writes a list of
' the files converted in a new sheet.
'
' Tested to work with Excel 2013 on Windows 7
' with NITDMEXCEL_2015-0-0.exe obtained at
' http://www.ni.com/example/27944/en/
Dim sourceDir As String, targetDir As String, fn As String, fnBase As String
Dim fso As Object, n As Long, resp As Integer, strNow As String, newSheet As Object
Dim tdmsAddIn As COMAddIn, importedWorkbook As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set tdmsAddIn = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
tdmsAddIn.Connect = True
Call tdmsAddIn.Object.Config.RootProperties.DeselectAll
Call tdmsAddIn.Object.Config.ChannelProperties.DeselectAll
tdmsAddIn.Object.Config.RootProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.GroupProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.ChannelProperties.SelectCustomProperties = False
'Choose TDMS Source Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Source Directory of TDMS Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
sourceDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(sourceDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, sourceDir
Exit Sub
End If
'Choose CSV Target Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Target Directory for CSV Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
targetDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(targetDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, targetDir
Exit Sub
End If
fn = Dir(sourceDir & "\*.tdms")
If fn = "" Then
MsgBox "No source TDMS files found.", vbInformation
Exit Sub
End If
resp = MsgBox("Begin conversion of TDMS files?" & vbCrLf & sourceDir & vbCrLf & "to" & vbCrLf & targetDir, vbYesNo, "Confirmation")
If resp = vbNo Then
MsgBox "Execution cancelled by user."
Exit Sub
End If
Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
strNow = WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss")
newSheet.Name = strNow
newSheet.Cells(1, 1).Value = "Files converted on " & strNow
newSheet.Cells(2, 1).Value = "TDMS Source Directory: " & sourceDir
newSheet.Cells(3, 1).Value = "CSV Target Directory: " & targetDir
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
n = 5
Do While fn <> ""
fnBase = fso.GetBaseName(fn)
On Error Resume Next
Call tdmsAddIn.Object.ImportFile(sourceDir & "\" & fn, True)
If Err Then
MsgBox Err.Description, vbCritical
Exit Sub
End If
Set importedWorkbook = ActiveWorkbook
Application.DisplayAlerts = False
importedWorkbook.Sheets(1).Delete
importedWorkbook.SaveAs Filename:=targetDir & "\" & fnBase & ".csv", FileFormat:=xlCSV
importedWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
newSheet.Cells(n, 1).Value = fnBase
n = n + 1
fn = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set fso = Nothing
Set newSheet = Nothing
Set importedWorkbook = Nothing
End Sub
Instead of trying to do this in VBA, I suggest that you use powershell to get all of the files and then call the Excel macro, for each file, using the Run method.
You'll also need to modify the macro to either (1) run on the current open file (solution below); or (2) take a filename as an argument (this changes the call to Run below)
The code is something like this (modify the call to get-childitem to fit your applicaton):
$excel = new-object -comobject excel.application
$files = get-childitem ... #etc, collect your files into an array
foreach ($file in $files)
{
$wb = $excel.workbooks.open($file.fullname)
$ws= $wb.worksheets.item(1)
$ws.Activate()
$excel.Run("GetTDM_AddIn")
$wb.save()
$wb.close()
}
$excel.quit()
I used this simple app to convert tdms files.
It supports multiple files and has command line support.
http://www.whiterocksoftware.com/2019/11/batch-convert-tdms-to-excel.html

Excel Password and carving out Tab name

I'm in the process of setting up a Macro to open up all files in a directory and copy a certain tab from each into a combined file (merge them in one workbook). I have two problems. Firstly the files are password protected - So when I use this line it opens the file.
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName)
However when it's password protected it fails. So I added the following to the end but it still fails.
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName),Password = "openfile"
2nd issue - When I copy the tabs (sheets) in I want to name them with the file name I took them from. However the file name is too long - So I want to take the name up to the first space (e.g. "Test file May 13" = sheet name "Test"). How do I get this code to work.
Any help greatly appreciated.
Full code below:
* gRnCT_File_Loc = Directory location.
* gsInputFileName = File Name.
Code to date:
Sub Pulldata()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set gRwksconfigeration = Sheets(gcsConfigSheetName)
gRnCT_File_Loc = gRwksconfigeration.Range(CT_File_Loc)
gRnCT_Tab_Search = gRwksconfigeration.Range(CT_Tab_Search)
gsInputFileName = Dir(gRnCT_File_Loc)
Set gwkscurrent = ActiveWorkbook
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> gcsConfigSheetName Then ws.Delete
Next ws
Do
On Error GoTo err:
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName)
On Error GoTo 0
On Error GoTo err1:
With Sheets(gRnCT_Tab_Search)
On Error GoTo 0
End With
gsInputFileName = Dir
Loop Until gsInputFileName = vbNullString
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
err:
MsgBox ("No files or files in incorrect format in " & gRnCT_File_Loc)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
err1:
MsgBox ("Sheet " & gRnCT_Tab_Search & " doesn't exist in file " & gsInputFileName)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Resume Next
End Sub
For the 2nd question about getting the 1st part of the file name, try:
if(instr(gsInputFileName," ") > 0
then short_file_name=left(gsInputFileName,instr(gsInputFileName," ")-1)
else short_file_name=gsInputFileName
endif
You are missing a : after password
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName),Password = "openfile"
should be:
Set gwkbInputdata = Workbooks.Open(gRnCT_File_Loc & gsInputFileName,Password:="openfile")
You could use split for your second problem using a space as your delimiter e.g.
Split(str, " ")(0)
where str is the original name of the file e.g. "Test file May 13"

Excel crashes when install an addin

Excel AddIn, .NET 4.0, NetOffice 1.5.1.2, ExcelDNA 1.29, C#
installers calls a xls (install.xls) with VBA as follow
At the end of install.xls, Excel will close.
However, after Excel closes, Excel crashes saying "Excel stops working... please send report to Microsoft" with two buttons, one is "Don't Send", the other is send
This ONLY happens on Windows XP + Excel 2007 or WinXP + Excel 2010.
Also during debug I notice if I replace Application.Wait with MsgBox, then there is no crashes issue at all. I feel there is some kind of timing issue but really has no clue no control.
The issue drives me crazy. Please help. thanks!
Private Sub Workbook_Open()
Dim quit As Integer
Dim added As Boolean
added = Add_Addin
Application.Wait (Now + TimeValue("0:00:02"))
If Workbooks.Count = 1 Then
Application.Wait Now + TimeValue("0:00:03")
Application.quit
Else
Application.Wait Now + TimeValue("0:00:03")
Me.Close
End If
End Sub
Private Function Add_Addin() As Boolean
On Error GoTo ERR_
Dim addinFile As String
addinFile = ThisWorkbook.Path & "\" & "MyAdd-In.xll"
If Len(addinFile) > 0 Then
Dim LEA As AddIn
Set LEA = Application.AddIns.Add(addinFile)
If (Not LEA Is Nothing) Then
LEA.Installed = True
Else
MsgBox "Failed to add XLL"
End If
'If (Application.RegisterXLL(addinFile) = True) Then
' MsgBox "Yeah, succeed registering XLL"
'Else
' MsgBox "Failed to register XLL"
'End If
Else
MsgBox "XLL file not found"
End If
addinFile = ThisWorkbook.Path & "\" & "MyFunc.xla"
If Len(addinFile) > 0 Then
Dim LEA2 As AddIn
Set LEA2 = Application.AddIns.Add(addinFile)
If (Not LEA2 Is Nothing) Then
LEA2.Installed = True
Else
MsgBox "Failed to add xla"
End If
Else
MsgBox "xla file not found"
End If
Add_Addin = True
Exit Function
ERR_:
MsgBox ("Error " & Err.Number & " " & Err.Description)
Add_Addin = False
End Function
I figured it out. I kicked off a web service call asychronously with callback When Excel opens. When the callback of the web service call is executed after Excel is disposed or close, the crash occurred. The callback disbales/enables ribbon buttons based on the result from web service. I fixed it by checking if Excel is null or disposed before doing anything else in the callback.

How can I tell if (in VBA) if a document is opened from SharePoint?

Is there a way to determine whether the current document (whether that be a Word document, Excel workbook or PowerPoint presentation) was opened from a SharePoint server?
It's the sort of thing that you'd think would have a property on ActiveDocument / ActiveWorkbook / ActivePresentation, but if there is such a property, I can't find it.
I could look at the FullName property, and see whether it begins http:// which I guess would be a reasonable hueristic, but I'm sure there must be a cleaner way.
If it makes a difference, let's assume Office 2007 or later (and SharePoint 2007 or later).
I faced the same problem some time ago and have not found clean way of determining this. The dirty way I used is analysing the origin path of the document and determining source based on it. It still has one or two pitfalls but should handle non-malevolent situations/users.
Private Sub Document_Open()
'if default drafts location is not set in registry then exit
If IsNull(GetDefaultDrafts()) Then Exit Sub
'if document path includes 'http://' then it comes from SharePoint
If InStr(ActiveDocument.Path, "http://") = 1 Then
'MsgBox ("Opened From SP")
Exit Sub
Else
'if it does not
If IsNull(GetCustomDrafts()) Then
'if there is no custom location for drafts in registry
'check if file path contains default location for drafts
'if it does then it most likely comes from SharePoint
If InStr(ActiveDocument.Path, GetDefaultDrafts()) = 1 Then
'MsgBox ("Opened From SP")
Exit Sub
Else
MsgBox WarningMessage(), vbCritical
Exit Sub
End If
Else
'there is custom location for drafts
If InStr(ActiveDocument.Path, GetCustomDrafts()) = 1 Then
'MsgBox ("Opened From SP")
Exit Sub
Else
MsgBox WarningMessage(), vbCritical
Exit Sub
End If
End If
End If
End Sub
Function GetDefaultDrafts()
Const HKEY_LOCAL_MACHINE = &H80000001
strComputer = "."
Set objRegistry = GetObject("winmgmts:\\" & _
strComputer & "\root\default:StdRegProv")
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"
strValueName = "Personal"
objRegistry.GetStringValue HKEY_LOCAL_MACHINE, strKeyPath, strValueName, strValue
If IsNull(strValue) Then
GetDefaultDrafts = Null
Else
GetDefaultDrafts = strValue + "\SharePoint Drafts"
End If
End Function
Function GetCustomDrafts()
Const HKEY_LOCAL_MACHINE = &H80000001
strComputer = "."
Set objRegistry = GetObject("winmgmts:\\" & _
strComputer & "\root\default:StdRegProv")
strKeyPath = "Software\Microsoft\Office\Common\Offline\Options"
strValueName = "Location"
objRegistry.GetStringValue HKEY_LOCAL_MACHINE, strKeyPath, strValueName, strValue
If IsNull(strValue) Then
GetCustomDrafts = Null
Else
GetCustomDrafts = strValue
End If
End Function
Function WarningMessage()
WarningMessage = "It seems that this document has not been opened from SharePoint library but from local copy instead. Local copies must not be used to preserve system functionality."
End Function

Resources