PREFACE: I am using SQL Server 2008 R2 BackEnd and MS Access 2007 for the FrontEnd
I have a Class Module that returns any ADO Recordset I want from the SQL Server. I can then assign this to any form RecordSource property.
The problem is that when I try to edit the fields it says "This form is read-only" in the status bar. I want the form to be editable.
I have two forms
FormEntities
FormEntitiesEdit
The FormEntitiesEdit form does NOT use the Class Module. Rather all the code is in the form itself.
The purpose of the class module is avoid redundancy and just be able to use the Class Module to get a recordset from SQL Server easily.
FIRST HERE IS MY GLOBAL MODULE
'Default error message. 'eh' stands for error handler
Public eh As String
'Global variables for universal use
Public conn As ADODB.Connection
Public rs As ADODB.Recordset
Public com As ADODB.Command
SECOND IS THE CLASS MODULE (Name is cADO).
THIS CLASS MODULE USES THE conn CONNECTION OBJECT ABOVE
Option Explicit
Private Const CONST_LockType = 3
Private Const CONST_CursorType = 1
Private Const CONST_CursorLocationServer = 3
Private Const CONST_CursorLocationClient = 2
Private m_Recordset As ADODB.Recordset
'For Public Recordset function
Private cSQL$
'**********************************************************************
Public Function cGetRecordset(ByRef sql) As ADODB.Recordset
Set m_Recordset = New ADODB.Recordset
cSQL = sql
cOpenRecordset
Set cGetRecordset = m_Recordset
End Function
'**********************************************************************
Public Property Set Recordset(Value As ADODB.Recordset)
'Assigns private variable a property
If Not Value Is Nothing Then Set m_Recordset = Value
End Property
'**********************************************************************
Public Property Get Recordset() As ADODB.Recordset
'Reads the recordset from the private variable and assigns to new object variable
Set Recordset = m_Recordset
End Property
'********************************** PRIVATE SECTION **********************************
Private Sub cOpenRecordset()
On Error GoTo eh
'Ensures that if a recordset is opened from previously that it closes before opening a new one
If m_Recordset.State adStateClosed Then m_Recordset.Close
Set m_Recordset.ActiveConnection = conn
With m_Recordset
.LockType = CONST_LockType
.CursorType = CONST_CursorType
.CursorLocation = CONST_CursorLocationClient
.Source = cSQL
.Open .Source
End With
If Not m_Recordset.EOF Then m_Recordset.MoveFirst
Exit Sub
eh:
eh = "Error # " & Str(Err.Number) & " was generated by " & _
Err.Source & Chr(13) & Err.Description
MsgBox eh, vbCritical, "Open Recordset System"
End Sub
'**********************************************************************
Private Sub cCloseRecordset()
m_Recordset.Close
Set m_Recordset = Nothing
End Sub
'**********************************************************************
Private Sub Class_Terminate()
If Not (m_Recordset Is Nothing) Then Set m_Recordset = Nothing
End Sub
THIRD IS THE CODE BEHIND MY FormEntities FORM (USES THE THE cADO CLASS MODULE)
Option Explicit
Dim db As cADO
'**********************************************************************
Private Sub Form_Current()
LoadTab
End Sub
'**********************************************************************
Private Sub Form_Load()
Set db = New cADO
FetchRecordSource
End Sub
'**********************************************************************
Private Sub FetchRecordSource()
db.cGetRecordset ("SELECT * FROM dbo.Entities")
Set Forms("fEntities").Recordset = db.Recordset
End Sub
FOURTH AND FINALLY IS THE CODE BEHIND THE FormEntitiesEdit FORM (THIS FORM DOES NOT USE THE CLASS MODULE AND I CAN EDIT IT)
Option Compare Database
Option Explicit
Dim rsEntity As New ADODB.Recordset
'**********************************************************************
Private Sub Form_Load()
FetchRecordSource
End Sub
'**********************************************************************
Private Sub FetchRecordSource()
Set rsEntity.ActiveConnection = conn
'Sets the record source for the main form
With rsEntity
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.CursorLocation = adUseClient
.Source = "SELECT * FROM dbo.Entities"
.Open .Source
End With
Set Forms("fEntitiesEdit").Recordset = rsEntity
End Sub
'**********************************************************************
Private Sub CloseConn()
rsEntity.Close
End Sub
If Access Jet SQL could do the SQL I would bind this form to a Linked Table instead. However I am using a hierarchical (recursive) query which Jet SQL cannot do so I have to bypass the idea of bound forms to Linked Tables.
I have .Allow Edits and .AllowAdditions on the form set to true.
I also tried changing the .LockType on the ADO Recordset to
adOpenKeyset and
adOpenDynamic
My LockType is adLockOptimistic
As you can see the properties are set correctly to be able to edit the recordset I return.
I know this is true because when I use the FormEntitiesEdit form with the same properties it lets me edit the field. But when I use the Class Module to return (using the same properties) it says it's read-only.
This is important because as you can see it is a lot simpler to use the Class Module, just need it to return an editable recordset.
Anyone have ideas? suggestions?
The problem is here in the class' cOpenRecordset() method:
.CursorLocation = CONST_CursorLocationClient
Here is where you assign constant values ...
Private Const CONST_CursorLocationServer = 3
Private Const CONST_CursorLocationClient = 2
Unfortunately, you swapped those two values. Here are the ADODB.CursorLocationEnum constants ...
adUseClient = 3
adUseServer = 2
So your class is effectively doing this ...
.CursorLocation = adUseServer
But you need a client-side cursor if you want the recordset to be editable. I think your class approach may work if you simply redefine the constant, or you will expose a different problem ...
Private Const CONST_CursorLocationClient = 3
FormEntitiesEdit is editable because you're using the correct constant there ...
.CursorLocation = adUseClient
I have tried every suggestion from many different sites, but none of them work, not even Microsoft's KB articles or references suggested in Stack Overflow.
I have a main form [frmMain], with a sub form called [frmTaskTracking] and a sub form within that sub form called [sfmActivites subform]. I need to obtain the filter for [sfmActivites subform] from a popup form [frmExportTasks] which is opened from [frmTaskTracking] as such:
[frmMain]
[frmTaskTracking]
[sfmActivites subform]
Filter
[frmExportTasks]
What is the correct way to reference the filter for the form [sfmActivites subform] in VBA??
Thanks so much!
Your question is very conceptual, so this answer may or may not apply to your specific issue.
I once had to create a CRUD app involving master-detail data, and I had to do it in Excel VBA, and didn't have access to the database... so I wrote the code against abstractions and implemented Model-View-Presenter, Command and Repository+UnitOfWork patterns... which might be slightly overkill for your needs.
However overkill this solution might be, it's as SOLID as VBA gets, and has allowed me to reuse the same form/view for every single one of the "master" and "details" tables I wanted to work with - again, your post isn't exactly crystal-clear on what it is exactly that you're doing, so I'm just going to expose the solution that worked for me. Is it the right way? Depends what you're doing. It was the right way for me, as I could test the entire functionality with mock data, and everything just worked when I got to the office and swapped the unit of work for one that actually connected to the database.
The key point is that the Presenter knows its MasterId, and its DetailsPresenter if it has one:
IPresenter
Option Explicit
Public Property Get UnitOfWork() As IUnitOfWork
End Property
Public Property Set UnitOfWork(ByVal value As IUnitOfWork)
End Property
Public Property Get View() As IView
End Property
Public Property Set View(ByVal value As IView)
End Property
Public Sub Show()
End Sub
Public Function ExecuteCommand(ByVal commandId As CommandType) As Variant
End Function
Public Function CanExecuteCommand(ByVal commandId As CommandType) As Boolean
End Function
Public Property Get DetailsPresenter() As IPresenter
End Property
Public Property Set DetailsPresenter(ByVal value As IPresenter)
End Property
Public Property Get MasterId() As Long
End Property
Public Property Let MasterId(ByVal value As Long)
End Property
Say I have a CategoriesPresenter and a SubCategoriesPresenter, I could have the CategoriesPresenter implemented like this:
Option Explicit
Private Type tPresenter
UnitOfWork As IUnitOfWork
DetailsPresenter As IPresenter
View As IView
End Type
Private this As tPresenter
Implements IPresenter
Implements IDisposable
Public Property Get UnitOfWork() As IUnitOfWork
Set UnitOfWork = this.UnitOfWork
End Property
Public Property Set UnitOfWork(ByVal value As IUnitOfWork)
Set this.UnitOfWork = value
End Property
Public Property Get View() As IView
Set View = this.View
End Property
Public Property Set View(ByVal value As IView)
Set this.View = value
End Property
Public Property Get DetailsPresenter() As IPresenter
Set DetailsPresenter = this.DetailsPresenter
End Property
Public Property Set DetailsPresenter(ByVal value As IPresenter)
Set this.DetailsPresenter = value
End Property
Public Sub Show()
IPresenter_ExecuteCommand RefreshCommand
View.Show
End Sub
Private Function NewCategory(Optional ByVal id As Long = 0, Optional ByVal description As String = vbNullString) As SqlResultRow
Dim result As SqlResultRow
Dim values As New Dictionary
values.Add "id", id
values.Add "description", description
Set result = UnitOfWork.Repository("Categories").NewItem(View.Model, values)
Set NewCategory = result
End Function
Private Sub Class_Terminate()
Dispose
End Sub
Private Sub Dispose()
If Not View Is Nothing Then Unload View
Disposable.Dispose this.UnitOfWork
Disposable.Dispose this.DetailsPresenter
Set this.UnitOfWork = Nothing
Set this.View = Nothing
Set this.DetailsPresenter = Nothing
End Sub
Private Sub IDisposable_Dispose()
Dispose
End Sub
Private Function IPresenter_CanExecuteCommand(ByVal commandId As CommandType) As Boolean
Dim result As Boolean
Select Case commandId
Case CommandType.CloseCommand, CommandType.RefreshCommand, CommandType.AddCommand
result = True
Case CommandType.DeleteCommand, _
CommandType.EditCommand
result = (Not View.SelectedItem Is Nothing)
Case CommandType.ShowDetailsCommand
If View.SelectedItem Is Nothing Then Exit Function
result = GetDetailsModel.Count > 0
End Select
IPresenter_CanExecuteCommand = result
End Function
Private Property Set IPresenter_DetailsPresenter(ByVal value As IPresenter)
Set DetailsPresenter = value
End Property
Private Property Get IPresenter_DetailsPresenter() As IPresenter
Set IPresenter_DetailsPresenter = DetailsPresenter
End Property
Private Function GetDetailsModel() As SqlResult
Set GetDetailsModel = DetailsPresenter.UnitOfWork.Repository("SubCategories") _
.GetAll _
.WhereFieldEquals("CategoryId", View.SelectedItem("Id"))
End Function
Private Function IPresenter_ExecuteCommand(ByVal commandId As CommandType) As Variant
Select Case commandId
Case CommandType.CloseCommand
View.Hide
Case CommandType.RefreshCommand
Set View.Model = UnitOfWork.Repository("Categories").GetAll
Case CommandType.ShowDetailsCommand
Set DetailsPresenter.View.Model = GetDetailsModel
DetailsPresenter.MasterId = View.SelectedItem("id")
DetailsPresenter.Show
Case CommandType.AddCommand
ExecuteAddCommand
Case CommandType.DeleteCommand
ExecuteDeleteCommand
Case CommandType.EditCommand
ExecuteEditCommand
End Select
End Function
Private Sub ExecuteAddCommand()
Dim description As String
If Not RequestUserInput(prompt:=GetResourceString("AddCategoryMessageText"), _
title:=GetResourceString("AddPromptTitle"), _
outResult:=description, _
default:=GetResourceString("DefaultCategoryDescription")) _
Then
Exit Sub
End If
UnitOfWork.Repository("Categories").Add NewCategory(description:=description)
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End Sub
Private Sub ExecuteDeleteCommand()
Dim id As Long
id = View.SelectedItem("id")
Dim childRecords As Long
childRecords = GetDetailsModel.Count
If childRecords > 0 Then
MsgBox StringFormat(GetResourceString("CannotDeleteItemWithChildItemsMessageText"), childRecords), _
vbExclamation, _
GetResourceString("CannotDeleteItemWithChildItemsMessageTitle")
Exit Sub
End If
If RequestUserConfirmation(StringFormat(GetResourceString("ConfirmDeleteItemMessageText"), id)) Then
UnitOfWork.Repository("Categories").Remove id
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End If
End Sub
Private Sub ExecuteEditCommand()
Dim id As Long
id = View.SelectedItem("id")
Dim description As String
If Not RequestUserInput(prompt:=StringFormat(GetResourceString("EditCategoryDescriptionText"), id), _
title:=GetResourceString("EditPromptTitle"), _
outResult:=description, _
default:=View.SelectedItem("description")) _
Then
Exit Sub
End If
UnitOfWork.Repository("Categories").Update id, NewCategory(id, description)
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End Sub
Private Property Let IPresenter_MasterId(ByVal value As Long)
'not implemented
End Property
Private Property Get IPresenter_MasterId() As Long
'not implemented
End Property
Private Property Set IPresenter_UnitOfWork(ByVal value As IUnitOfWork)
Set UnitOfWork = value
End Property
Private Property Get IPresenter_UnitOfWork() As IUnitOfWork
Set IPresenter_UnitOfWork = UnitOfWork
End Property
Private Sub IPresenter_Show()
Show
End Sub
Private Property Set IPresenter_View(ByVal value As IView)
Set View = value
End Property
Private Property Get IPresenter_View() As IView
Set IPresenter_View = View
End Property
The SubCategoriesPresenter looks like this:
Option Explicit
Private Type tPresenter
MasterId As Long
UnitOfWork As IUnitOfWork
DetailsPresenter As IPresenter
View As IView
End Type
Private this As tPresenter
Implements IPresenter
Implements IDisposable
Private Function NewSubCategory(Optional ByVal id As Long = 0, Optional ByVal categoryId As Long = 0, Optional ByVal description As String = vbNullString) As SqlResultRow
Dim result As SqlResultRow
Dim values As New Dictionary
values.Add "id", id
values.Add "categoryid", categoryId
values.Add "description", description
Set result = UnitOfWork.Repository("SubCategories").NewItem(View.Model, values)
Set NewSubCategory = result
End Function
Public Property Get UnitOfWork() As IUnitOfWork
Set UnitOfWork = this.UnitOfWork
End Property
Public Property Set UnitOfWork(ByVal value As IUnitOfWork)
Set this.UnitOfWork = value
End Property
Public Property Get View() As IView
Set View = this.View
End Property
Public Property Set View(ByVal value As IView)
Set this.View = value
View.Resize width:=400
End Property
Public Sub Show()
View.Show
End Sub
Private Sub Class_Terminate()
Dispose
End Sub
Private Sub Dispose()
If Not View Is Nothing Then Unload View
Disposable.Dispose this.UnitOfWork
Disposable.Dispose this.DetailsPresenter
Set this.UnitOfWork = Nothing
Set this.View = Nothing
Set this.DetailsPresenter = Nothing
End Sub
Private Sub IDisposable_Dispose()
Dispose
End Sub
Private Function IPresenter_CanExecuteCommand(ByVal commandId As CommandType) As Boolean
Dim result As Boolean
Select Case commandId
Case CommandType.CloseCommand, _
CommandType.RefreshCommand, _
CommandType.AddCommand
result = True
Case CommandType.DeleteCommand, _
CommandType.EditCommand
result = (Not View.SelectedItem Is Nothing)
End Select
IPresenter_CanExecuteCommand = result
End Function
Private Property Set IPresenter_DetailsPresenter(ByVal value As IPresenter)
'not implemented
End Property
Private Property Get IPresenter_DetailsPresenter() As IPresenter
'not implemented
End Property
Private Sub ExecuteAddCommand()
Dim description As String
If Not RequestUserInput(prompt:=GetResourceString("AddSubCategoryMessageText"), _
title:=GetResourceString("AddPromptTitle"), _
outResult:=description, _
default:=GetResourceString("DefaultSubCategoryDescription")) _
Then
Exit Sub
End If
UnitOfWork.Repository("SubCategories").Add NewSubCategory(categoryId:=this.MasterId, description:=description)
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End Sub
Private Sub ExecuteDeleteCommand()
Dim id As Long
id = View.SelectedItem("id")
If RequestUserConfirmation(StringFormat(GetResourceString("ConfirmDeleteItemMessageText"), id)) Then
UnitOfWork.Repository("SubCategories").Remove id
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End If
End Sub
Private Sub ExecuteEditCommand()
Dim id As Long
id = View.SelectedItem("id")
Dim description As String
If Not RequestUserInput(prompt:=StringFormat(GetResourceString("EditSubCategoryDescriptionText"), id), _
title:=GetResourceString("EditPromptTitle"), _
outResult:=description, _
default:=View.SelectedItem("description")) _
Then
Exit Sub
End If
UnitOfWork.Repository("SubCategories").Update id, NewSubCategory(id, this.MasterId, description)
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End Sub
Private Function IPresenter_ExecuteCommand(ByVal commandId As CommandType) As Variant
Select Case commandId
Case CommandType.CloseCommand
View.Hide
Case CommandType.RefreshCommand
Set View.Model = UnitOfWork.Repository("SubCategories") _
.GetAll _
.WhereFieldEquals("CategoryId", this.MasterId)
Case CommandType.EditCommand
ExecuteEditCommand
Case CommandType.DeleteCommand
ExecuteDeleteCommand
Case CommandType.AddCommand
ExecuteAddCommand
End Select
End Function
Private Property Let IPresenter_MasterId(ByVal value As Long)
this.MasterId = value
End Property
Private Property Get IPresenter_MasterId() As Long
IPresenter_MasterId = this.MasterId
End Property
Private Property Set IPresenter_UnitOfWork(ByVal value As IUnitOfWork)
Set UnitOfWork = value
End Property
Private Property Get IPresenter_UnitOfWork() As IUnitOfWork
Set IPresenter_UnitOfWork = UnitOfWork
End Property
Private Sub IPresenter_Show()
Show
End Sub
Private Property Set IPresenter_View(ByVal value As IView)
Set View = value
End Property
Private Property Get IPresenter_View() As IView
Set IPresenter_View = View
End Property
In your case you would have a DetailsPresenter isntance right here, and that child would also have its own DetailsPresenter instance.
The hardest thing for me, was to implement the commands. Here's something that might help:
CommandCallback
Option Explicit
Private owner As IPresenter
Implements ICommandCallback
Public Property Get CallbackOwner() As IPresenter
Set CallbackOwner = owner
End Property
Public Property Set CallbackOwner(ByVal value As IPresenter)
Set owner = value
End Property
Private Property Set ICommandCallback_CallbackOwner(ByVal value As IPresenter)
Set owner = value
End Property
Private Property Get ICommandCallback_CallbackOwner() As IPresenter
Set ICommandCallback_CallbackOwner = owner
End Property
Private Function ICommandCallback_CanExecute(ByVal cmd As CommandType) As Boolean
If owner Is Nothing Then Exit Function
ICommandCallback_CanExecute = CallByName(owner, "CanExecuteCommand", VbMethod, cmd)
End Function
Private Sub ICommandCallback_Execute(ByVal cmd As CommandType)
If owner Is Nothing Then Exit Sub
If Not ICommandCallback_CanExecute(cmd) Then Exit Sub
CallByName owner, "ExecuteCommand", VbMethod, cmd
End Sub
This allowed me to get the logic completely outside of the view, and into the presenters.
Here's the code-behind for my form:
Option Explicit
Private Type tView
Model As SqlResult
Selection As SqlResultRow
Callback As ICommandCallback
End Type
Private this As tView
'MinSize is determined by design-time size.
Private minHeight As Integer
Private minWidth As Integer
Private layoutBindings As New List
Implements IView
Private Sub IView_Resize(Optional ByVal width As Integer, Optional ByVal height As Integer)
If width <> 0 Then Me.width = width
If height <> 0 Then Me.height = height
End Sub
Private Sub UserForm_Initialize()
BindControlLayouts
minHeight = Me.height
minWidth = Me.width
End Sub
Private Sub BindControlLayouts()
'todo: refactor this
Dim buttonLeftAnchor As Integer
buttonLeftAnchor = EditButton.Left
Dim buttonMargin As Integer
buttonMargin = 2
EditKeyButton.Top = AddButton.Top
EditDateButton.Top = EditKeyButton.Top + EditKeyButton.height + buttonMargin
EditDescriptionButton.Top = EditDateButton.Top + EditDateButton.height + buttonMargin
EditKeyButton.Left = buttonLeftAnchor
EditDateButton.Left = buttonLeftAnchor
EditDescriptionButton.Left = buttonLeftAnchor
Dim instructionsLabelLayout As New ControlLayout
instructionsLabelLayout.Bind Me, InstructionsLabel, AnchorAll
Dim backgroundImageLayout As New ControlLayout
backgroundImageLayout.Bind Me, BackgroundImage, AnchorAll
Dim itemsListLayout As New ControlLayout
itemsListLayout.Bind Me, ItemsList, AnchorAll
Dim closeButtonLayout As New ControlLayout
closeButtonLayout.Bind Me, CloseButton, BottomAnchor + RightAnchor
Dim addButtonLayout As New ControlLayout
addButtonLayout.Bind Me, AddButton, RightAnchor + TopAnchor
Dim editButtonLayout As New ControlLayout
editButtonLayout.Bind Me, EditButton, RightAnchor
Dim showDetailsButtonLayout As New ControlLayout
showDetailsButtonLayout.Bind Me, ShowDetailsButton, RightAnchor
Dim deleteButtonLayout As New ControlLayout
deleteButtonLayout.Bind Me, DeleteButton, RightAnchor
Dim editKeyButtonLayout As New ControlLayout
editKeyButtonLayout.Bind Me, EditKeyButton, RightAnchor
Dim EditDateButtonLayout As New ControlLayout
EditDateButtonLayout.Bind Me, EditDateButton, RightAnchor
Dim EditDescriptionButtonLayout As New ControlLayout
EditDescriptionButtonLayout.Bind Me, EditDescriptionButton, RightAnchor
layoutBindings.Add closeButtonLayout, _
backgroundImageLayout, _
instructionsLabelLayout, _
itemsListLayout, _
addButtonLayout, _
editButtonLayout, _
showDetailsButtonLayout, _
deleteButtonLayout, _
editKeyButtonLayout, _
EditDateButtonLayout, _
EditDescriptionButtonLayout
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = True
Hide
End Sub
Private Sub UserForm_Resize()
Application.ScreenUpdating = False
If Me.width < minWidth Then Me.width = minWidth
If Me.height < minHeight Then Me.height = minHeight
Dim layout As ControlLayout
For Each layout In layoutBindings
layout.Resize Me
Next
Application.ScreenUpdating = True
End Sub
Public Property Get Model() As SqlResult
Set Model = this.Model
End Property
Public Property Set Model(ByVal value As SqlResult)
Set this.Model = value
OnModelChanged
End Property
Public Property Get SelectedItem() As SqlResultRow
Set SelectedItem = this.Selection
End Property
Public Property Set SelectedItem(ByVal value As SqlResultRow)
If (Not (value Is Nothing)) Then
If (ObjPtr(value.ParentResult) <> ObjPtr(this.Model)) Then
Set value.ParentResult = this.Model
End If
End If
Set this.Selection = value
EvaluateCanExecuteCommands
End Property
Private Sub EvaluateCanExecuteCommands()
AddButton.Enabled = this.Callback.CanExecute(AddCommand)
CloseButton.Enabled = this.Callback.CanExecute(CloseCommand)
DeleteButton.Enabled = this.Callback.CanExecute(DeleteCommand)
EditButton.Enabled = this.Callback.CanExecute(EditCommand)
ShowDetailsButton.Enabled = this.Callback.CanExecute(ShowDetailsCommand)
EditDateButton.Enabled = EditButton.Enabled
EditDescriptionButton.Enabled = EditButton.Enabled
EditKeyButton.Enabled = EditButton.Enabled
End Sub
Public Sub Initialize(cb As ICommandCallback, ByVal title As String, ByVal instructions As String, ByVal commands As ViewAction)
Localize title, instructions
Set this.Callback = cb
AddButton.Visible = commands And ViewAction.Create
EditButton.Visible = commands And ViewAction.Edit
DeleteButton.Visible = commands And ViewAction.Delete
ShowDetailsButton.Visible = commands And ViewAction.ShowDetails
EditKeyButton.Visible = commands And ViewAction.EditKey
EditDateButton.Visible = commands And ViewAction.EditDate
EditDescriptionButton.Visible = commands And ViewAction.EditDescription
If (commands And PowerEdit) = PowerEdit Then
EditButton.Top = AddButton.Top
Else
EditButton.Top = AddButton.Top + AddButton.height + 2
End If
End Sub
Private Sub Localize(ByVal title As String, ByVal instructions As String)
Me.Caption = title
InstructionsLabel.Caption = instructions
CloseButton.Caption = GetResourceString("CloseButtonText")
AddButton.ControlTipText = GetResourceString("AddButtonToolTip")
EditButton.ControlTipText = GetResourceString("EditButtonToolTip")
DeleteButton.ControlTipText = GetResourceString("DeleteButtonToolTip")
ShowDetailsButton.ControlTipText = GetResourceString("ShowDetailsButtonToolTip")
End Sub
Private Sub OnModelChanged()
ItemsList.Clear
If this.Model Is Nothing Then Exit Sub
this.Model.ValueSeparator = StringFormat("\t")
Dim row As SqlResultRow
For Each row In this.Model
Set row.ParentResult = this.Model
ItemsList.AddItem row.ToString
Next
End Sub
Private Sub ExecuteCommandInternal(method As CommandType)
If this.Callback Is Nothing Then Exit Sub
If this.Callback.CallbackOwner Is Nothing Then Exit Sub
this.Callback.Execute method
End Sub
Private Sub AddButton_Click()
ExecuteCommandInternal AddCommand
End Sub
Private Sub DeleteButton_Click()
ExecuteCommandInternal DeleteCommand
End Sub
Private Sub CloseButton_Click()
ExecuteCommandInternal CloseCommand
End Sub
Private Sub EditButton_Click()
ExecuteCommandInternal EditCommand
End Sub
Private Sub EditKeyButton_Click()
ExecuteCommandInternal EditKeyCommand
End Sub
Private Sub ShowDetailsButton_Click()
ExecuteCommandInternal ShowDetailsCommand
End Sub
Private Sub ItemsList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ExecuteCommandInternal EditCommand
End Sub
Private Sub ItemsList_Change()
If ItemsList.ListIndex >= 0 Then
Set SelectedItem = this.Model(ItemsList.ListIndex)
Else
Set SelectedItem = Nothing
End If
End Sub
Private Sub IView_Initialize(cb As ICommandCallback, ByVal title As String, ByVal instructions As String, ByVal commands As ViewAction)
Initialize cb, title, instructions, commands
End Sub
Private Property Get IView_CommandCallback() As ICommandCallback
Set IView_CommandCallback = this.Callback
End Property
Private Property Set IView_Model(ByVal value As SqlResult)
Set Model = value
End Property
Private Property Get IView_Model() As SqlResult
Set IView_Model = Model
End Property
Private Property Set IView_SelectedItem(ByVal value As SqlResultRow)
Set SelectedItem = value
End Property
Private Property Get IView_SelectedItem() As SqlResultRow
Set IView_SelectedItem = SelectedItem
End Property
Private Sub IView_Show()
Show
End Sub
Private Sub IView_Hide()
Hide
End Sub
Obviously you won't be able to use this code as-is without me writing an entire series of blog posts on the subject. But I hope it's enough to illustrate the approach.
Alternatively, you could go the easy way and have a Globals.bas module to share values between forms - there's a balance to achieve between doing it right and getting it done.
I'm trying to create a Class which will handle multiple Control Events in Access. This is to save the repetition of typing out many lines of identical code.
I've followed the answer located on the following page, but with a few adjustments to tailor it to Access rahter than Excel.
How to assign a common procedure for multiple buttons?
My Class code below:
Option Compare Database
Public WithEvents ct As Access.CommandButton 'Changed object type to something recognised by Access
Public Sub ct_Click()
MsgBox ct.Name & " clicked!"
End Sub
My Form code below:
Option Compare Database
Private listenerCollection As New Collection
Private Sub Form_Load()
Dim ctItem
Dim listener As clListener
For Each ctItem In Me.Controls
If ctItem.ControlType = acCommandButton Then 'Changed to test whether control is a Command Button
Set listener = New clListener
Set listener.ct = ctItem
listenerCollection.Add listener
End If
Next
End Sub
I have noted with comments where I have made changes to the (working) Excel code. I think the problem comes with the object declaration in the Class. Note: no errors are thrown during this procedure; it simply doesn't trigger the event.
Thanks in advance!
Edit:
I've since narrowed the problem down to there being no '[Event Procedure]' in the 'On Click' Event. If I add it manually, the Class works as expected. Obviously, I don't want to have to add these manually - it defeats the object. Any ideas how I would go about this?
In your OnLoad event you can add this line
Dim ctItem
Dim listener As clListener
For Each ctItem In Me.Controls
If ctItem.ControlType = acCommandButton Then 'Changed to test whether control is a Command Button
Set listener = New clListener
Set listener.ct = ctItem
listener.ct.OnClick = "[Event Procedure]" '<------- Assigned the event handler
listenerCollection.Add listener
End If
Next
Although I'm not sure if this is more is less code than just double clicking in the OnClick in the designer and pasting in a method call. It's cool regardless.
Edit:
You could change your class like this
Public WithEvents ct As Access.CommandButton 'Changed object type to something recognised by Access
Public Function AddControl(ctrl as Access.CommandButton) as Access.CommandButton
set ct = ctrl
ct.OnClick = "[Event Procedure]"
Set AddControl = ct
End Function
Public Sub ct_Click()
MsgBox ct.Name & " clicked!"
End Sub
Then in your form you can add a ct like this
For Each ctItem In Me.Controls
If ctItem.ControlType = acCommandButton Then 'Changed to test whether control is a Command Button
Set listener = New clListener
listener.AddControl ctItem
listenerCollection.Add listener
End If
Next
Now the event handler is added in the class.
A Generic Approach to handling Access Form Controls input with a class module:
This code was crafted to handle an application written within a popup window. The Main Form contains a tab control where each tab contains its own subform to either a linked child table or an independent table. The use or non-use of a tab control shouldn't make any difference to the class module processing.
The code can be trimmed to meet your application's needs. For example one could remove controls that one is not using from the class module. Likewise, the controls collection subroutine can be selective by using the TypeName(Ctl) statement to filter the controls that get added to the collection.
In a class module called clsMultipleControls put the following code.
Option Compare Database
Option Explicit
Private m_PassedControl As Control
Private WithEvents atch As Attachment
Private WithEvents bfrm As BoundObjectFrame
Private WithEvents chk As CheckBox
Private WithEvents cbo As ComboBox
Private WithEvents btn As CommandButton
Private WithEvents cctl As CustomControl
Private WithEvents img As Image
Private WithEvents lbl As Label
Private WithEvents lin As Line
Private WithEvents Lst As ListBox
Private WithEvents frm As ObjectFrame
Private WithEvents optb As OptionButton
Private WithEvents optg As OptionGroup
Private WithEvents pg As Page
Private WithEvents pgb As PageBreak
Private WithEvents Rec As Rectangle
Private WithEvents sfm As SubForm
Private WithEvents tctl As TabControl
Private WithEvents txt As TextBox
Private WithEvents tgl As ToggleButton
Property Set ctl(PassedControl As Control)
Set m_PassedControl = PassedControl
Select Case TypeName(PassedControl)
Case "Attachment"
Set atch = PassedControl
Case "BoundObjectFrame"
Set bfrm = PassedControl
Case "CheckBox"
Set chk = PassedControl
Case "ComboBox"
Set cbo = PassedControl
Case "CommandButton"
Set btn = PassedControl
Case "CustomControl"
Set cctl = PassedControl
Case "Image"
Set img = PassedControl
Case "Label"
Set lbl = PassedControl
Case "Line"
Set lin = PassedControl
Case "ListBox"
Set Lst = PassedControl
Case "ObjectFrame"
Set frm = PassedControl
Case "OptionButton"
Set optb = PassedControl
Case "OptionGroup"
Set optg = PassedControl
Case "Page"
Set pg = PassedControl
Case "PageBreak"
Set pgb = PassedControl
Case "Rectangle"
Set Rec = PassedControl
Case "SubForm"
Set sfm = PassedControl
Case "TabControl"
Set tctl = PassedControl
Case "TextBox"
Set txt = PassedControl
Case "ToggleButton"
Set tgl = PassedControl
End Select
End Property
At the top of the Main Form module place the following code.
Public collControls As Collection
Public cMultipleControls As clsMultipleControls
In the Load event of the Main Form place the following code.
GetCollection Me
At the bottom of the Main Form code place the following recursive public subroutine:
Public Sub GetCollection(frm As Form)
Dim ctl As Control
On Error Resume Next
Set collControls = collControls
On Error GoTo 0
If collControls Is Nothing Then
Set collControls = New Collection
End If
For Each ctl In frm.Controls
If ctl.ControlType = acSubform Then
GetCollection ctl.Form
Else
Set cMultipleControls = New clsMultipleControls
Set cMultipleControls.ctl = ctl
collControls.Add cMultipleControls
End If
Next ctl
end sub
I'd advise giving each control in the form and its subforms a unique name so you can easily utilize the Select statement based on the control name to effectuate processing control in each class module event. For example, each textbox change event will be sent to the txt_change event in the class module where you can use the m_PassedControl.name property in a select statement to direct which code will be executed on the passed control.
The select event is quite useful if you have multiple controls that will receive the same post entry processing.
I use the Main Form Load event rather than the Activate event because a popup form (and its subforms) do not fire the Activate or Deactivate events.
One can also pass the m_PassedControl on to a subroutine in a regular module if you have you have some lengthy processing to accommodate.
Unfortunately, Access does not automatically fire VBA events unless you actually set the event up in the VBA module. So if you want to use a textbox change event you have to make sure the textbox change event is actually set up in applicable vba module. You don't need to add any code to the event, but the empty event must be there or the event and its class module equivalent will not fire. If anyone knows of a work around for this I'd be glad to hear about it.
I found this basic class module structure in an Excel userform code example at http://yoursumbuddy.com/userform-event-class-multiple-control-types/. It's a flexible structure. I have created versions that work with Excel userforms, Excel worksheets with activex controls, and now for Access forms.
Followup Note: The above code works fine with 64 bit Access 2013 on 64 bit Windows 10. But it fails on 64 bit Access 2013 on 64 bit Windows 7 when you try to close the main form. The solution is to move the following code from the main form to a VBA module.
Public collControls As Collection
Public cMultipleControls As clsMultipleControls
I have this and I want to use something similar to the way Java uses .class files to be able to call events and use them in my main code.
The problem is that I cannot get the .class file to use my Dims
Form1.vb:
Namespace LFS_External_Client
Public Class Form1
Inherits Form
Private OutGauge As OutGaugeInterface
Dim SpeedPref As String
Dim FuelCapacity As String
Dim Fuel As String
Public Sub New()
InitializeComponent()
End Sub
Private Sub Form1_Load() Handles MyBase.Load
Some Code
GetFuel()
End Sub
End Class
End Namespace
Then in the Dataproccer.vb (.class file):
Public Class DataProcesser
Public Sub GetFuel()
Some Code
Fuel = og.Fuel.ToString() * FuelCapacity
End Sub
End Class
Code was shortened but has all of the relevant and necessary parts.
If you want to use the actual variables from the form instead of passing them through the method calls, you would need to declare them public instead of using dim:
...
Private OutGauge As OutGaugeInterface
Public SpeedPref As String
Public FuelCapacity As String
Public Fuel As String
...
Dim FuelCapacity As String
Private Sub Form1_Load() Handles MyBase.Load
Some Code
DataProcesser.GetFuel(FuelCapacity)
End Sub
Public Shared Sub GetFuel(Byval FuelCapacity as string)
Some Code
Fuel = og.Fuel.ToString() * FuelCapacity
End Sub
Looking at the MSDN page for the Dim Statement.
It states:
Code outside a class, structure, or module must qualify a member
variable's name with the name of that class, structure, or module.
Code outside a procedure or block cannot refer to any local variables
within that procedure or block.
Also according to this MSDN article the default access level for the Dim Statement is Private at the Module Level.
So why not make GetFuel a function and pass the FuelCapacity in like #kcBeard states and return the Fuel value.
Private Sub Form1_Load() Handles MyBase.Load
Some Code
Fuel = DataProcesser.GetFuel(FuelCapacity)
End Sub
Public Shared Function GetFuel(Byval FuelCapacity as string) as string
Some Code
return og.Fuel.ToString() * FuelCapacity
End Function
You can make SpeedPref, FuelCapacity and Fuel public member variables, however a better approach would be to make them properties on the class with appropriate getters and setters. Dim just declares a variable. Please see the modified code sample below:
Form1.vb:
Namespace LFS_External_Client
Public Class Form1
Inherits Form
Private OutGauge As OutGaugeInterface
Private _SpeedPref As String
Private _FuelCapacity As String
Private _Fuel As String
Public Property SpeedPref
Get
return _SpeedPref
End Get
Set(value As String)
_SpeedPref = value
End Set
End Property
...
End Class
End Namespace
I'm having problems attaching an uncheck command to a checkbox. Or more correct, I do not know how to code it. Here's my code for the check command, how should it look to get uncheck also working?
View:
<CheckBox commands:Checked.Command="{Binding CheckCommand}"
IsChecked="False"></CheckBox>
ViewModel:
Private _CheckCommand As DelegateCommand(Of Object)
CheckCommand = New DelegateCommand(Of Object)(AddressOf Checked)
Private Sub Checked(ByVal parameter As Object)
End Sub
Command:
Public Class ToggleCheckedCommandBehaviour
Inherits CommandBehaviorBase(Of CheckBox)
Public Sub New(ByVal checkableObject As CheckBox)
MyBase.New(checkableObject)
AddHandler checkableObject.Checked, AddressOf checkableObject_Checked
End Sub
Private Sub checkableObject_Checked(ByVal sender As Object, ByVal e As System.Windows.RoutedEventArgs)
CommandParameter = TargetObject.Name
ExecuteCommand()
End Sub
End Class
Public NotInheritable Class Checked
Private Sub New()
End Sub
Private Shared ReadOnly SelectedCommandBehaviorProperty As DependencyProperty = _
DependencyProperty.RegisterAttached("SelectedCommandBehavior", _
GetType(ToggleCheckedCommandBehaviour), _
GetType(Checked), _
Nothing)
Private Shared ReadOnly CommandProperty As DependencyProperty = _
DependencyProperty.RegisterAttached("Command", _
GetType(ICommand), _
GetType(Checked), _
New PropertyMetadata(AddressOf OnSetCommandCallback))
Public Shared Sub SetCommand(ByVal CheckBox As CheckBox, ByVal command As ICommand)
CheckBox.SetValue(CommandProperty, command)
End Sub
Public Shared Function GetCommand(ByVal CheckBox As CheckBox) As ICommand
Return TryCast(CheckBox.GetValue(CommandProperty), ICommand)
End Function
Private Shared Sub OnSetCommandCallback(ByVal dependencyObject As DependencyObject, ByVal e As DependencyPropertyChangedEventArgs)
Dim CheckBox = TryCast(dependencyObject, CheckBox)
If Not CheckBox Is Nothing Then
Dim behavior = GetOrCreateBehavior(CheckBox)
behavior.Command = TryCast(e.NewValue, ICommand)
End If
End Sub
Private Shared Function GetOrCreateBehavior(ByVal CheckBox As CheckBox) As ToggleCheckedCommandBehaviour
Dim behavior = TryCast(CheckBox.GetValue(SelectedCommandBehaviorProperty), ToggleCheckedCommandBehaviour)
If behavior Is Nothing Then
behavior = New ToggleCheckedCommandBehaviour(CheckBox)
CheckBox.SetValue(SelectedCommandBehaviorProperty, behavior)
End If
Return behavior
End Function
End Class
End Namespace
As mentioned the check command works fine, and the command and method connected to it gets fires, what do I need to do to get the uncheck also working?
For info I'm using PRISM, CAL, MVVM and SL4 - in VB.NET
The fact that the Checked command is working correctly means that the attached behavior was correctly implemented. That said, the behavior only monitors a single event which you specify in this line:
AddHandler checkableObject.Checked, AddressOf checkableObject_Checked
Thus, you are subscribing to the Checked event of the Checkbox control. As you want to have control of the Checkbox being unchecked, you simply need to create another attached behavior using the Unchecked event. This assumes that you want a different command executed when the button is checked/unchecked. If you use the same command, then binding to the Command property should suffice.
I hope this helps.