I need a small help dear people. I have a form where I have listbox and with selecting listbox I populate some fields and subform in the form.
What I`m trying to achieve is that the subform should not be with 0 records.
So I have a control where is checking if the recordset is 0 and is pop up a message but exit sub is not helping and user can stil get to the next record.
Private Sub lstRev_BeforeUpdate(Cancel As Integer)
Dim DataConn10 As New ADODB.Recordset
Dim Comm10 As String
Set Conn = CurrentProject.Connection
Comm10 = " SELECT tblLIVE.SID " & _
" FROM tblLIVE " & _
" WHERE tblLIVE.CID = " & Me.txtCID & " And tblLIVE.PID =
" & Me.txtPIDRev & " And tblLIVE.MNumber = '" & Me.txtSMNum & "'"
DataConn10.Open Comm10, Conn, adOpenKeyset, adLockOptimistic
If DataConn10.RecordCount = 0 And Not IsNull(Me.txtMIDRev) Then
Dim x As Integer
x = MsgBox("Are sure that you want to leave the form without adding Line in subform. If you press yes Rev will be deleted. If you press No please enter Line", vbYesNo)
If x = vbYes Then
MsgBox "Delete"
Else
MsgBox "EnterSOV"
'Here I need something to tell him to stay in the same record :(
DataConn10.Close
Exit Sub
End If
End If
End Sub
You can add Cancel=True to prevent the before update method from finishing. Just add this before your Exit Sub.
Related
I have a split form with a combo box (named cmb_KostenstellenAll) that shows cost centers. I can filter my form with cost center from this combo box (My form comes from a query called qryFürFormular).I added a list box (named lbx_KsAll) to make multiple selections when applying the filter. If is selected in the combo box, the list box becomes visible and I can select more than one cost center. Codes to do this:
Private Sub cmb_KostenstellenAll_AfterUpdate()
If Me.cmb_KostenstellenAll = "<Multiple selection>" Then
Me.lbx_KsAll.Visible = True
else
Me.lbx_KsAll.Visible = False
Me.Requery
End If
end sub
Private Sub lbx_KsAll_AfterUpdate()
Dim varItem As Variant
Dim strCriteria As String
Dim TempMultiState As TempVar
For Each varItem In Me!lbx_KsAll.ItemsSelected
strCriteria = strCriteria & "," & Me!lbx_KsAll.ItemData(varItem) & ""
Next varItem
If Len(strCriteria) = 0 Then
Exit Sub
Else
strCriteria = Right(strCriteria, Len(strCriteria) - 1)
TempVars!TempMultiState = strCriteria
MsgBox (TempVars!TempMultiState)
End If
End Sub
However, when I click the search button (named cmd_Search) with two selected cost center (called Sondermachninenbau and Testing), I get an error: syntax error (missing operator) in query expression '([Kostenstellen_NEU] in (Sondermachninenbau,Testing))'.
I wrote this code:
Private Sub cmd_Suchen_Click()
Call Search
End Sub
Sub Search()
Dim myKS, strSQL, strCriteria As String
If IsNull(Me.cmb_KostenstellenAll) Then
ElseIf Me.cmb_KostenstellenAll = "<Multiple selection>" Then
strCriteria = "[Kostenstellen_NEU] in (" & TempVars!TempMultiState & ")"
MsgBox (TempVars!TempMultiState)
Else
myKS = "[Kostenstellen_NEU]='" & Me.cmb_KostenstellenAll & "'"
strCriteria = myKS
End If
strSQL = "select * from qryFürFormular where (" & strCriteria & ")"
Me.RecordSource = strSQL
Me.Requery
End Sub
Me.RecordSource = strSQL is highligted.
In the example where I got the code like this(He had a table called Customers and
then created a form and added a subform with record source Customers) :
End If
strSQL = "select * from customers where (" & strCriteria & ")"
Me.customers_subform.Form.RecordSource = strSQL
Me.Customers_subform.FormRequery
End Sub
Looking for a way to click on a record in a form and then have it go to another record in the same form.
Example: There's a form that lists Products and associated records along with that product. One of the records is a "Replaced" field. Which will show what past Products it replaced.
I want to be able to click in the Replaced field and have it go to that Product record.
txtProduct: Iphone6
txtReplaced: Iphone5 (click on Iphone5) -> and then shows
txtProduct: Iphone5
txtReplaced: Iphone4
I looked into GoToRecord and FindRecord. Thinking the best way to go about it is to put vba code into the On Click event procedure using one of those for txtReplaced. Just not sure how to do that
EDIT to include attempt using RecordsetClone. It's now giving me the error that it can't find the record when I know it's there. Any insight on what I'm doing wrong?
Private Sub txtSupersedes_DblClick(Cancel As Integer)
Dim rs As Object
Set rs = Me.RecordsetClone
rs.FindFirst "[Model]='" & Me.txtSupersedes.Value & "'"
If rs.NoMatch Then
MsgBox "Sorry, could not find Model '" & txtSupersedes & "' ", vbOKOnly, vbInformation
Else
Me.Bookmark = rs.Bookmark
End If
rs.Close
End Sub
Private Sub txtSupersedes_DblClick(Cancel As Integer)
Dim rs As Object
Dim txtValue As String
txtValue = Me![txtSupersedes].Value
With Me.Parent.Form
Set rs = .RecordsetClone
rs.FindFirst "[Model]= '" & txtValue & "'"
If rs.NoMatch Then
MsgBox "Sorry, could not find Model '" & txtSupersedes & "' ", vbOKOnly, vbInformation
Else
.Bookmark = rs.Bookmark
End If
rs.Close
End With
End Sub
I have an Access 2016 database which use a form to select a time interval of 1 or more days.
A button let me to get the begin and end dates of the interval and do the follow 2 things:
a) build a query that, based on the dates, extracts a dataset from a table
b) open a pop-up form that show the dataset extracted by the query. There is no code on OpenForm event.
The magic is that everything works like a charm until I disable the Shift Bypass Key with the command
CurrentDb.Properties("AllowBypassKey") = False
After that the query still works well, but when the code try to open the form, 95% of the times, I get the error '2501 The OpenForm action was canceled', even if it worked well with Access 2013.
The code is quite simple, but after 3 days of hard work I still don't understand what is wrong. The only thing I got is that if I don't execute the CreateQueryDef instruction the error goes away and the form opens regoularly (even if it does not show the right dataset).
Therefore both the routine works alone, but they conflict if they run one after the other.
Below the code behind the button:
Private Sub Cmd_Meteo_Click()
On Error GoTo Err
Dim strFrmName As String
Dim datBegin As Date
Dim datEnd As Date
'Set the time interval
datBegin = Me.Txt_BeginTreatment 'Set the begin of the interval
datEnd = Me.Txt_Data 'Set tha end of the interval
'Build the query with meteo data
Call GetMetoData(Me.Txt_Region, Me.Cmb_MeteoStation, datBegin, datEnd, False)
'Set the form name
strFrmName = "Frm_DatiMeteoControllo"
'Check if the form is already open
If CurrentProject.AllForms(strFrmName).IsLoaded Then 'If the form is already open
DoCmd.Close acForm, strFrmName 'Close the form
End If
DoCmd.OpenForm strFrmName 'This line rise the 2501 error!
Exit_sub:
Exit Sub
Err:
MsgBox Err.Number & " " & Err.Description
Resume Exit_sub
End Sub
and the subroutine that build the query:
Public Sub GetMetoData(strRegion As String, intIdSM As Integer, datBegin As Date, datEnd As Date, bolTot As Boolean)
On Error GoTo Err
Dim db As DAO.Database
Dim strDbName As String
Dim qdf As DAO.QueryDef
Dim strSqlMeteo As String
Dim strLinkName As String
Dim strQryName As String
Set db = CurrentDb 'Set the db
strDbName = Application.CurrentProject.Name 'Get the db name
strTblName = GetMeteoTableName(strRegion, intIdSM) 'Get the name of the data table
strLinkName = "Tbl_DatiMeteo" 'Set the name of the linked table
strQryName = "TmpQry_DatiMeteoControllo" 'Set th name of the query
'SQL statement for the query
strSqlMeteo = "SELECT " & strLinkName & ".Data, ([" & strLinkName & "].[Precipitazione]) AS PrecTot, " & _
strLinkName & ".Tmin, " & strLinkName & ".Tmean, " & strLinkName & ".Tmax" & vbCrLf & _
"FROM " & strLinkName & vbCrLf & _
"WHERE (((" & strLinkName & ".Data) Between #" & Format(datBegin, "mm/dd/yyyy") & "# And #" & Format(datEnd, "mm/dd/yyyy") & "#));"
'Delete the previous query
If QueryEsiste(strDbName, strQryName) Then 'If the query already exist...
DoCmd.DeleteObject acQuery, strQryName 'delete the query.
End If
'Make the new query
Set qdf = db.CreateQueryDef(strQryName, strSqlMeteo)
Exit_sub:
qdf.Close
Set qdf = Nothing
db.Close
Set db = Nothing
Exit Sub
Err:
MsgBox Error$
Resume Exit_sub
End Sub
Does anyone has a hint or faced the same problem?
There should be no reason to delete the query:
If QueryEsiste(strDbName, strQryName) Then
' Modify the previous query.
Set qdf = db.QueryDef(strQryName)
qdf.SQL = strSqlMeteo
Else
' Create the new query.
Set qdf = db.CreateQueryDef(strQryName, strSqlMeteo)
End If
First off I am a bit of a novice when its comes to VBA, so everything I do is a bit of hit and miss but normally I eventually figure out the problem.
However this time I have been stuck for days and can't seem to find the issue!
I have the following form and subforms with the below structure. (Access2013)
Main Form [Job Number]
Subform [Out2] (this is where a user scans a barcode into the relevant field)
Subform [DS] (this is where the scanned barcode from [Out2] creates a new record)
Subform [DS] fields : Id, Job No, BarCode, Description, Date, User
What I am trying to achieve with the code below, is in 'The Before Update' event of the [DS] BarCode field, the Dcount function will check the list of Barcodes already entered in the subform container [DS], and if there
is more than one it will undo the duplicate entry. Unfortunately nothing is happening when a duplicate entry is entered.
(not even errors)
P.S. Setting the table (No Duplicates) thing will not work for this DB.
Private Sub BarCode_BeforeUpdate(Cancel As Integer)
Dim BarCode As String
Dim strLinkCriteria As String
Dim rsc As DAO.Recordset
Set rsc = Me.RecordsetClone
BarCode = Me.BarCode.Text
strLinkCriteria = "[Barcode]=" & "'" & Replace(Me![BarCode], "'", "''")
'Check Items Subform for duplicate BarCode
If DCount("BarCode", "Forms![Job Number]![DS]", strLinkCriteria) > 0 Then
'Undo duplicate entry
Me.Undo
'Message box warning of duplication
MsgBox "Warning Item Title " _
& BarCode & " has already been entered." _
& vbCr & vbCr & "You will now been taken to the record.", _
vbInformation, "Duplicate Information"
'Go to record of original Title
rsc.FindFirst strLinkCriteria
Me.Bookmark = rsc.Bookmark
End If
Set rsc = Nothing
End Sub
Here is how to handle this:
Private Sub BarCode_BeforeUpdate(Cancel As Integer)
Dim rsc As DAO.Recordset
Dim BarCode As String
Dim Criteria As String
Set rsc = Me.RecordsetClone
BarCode = Nz(Me!BarCode.Value)
Criteria = "[Barcode] = '" & Replace(BarCode, "'", "''") & "'")
rsc.FindFirst Criteria
Cancel = Not rsc.NoMatch
If Cancel = True Then
' Message box warning of duplication
MsgBox "Warning Item Title " _
& BarCode & " has already been entered." _
& vbCrLf & vbCrLf & "You will now been taken to the record.", _
vbInformation, "Duplicate Information"
' Go to record of original Title
Me.Bookmark = rsc.Bookmark
End If
Set rsc = Nothing
End Sub
I already have the query that retrieves me the data in a correct way, this is my code.
Sub Main()
Dim sDBPath As String
sDBPath = "C:\Users\ges\Documents\ExploWR.mdb"
Call Query_Access_to_excel(sDBPath, "Explo1", "SELECT eipl.MOD_CODE, eipl.BOM_KEY, eipl.DIF, eipl.PART_NO, eipl.PART_DESC, eipl.QTY_PER_CAR, eipl.INTERIOR_COLOUR, eipl.EXTERIOR_COLOUR, eipl.SOURCE_CODE, eipl.SHOP_CLASS," & _
" eipl.PART_CLASS, eipl.PROCESS_CODE, eipl.OPERATION_NO, eipl.DESIGN_NOTE_NO, eipl.WIP, eipl.PART_ID_CODE, eipl.ADOPT_DATE_Y2K,eipl.ABOLISH_DATE_Y2K, ipo_Modelos.EIM, ipo_Modelos.DEST, ipo_Modelos.MY " & _
" FROM eipl, explo, ipo_Modelos" & _
" WHERE explo.MOD_CODE = eipl.MOD_CODE And explo.MY = ipo_Modelos.MY" & _
" And explo.PLANT = ipo_Modelos.PLANT And eipl.ADOPT_DATE_Y2K <= explo.ADOP " & _
" And explo.DEST = ipo_Modelos.DEST And explo.EIM = ipo_Modelos.EIM")
End Sub
Sub Query_Access_to_excel(sBd As String, sHoja As String, sSQL As String)
On Error GoTo error_handler
Dim rs As ADODB.Recordset
Dim conn As String
Dim Range_Destino As Range
Set Range_Destino = ActiveWorkbook.Sheets(sHoja).Cells(6, 1)
conn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source= " & sBd & ";"
Set rs = New ADODB.Recordset
Call rs.Open(sSQL, conn, adOpenForwardOnly, adLockReadOnly)
If Not rs.EOF Then
Range_Destino.Offset(1, 0).CopyFromRecordset rs
DoEvents
MsgBox "Import Complete", vbInformation
Else
MsgBox "No registers to import", vbInformation
End If
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
If Not Range_Destino Is Nothing Then
Set Range_Destino = Nothing
End If
Exit Sub
error_handler:
MsgBox Err.Description, vbCritical
End Sub
What I want to do is to correctly place the data in the cells, something like this.
And what I have is something like this. I want to place the data in the correct cells, I'm talking about the last 3 fields to be properly placed in the columns like the first image. I have no idea how to do this without affecting my query.
So as far as exporting the data into excel you have several options:
SQL do command:
https://msdn.microsoft.com/en-us/library/office/ff844793.aspx
Same command but in VBA:
Using Excel VBA to export data to MS Access table
You could iterate through the table and create an array then print that array into a spreadsheet
Once you have the data in excel you're just looking at formatting -- adding some filters, changing the text align, ect.. you can use the "Record Macro" function to perform those tasks and clean the code.
So I guess for clarification - what do you mean 'affecting your query?'