I have an Excel VBA program that I'm working on which seems to work just when I use F8 to step through the program. I can do this and go from start to finish on the program and it has no problems. However, If i press F5 and run the program, it bombs causing excel to close and restart (no error message is given)
:(
I've narrowed it down to something happening in one particular module but lacking any indication as to what it is, I can't seem to find what is wrong.
Any help is very very greatly appreciated
The module that seems to be giving me the issue is:
Sub gwLoadWheels(ByRef db As DAO.Database, ByRef pColl As clsParts, ByRef pCrib As clsCrib, ByRef pExcept As clsExceptions)
Dim i As Long
Dim rs As DAO.Recordset
Dim sSQL As String
Dim iSH As Worksheet
Dim cWheel As clsCribItem
Dim rPart As clsPart
Dim rExcept As clsException
On Error GoTo ErrHandler
For Each rPart In pColl
sSQL = "SQL String Removed, Verified using SQL Query in MS Access"
Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot, dbReadOnly)
If Not rs.EOF Then
rs.MoveLast
rs.MoveFirst
For i = 1 To rs.RecordCount
If pCrib.ItemExists(rs!wheel_ID) = False Then
With pCrib
.AddItem (rs!wheel_ID)
With .Item(rs!wheel_ID)
.AveragePieces = rs!Avg_Pieces
.Burn = rs!BurnQty
.Cost = rs!AvgUnitCost
.HoleDiameter = rs!Hole
.OnHand = rs!OnHand
.OnOrder = rs!OnOrder
.OrderQty = rs!OrderQty
.OutsideDiameter = rs!OD
.Radius = rs!Radius
.Spec = rs!Specification
.Treatment = rs!Treat
.Width = rs!Width
.TotalPieces = rs!Number_Per * rPart.Qty
End With
End With
Else
pCrib.Item(rs!wheel_ID).TotalPieces = pCrib.Item(rs!wheel_ID).TotalPieces + (rs!Number_Per * rPart.Qty)
End If
Next i
Else
With pExcept
.AddException (rPart.PartID)
.Exception(rPart.PartID).Qty = .Exception(rPart.PartID).Qty + rPart.Qty
End With
End If
rs.Close
Set rs = Nothing
Next rPart
GoTo SubExit
ErrHandler:
MsgBox "Error: " & Err.Number & vbCrLf & "Description:" & vbCrLf & Err.Description, vbCritical, "Error Info"
i = i
SubExit:
End Sub
Related
I am debugging some VBA code I've written in Excel 2016, and this sub is crashing Excel 2016 on windows Server with no errors.
It is crashing on the Set RegObj = GetObject...
Sub TestPrinter()
On Error GoTo e
Dim RegObj As Object
'This next line is where the crash occurs...
Set RegObj = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
Exit Sub
e:
MsgBox "Error number " & Err & " in TestPrinter" & vbCrLf & "Error: " & Error$(Err)
End Sub
My end goal is to enumerate the printers connected on the machine, and then set Application.ActivePrinter based on the string I pull out of the registry. This code is working fine on every other machine I've tried it on - but fails on this one server.
How can I go about debugging this? The error handler is never hit.
This does not answer your question but rather provides an alternative solution to setting the active printer.
You can use something like this to get the printer names:
Public Function GetPrinterNames() As Collection
Dim coll As New Collection
Dim i As Long
'
On Error Resume Next
With CreateObject("WScript.Network")
For i = 1 To .EnumPrinterConnections.Count Step 2
coll.Add .EnumPrinterConnections(i)
Next
End With
On Error GoTo 0
Set GetPrinterNames = coll
End Function
Note that the above does NOT give you the port number but that is not really necessary as you could use something like this to set the printer:
'*******************************************************************************
'Sets the ActivePrinter without requiring the winspool port number
'*******************************************************************************
Public Function SetPrinter(ByVal printerName As String) As Boolean
If LenB(printerName) = 0 Then Exit Function
Dim i As Long
'
On Error Resume Next
Application.ActivePrinter = printerName
If Err.Number = 0 Then
SetPrinter = True
Exit Function
End If
Err.Clear
For i = 0 To 99
Application.ActivePrinter = printerName & " on NE" & Format$(i, "00:")
If Err.Number = 0 Then
SetPrinter = True
Exit Function
End If
Err.Clear
Next i
On Error GoTo 0
End Function
I have the following routine below that is meant to open an Excel spreadsheet and then go row by row to import the results into a table that is passed in. It works fine but the problem is if I try to open that same spreadsheet a second time I get a message that the file is in use and I have to Ctrl-Alt-Del to shut down Excel before I can use it again. I thought that the Set mySheet=Nothing and Set xlApp=Nothing would release the file but apparently not. What more can I do to make sure that Access lets go of the Excel file? Thanks in advance!
Public Sub MakeTempTable(strFilePath As String, tablename As String)
Dim mySheet As Object
Dim xlApp As Object
Dim rs As DAO.Recordset
Dim sql As String
sql = "DELETE * FROM " & tablename
DoCmd.RunSQL sql
Set rs = CurrentDb.OpenRecordset(tablename)
Set xlApp = CreateObject("Excel.Application")
Set mySheet = xlApp.Workbooks.Open(strFilePath).Sheets(1)
xlApp.Visible = False
Set mySheet = xlApp.Sheets("Input")
Dim dRows As Double
dRows = 1
Dim dRow As Double, dCol As Double
dRow = 2
On Error GoTo ERR
Do
dCol = 1
rs.AddNew
If mySheet.cells(dRow, 3) = "" Then Exit Do
Do
If mySheet.cells(dRow, dCol).Value <> "_END_" Then
rs.Fields(dCol).Value = Nz(mySheet.cells(dRow, dCol).Value, "")
dCol = dCol + 1
Else
Exit Do
End If
Loop
rs.Update
dRow = dRow + 1
Loop
EXITSUB:
Set mySheet = Nothing
Set xlApp = Nothing
Exit Sub
ERR:
If ERR.Number = 3265 Then MsgBox "The species selected are incompatible. Canceling import.", vbCritical, "IMPORT ERROR"
GoTo EXITSUB
End Sub
Try using
xlApp.Quit
When you set xlApp to nothing you are only clearing the object within the procedure, you aren't doing anything to the actual Excel instance. All that setting XXX = nothing allows you to do is then reuse that object.
You will need to legally close the workbooks that are open as in
xlApp.Workbooks.Close
EXITSUB:
This will close the instances that are open.
Prior to this, kill all the instances or reboot your machine to clear all the instances that are open.
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 a function that brings data from sql server. The function is tested and is used in many macros. Now I am trying to use it and for some reason it doesn't work, although I am testing the query and it does have data
I opened a macro where the function works and try to test it from there, but still doesn't work.
I am calling to function GetDataFromDatabase (see below) from the following code:
Sub testing()
Dim query As String
Dim ImportedData As Range
query = GetQuery
Debug.Print query
Call GetDataFromDatabase(query, Range("AB1"), False)
End Sub
Note, that when debug.pring prints the query, I take it, run in in the database and I get the data, so the GetQuery function works.
The function includes the following line:
On Error GoTo CloseConnection
And indeed, at some point it goes to closeConnection (line marked below in the function). How do I know what is the error?
Sub GetDataFromDatabase(query As String, cellToCpyData As Range, WithHeaders As Boolean)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LocalDBCon As ADODB.Connection
Dim SqlTableDatasSet As ADODB.Recordset
Dim SqlDataSetFields As ADODB.Field
Dim Ctr As Long
Dim RDBConString As String
RDBConString = "connection string (the right one)"' This here is ok, I deleted the actual sting
Set LocalDBCon = New ADODB.Connection
Set SqlTableDatasSet = New ADODB.Recordset
LocalDBCon.ConnectionString = RDBConString
On Error GoTo CloseConnection
LocalDBCon.Open
With SqlTableDatasSet
.ActiveConnection = LocalDBCon
.ActiveConnection.CommandTimeout = 0
.Source = query
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With
'Adding the sql table headers
If WithHeaders Then
Ctr = 0
For Each SqlDataSetFields In SqlTableDatasSet.Fields
cellToCpyData.Offset(0, Ctr) = SqlDataSetFields.Name
Ctr = Ctr + 1
Next SqlDataSetFields
Set cellToCpyData = cellToCpyData.Offset(1, 0)
End If
---->>cellToCpyData.CopyFromRecordset SqlTableDatasSet 'When not working, jumps from here to CloseConnection<<------------------------------------
SqlTableDatasSet.Close
Wrapup:
On Error Resume Next
LocalDBCon.Close
Exit Sub
CloseConnection:
On Error Resume Next
LocalDBCon.Close
End Sub
You need to add this line of code between "CloseConnection:" and "On Error Resume Next"
Debug.Print Err.Number & " - " & Err.Description
This will print to the immediate window what error is causing the problem. That will give a starting point to go from.
My code works fine if something is selected from the drop down and macro is run.
But if nothing is selected, which should never be the case, I get runtime error Invalid column name.
Instead, I want a msg box to say "Ensure X is selected from Drop Down" with OK button, instead of said runtime error.
The error occurs on below line which I found on debug:
rs1.Open sqlstrSchemeDetail, DBCONT
The error occurs because a sql string cannot be created if nothing is selected.
Call connectDatabase
rs1.Open sqlstrSchemeDetail, DBCONT 'WHERE ERROR HAPPENS
'Debug.Print sqlstrSel
Debug.Print sqlstrSchemeDetail
For intColIndex = 0 To rs1.Fields.Count - 1
Sheet2.Range("A1").Offset(0, intColIndex).Value = rs1.Fields(intColIndex).Name
Next
Sheet2.Range("A2").CopyFromRecordset rs1
'rs.Close
'Set rs = Nothing
Call closeDatabase
This is the DBCONT
Public Function connectDatabase()
Set DBCONT = CreateObject("ADODB.Connection")
Dim sConn As String
sConn = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=PamwinPlusLIVE;Data Source=GS1NHHMSQLV04\INST04;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=SL1NHHMCTXV108;Use Encryption for Data=False;Tag with column collation when possible=False"
DBCONT.Open sConn
DBCONT.cursorlocation = 3
End Function
Further More
Dim sqlstrSchemeDetail As String
sqlstrSchemeDetail = "Select scheme.SchemeID, DevOfficer.Description [Scheme
Owner], scheme.Description [Scheme Description], scheme.Version [v.],
Status.Description [Status], TenureType.Description [Tenure Type],
Template.Description [Template], Units.Units,scheme.lastupdatedDate
[Updated] from scheme inner join Status on scheme.Status = status.StatusID
inner join TenureType on scheme.TenureTypeID = TenureType.TenureTypeID inner
join DevOfficer on scheme.devofficer = devofficer.devofficerid inner join
SelScheme ON Scheme.SchemeID = SelScheme.SchemeID inner join Template on
scheme.TemplateID = template.templateid inner join (select
scheme.SchemeID,sum(units) as Units from Property inner join scheme on
Property.SchemeID = scheme.SchemeID group by scheme.SchemeID) Units on
Units.schemeid = scheme.schemeid where scheme.masterSchemeID is null and
SelScheme.SelID =" & GG
Dim GG As String
GG = Split(Sheet1.ComboBox1.Value, "-")(0)
GG returns an ID if something is selected from the drop down box and the code will then work. If nothing in the drop down box is selected, GG is some text which makes the code fail on
rs1.Open sqlstrSchemeDetail, DBCONT
Create a custom error handling label.
sub main()
on error goto found_error
Call connectDatabase
rs1.Open sqlstrSchemeDetail, DBCONT --WHERE ERROR HAPPENS
'Debug.Print sqlstrSel
Debug.Print sqlstrSchemeDetail
For intColIndex = 0 To rs1.Fields.Count - 1
Sheet2.Range("A1").Offset(0, intColIndex).Value = rs1.Fields(intColIndex).Name
Next
Sheet2.Range("A2").CopyFromRecordset rs1
'rs.Close
'Set rs = Nothing
Call closeDatabase
exit sub
found_error:
msgbox err.number & chr(10) & err.description & chr(10) & sqlstrSchemeDetail & chr(10) & sqlstrSel
end sub
Thank you all for your input. As advised, I caught the error earlier. I did this by saying if sqlstring = x then MsgBox y and exit sub, else continue open recordset...
If GG = "2. Select Selection" Then
MsgBox "Please Pick a Selection"
Exit Sub
Else Call connectDatabase 'Debug.Print sqlstrSel
rs1.Open sqlstrSchemeDetail, DBCONT
' Debug.Print sqlstrSchemeDetail
For intColIndex = 0 To rs1.Fields.Count - 1
Sheet2.Range("A1").Offset(0, intColIndex).Value =
rs1.Fields(intColIndex).Name
Next
Sheet2.Range("A2").CopyFromRecordset rs1
End If