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've searched for a bit, but I couldn't find a similar enough question/answer. So here it goes:
I have a class object called Project. A Project can have multiple Scenarios assoicated with it.
I've created the class modules for each object. But I am having difficulty in, I believe, instantiating the Scenarios collection for a given Project.
Here are the class modules:
1) cProject:
Private pProjectID As Integer
Private pName As String
Private pDateCreated As String
Private pScenarios As cScenarios
' PROPERTIES
Public Property Get ProjectID() As Integer
ProjectID = pProjectID
End Property
Public Property Let ProjectID(value As Integer)
pProjectID = value
End Property
Public Property Get name() As String
name = pName
End Property
Public Property Let name(value As String)
pName = value
End Property
Public Property Get Scenarios() As cScenarios
Set Scenarios = pScenarios
End Property
Public Property Set Scenarios(value As cScenarios)
Set pScenarios = value
End Property
2) cScenarios collection class module:
Private pScenarios As Collection
Private Sub Class_Initialize()
Set pScenarios = New Collection
End Sub
Private Sub Class_Terminate()
Set pScenarios = Nothing
End Sub
Public Function Item(index As Variant) As cScenario
Set Item = pScenarios.Item(index)
End Function
Public Property Get Count() As Long
Count = pScenarios.Count
End Property
Public Sub Add(obj As cScenario)
pScenarios.Add obj
End Sub
Public Sub Remove(index As Variant)
pScenarios.Remove index
End Sub
And finally (3) the Scenario class object:
Private pScenarioID As Integer
Private pName As String
Private pDateCreated As String
Private pParent As cProject
Public Property Get ScenarioID() As Integer
ScenarioID = pScenarioID
End Property
Public Property Let ScenarioID(value As Integer)
pScenarioID = value
End Property
Public Property Get name() As String
name = pName
End Property
Public Property Let name(value As String)
pName = value
End Property
Public Property Get parent() As cProject
parent = pParent
End Property
Public Property Let parent(value As cProject)
pParent = value
End Property
Here is a standard module:
Sub test1()
Dim cS As cScenarios
Dim s As cScenario
Set cS = New cScenarios
For i = 1 To 3
Set s = New cScenario
s.name = "s" & i
cS.Add s
Next
Debug.Print cS.Item(3).name
Debug.Print cS.Count
End Sub
This works. All is good. For now. I am able to populate cS with multiple scenarios. However, if I reference the scenarios collection as a child object of the project (see below in test2() ), I get a "Run-time error '91': Object variable or With block variable not set" triggered on the cs.Add call.
Sub test2()
Dim p As cProject
Dim cS As cScenarios
Dim s As cScenario
Set p = New cProject
Set cS = p.Scenarios
For i = 1 To 3
Set s = New cScenario
s.name = "s" & i
cS.Add s
Next
Debug.Print cS.Item(3).name
Debug.Print cS.Count
End Sub
What did I do wrong building my class modules and/or how do I fix it? Thanks.
You are not initializing pScenarios in the cProject class before trying to access it with Add().
You can fix that by adding an initializer to cProject:
Private Sub Class_Initialize()
Set pScenarios = New cScenarios
End Sub
This will guarantee that the cS instance will not be Nothing when you try to invoke Add on it inside test2.
Another way (weaker IMO) would be to set p.Scenarios = new cScenarios after newing up p inside test2.
Also, make sure that the property setter for cScenario.parent is Property Set instead of Property Let.
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 am not sure I am doing any of this correctly. Is it because I am opening two connections? I am closing them regardless of errors. I did try putting in some inner transaction scopes and setting the second one to RequiresNew. The two methods are independent of each other, however, if one fails I need them both to rollback. I may have to modify how I am creating and closing the connections, I feel. Any thoughts? Here is some example code of what I am doing:
Public Sub TransMethod()
Using sTran As New Transactions.TransactionScope
factory1.UpdateMethod(someObject1)
facotry2.insert(someobject2)
sTran.Complete()
End Using
End Sub
Public Class factory1
Public Shared Sub UpdateMethod(obj)
dim someSQLParams....
DataAcces.ExecuteNonQuery(command,someSQLParams)
End Sub
End Class
Public Class factory2
Public Shared Sub Insert(obj)
dim someSQLParams....
DataAcces.ExecuteNonQuery(command,someSQLParams)
End Sub
End Class
Public Function ExecuteNonQuery(ByVal spname As String, _
ByVal ParamArray parameterValues() As Object) As Object
Dim connection As SqlConnection = Nothing
Dim command As SqlCommand = Nothing
Dim res As Object = Nothing
Try
connection = New SqlConnection(_connectionString)
command = New SqlCommand(spname, connection)
command.CommandType = CommandType.StoredProcedure
command.Parameters.AddRange(parameterValues)
connection.Open()
command.ExecuteNonQuery()
res = command.Parameters(command.Parameters.Count - 1).Value
Catch ex As Exception
CreateDataEntry(ex, WriteType.ToFile, spname)
If Not (transaction Is Nothing) Then
transaction.Rollback()
End If
Finally
If Not (connection Is Nothing) AndAlso _
(connection.State = ConnectionState.Open) Then _
connection.Close()
If Not (command Is Nothing) Then command.Dispose()
End Try
Return res
End Function
Whenever you open more than 1 connection using TransactionScope, it changes from a normal transaction against sql server to a distributed transaction, which requires setting up the MSDTC.
That will happen even if the connections have the same connection string, which is one of the "by design" issues. I haven't followed up if it remains the same on .net 3.5+