I have a record set created mannually as follows
Dim rs As ADODB.Recordset
rs.Open Dim Fields() As String
Fields(0) = ""
Fields(1) = "January"
Fields(2) = "February"
Fields(3) = "March"
Fields(4) = "April"
Fields(5) = "May"
rs.AddNew Fields
rs.Close
I've been trying to bind it to my combobox as follows
combo1.RowSource = rs
combo1.BoundColumn = "Fields"
Set rs = Nothing
I see compiliation error at: combo1.RowSource = rs
Please help me in binding this recordset to my combo box. Thanks in advance
I assume you are playing with a DataCombo based on the odd set of things mentioned in your question above.
You're a bit off with your attempt to create a fabricated Recordset. You also need a "destination" for selected or entered data so you need a DataSource and DataField.
While many fear and loathe VB6 data binding, there really isn't much to it. It helps to have taken one of the formal VB6 courses covering the topic but sadly those haven't been offered for quite a long time. The textbooks can still be had, though these days it seems to be a lot to expect anyone to do any actual study.
Here I have several Command buttons, a DataCombo, and a multiline TextBox:
Option Explicit
Private rsValues As ADODB.Recordset
Private rsData As ADODB.Recordset
Private Sub NewEnabled(ByVal Enable As Boolean)
DataCombo1.Enabled = Enable
cmdSave.Enabled = Enable
cmdCancel.Enabled = Enable
cmdNew.Enabled = Not Enable
cmdDump.Enabled = Not Enable
End Sub
Private Sub cmdCancel_Click()
rsData.CancelUpdate
NewEnabled False
End Sub
Private Sub cmdDump_Click()
With rsData
Text1.Text = vbNullString
Text1.SelText = "Records: " & CStr(.RecordCount) & vbNewLine
If .RecordCount > 0 Then
.MoveFirst
Do Until .EOF
Text1.SelText = CStr(.AbsolutePosition) _
& ": " & CStr(!Month.Value) & vbNewLine
.MoveNext
Loop
End If
End With
End Sub
Private Sub cmdNew_Click()
rsData.AddNew
rsData!Month.Value = vbNullString
NewEnabled True
End Sub
Private Sub cmdSave_Click()
rsData.Update
NewEnabled False
End Sub
Private Sub Form_Load()
Dim Month As Integer
Set rsValues = New ADODB.Recordset
With rsValues
.CursorLocation = adUseClient
.Fields.Append "MonthName", adVarWChar, 255
.Open
.AddNew Array(0), Array(vbNullString)
For Month = 1 To 12
.AddNew Array(0), Array(MonthName(Month))
Next
End With
Set rsData = New ADODB.Recordset
With rsData
.CursorLocation = adUseClient
.Fields.Append "Month", adVarWChar, 255
.Open
End With
With DataCombo1
.ListField = "MonthName"
Set .RowSource = rsValues
.DataField = "Month"
Set .DataSource = rsData
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
rsData.Close
rsValues.Close
End Sub
This works just fine. However it may not be what you were after at all. That is really hard to tell from some code in a vacuum, especially when it appears to be air code that isn't close to correct.
Before you go any further with this, take a look at this. It's pretty simple to bind the control by hand, and avoids all sorts of subtle headaches that you will encounter in VB6 data binding. I have used data binding only once in the many thousands of lines of vb6 code I have delivered to customers, and that was to work around a very esoteric bug in Microsoft's DataRepeater control.
Related
I am developing a small project, but my knowledge in vba is still a little limited, so I would like to ask for your help.
The project is in excel and the database in access:
Table1 with 3 fields: Brand, Model and Port
Apple / iPhone XR / Lighning
Samsung / Galaxy A42 / usb-c
Xiaomi / Redmi / usb-c
Code in userform:
Private Sub UserForm_Initialize()
Call Brand
End Sub
Private Sub comboBrand_Change()
Set rs = New ADODB.Recordset
Module1.ConnectBD
rs.Open "SELECT * FROM Table1", Conexao, adOpenKeyset, adLockReadOnly
txtModel.Value = rs(2)
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Module1.DisconnectBD
End Sub
Sub Brand()
Set rs = New ADODB.Recordset
Module1.ConnectBD
rs.Open "SELECT DISTINCT brand FROM Table1 ORDER BY brand ASC", Conexao, adOpenKeyset, adLockReadOnly
Do Until rs.EOF
comboBrand.AddItem rs!Brand
rs.MoveNext
Loop
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Module1.DisconnectBD
End Sub
What I want is that every time I change the value in the ComboBox, the textbox Model updates according to the table; but the only value I can get is always the first line, that is "iPhone XR", no matter what I put in the combobox.
I know I have to reference the line with what is selected in the combobox but I can't get there; can you help?
After a few more attempts I finally found the solution:
Private Sub comboBrand_Change()
Set rs = New ADODB.Recordset
Module1.ConnectBD
rs.Open "SELECT * FROM Table1 WHERE brand ='" & UserForm1.comboBrand.Text & "'", Conexao, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 0 Then
UserForm1.txtModel = rs!Model
UserForm1.txtPort = rs!Port
UserForm1.txtID = rs!ID
Else
MsgBox "Not found!", vbInformation, "Brand"
End If
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Module1.DisconnectBD
Exit Sub
End Sub
I understand the report recordset property cant be connected too.
However I want/need to do something like:
Private Sub testLoad()
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
cmd.ActiveConnection = gcn
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "mysp_ProofofJobScott"
'Your parameters
cmd.Parameters("#StartJob").value = 1234
cmd.Parameters("#Cmonth").value = "February 2020"
Set Me.Recordset = cmd.Execute
End Sub
Which would work fine...if I could bind a report to a recordset.
I am already using a variation of this for all my forms, and would like to be consistent in my approach.
I got thinking is there a way to use the cmd.execute to populate a temporary table, become a source for the recordsource or some other work around?
Easy and fast is the Passthrough query, but you have to take care on passed arguments to be valid as you just concat sp name with them.
Consider change cMonth to a date, then evaluate month in sp.
Code to create PT query:
Private Sub CreatePTProofofJobScott(StartJob As Long, cMonth As String)
Const QueryDefName As String = "PTProofofJobScott"
With CurrentDb
Dim QdfExists as Boolean
Dim qdf As DAO.QueryDef
For Each qdf In .QueryDefs
If qdf.Name = QueryDefName Then
QdfExists = True
Exit For
End If
Next
If Not QdfExists Then
.CreateQueryDef(QueryDefName)
End If
With .QueryDefs(QueryDefName)
.Connect = "ODBC;DSN=yourDsnToSqlServer" 'or Conn-String https://www.connectionstrings.com/microsoft-odbc-driver-17-for-sql-server/
.SQL = "EXEC mysp_ProofofJobScott " & StartJob & ", '" & cMonth & "'"
End With
End With
End Sub
Use in Report_Open event with wanted args:
Private Sub Report_Open(Cancel As Integer)
CreatePTProofofJobScott Split(Me.OpenArgs,";")(0), Split(Me.OpenArgs,";")(1)
Me.RecordSource = "PTProofofJobScott"
End Sub
Pass args to OpenArgs on open cmd
DoCmd.OpenReport "yourReport",acViewPreview,,,,"1234;February 2020"
For future development, you should have a look at SSRS as FoggyDay noted
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 have built a database that I get an occasional error in.
I have a bound form in split form/datasheet view. Occasionally when updating records, I get the "Update or CancelUpdate without AddNew or Edit" error when moving to a new record. This will happen in either the single record form, or on the datasheet.
It does not happen every time the record is saved. Maybe 1 out of 20 or 30 times.
I do have an AuditTrail built in, which is my only guess as to what may be causing the problem.
The VBA on the form:
Private Sub Form_AfterDelConfirm(Status As Integer)
If Status = acDeleteOK Then Call AuditChanges("ApptID", "DELETED PRIOR RECORD")
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
If Me.NewRecord Then
Call AuditChanges("ApptID", "NEW")
Else
Call AuditChanges("ApptID", "EDIT")
End If
End Sub
Private Sub Form_Delete(Cancel As Integer)
If Status = acDeleteOK Then Call AuditChanges("ApptID", "DELETE BUTTON HIT")
End Sub
The AuditTrail code is:
Sub AuditChanges(IDField As String, UserAction As String)
On Error GoTo AuditChanges_Err
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim ctl As Control
Dim datTimeCheck As Date
Dim strUserID As String
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open "SELECT * FROM AuditTrail", cnn, adOpenDynamic, adLockOptimistic
datTimeCheck = Now()
strUserID = Environ("USERNAME")
Select Case UserAction
Case "EDIT"
For Each ctl In Screen.ActiveControl.Parent.Controls
If ctl.Tag = "Audit" Then
If Nz(ctl.Value) <> Nz(ctl.OldValue) Then
With rst
.AddNew
![DateTime] = datTimeCheck
![UserName] = strUserID
![FormName] = Screen.ActiveControl.Parent.Name
![Action] = UserAction
![RecordID] = Screen.ActiveControl.Parent.Controls(IDField).Value
![FieldName] = ctl.ControlSource
![OldValue] = ctl.OldValue
![NewValue] = ctl.Value
.Update
End With
End If
End If
Next ctl
Case Else
With rst
.AddNew
![DateTime] = datTimeCheck
![UserName] = strUserID
![FormName] = Screen.ActiveControl.Parent.Name
![Action] = UserAction
![RecordID] = Screen.ActiveControl.Parent.Controls(IDField).Value
.Update
End With
End Select
AuditChanges_Exit:
On Error Resume Next
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
Exit Sub
AuditChanges_Err:
MsgBox Err.Description, vbCritical, "ERROR!"
Resume AuditChanges_Exit
End Sub
If the error doesn't involve the VBA code, I have no idea what the problem could be.
I concur with dbmitch; adding some extra info to your error message would be a great help.
In addition, if that doesn't get you exactly what you want, you can also implement the little-known ERL function. Most people don't even know that Access can trap at the line level if they add line numbers (are you old enough to remember Basic?) to their code.
So, something like:
Sub AuditChanges(IDField As String, UserAction As String)
10 On Error GoTo AuditChanges_Err
20 Dim cnn As ADODB.Connection
30 Dim rst As ADODB.Recordset
40 Dim ctl As Control
50 Dim datTimeCheck As Date
60 Dim strUserID As String
70 Set cnn = CurrentProject.Connection
80 Set rst = New ADODB.Recordset
etc...
And then you could change your error handler to be something like:
400 MsgBox "UserAction: " & UserAction & vbCrLf & _
"IDField: " & IDField & vbCrLf & _
"Error Line: " & Erl & vbCrLf & _
"Error: (" & Err.Number & ") " & Err.Description, vbCritical, "ERROR!"
Turns out that the problem didn't seem to have any issues with the AuditTrail code.
There is a combobox that was getting hung up occasionally when moving to a new record.
I added the code below to the 'On Exit' event for the field, and I haven't seen the error come up since.
If Me.Dirty Then
Me. Dirty = False
End If
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