I am getting "Run-time error '3251': Operation is not supported for this type of object." when I am trying to use the "FindFirst" on my DAO RecordSet. Can someone explain to me what I am doing wrong for this not to search for the record. The variable I am using is returning the correct value for the search.
Private Sub ctrSend_Click()
Dim intI As Integer
Dim lst As ListBox
Dim varItem As Variant
Dim rst As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim qtySum As Variant
Dim qtyDiff As Variant
Dim rowMax As Variant
Dim rowUpdate As Variant
Set lst = Me![lstShipping]
Set rst = CurrentDb.OpenRecordset("ShipInv", dbOpenTable)
Set rst2 = CurrentDb.OpenRecordset("Storage", dbOpenTable)
qtySum = 0
rowMax = 0
With lst
If .ItemsSelected.count = 0 Then Exit Sub
For Each varItem In .ItemsSelected
qtySum = qtySum + .Column(3, varItem)
Next
If Me.[ctrQtyProd] = qtySum Then
MsgBox "Qty Selected EQUALS Qty Being Shipped.", vbOKOnly, "Confirmation Message"
ElseIf Me.[ctrQtyProd] > qtySum Then
MsgBox "Qty Selected LESS THAN Qty Being Shipped, please select more Inventory.", vbOKOnly, "Confirmation Message"
Else
qtyDiff = qtySum - Me.[ctrQtyProd]
rowMax = lst.Column(3, lst.ItemsSelected.count)
rowUpdate = rowMax - qtyDiff
rst2.FindFirst "[BIN] = '" & lst.Column(0, lst.ItemsSelected.count) & "'"
rst2![QtyProd] = lst.Column(3, lst.ItemsSelected.count)
rst2.Update
rst2.Close
MsgBox "Storage Successfully Updated.", vbOKOnly, "Confirmation Message"
End If
End With
With lst
For Each varItem In .ItemsSelected
rst.AddNew
rst!Order = Me.[ctrSOrder]
rst!EntDate = Date
rst!ShipDate = Me.[ctrSDate]
rst!BIN = .Column(0, varItem)
rst!SKU = .Column(1, varItem)
rst!Lot = .Column(2, varItem)
rst!QtyProd = rowUpdate
rst.Update
Next
End With
rst.Close
Set rst = Nothing
Set rst2 = Nothing
MsgBox "Shipping List Successfully Updated.", vbOKOnly, "Confirmation Message"
End Sub
Did you try opening the recordset as a dbOpenDynaset (default without the enum specified in the open statement) or dbOpenSnapshot instead? The documentation on the Microsoft MSDN site specifies it takes one of those two recordsets.
Locates the first record in a dynaset- or snapshot-type Recordset object that satisfies the specified criteria and makes that record the current record (Microsoft Access workspaces only).
Microsoft MSDN article on Recordset.FindFirst
Related
I have a Stored Procedure on the SQL Server and I pull the results via VBA (Library: MS ActiveX Data Objects Library, ADODB).
Everything works fine when I only expect the query to return the result for 1 SELECT statement.
Now the Query consists of 5 SELECT statements and I want get all records from each recordset to be put into an array so I can work with the data. I am not able to do so, please help me further.
SQL Query results look like this in SQL Server Management Studio:
I tried different approaches in VBA, but non is working and will lead to different errors.
Error Numbers are either "3251", "3704" or "91".
This is my function to put the results into a RecordSet:
Function getAnalysisInformationFromDB(ByRef rs As Recordset, ByVal sSQL As String) As Boolean
On Error GoTo errHandler
Set cnn = New ADODB.Connection
cnn.Open conString
Set rs = cnn.Execute(sSQL)
rs.MoveFirst
getAnalysisInformationFromDB = True
Exit Function
errHandler:
Dim sErrMsg As String
If Err Then
If Not cnn Is Nothing Then
If cnn.Errors.Count > 0 Then
Dim i As Integer
For i = 0 To cnn.Errors.Count - 1 Step 1
sErrMsg = sErrMsg & cnn.Errors.Item(i) & vbCrLf
Next
End If
End If
If sErrMsg = "" Then
If Err.Number = 3021 Then
sErrMsg = "AnalysisID not found in DB"
Else
sErrMsg = Err.Number & " " & Err.Description
End If
End If
End If
If sErrMsg <> "" Then
MsgBox sErrMsg, vbCritical
End If
If Not cnn Is Nothing Then
If cnn.State = adStateOpen Then cnn.Close
End If
Set cnn = Nothing
End Function
Different approaches no look like this:
Sub getData()
Dim sSQL As String
sSQL = "confidential" ' --> SQL Connection String etc...
Dim rsAnalysis
If Not getAnalysisInformationFromDB(rsAnalysis, sSQL) = True Then Exit Sub
Dim vHeader() As Variant
Dim vData() As Variant
Dim rsTemp
Do Until rsAnalysis Is Nothing
Set rsTemp = rsAnalysis.NextRecordset()
vData = rsTemp.GetRows
' Do something with the Array...
' ...
Loop
End Sub
Or (here it does not even jump to the error handler, eventhough an error occurs...):
Sub getData2()
Dim rsAnalysis
If Not getAnalysisInformationFromDB(rsAnalysis, sSQL) = True Then Exit Sub
Do Until rsAnalysis Is Nothing
rsAnalysis.MoveFirst
On Error GoTo check_RS
Dim iCount As Integer: iCount = -1
For Each s In rsAnalysis.Fields
iCount = iCount + 1
ReDim Preserve vHeader(iCount): vHeader(iCount) = s.name
Next
If Not rsAnalysis.BOF And Not rsAnalysis.EOF Then
vData = rsAnalysis.GetRows
End If
Stop
Erase vHeader
retry_RS:
Set rsAnalysis = rsAnalysis.NextRecordset()
Loop
check_RS:
If Err Then
Debug.Print Err.Number
If Err.Number = 91 Or Err.Number = 3704 Or Err.Number = 3251 Then
GoTo retry_RS
End If
End If
End Sub
edit: the error always happens when I try to hand over the recordset to the array variable (vData = rsAnalysis.GetRows)
I am using the following code that is linked to a button cmdAdd. Using the 'On Click' event, the ListBox selection information is copied to a table KitBuild.
Private Sub cmdAdd_Click()
Dim strSQL As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim ctl As Control
Dim varItem As Variant
On Error GoTo ErrorHandler
Set db = CurrentDb()
Set rs = db.OpenRecordset("KitBuild", dbOpenDynaset, dbAppendOnly)
'make sure a selection has been made
If Me.lstResults.ItemsSelected.Count = 0 Then
MsgBox "At least 1 part must be selected."
Exit Sub
End If
'add selected value(s) to table
Set ctl = Me.lstResults
For Each varItem In ctl.ItemsSelected
rs.AddNew
rs!ItemNo = ctl.ItemData(varItem)
rs.Update
Next varItem
ExitHandler:
Set rs = Nothing
Set db = Nothing
Exit Sub
ErrorHandler:
Select Case Err
Case Else
MsgBox Err.Description
DoCmd.Hourglass False
Resume ExitHandler
End Select
End Sub
Shown below is the table KitBuild where selections are saved. Currently, it only transfers over 1 piece of information from the selection which is No from qryParts into the column called ItemNo (ID #8). This works fine but I also need to transfer over the Description and Unit Cost of records from qryParts to KitBuild.
I tried changing the following to rs!Description and rs!UnitCost but the No value just shifts over to those columns (ID #9, 10) rather than providing the Description and Cost.
'add selected value(s) to table
Set ctl = Me.lstResults
For Each varItem In ctl.ItemsSelected
rs.AddNew
rs!ItemNo = ctl.ItemData(varItem)
rs.Update
Next varItem
This is an example of the information I would like copied from qryParts to KitBuild.
How can I modify the code to include No, Description and Cost?
I assume that your ListBox has data in the order as on your last picture. Use this:
'add selected value(s) to table
Set ctl = Me.lstResults
For Each varItem In ctl.ItemsSelected
rs.AddNew
rs!ItemNo = ctl.Column(0)
rs!Description = ctl.Column(1)
rs!UnitCost = ctl.Column(2)
rs.Update
Next varItem
I'm trying to populate a combo box or drop down list from an access database. I used the following website for code template. I modified it to suit my needs. I keep getting the error: 5941 The requested member of the collection does not exist"
Source code: http://www.fontstuff.com/mailbag/qword02.htm
My Code:
Private Sub Document_Open()
On Error GoTo Document_Open_Err
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=*path to database removed for post*;"
rst.Open "SELECT DISTINCT TOP 25 [Equipment] FROM tblEquipment ORDER BY [Equipment];", _
cnn, adOpenStatic
rst.MoveFirst
With ActiveDocument.FormFields("Equipment").DropDown.ListEntries
.Clear
Do
.Add rst![Equipment]
rst.MoveNext
Loop Until rst.EOF
End With
Document_Open_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
Document_Open_Err:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Error!"
Resume Document_Open_Exit
End Sub
Code that almost works:
Private Sub Document_Open()
On Error GoTo Document_Open_Err
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=*removed for post*;"
rst.Open "SELECT DISTINCT TOP 25 [Field1] FROM Equipment_List ORDER BY [Field1];", _
cnn, adOpenStatic
rst.MoveFirst
With ActiveDocument.FormFields("Equipment").DropDown.ListEntries
.Clear
Do
.Add rst![Field1]
rst.MoveNext
Loop Until rst.EOF
End With
Document_Open_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
Document_Open_Err:
MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Error!"
Resume Document_Open_Exit
End Sub
I'm updating my last post here. See the code below; set a reference to DAO and make a couple minor tweaks to suit your needs.
Option Explicit
'Requires a reference to the '"Microsoft DAO 3.51 (or 3.6) Object Library."
Private Sub Userform_Initialize()
Dim myDataBase As DAO.Database
Dim myActiveRecord As DAO.Recordset
Dim i As Long
'Open the database to retrieve data
Set myDataBase = OpenDatabase("D:\Data Stores\sourceAccess.mdb")
'Define the first recordset
Set myActiveRecord = myDataBase.OpenRecordset("Table1", dbOpenForwardOnly)
'Set the listbox column count
ListBox1.ColumnCount = myActiveRecord.Fields.Count
i = 0
'Loop through all the records in the table until the EOF marker is reached.
Do While Not myActiveRecord.EOF
'Use .AddItem method to add a new row for each record
ListBox1.AddItem
ListBox1.List(i, 0) = myActiveRecord.Fields("Employee Name")
ListBox1.List(i, 1) = myActiveRecord.Fields("Employee DOB")
ListBox1.List(i, 2) = myActiveRecord.Fields("Employee ID")
i = i + 1
'Get the next record
myActiveRecord.MoveNext
Loop
'Close the database and clean-up
myActiveRecord.Close
myDataBase.Close
Set myActiveRecord = Nothing
Set myDataBase = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Sub CommandButton1_Click()
Dim oRng As Word.Range
Dim oBM As Bookmarks
Set oBM = ActiveDocument.Bookmarks
Set oRng = oBM("EmpName").Range
oRng.Text = ListBox1.Text
oBM.Add "EmpName", oRng
Set oRng = oBM("EmpDOB").Range
oRng.Text = ListBox1.List(ListBox1.ListIndex, 1)
oBM.Add "EmpDOB", oRng
Set oRng = oBM("EmpID").Range
oRng.Text = ListBox1.List(ListBox1.ListIndex, 2)
oBM.Add "EmpID", oRng
Me.Hide
lbl_Exit:
Exit Sub
End Sub
Code Source:
https://gregmaxey.com/word_tip_pages/populate_userform_listbox_or_combobox.html
i have a question about changing a memofield from "plain text" to "rich text" using VBScript, i found some solutions here and on the internet but all the solutions are for VBScript within access. I try to start an vbscript through Windows, but my script doesn't work. I'm kindly new to VBScripting so i hope you guys can help me. I used an example from the forum for my script:
How to convert a text field in an Access table to a rich text memo using VBA
My Script:
Dim db
Dim tdf
Dim fld1
Dim fld2
Set accessApp = GetObject("D:\test.mdb")
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDataBase "D:\test.mdb", true
accessApp.visible = false
accessApp.UserControl = true
Set accessApp.db = CurrentDB
Set accessApp.tdf = db.TableDefs("Database")
Set accessApp.fld1 = tdf.Fields("Name_Memofield1")
Set accessApp.fld2 = tdf.Fields("Name_Memofield2")
Debug.Print "acTextFormatPlain: " & acTextFormatPlain & _
"; acTextFormatHTMLRichText: " & acTextFormatHTMLRichText
With fld1.Properties("TextFormat")
Debug.Print "TextFormat: " & .Value
If .Value = acTextFormatPlain Then
.Value = acTextFormatHTMLRichText
Debug.Print "TextFormat changed to: " & .Value
End If
End With
With fld2.Properties("TextFormat")
Debug.Print "TextFormat: " & .Value
If .Value = acTextFormatPlain Then
.Value = acTextFormatHTMLRichText
Debug.Print "TextFormat changed to: " & .Value
End If
End With
The error what occures tells me that the problem is in the "Set accessApp.db = CurrentDB" the error which occured is: "Object doesn't support this prperty or method accessApp.db" If i change "accessApp.db" to "db" an other error occures: "Object required: 'CurrentDB' "
Try something like the code below. It will need tidying.
Option Explicit
Dim accessApp
Dim db
Dim dbname
Dim tdf
Dim fld1
Dim fld2
Dim acTextFormatPlain
Dim acTextFormatHTMLRichText
Dim dbInteger
'acTextFormatPlain=0
'acTextFormatHTMLRichText=1
dbInteger=3
dbname="D:\Test.mdb"
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDataBase(dbname)
set db=accessapp.CurrentDb
Set tdf = db.TableDefs("2emails")
'The property may not exist
SetFieldProperty tdf.Fields(1), "TextFormat", dbInteger, 0
With tdf.Fields(1).Properties("TextFormat")
If .Value = 0 Then
.Value = 1
msgbox "TextFormat changed to: " & .Value
End If
End With
Sub SetFieldProperty(ByVal fld , ByVal strPropertyName , ByVal iDataType , ByVal vValue )
Dim prp
Set prp = Nothing
On Error Resume Next
Set prp = fld.Properties(strPropertyName)
On Error GoTo 0
If prp Is Nothing Then
Set prp = fld.CreateProperty(strPropertyName, iDataType, vValue)
fld.Properties.Append prp
Else
prp.Value = vValue
End If
End Sub
I have been using this syntax which will export every table in a database to ONE excel workbook, but now my needs are to export every table to it's own workbook. How could this be tweaked to export each table to it's own workbook?
Sub ExportToExcel()
Dim td As DAO.TableDef, db As DAO.Database
Dim out_file As String
out_file = "C:\fromaccess.xlsx"
Set db = CurrentDb()
For Each td in db.TableDefs
If Left(td.Name, 4) = "MSys" Then
'Do Nothing
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","")
End If
Next
End Sub
EDIT
I tried the suggestion by #HA560 but get an error of
Run-time error '91':
Object variable or With block variable not set
This is updated code:
Sub ExportToExcel()
Dim td As DAO.TableDef, db As DAO.Database
Dim out_file As String
Dim xl As Excel.Application
out_file = "C:\fromaccess.xlsx"
Set db = CurrentDb()
For Each td in db.TableDefs
xl.Workbooks.Add
If Left(td.Name, 4) = "MSys" Then
'Do Nothing
Else
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","")
End If
Next
End Sub
Bit of a long one which includes a three procedures. After running you should have a list of table names and TRUE/FALSE in the immediate window saying whether the export was successful.
ExportAll - The main procedure.
CreateXL - this creates an instance of Excel. It uses late binding, so no need to set references.
QueryExportToXL - this is the code to export the table. I haven't used TransferSpreadsheet as I like more control.
You need to pass a worksheet reference to the function.
You can pass either a query name or a recordset to the function.
You can pass an alternative sheet name.
The default cell to paste into is A1, but you can change this.
By default it adjusts the column widths to fit.
You can pass a collection of heading names to use instead of the field names.
There's not much error handling in there - such as passing a different number of heading names than there are fields, giving illegal sheet names.
It needs work :)
Public Sub ExportAll()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rst As DAO.Recordset
Dim oXL As Object
Dim oWrkBk As Object
Set db = CurrentDb
'Create instance of Excel.
Set oXL = CreateXL
For Each tdf In db.TableDefs
If Left(tdf.Name, 4) <> "MSys" Then
'Create workbook with single sheet.
Set oWrkBk = oXL.WorkBooks.Add(-4167) 'xlWBATWorksheet
'Open the table recordset.
Set rst = tdf.OpenRecordset
'In the immediate window display table name and TRUE/FALSE if exported successfully.
Debug.Print tdf.Name & " - " & QueryExportToXL(oWrkBk.worksheets(1), , rst, tdf.Name)
'Save and close the workbook.
oWrkBk.SaveAs "<path to folder>" & tdf.Name
oWrkBk.Close
End If
Next tdf
End Sub
'----------------------------------------------------------------------------------
' Procedure : CreateXL
' Author : Darren Bartrup-Cook
' Date : 02/10/2014
' Purpose : Creates an instance of Excel and passes the reference back.
'-----------------------------------------------------------------------------------
Public Function CreateXL(Optional bVisible As Boolean = True) As Object
Dim oTmpXL As Object
'''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Excel is not running. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpXL = GetObject(, "Excel.Application")
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Excel. '
'Reinstate error handling. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpXL = CreateObject("Excel.Application")
End If
oTmpXL.Visible = bVisible
Set CreateXL = oTmpXL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateXL."
Err.Clear
End Select
End Function
'----------------------------------------------------------------------------------
' Procedure : QueryExportToXL
' Author : Darren Bartrup-Cook
' Date : 26/08/2014
' Purpose : Exports a named query or recordset to Excel.
'-----------------------------------------------------------------------------------
Public Function QueryExportToXL(wrkSht As Object, Optional sQueryName As String, _
Optional rst As DAO.Recordset, _
Optional SheetName As String, _
Optional rStartCell As Object, _
Optional AutoFitCols As Boolean = True, _
Optional colHeadings As Collection) As Boolean
Dim db As DAO.Database
Dim prm As DAO.Parameter
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field
Dim oXLCell As Object
Dim vHeading As Variant
On Error GoTo ERROR_HANDLER
If sQueryName <> "" And rst Is Nothing Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Open the query recordset. '
'Any parameters in the query need to be evaluated first. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set db = CurrentDb
Set qdf = db.QueryDefs(sQueryName)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset
End If
If rStartCell Is Nothing Then
Set rStartCell = wrkSht.cells(1, 1)
Else
If rStartCell.Parent.Name <> wrkSht.Name Then
Err.Raise 4000, , "Incorrect Start Cell parent."
End If
End If
If Not rst.BOF And Not rst.EOF Then
With wrkSht
Set oXLCell = rStartCell
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Paste the field names from the query into row 1 of the sheet. '
'Or the alternative field names provided in a collection. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If colHeadings Is Nothing Then
For Each fld In rst.Fields
oXLCell.Value = fld.Name
Set oXLCell = oXLCell.Offset(, 1)
Next fld
Else
For Each vHeading In colHeadings
oXLCell.Value = vHeading
Set oXLCell = oXLCell.Offset(, 1)
Next vHeading
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Paste the records from the query into row 2 of the sheet. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oXLCell = rStartCell.Offset(1, 0)
oXLCell.copyfromrecordset rst
If AutoFitCols Then
.Columns.Autofit
End If
If SheetName <> "" Then
.Name = SheetName
End If
'''''''''''''''''''''''''''''''''''''''''''
'TO DO: Has recordset imported correctly? '
'''''''''''''''''''''''''''''''''''''''''''
QueryExportToXL = True
End With
Else
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'There are no records to export, so the export has failed. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
QueryExportToXL = False
End If
Set db = Nothing
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure QueryExportToXL."
Err.Clear
Resume
End Select
End Function
After for each use workbooks.add()method...out_file=activeworkbook.path