I want to make a rest call [post/get] from excel macro from background . The macro should execute silently for every 5sec. If rest call gets valid response, show some message to user.
Note: When macro is running in the background Async , it should not interrupt the user experience on excel
I have used call back method, but the problem is excel is slow as the macro which makes rest call runs continuously at the background. Below is the code FYR.
'MyReadyStateHandler class module
Sub OnReadyStateChange()
DoEvents
If Actions.docx.readyState = 4 Then
If Actions.docx.Status = 200 Then
IsReadyState = True
outPutText = Actions.docx.responseText
Exit Sub
Else
IsReadyState = False
Exit Sub
End If
End If
End Sub
_________________________
'Sub using MyReadyStateHandler
Public sub TestRestServiceStatus()
Set MyOnReadyStateWrapper = New MyReadyStateHandler
Set docx = New MSXML2.XMLHTTP60
docx.OnReadyStateChange = MyOnReadyStateWrapper
docx.Open "POST", urlString, False
docx.send jsonBody
responceStatus = MyOnReadyStateWrapper.IsReadyState
If (responceStatus = True) Then
Dim notificationOutPut As String
notificationOutPut=MyOnReadyStateWrapper.outPutText
If InStr(notificationOutPut , "PROCESSING") > 0 Then
Call TestRestServiceStatus
ElseIf InStr(notificationOutPut , "COMPLETE") > 0 Then
'Notify User on Excel
EndIF
EndIf
End sub
Related
I am trying to run a VBA script (the script refers to a button, CommandButton1_Click ()), from a Python script. But all the time he writes an error that the macro cannot be found. I tried different spellings of names, put the macro as Public Sub. The CommandButton1_Click () macro itself calls the main macro. It is what, in fact, is needed, but it is launched only through CommandButton1_Click (). It seems to me that the point is in the passed argument, but how to pass it correctly? ActiveSheet.Name not working
Python:
if os.path.exists(r'./Результат/Отчет_Собираемость — копия.xlsm'):
excel_macro = win32com.client.DispatchEx("Excel.Application")
excel_path = os.path.expanduser(r'\\guo.local\DFSFILES\MSK\HOME\dobychin.ia\Desktop\report collection\1 вариант(Загрузка данных - Python, формирование отчета -VBA)\Результат/Отчет_Собираемость — копия.xlsm')
workbook = excel_macro.Workbooks.Open(Filename=excel_path, ReadOnly =1)
param = "ActiveSheet.Name"
# excel_macro.Application.Run("Отчет_Собираемость.xlsm!Лист3 (ОТЧЕТ_день).CommandButton1_Click()")
excel_macro.Application.Run("CommandButton1_Click")
workbook.Save()
excel_macro.Application.Quit()
del excel_macro
VBA:
Private Sub CommandButton1_Click()
Call main(ActiveSheet.Name)
MsgBox ("Готово!")
End Sub
VBA:
Sub main(ws_name)
Call optimize
Call dell_sheets
Set ws = ThisWorkbook.Sheets(ws_name)
ws.CommandButton1.Visible = False
ws.SpinButton1.Visible = False
Set dws = ThisWorkbook.Sheets("!Периоды")
i = 1
Do While dws.Cells(i, 3) <> ""
mc = dws.Cells(i, 3)
ws.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Set aws = ActiveSheet
aws.Cells(3, 2) = mc
Application.Calculate
aws.UsedRange.Value = aws.UsedRange.Value
aws.Name = mc
i = i + 1
Loop
ws.Activate
ws.CommandButton1.Visible = True
ws.SpinButton1.Visible = True
Call unoptimize
End Sub
I have a workbook with userforms to write to several numeric and date fields. I need to validate the textbox control for proper numbers and dates.
Rather than replicate the validation for each textbox, I thought I would call a common subprocedure within the BeforeUpdae event of each textbox.
I have two problems.
If I execute the form and test using text in tbAmount box, it seems the ContolValidate procedure is not called.
If I run it in break mode with a breakpoint on Call ContolValidate(What, CurrentControl), it will step through that procedure.
Even though it steps through the procedure, the Cancel = True does not seem to work.
If I paste the ContolValidate code directly in the BeforeUpdate, the Cancel = True does work.
This code is all on the userform.
Private Sub tbAmount1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim What As String
Dim CurrentControl As Control
What = "NumericField"
Set CurrentControl = Me.ActiveControl
Call ContolValidate(What, CurrentControl)
End Sub
Private Sub ContolValidate(What, CurrentControl)
If Not IsNumeric(CurrentControl.Value) Then
ErrorLabel.Caption = "Please correct this entry to be numeric."
Cancel = True
CurrentControl.BackColor = rgbPink
CurrentControl.SelStart = 0
CurrentControl.SelLength = Len(CurrentControl.Value)
Else
If CurrentControl.Value < 0 Then
ErrorLabel.Caption = "This number cannot be negative."
Cancel = True
CurrentControl.BackColor = rgbPink
CurrentControl.SelStart = 0
CurrentControl.SelLength = Len(CurrentControl.Value)
End If
End If
End Sub
Private Sub tbAmount1_AfterUpdate()
ErrorLabel.Visible = False
tbAmount1.BackColor = Me.BackColor
End Sub
(1) When your control is named tbAmount1 and the code is in the code-behind module of the form, the trigger should fire.
(2) As #shahkalpesh mentioned in his comment, Cancel is not known in your validate-routine. Putting Option Explicit at the top of you code would show you that.
I would suggest to convert the routine to a function. In the code below, I return True if the content is okay and False if not (so you need to put a Not to the result to set the Cancel-parameter)
Private Sub tbAmount1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Cancel = Not ControlValidate("NumericField", Me.ActiveControl)
End Sub
Private Function ControlValidate(What, CurrentControl) As Boolean
ControlValidate = False
If Not IsNumeric(CurrentControl.Value) Then
errorlabel.Caption = "Please correct this entry to be numeric."
ElseIf CurrentControl.Value < 0 Then
errorlabel.Caption = "This number cannot be negative."
Else
ControlValidate = True ' Input is okay.
End If
If ControlValidate Then
CurrentControl.BackColor = vbWhite
Else
CurrentControl.BackColor = rgbPink
CurrentControl.SelStart = 0
CurrentControl.SelLength = Len(CurrentControl.Value)
End If
End Function
P.S.: I changed the name to ControlValidate - "contol" seems wrong to me...
I'm trying to write data into an Excel workbook that is hosted in our SharePoint document library.
I instantiate Excel from Microsoft Project.
I tried the following:
Check if file can be checked out
If it can be checked out, then open it
Here's the code snippet:
If ExcelApp.Workbooks.CanCheckOut (FileURL) = True Then
Set NewBook = ExcelApp.Workbooks.Open(FileName:=FileURL, ReadOnly:=False)
ExcelApp.Workbooks.CheckOut (FileURL)
Else
MsgBox "File is checked out in another session."
End If
The CanCheckOut function always returns FALSE. I'm not able to tell when a file can be checked out by the Excel instance.
Is it not working because I'm calling the VBA code from MS Project?
My app should be able to check if a file is not checked out, then check it out, update it, and save + check it back in.
I've found through trial and error that Workbooks.CanCheckOut (Filename:= FullName) where FullName is the URL for the SharePoint file only works for files that are not open in the current instance of Excel.
The method will always return False if you have the file open in the current instance of Excel which is obviously the case here.
Workbooks.CheckOut (ActiveWorkbook.FullName) opens the file, checks it out and then inexplicably, closes the file. So opening and checking out a SharePoint file becomes a 3 step process.
Sub CheckOutAndOpen()
Dim TestFile As String
TestFile = "http://spserver/document/Test.xlsb"
If Workbooks.CanCheckOut(TestFile) = True Then
Workbooks.CheckOut(TestFile)
Workbooks.Open (TestFile)
Else
MsgBox TestFile & " can't be checked out at this time.", vbInformation
End If
End Sub
This is all a bit counter intuitive because when working manually with SharePoint files you have to open them to see if they can be checked out and then perform the check-out operation.
Neither MSDN or Excel VBA help mention that the Workbooks.CanCheckOut (Filename:= FullName) method always returns False if you have the file open in the current instance of Excel.
The other methods never worked for me. This will CheckOut the file and either open it hidden and terminate (Visible = False), or you can just have it open (Visible = True) and remove the Quit, BUT while the doc is Checked out, I can't seem to target or check in that mXLApp doc further. The solution is to not leave the mXLApp doc open, but then once closed to open that same doc as normal, and then it will Check in with the Check in code line.
Sub TestCheckOut()
Dim FileName as String
FileName = "http://spserver/document/Test.xlsx"
SP_CheckOut FileName
End Sub
Sub SP_CheckOut(docCheckOut As String)
Set mXlApp = CreateObject("Excel.Application")
' Determine if workbook can be checked out.
' CanCheckOut does not actually mean the doc is not currently checked out, but that the doc can be checked in/out.
If mXlApp.Workbooks.CanCheckOut(docCheckOut) = True Then
mXlApp.Workbooks.Open fileName:=docCheckOut
mXlApp.Workbooks.CheckOut docCheckOut
' False is hidden
mXlApp.Visible = False
mXlApp.Quit
Set mXlApp = Nothing
Workbooks.Open fileName:=docCheckOut
Else
MsgBox "Unable to check out this document at this time."
End If
End Sub
As for Checkin, can't get any methods to work except:
Workbooks(CheckName).checkin SaveChanges:=True, Comments:=""
Sub CheckIn(CheckName As String, CheckPath As String)
' Must be open to save and then checkin
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(CheckName)
If Err = 0 Then
WorkbookIsOpen = True
Else
WorkbookIsOpen = False
Set wb = Workbooks.Open(CheckPath)
End If
wb.CheckIn SaveChanges:=True, Comments:=""
End Sub
I did try using a Query on the SharePoint browser link to determine who has the doc checked out (if anyone). This worked sometimes. If it did work, half the time it would take too long to be useful, and the other half of the time it would throw a timeout error. Not to mention the query would disrupt other processes, like saving or certain other macros. So I put together a WebScrape which quickly returns who might have the doc checked out.
Sub TestWho()
Dim SPFilePath As String
SPFilePath = "http://teams.MyCompany.com/sites/PATH/PATH/Fulfillment/Forms/AllItems.aspx"
Debug.Print CheckedByWho(SPFilePath , "YOURdocName.xlsx")
End Sub
Function CheckedByWho(ShareFilePath As String, ShareFileName As String)
Dim ie As Object
Dim CheckedWho As String
Dim ImgTag As String
Dim CheckStart, CheckEnd As Integer
Dim SplitArray() As String
Set ie = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
With ie
.Visible = False
.Navigate ShareFilePath
Do Until .readyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
End With
CheckedWho = "Not Check Out"
For Each objLink In ie.document.getElementsByTagName("img")
ImgTag = objLink.outerHTML
CheckedOutPos = InStr(objLink.outerHTML, ShareFileName & "
Checked Out To:")
If CheckedOutPos > 0 Then
CheckStart = InStr(objLink.outerHTML, "Checked Out To: ")
CheckedWho = Mid(objLink.outerHTML, CheckedOutPos + 41)
SplitArray = Split(CheckedWho, """")
CheckedWho = SplitArray(0)
End If
Next objLink
CheckedByWho = CheckedWho
ie.Quit
End Function
I have an Excel application I've developed and now want to store all of the data in an Access file (rather than an Excel sheet). I'm able to read data in and write data out, my issue has to do with handling concurrent users. There's around 150-200 square images that when clicked open up a UserForm that is loaded with data. Users are able to go in and edit any of that data so I want to make sure that two users are not editing a record at the same time. Given the size of it I do not want to lock down the entire file, just the one record. Everything I've read so far indicates that the record only locks while in .Edit, however I want to lock it as soon as the user opens the UserForm, then apply any edits they made and unlock it.
Here's where I'm at now with the code, the first three sections are where the main focus is with this:
Sub OpenDAO()
Set Db = DBEngine.Workspaces(0).OpenDatabase(Path, ReadOnly:=False)
strSQL = "SELECT * FROM AccessDB1 WHERE ID = 5" '& Cells(1, Rng.Column)
Set Rs = Db.OpenRecordset(strSQL)
End Sub
'==========================================================================
Sub CloseDAO()
On Error Resume Next
Rs.Close
Set dbC = Nothing
Set Rs = Nothing
Set Db = Nothing
End Sub
'==========================================================================
Function ADO_update(Target As Range)
Set ws = Sheets("Sheet1")
Set dbC = DBEngine.Workspaces(0).Databases(0)
'if no change exit function
If Target.Value = oldValue Then GoTo 0
On Error GoTo trans_Err
'begin the transaction
DBEngine.BeginTrans
dbC.Execute "UPDATE AccessDB1 SET Field1 = 5 WHERE ID= 5"
DBEngine.CommitTrans dbForceOSFlush
Exit Function
trans_Err:
'roll back the transaction
Workspaces(0).Rollback
0
End Function
'==========================================================================
Function MakeSQLText(data As Variant)
If (IsNumeric(data)) Then
MakeSQLText = data
Else
MakeSQLText = "'" & Replace(data, "'", "''") & "'"
End If
End Function
I have this very simple function
Public Function HRows(xx As String)
BeginRow = 2
EndRow = 10
' HideRows
For RowCnt = BeginRow To EndRow
Cells(RowCnt,ChkCol).EntireRow.Hidden = True
Next RowCnt
End Function
When invoked from a command button it works fine, when invoked as a formula, e.g =HRows(A1), from a worksheet cell it doesn't do anything on Excel 2003, it does work in Open Office Calc 4.1
This happens on an otherwise empty spreadsheet - no protection, no comments, no shapes (which have been suggested as inhibitors in other questions)
Eventually, I want to hide/show the relevant sections of a spreadsheet, depending on what the user enters in certain key cells - I don't want to have to add command buttons to control the hiding.
I've already introduced this method here https://stackoverflow.com/a/23232311/2165759, for your purpose a code will be as follows:
Place code to one of the module of VBAProject:
Public Tasks, PermitNewTasks, ReturnValue
Function HideRowsUDF(lBegRow, lEndRow) ' Use this UDF on the sheet
If IsEmpty(Tasks) Then TasksInit
If PermitNewTasks Then Tasks.Add Application.Caller, Array(lBegRow, lEndRow)
HideRowsUDF = ReturnValue
End Function
Function HideRows(lFrom, lUpTo) ' actually all actions performed within this function, it runs without UDF limitations
Range(Rows(lFrom), Rows(lUpTo)).EntireRow.Hidden = True
HideRows = "Rows " & lFrom & "-" & lUpTo & " were hidden"
End Function
Sub TasksInit()
Set Tasks = CreateObject("Scripting.Dictionary")
ReturnValue = ""
PermitNewTasks = True
End Sub
Place code to ThisWorkbook section of Microsoft Excel Objects in VBAProject:
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim Task, TempFormula
If IsEmpty(Tasks) Then TasksInit
Application.EnableEvents = False
PermitNewTasks = False
For Each Task In Tasks
TempFormula = Task.FormulaR1C1
ReturnValue = HideRows(Tasks(Task)(0), Tasks(Task)(1))
Task.FormulaR1C1 = TempFormula
Tasks.Remove Task
Next
Application.EnableEvents = True
ReturnValue = ""
PermitNewTasks = True
End Sub