I have a problem with a Excel VBA code that constantly get stuck in 'running' when I execute the code, see figure
The Purpose of the code is:
Log into SAP
Execute a transaction (in this case IW73)
Export a Spreadsheet as .txt
The Problem after closing the SAP session the Excel get stuck in "Running". We have tried running it on different computers with the same (Stuck in 'Running') error.
Code:
Sub Logontrial()
Dim SapGuiApp As Object
Dim oConnection As Object
Dim SAPCon As Object, SAPSesi As Object
Dim SapGuiAuto As Object, SAPApp As Object
If SapGuiApp Is Nothing Then
Set SapGuiApp = CreateObject("Sapgui.ScriptingCtrl.1")
End If
If oConnection Is Nothing Then
Set oConnection = SapGuiApp.OpenConnection("5.1.1 AP1 ERP Production", True)
End If
If SAPSesi Is Nothing Then
Set SAPSesi = oConnection.Children(0)
End If
Application.DisplayAlerts = False
With SAPSesi
SAPSesi.findById("wnd[0]/usr/txtRSYST-MANDT").Text = "500"
SAPSesi.findById("wnd[0]/usr/txtRSYST-BNAME").Text = "UserName"
SAPSesi.findById("wnd[0]/usr/pwdRSYST-BCODE").Text = "Password"
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").Text = "EN"
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").SetFocus
SAPSesi.findById("wnd[0]/usr/txtRSYST-LANGU").caretPosition = 2
SAPSesi.findById("wnd[0]").sendVKey 0
' start extraction
On Error GoTo Resume1
' DoEvents
SAPSesi.findById("wnd[0]").maximize
SAPSesi.findById("wnd[0]/tbar[0]/okcd").Text = "/nIW73"
SAPSesi.findById("wnd[0]").sendVKey 0
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").Text = "GB10"
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").SetFocus
SAPSesi.findById("wnd[0]/usr/ctxtSWERK-LOW").caretPosition = 4
SAPSesi.findById("wnd[0]").sendVKey 8
SAPSesi.findById("wnd[0]").sendVKey 0
SAPSesi.findById("wnd[0]/mbar/menu[0]/menu[11]/menu[2]").Select
SAPSesi.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").Select
SAPSesi.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").SetFocus
SAPSesi.findById("wnd[1]/tbar[0]/btn[0]").press
SAPSesi.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = "DataImport1.txt"
SAPSesi.findById("wnd[1]/usr/ctxtDY_FILENAME").caretPosition = 15
SAPSesi.findById("wnd[1]/tbar[0]/btn[11]").press
SAPSesi.findById("wnd[0]/tbar[0]/okcd").Text = "/n"
SAPSesi.findById("wnd[0]").sendVKey 0
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
End With
' This part after closing the SAP session it get stuck.
Resume1:
Application.DisplayAlerts = True
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
Exit Sub
End Sub
Thanks in advance
//Patrick
Disclaimer: This is not quality code, and most probably one day someone can put some bunch of hate towards you.
Before finding something better, try the following, it should work. Simply write End here:
Set SAPSesi = Nothing
Set oConnection = Nothing
Set SapGuiApp = Nothing
End
Then look for a better solution.
Related
I have a VBA macro that cycles through a list of 1500 PDF Files Ranging from 60 to 500 pages. The code checks each file from the list to see if it contains a certain keyword obtained from a user. The code seems to bug out sometimes if the file is too big, so I limited each pdf that will be searched to 12 MB.
Now The problem I am having is that randomly the macro will just stall on a random file and not do anything regardless of file size. It will just stay on that file unless I go and move the mouse.
So I was wondering what the best way to tackle this would be? I was thinking of adding an event of moving the mouse before and after the .FindText method, but I think the best way would be to limit the time each file is open to 30 seconds. I am not sure how to incorporate it within the loop though, Thanks.
Also if you have any suggestions on other improvements I would aprreciate it thank you.
Sub PDFSearch()
Dim FileList As Worksheet, Results As Worksheet
Dim LastRow As Long, FileSize As Long
Dim KeyWord As String
Dim TooLarge As Boolean
Dim PDFApp As Object, PDFDoc As Object
Application.DisplayAlerts = False
Set FileList = ThisWorkbook.Worksheets("Files")
Set Results = ThisWorkbook.Worksheets("Results")
LastRow = FileList.Cells(Rows.Count, 1).End(xlUp).Row
KeyWord = InputBox("What Term Would You Like To Search For?")
Results.Rows(3 & ":" & .Rows.Count).ClearContents
For x = 3 To LastRow
TooLarge = False
FileSize = FileLen(FileList.Cells(x, 1).Value) / 1000
If FileSize > 12000 Then TooLarge = True
If TooLarge = False Then
Set PDFApp = CreateObject("AcroExch.App")
If Err.Number <> 0 Then
MsgBox "Could not create the Adobe Application object!", vbCritical, "Object Error"
Set PDFApp = Nothing
Exit Sub
End If
On Error Resume Next
App.CloseAllDocs 'Precautionary - Sometimes It Doesn't Close The File
On Error GoTo 0
Set PDFDoc = CreateObject("AcroExch.AVDoc")
If Err.Number <> 0 Then
MsgBox "Could not create the AVDoc object!", vbCritical, "Object Error"
Set PDFDoc = Nothing
Set PDFApp = Nothing
Exit Sub
End If
If PDFDoc.Open(FileList.Cells(x, 1).Value, "") = True Then
PDFDoc.BringToFront
If PDFDoc.FindText(KeyWord, False, False, True) = True Then
Results.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = FileList.Cells(x, 1).Value
End If
End If
PDFApp.Exit
End If
On Error Resume Next
PDFDoc.BringToFront 'Precautionary - Sometimes Command Doesn't Close The File
PDFApp.Exit
On Error GoTo 0
Set PDFDoc = Nothing
Set PDFApp = Nothing
FileSize = 0
Next x
Application.DisplayAlerts = True
End Sub
I have an issue with a macro that is located in Outlook. The code is triggered by a "Private Sub" code that creates a "TriggerExcel(1)" or "TriggerExcel(2)" which depends of the mail subject.
When the code is triggered it sometimes got stuck at line: Set ExApp = Excel.Application 'Codes
Where I get the following Error:
My guess is that the code doesn't define the excel object correctly in the code, but I have a hard time to understand how this should be made... Any advice or suggestions are much appreciated.
Public Sub TriggerExcel(Mode As Integer)
‘Activate following tool reference: Tool-References-Microsoft Excel 14.0 Object library -biblioteket
Dim ExApp As Excel.Application
Dim ExWbk As Workbook
Set ExApp = Excel.Application 'Codes
cause error here
ExApp.DisplayAlerts = False
If Mode = 1 Then
On Error Resume Next
Set ExWbk = Workbooks("Nyins.xlsm")
Debug.Print ExWbk.Name
On Error GoTo 0
'Set ExWbk = ExApp.Workbooks.Open("C:\Users\linsten\Desktop\Nyins.xlsm")
ExApp.Visible = False
'ExWbk.Application.Run "mymain.main"
If ExWbk Is Nothing Then
Set ExWbk = ExApp.Workbooks.Open("\\Sca9a\pd-61$\Control\Process\Nyins.xlsm")
End If
ExWbk.Application.Run "MainModule.main"
ElseIf Mode = 2 Then
Set ExApp = Excel.Application
On Error Resume Next
Set ExWbk = Workbooks("Val.xlsm")
Debug.Print ExWbk.Name
On Error GoTo 0
ExApp.Visible = False
If ExWbk Is Nothing Then
Set ExWbk = ExApp.Workbooks.Open("\\Sca9a\pd-61$\Control\Process\Daily\Val.xlsm")
End If
ExWbk.Application.Run "MyMain.Main"
End If
ExWbk.Close
ExApp.Quit
End Sub
I have a small Excel-macro which opens a visio-file. With Excel 2010 everything worked fine. Now I've installed Office 2016 and tried the same excel-macro and it won't work.
There is no exception, but I see that my variable "VisioDoc" is empty.
Do you have any ideas where the Problem could be?
Sub cmdChooseFile_Click()
'...do something
Set VisioDoc = openDocument(filepath)
If VisioDoc Is Nothing Then
MsgBox "boom, didn't work!", vbExclamation
Exit Sub
End If
End Sub
Private Function openDocument(docPath As String) As Visio.Document
visioOpened = True
Application.StatusBar = "Lade Visiodokument..."
On Error Resume Next
Set VisioApp = GetObject(, "Visio.Application")
If VisioApp Is Nothing Then
Set VisioApp = CreateObject("Visio.Application")
VisioApp.Visible = False
visioOpened = False
End If
Set openDocument = VisioApp.Documents.Open(docPath)
Application.StatusBar = False
End Function
I will now take the opportunity to ask here, I have really tried a lot of different way, but it seems that I am not able to be able to close the Excel task in task-manger, It hangs until I close Access completely, annoying, because I can not run two different jobs using Excel from Access. Second job will give me errors.
I have made some comments to where I still is able to get rid of Excel.
The purpose for the code is to run some query's and export data to excel and then lock the excel sheet so users only can fill in answers to the data.
Code:
Private Sub Command65_Click()
Dim r As Double
'On Error GoTo Error_Handler
Dim objExcel As Excel.Application
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet
Dim dbs As DAO.Database
Dim rSt As DAO.Recordset
Set dbs = CurrentDb
Set rSt = CurrentDb.OpenRecordset("qry_VC_Confirmation")
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
'objExcel.Quit ' at this point it still works to close again
'Set objExcel = Nothing ' at this point it will remove from task manager
Set objWorkbook = objExcel.Workbooks.Add
Set objWorksheet = objWorkbook.Worksheets(1)
'Set objWorkbook = Nothing ' can close still at this stage
'Set objWorksheet = Nothing ' can close still at this stage
'objExcel.Quit ' at this point it still works to close again ?
'Set objExcel = Nothing ' at this point it still will not remove from task manager
iFld = 0
irow = 1
For icol = 1 To (rSt.Fields.count)
objWorksheet.Cells(irow, icol) = rSt.Fields(iFld).Name
objWorksheet.Cells(irow, icol).Interior.ColorIndex = 1
objWorksheet.Cells(irow, icol).Font.ColorIndex = 2
objWorksheet.Cells(irow, icol).Font.Bold = True
iFld = iFld + 1
Next
'Set objWorkbook = Nothing '
'Set objWorksheet = Nothing '
'objExcel.Quit ' at this point it still works to close Excel again ?
'Set objExcel = Nothing ' at this point it will still remove from task manager
irow = 2
If Not rSt.BOF Then rSt.MoveFirst
Do Until rSt.EOF
iFld = 0
lRecords = lRecords + 1
For icol = 1 To (rSt.Fields.count)
objWorksheet.Cells(irow, icol) = rSt.Fields(iFld)
iFld = iFld + 1
Next
irow = irow + 1
rSt.MoveNext
Loop
r = irow - 1
Columns("A:F").EntireColumn.AutoFit
ActiveSheet.Protection.AllowEditRanges.Add Title:="Unprotected", Range:=Range("F2:F" & r)
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="secret"
objWorkbook.SaveAs ("C:\Dropbox\VC_Confirmation.xlsx")
ExitSub:
Set objWorkbook = Nothing '
Set objWorksheet = Nothing '
objExcel.Quit ' at this point it still works to close excel again ?
Set objExcel = Nothing ' at this point it will **NOT** remove from task manager
Exit Sub
Error_Handler:
MsgBox Error$
Resume ExitSub
End Sub
In the comments you mentioned that you had reset your code (i.e. pressed the stop button). This means that the portion of your code that kills excel did not run, thus leaving an open session of excel. There is a small (possibly semantic) issue with your code, but I don't believe that's what was causing your issue. Regardless, you should properly shut down the application like this.
ExitSub:
If Not objWorksheet Is Nothing Then
set objWorksheet = Nothing
End If
' You have to check for the workbook's existence before
' you try to close something that isn't there. This avoids runtime errors.
' Since your error handler points you back here, this code always runs, so
' The workbook might not be open.
If Not objWorkbook Is Nothing Then
objWorkbook.close
Set objWorkbook = Nothing
End If
' Same goes for quitting the application
If Not objExcel Is Nothing Then
objExcel.Quit
Set objExcel = Nothing
End If
Exit Sub
Error_Handler:
' error handling code here
Resume ExitSub
End Sub
Columns("A:F").EntireColumn.AutoFit
Adding as an answer just in case. Fully qualify this with the worksheet name and try again. This same problem was a huge bother to me too. You have to qualify 100% of your references, no matter what. Also, be super careful about using With statements on ranges, worksheets etc. So change it to ObjWorksheet.Columns("A:F")... instead
what is wrong with the following code?, Every time I run it I get a "Run-Time Error 91, Object variable or with black variable not set"
Private Sub Document_Open()
Dim workBook As workBook
Application.ScreenUpdating = True
Set workBook = Workbooks.Open("Z:\Credit_Check_DB.xls", True, True)
txtCompany1.Value = workBook.Worksheets("Sheet2").Range("A1").Formula
txtCompany2.Value = workBook.Worksheets("Sheet2").Range("A1").Formula
txtCityState1.Value = workBook.Worksheets("Sheet2").Range("C1").Formula
txtCityState2.Value = workBook.Worksheets("Sheet2").Range("C1").Formula
txtDate1.Value = workBook.Worksheets("Sheet2").Range("F1").Value
txtAddress1.Value = workBook.Worksheets("Sheet2").Range("B1").Formula
txtZip1.Value = workBook.Worksheets("Sheet2").Range("D1").Formula
txtPO.Value = "Purchase Order#: " & workBook.Worksheets("Sheet2").Range("I1").Formula
txtRec.Value = workBook.Worksheets("Sheet2").Range("K1").Formula
workBook.Close False
Set workBook = Nothing
Application.ScreenUpdating = True
Close_Excel
End Sub
Private Sub Close_Excel() 'closes excel application.
Dim Excel As Excel.Application
Dim ExcelOpened As Boolean
ExcelOpened = False
On Error Resume Next
Set Excel = GetObject(, "Excel.Application")
If Excel Is Nothing Then
Set Excel = New Excel.Application
ExcelOpened = True
End If
On Error GoTo 0
With Excel
If ExcelOpened Then
.Visible = True
.Workbooks.Add
End If
.ActiveWorkbook.Close False ***<-***!!!!!Debugger points to here!!!!!******
.Quit
End With
End Sub
any idea what is wrong with my code? I am basically pulling information from Excel into word.
Maybe Excel does not point to any Excel application (something went wrong, but you skipped the error), so ActiveWorkbook points to nothing. You should put On Error GoTo 0 immediately after GetObject.