I'm using Access 2013 and have a query "qryMatchingStyle" and field "FilePath" that contain a list of files paths to copy images from. I then have a table, "tmpDestFolders" and field "FlatFile" to copy the images to. I call the below Function that is in a Module to copy the images - however, it only ever copies the first image even though they are more - why is this? Is my loop incorrect or do I need to put this in a Class Module?
Public Function CopyStyle()
Dim rst As ADODB.Recordset
Dim strSQL As String
Dim strEmail As String
Dim ToPath As String
Dim FromPath As String
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
FromPath = DLookup("FilePath", "qryMatchingStyle")
ToPath = DLookup("FlatFile", "tmpDestFolders")
Set rst = New ADODB.Recordset
DoCmd.SetWarnings False
strSQL = "[qryMatchingStyle]" 'source of recordset
rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If Not rst.EOF Then
Do While Not rst.EOF
'copy file code here
Call fso.CopyFile(FromPath, ToPath)
rst.MoveNext
Loop
End If
Set rst = Nothing
'Update flag to say style was copied
DoCmd.RunSQL "UPDATE qryMatchingStyle INNER JOIN tblLocalStyleCol ON qryMatchingStyle.Style = tblLocalStyleCol.Style SET tblLocalStyleCol.[Style Copied] = True", -1
'MsgBox "All matching style images copied"
End Function
That's because FromPath and ToPath are assigned once; they are not fecteched from the Recordset. Try this:
Do While Not rst.EOF
FromPath = rst.Fields("FilePath").Value
ToPath = rst.Fields("FlatFile").Value
Call fso.CopyFile(FromPath, ToPath)
rst.MoveNext
Loop
p.s. there is no need for the If Not rst.EOF statement that envelops this loop, nor for the first assignments of FromPath and ToPath. These can be removed form your code.
Related
I have some vba code that 'attempts' to loop through an array of DAO recordsets. When running the loop, I get a runtime error 'Oject required' at rst.MoveFirst. It seems that rst is not properly initialized but I'm not sure how to fix it. Maybe looping through an array of recordsets isnt even possible in this way I have never tried it before. The code runs from a custom class module. There is a bunch more code in the module but most of the important stuff I post below. A couple things I tried:
Set rst to a new recordset instance manually:
Set rst = New DAO.Recordset
Declaring the array outside the loop:
Set recordsets = Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
' Loop through each recordset and insert data into Excel file
For Each rst In recordsets
Setting rst to an open recordset right before rst.MoveFirst:
For Each rst In Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
Set rst = rst.OpenRecordset()
rst.MoveFirst
The three recordsets in the array are properly initialized, set and are not Nothing. I had previously written the code for each of the three recordsets seperately and it works that way. I am aware that I need to change the variable name XLColumn, but thats not really an issue atm. Its probably something bassic but I couldn't figure it out for a while now so I thought I'd just ask.
I am using the following libraries for which references are properly set:
Visual Basic for Applications
Microsoft Access 16.0 Object Library
OLE Automation
Microsoft Office 16.0 Access database engine Object
Library
Microsoft Excel 16.0 Object Library
Microsoft Office 16.0 Object Library
My version of Access:
Microsoft® Access® für Microsoft 365 MSO (Version 2301 Build 16.0.16026.20002) 32 Bit
The code:
Option Compare Database
Option Explicit
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rsRes As DAO.Recordset 'rs of temp table (Output)
Dim rsZwi As DAO.Recordset 'rs of temp table (Zwischenwerte)
Dim rsRec As DAO.Recordset 'rs clone of subform Rechenwerte
Dim Recordset As Recordset
Dim rstRechenwerte As DAO.Recordset 'rs of tblRechenwerte
Dim rstZwischenwerte As DAO.Recordset 'rs of tblZwischenwerte
Dim rstZutaten As DAO.Recordset 'rs of tblZutaten
Dim RezeptID As Integer 'Current form active RezeptID
Dim RechengruppeID As Integer 'Current Form active RechengruppeID
Dim xlColumn As String 'Excel Column of Zutaten
Dim xlLastRow As Long 'Excel last row number after insertion
Dim xlColumn2 As String 'Excel Column one to the right of Zutaten
Dim k As Integer
Dim Export As Boolean 'Export the Excel File
Dim ExclExportPath As String 'Export location as string
Sub Calculate()
'***************************************************************************
'Purpose: Calculate a recipe based on Rechenwerte,
'save them temporarily and display them on a form.
'Inputs: None
'***************************************************************************
'***********************************************************************
' Preparations
'***********************************************************************
'Disable user input
Call mdlMiscFunctions.DisableKeyboardMouse(True)
'Clear temporary data tables for Results and Zwischenwerte
If Not rsRes.EOF Then Call ClearTableOnClose("tblTempResults")
If Not rsZwi.EOF Then Call ClearTableOnClose("tblTempZwischenwerte")
'Prevent prompt to save changes to excel
xlApp.DisplayAlerts = False
xlApp.Visible = False
'***********************************************************************
' Insert Data into Excel File
'***********************************************************************
Dim rst As DAO.Recordset
Dim xlCell As String
Dim xlFormula As String
Dim xlColumn As String
' Loop through each recordset and insert data into Excel file
For Each rst In Array(rstRechenwerte, rstZwischenwerte, rstZutaten)
rst.MoveFirst
If Not rst.EOF Then
Do Until rst.EOF
xlCell = rst!xlCell
xlSheet.Range(xlCell).Value = rst.Fields(1)
If rst.Fields.Count > 2 Then
xlFormula = rst!xlFormula
xlSheet.Range(xlCell).Offset(0, 1).Formula = xlFormula
xlSheet.Range(xlCell).Offset(0, 1).Value = xlSheet.Range(xlCell).Offset(0, 1).Value
Else
xlSheet.Range(xlCell).Offset(0, 1).Value = rst.Fields(2)
End If
rst.MoveNext
Loop
Else
Select Case rst.Name
Case "rstRechenwerte"
MsgBox "Error: Keine Rechenwerte vorhanden!", vbCritical
Case "rstZwischenwerte"
MsgBox "Error: Keine Zwischenwerte vorhanden!", vbCritical
Case "rstZutaten"
MsgBox "Error: Keine Zutaten vorhanden!", vbCritical
End Select
End If
Next rst
Class initialization is the following:
Private Sub Class_Initialize()
'***************************************************************************
'Purpose: Sub for initializing class variables
'Inputs: None
'***************************************************************************
'Values for variables 1 (Neccesary for recordsets)
RezeptID = Forms.frmCalcBatch.RezeptID 'RezeptID on current form
RechengruppeID = Forms.frmCalcBatch.RechengruppeID 'Rechengruppe on Current Form
'Initialize Objects
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets("Tabelle1") 'Set xlSheet to the first sheet in the workbook
Set rsRes = CurrentDb.OpenRecordset("tblTempResults", dbOpenDynaset)
Set rsZwi = CurrentDb.OpenRecordset("tblTempZwischenwerte", dbOpenDynaset)
Set rsRec = Forms.frmCalcBatch.frmSubRechenwerteBox.Form.Recordset.Clone 'rs clone of Rechenwerte subform
Set rstRechenwerte = CurrentDb.OpenRecordset("SELECT Rechenwert, WertBezeichnung, XLCell FROM tblRechenwerte WHERE RechengruppeID = " & RechengruppeID)
Set rstZwischenwerte = CurrentDb.OpenRecordset("SELECT ZWBezeichnung, XLFormula, XLCell FROM tblZwischenwerte WHERE RezeptID = " & RezeptID)
Set rstZutaten = CurrentDb.OpenRecordset("SELECT Zutat, XLFormula, XLCell FROM tblZutaten WHERE RezeptID = " & RezeptID)
'Values for Variables 2 (recordsets neccesary for variables)
xlColumn2 = Split(rstZutaten!xlCell, "1")(0) 'extract excel column denominator for Zutaten
xlColumn2 = Chr(Asc(xlColumn2) + 1) 'Move one column to the right using Asc (A->B etc.)
'Settings:
If Forms.frmCalcBatch.cbExport = True Then
Export = True
ExclExportPath = GetExportPath
Else
Export = False
ExclExportPath = ""
End If
End Sub
You cannot New up a DAO.Recordset, the code will not even compile.
To loop through an array of recordsets, each recordset must initialized before it is added to the array.
For example:
Dim r1 As DAO.Recordset, r2 As DAO.Recordset, r3 As DAO.Recordset
Set r1 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Set r2 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Set r3 = CurrentDb().OpenRecordset("YourTableOrQueryName")
Put the recordsets now in the array.
Dim arr As Variant
arr = Array(r1, r2, r3)
To loop, you need to use a For loop and either access the recordset from the array directly, or declare another recordset variable to hold the iterating recordset.
Through an iterator variable:
Dim r As DAO.Recordset, i As Integer
For i = LBound(arr) To UBound(arr)
Set r = arr(i)
If Not r.EOF Then
r.MoveFirst
Debug.Print r.RecordCount
End If
Next i
Access it directly from the array:
For i = LBound(arr) To UBound(arr)
If Not arr(i).EOF Then
arr(i).MoveFirst
Debug.Print arr(i).RecordCount
End If
Next i
Though I fail to see why you need to have 3 recordsets in memory at the same time. Personally, I would offload the work that needs to be done in the loop to a separate function and pass the recordset as parameter. The function itself would return a success/failed status, so you can take the appropriate action based on the result.
Another approach would be to store the source names in the array, and create the recordset on demand during the loop.
Hope this helps.
quite new to VBA. I tried to fix this problem by my own but any of the open threats seems to fit in what I need.
Context:
I have this Macro that brings info from a DDBB and copies it in a new Workbook. I would like to organize different queries in different modules than the main one and call them on demand.
Problem:
I have set my query in a new module as a string, but I get ByRef or Method or data member not found all the time:
Main Sub
Sub Consulta_Sql_ERP()
'Declare variables
Set objMyConn = New ADODB.Connection
Set objMyRecordset = New ADODB.Recordset
Dim strSQL As String
Dim ws2 As Workbook
Dim iCols As Integer
'Open Connection'
objMyConn.ConnectionString = "Provider=SQLOLEDB.1;
Data Source=(...);
Initial Catalog=(...);
User ID=(...);
Password=(...);
Persist Security Info=True;"
objMyConn.Open
'Set and Excecute SQL Command'
strSQL = Module4.Querys(Query1)
'Open Recordset'
Set objMyRecordset.ActiveConnection = objMyConn
objMyRecordset.Open strSQL
'Open a NewWorkbook
Call NewBook
'Copy Data to the new book
Set ws2 = ActiveWorkbook
ws2.Worksheets("Sheet1").Activate
'Copy headers
For iCols = 0 To objMyRecordset.Fields.Count - 1
Worksheets("Sheet1").Cells(1, iCols + 1).Value = objMyRecordset.Fields(iCols).Name
Next
ActiveSheet.Range("A2").CopyFromRecordset (objMyRecordset)
objMyConn.Close
'Close and save
Call carpetaventas
'ws.SaveAs Savechanges:=True, Filename:="" & Format(Date, "yyyymmdd")
'ws2.Close Savechanges:=True, Filename:="" & Format(Date, "yyyymmdd"),
'RouteWorkbook:="C:\Ventas"
End Sub
The module in which I have the String of my query is "Module4"
Sub in which I have my Query:
Sub Queries(Query1 As String)
Set Query1 = "Select * from table1"
End Sub
It works if I directly introduce the Query after "strSQL" but not if I "call" the Sub on Module4. Any ideas?
Thanks a lot in advance.
strSQL = Module4.Query1()
Function Query1() As String
Query1 = "Select * from table1"
End Sub
I am wanting to query a SQL Server Table and store the results from that query in an array. I am only returning a Distinct() from one field so it should be pretty straight forward. My syntax produces the error
Invalid Qualifier
On this line of code Set r = conn.Execute and it highlights the word conn How should I re-write this syntax to still use ADO but be able to successfully run this procedure?
Public Function ReturnData()
Dim c As ADODB.Connection
Dim r As ADODB.Recordset
Dim f As ADODB.Field
Dim conn As String
Dim arrResults() As Variant
Set c = New ADODB.Connection
With c
.Provider = "sqloledb.1"
With .Properties
.Item("Data Source") = "ServerName"
.Item("Initial Catalog") = "Database"
.Item("PassWord") = "password"
.Item("User ID") = "user"
End With
.Open
Set r = conn.Execute("SELECT Distinct(Name) from registered where cancelled IS NULL;")
i = 0
r.MoveFirst
Do Until rst.EOF
arrResults(i) = rst.Fields(0)
i = i + 1
Loop
rst.Close
Set rst = Nothing
c.Close
End Function
Another way to get a recordset into an array is to use Split and Recordset.GetString. It avoids the loop anyway. Here's an example.
Public Sub RsToArray()
Dim adoCon As ADODB.Connection
Dim adoRs As ADODB.Recordset
Dim vaLocations As Variant
Set adoCon = New ADODB.Connection
adoCon.Open sConn
Set adoRs = adoCon.Execute("SELECT DISTINCT LocationName FROM Locations")
vaLocations = Split(adoRs.GetString, vbCr)
Debug.Print Join(vaLocations, "|")
adoRs.Close
adoCon.Close
Set adoRs = Nothing
Set adoCon = Nothing
End Sub
you've got conn is a string there, c is a connection - can you do c.execute
try
Set r = c.Execute(...
I'm not sure if you need a command object, if you do, then see
https://msdn.microsoft.com/en-us/library/ms675065%28v=vs.85%29.aspx
to see how to make a command for your connection and execute it
Anyhow, at the moment you are trying to 'execute' on a string - string is a primitive type and does not execute on the DB - I think you just mixed c and conn up - let us know how it goes
I have a table with a field containing multi-valuable as shown below:
In the form, I want to let the user enter a NCR_Num in the textbox then using VBA to do some input validation then add it to the "text_Pool" as shown below:
This Text_Pool has the NCR_Num as the control source so if there is a NCR number added or deleted from it, it will automatically update the NCR_Num field.
I am not quite sure how to handle this data type.
In VBA, I cannot obtain the value from the Text_Pool because I think I need to treat it as an array or recordset
Below is an example of me trying the recordset attempt but obviously I am quite confused on what I am doing:
Public Function get_NCR_Num(SCAR_Num As Integer) As Integer()
Dim dbsMain As DAO.Database
Dim rstMain As DAO.Recordset
Dim childRS As Recordset
Dim sSearchField, sCriteria As String
Set dbsMain = CurrentDb
Set rstMain = dbsMain.OpenRecordset("tbl_SCAR", dbOpenDynaset, dbReadOnly)
Set childRS = rstMain!NCR_Num.Value
sSearchField = "[SCAR_Num]"
sCriteria = sSearchField & " = " & [SCAR_Num]
With rstMain
.MoveLast
.FindFirst (sCriteria)
With childRS
Do While (Not .EOF)
MsgBox (childRS!NCR_Num.Value)
.MoveNext
Loop
End With
End With
rstMain.Close
dbsMain.Close
Set rstMain = Nothing
Set dbsMain = Nothing
End Function
Any help will be appreciated!
I misunderstood your question, and have updated the answer with the following code. This should do what you want. Replace the code you have in subroutine 'Command_LinkNCR_Click' with the following.
This will: (a) validate nbr exists; (b) add if not present; (c) remove if present;
WARNING!! This code only addresses the one issue you were trying to overcome. However, it makes an update of the same recordset as you are viewing on the form, so there may be an issue if your form is 'Dirty'.
Give this a try and let me know if you have questions.
Private Sub Command_LinkNCR_Click()
Dim dbs As DAO.Database
Dim rsMain As DAO.Recordset
Dim rsChild As DAO.Recordset
Dim strSQL As String
Dim blnMatch As Boolean
If IsNull(Me.Text_NCR) Or Me.Text_NCR = "" Then
MsgBox "No value entered for NCR_Num", vbOKOnly, "Missing Value"
Exit Sub
End If
blnMatch = False
Set dbs = CurrentDb
' Only need to work on the current record
strSQL = "select * from tbl_SCAR where SCAR_Num = " & Me!SCAR_Num & ";"
Set rsMain = dbs.OpenRecordset(strSQL, dbOpenDynaset)
If rsMain.EOF Then
' Should never happen
Else
Set rsChild = rsMain!NCR_Num.Value
If rsChild.EOF Then ' If no values yet, add this new one
MsgBox "Add item"
Else
Do While Not rsChild.EOF
' See if we have a match...
If Int(rsChild.Fields(0)) = Int(Me.Text_NCR) Then
blnMatch = True
rsChild.Delete ' Delete item
Exit Do
End If
rsChild.MoveNext
Loop
If blnMatch = False Then ' Need to Add it
rsMain.Edit
rsChild.AddNew
rsChild.Fields(0) = Me.Text_NCR
rsChild.Update
rsMain.Update
End If
End If
End If
'rsChild.Close
rsMain.Close
dbs.Close
Set rsMain = Nothing
Set rsChild = Nothing
Set dbs = Nothing
Me.Refresh
End Sub
I have put together a procedure to cycle through a table containing paths to text files and import them into the database.
Reason for procedure:
The reason for this is I am building a back end to many reporting databases that rely on nightly updated text files. Recently they changed the server name and file names for these files, so I'm trying to build something more reliable so I don't have to run through the link table wizard making sure all the data types are exactly the same as before.
Issue:
The issue I have is the With .edit .update isn't acting like I thought it should and updating the field 'Updated' in the table to today's date.
Here is the code. I'm still new to programming, so apologies.
Private Sub ImportAll()
' Loops through table containing paths to text files on network and imports
Dim ID As Integer
Dim netPath As String
Dim netDir As String
Dim netFile As String
Dim localTable As String
Dim activeTable As Boolean
Dim updatedTable As Date
Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("Tables")
Do Until rst.EOF
ID = rst.Fields("Table ID").Value
netDir = rst.Fields("Network Location").Value
netFile = rst.Fields("File Name").Value
localTable = rst.Fields("Local Table Name").Value
activeTable = rst.Fields("Active").Value
updatedTable = rst.Fields("Updated").Value
If activeTable = True And updatedTable <> Date Then
If ifTableExists(localTable) Then
On Error GoTo ImportData_Err
CurrentDb.Execute "DELETE * FROM " & localTable, dbFailOnError
netPath = netDir & netFile
DoCmd.TransferText acImportDelim, , localTable, netPath, True, ""
rst.Edit
updatedTable = Date
rst.Update
Else
netPath = netDir & netFile
DoCmd.TransferText acImportDelim, , localTable, netPath, True, ""
With rs
.Edit
.Fields("Updated") = Date
.Update
End With
End If
End If
rst.MoveNext
Loop
rst.Close
Set rst = Nothing
ImportData_Exit:
Exit Sub
ImportData_Err:
MsgBox Error$
Resume ImportData_Exit
End Sub
Thank you.
Where you have
With rs
You meant
With rst
Mistakes such as this can be caught by turning on Option Explicit. Option Explicit means that all variables must be declared.
See here: How do I force VBA/Access to require variables to be defined?