MVC Pattern from VB 6.0 Tutorial

Model view controller is a most effective way of programming. In this article i will be explaining how we can achieve MVC pattern in visual basic 6.0.

There will be three projects

1. Data Project
Does all the data access work
All insert, update and select are done here

Has direct access to database
Has all the reference to data access objects


2. BusinessLogic Project
Does all the business logic processing
All calculations and how data should be rendered is done

Has data Project Reference

3. Forms Project
Does all the interfacing part here
Has direct user interaction

Has businessLogic Reference


Lets start the visual basic MVC Tutorial from here


(I am simply using the example of "User Access module" of an application here to explain this article, hope it works well)

Note:
In this tutorial there can be some functions which can be ignored
You have to work around a little to make this code working
It won't work on copy paste basis
But Main way of doing is clearly Explained so Enjoy coding

1.. Tables used in the tutorial

CREATE TABLE DUSERACCESS (
USERID VARCHAR(10) NOT NULL,
MENU_ID DECIMAL(10,0) NOT NULL,
PRIMARY KEY(USERID,MENU_ID)
)
GO


CREATE TABLE MENUTABLE (
MENU_ID DECIMAL(10,0) NOT NULL,
MENUNAME VARCHAR(30),
MENUCAPTION VARCHAR(30),
MODULE_ID DECIMAL(2,0),
MENU_SEQ DECIMAL(3,0),
PRIMARY KEY(MENU_ID)
)
GO


CREATE TABLE TBLUSER (
USERID VARCHAR(15) NOT NULL,
DESCRIPTION VARCHAR(50),
PASSWORD VARCHAR(50) NOT NULL,
DISTRICT DECIMAL(2,0) NOT NULL,
ACCESSLEVEL DECIMAL(5,0) NOT NULL,
USERIP VARCHAR(20) NOT NULL,
ISACTIVE VARCHAR(1) NOT NULL,
PRIMARY KEY(USERID)
)
GO
ALTER TABLE TBLUSER
ADD CONSTRAINT CHK1
CHECK (ISACTIVE IN('Y','N'))
GO
ALTER TABLE TBLUSER
ADD CONSTRAINT U_R_FK
FOREIGN KEY(ACCESSLEVEL)
REFERENCES TBLROLE(ROLLID)
ON DELETE NO ACTION
ON UPDATE NO ACTION
GO


2.. Data Project Classes and Modules Required

modules
name : modConn ( this module is for connection ODBC Connection is used in this context)

Global Cnn As ADODB.Connection


Sub Main()

If Cnn Is Nothing Then
On Error GoTo ConnectionError
Set Cnn = New ADODB.Connection
' Cnn.CursorLocation = adUseClient
'Cnn.Open "dsn=vote"
Cnn.Open "dsn=Election", "db2admin", "commission"


frmCreateUserAccess.Show
End If

Exit Sub

ConnectionError:
Set Cnn = Nothing
Err.Raise Err.Number, "Opening Database", Err.Description


End Sub

name: DataProperties ( this module is for mapping the Database table fields)

Public Type DUserProps

strUserID As String * 10
strDescription As String * 50
strPassword As String * 50
intDistrict As Integer
intAccessLevel As Integer
strUserIP As String * 20
strIsActive As String * 1
strAccessLevel As String * 10

End Type

Public Type DUserData
Buffer As String * 150
End Type


Public Type DUserAccessProps

lngMenuId As Long
strMenuName As String * 30
strMenuCaption As String * 50
strUserID As String * 10
End Type

Public Type DUserAccessData
Buffer As String * 94
End Type




classes
name: Buffer (this class is for data transformation to and from in a binary string format)

Option Explicit

Private Type BufferProps
Length As Integer
EstCount As Long
MaxCount As Long
Count As Long
End Type

Private Type BufferData
Buffer As String * 8
End Type

Private Const BUFFER_START = 9
Private mstrBuffer As String
Private mudtProps As BufferProps
Private mlngPos As Long

Public Sub Initialize(Length As Integer, EstimatedCount As Long)

With mudtProps
.Length = Length
.EstCount = EstimatedCount
.MaxCount = EstimatedCount
.Count = 0
mstrBuffer = Space$(BUFFER_START + .MaxCount * .Length)
mlngPos = BUFFER_START
End With

End Sub

Public Sub Add(Data As String)

With mudtProps
If .Count = .MaxCount Then
mstrBuffer = mstrBuffer & _
Space$(mudtProps.EstCount / 2 * mudtProps.Length)
.MaxCount = .MaxCount + mudtProps.EstCount / 2
End If

Mid$(mstrBuffer, mlngPos, .Length) = Data
mlngPos = mlngPos + .Length
.Count = .Count + 1
End With

End Sub

Public Function GetState() As String

Dim udtData As BufferData

LSet udtData = mudtProps
Mid$(mstrBuffer, 1, Len(udtData.Buffer)) = udtData.Buffer
GetState = Left$(mstrBuffer, mlngPos)

End Function

Public Sub SetState(Buffer As String)

Dim udtData As BufferData

udtData.Buffer = Mid$(Buffer, 1, Len(udtData.Buffer))
LSet mudtProps = udtData
mstrBuffer = Buffer

End Sub

Public Property Get Item(Index As Long) As String

Item = Mid$(mstrBuffer, BUFFER_START + (Index - 1) * _
mudtProps.Length, mudtProps.Length)

End Property

Public Function Count() As Long

Count = mudtProps.Count

End Function

Public Function Length() As Long

Length = mudtProps.Length

End Function

Public Property Let Item(Index As Long, Buffer As String)

Mid$(mstrBuffer, BUFFER_START + (Index - 1) * _
mudtProps.Length, mudtProps.Length) = Buffer

End Property

Name:clsdbLogin


Private DUProps As DUserProps

Private Function GetState() As String

Dim DUdata As DUserData
LSet DUdata = DUProps
GetState = DUdata.Buffer

End Function

Private Sub SetState(Buffer As String)

Dim DUdata As DUserData

DUdata.Buffer = Buffer
LSet DUProps = DUdata

End Sub



Public Function getLoginDetails(ByVal strUName As String, _
Optional strPass As String, Optional intmod As Integer) As String
Dim mObjBuffer As New Buffer
Dim rs As Recordset
Dim DUdtData As DUserData
Dim DUdtProps As DUserProps
Dim Mysql As String
On Error GoTo ACerr
If strPass <> "" And intmod <> 0 Then
Set rs = New Recordset
' Mysql = " SELECT DECRYPT_CHAR('" & strPass & "','" & strUName & "') FROM a"
' rs.Open Mysql, Cnn, adOpenStatic
' strPass = rs!DECRYPT_CHAR

Mysql = "select * from tblUser where Userid='" & strUName & "'" _
& " AND DECRYPT_CHAR(Password,'" & strUName & "') ='" & strPass & "' AND district= " & intmod & ""
ElseIf strPass = "" And intmod <> 0 Then
Mysql = " select USERID,DESCRIPTION, DECRYPT_CHAR(password,'" & strUName & "')as Password ,DISTRICT,ACCESSLEVEL,USERIP,ISACTIVE " & _
" From tblUser where userid='" & strUName & "' AND district= " & intmod
'Mysql = "select * from tblUser where userid='" & strUName & "' AND district= " & intmod

End If


Set rs = New Recordset
rs.Open Mysql, Cnn, adOpenStatic


mObjBuffer.Initialize Len(DUdtData.Buffer), rs.RecordCount

Do While Not rs.EOF
With DUdtProps
.strUserID = IIf(IsNull(rs("UserID")), "", rs("UserID"))
.strDescription = IIf(IsNull(rs("Description")), "", rs("Description"))
.strPassword = IIf(IsNull(rs("Password")), "", rs("Password"))
.intDistrict = IIf(IsNull(rs("DISTRICT")), "0", rs("DISTRICT"))
.intAccessLevel = IIf(IsNull(rs("ACCESSLEVEL")), "0", rs("ACCESSLEVEL"))
.strUserIP = IIf(IsNull(rs("USERIP")), "", rs("USERIP"))
.strIsActive = IIf(IsNull(rs("ISACTIVE")), "", rs("ISACTIVE"))

End With
LSet DUdtData = DUdtProps
mObjBuffer.Add DUdtData.Buffer
rs.MoveNext
Loop

rs.Close
Set rs = Nothing
getLoginDetails = mObjBuffer.GetState
Exit Function
ACerr:

Err.Raise Err.Number, Err.Source, Err.Description

End Function



'Public Function getPassword(ByVal strUName As String) As ADODB.Recordset
'
' On Error GoTo err
' Dim MySql As String
'
'
'
' MySql = "select * from DUser where user_name='" & strUName & "'"
'
' Set getPassword = New ADODB.Recordset
' getPassword.Open (MySql), Cnn, adOpenKeyset, adLockOptimistic
'
'
'Exit Function
'err:
' err.Raise err.Number, "getPass", OracleError.OracleError(err.Number)
'
'End Function


Public Function searchUser(ByVal strFilter As String) As String
Dim mObjBuffer As New Buffer
Dim rs As Recordset
Dim DUdtData As DUserData
Dim DUdtProps As DUserProps
Dim Mysql As String
On Error GoTo ACerr
Mysql = "select * from TBLUSER " & strFilter
' Mysql = " select USERID,DESCRIPTION, DECRYPT_CHAR(password,'" & UserID & "') as Password ,DISTRICT,ACCESSLEVEL,USERIP,ISACTIVE " & _
' " From tblUser " & strFilter
Set rs = New Recordset
rs.Open Mysql, Cnn, adOpenKeyset


mObjBuffer.Initialize Len(DUdtData.Buffer), rs.RecordCount

Do While Not rs.EOF
With DUdtProps
.strUserID = IIf(IsNull(rs("UserID")), "", rs("UserID"))
.strDescription = IIf(IsNull(rs("Description")), "", rs("Description"))
.strPassword = IIf(IsNull(rs("Password")), "", rs("Password"))
.intDistrict = IIf(IsNull(rs("DISTRICT")), "0", rs("DISTRICT"))
.intAccessLevel = IIf(IsNull(rs("ACCESSLEVEL")), "0", rs("ACCESSLEVEL"))
.strUserIP = IIf(IsNull(rs("USERIP")), "", rs("USERIP"))
.strIsActive = IIf(IsNull(rs("ISACTIVE")), "", rs("ISACTIVE"))


End With
LSet DUdtData = DUdtProps
mObjBuffer.Add DUdtData.Buffer
rs.MoveNext
Loop

rs.Close
Set rs = Nothing
searchUser = mObjBuffer.GetState
Exit Function
ACerr:

Err.Raise Err.Number, Err.Source, Err.Description

End Function



Public Sub Add_User(ByVal Buffer As String)

On Error GoTo ACerr
SetState Buffer
Dim strSql As String


strSql = "INSERT INTO TBLUSER (USERID, Description, PASSWORD, District, AccessLevel" _
& ",UserIP, isactive) VALUES " & _
"('" & Trim(MakeStr(DUProps.strUserID)) & "','" & Trim(MakeStr(DUProps.strDescription)) & "'," & _
"ENCRYPT('" & Trim(DUProps.strPassword) & "','" & Trim(DUProps.strUserID) & "','') ," & DUProps.intDistrict & "," & _
"" & DUProps.intAccessLevel & ",'" & Trim(MakeStr(DUProps.strUserIP)) & "'," & _
"'" & Trim(MakeStr(DUProps.strIsActive)) & "' )"
Cnn.Execute strSql


Exit Sub
ACerr:

Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Public Sub Modify_User(ByVal Buffer As String, intUserID As String)

On Error GoTo ACerr
Dim strSql As String
SetState Buffer
If Trim(DUProps.strPassword) = "" Then
strSql = "UPDATE TBLUSER SET Description ='" & Trim(MakeStr(DUProps.strDescription)) & "'," & _
"District=" & DUProps.intDistrict & ",AccessLevel=" & DUProps.intAccessLevel & "," & _
" USERIP='" & Trim(MakeStr(DUProps.strUserIP)) & "',isactive='" & DUProps.strIsActive & "'" & _
" WHERE UserID='" & Trim(intUserID) & "'"

ElseIf Trim(DUProps.strPassword) = "N/A" Then
strSql = "UPDATE TBLUSER SET Description ='" & Trim(MakeStr(DUProps.strDescription)) & "'," & _
"District=" & DUProps.intDistrict & ",AccessLevel=" & DUProps.intAccessLevel & "," & _
" USERIP='" & Trim(MakeStr(DUProps.strUserIP)) & "',isactive='" & DUProps.strIsActive & "'" & _
" WHERE UserID='" & Trim(intUserID) & "'"
Else
strSql = "UPDATE TBLUSER SET Description ='" & Trim(MakeStr(DUProps.strDescription)) & "'," & _
"District=" & DUProps.intDistrict & ",AccessLevel=" & DUProps.intAccessLevel & "," & _
" USERIP='" & Trim(MakeStr(DUProps.strUserIP)) & "',isactive='" & DUProps.strIsActive & "'," & _
" Password=ENCRYPT('" & Trim(DUProps.strPassword) & "','" & Trim(DUProps.strUserID) & "','') WHERE UserID='" & Trim(intUserID) & "'"
End If
Cnn.Execute strSql

Exit Sub
ACerr:

Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Public Sub ChangePassword(ByVal strPass As String, strUserID As String)

On Error GoTo ACerr
Dim strSql As String


'Cnn.Execute StrSql

'StrSql = "UPDATE TBLUSER SET Password=ENCRYPT('" & Trim(strPass) & "','" & Trim(strUserID) & "','') WHERE UserID='" & intUserID & "'"

strSql = "UPDATE TBLUSER SET Password=ENCRYPT('" & Trim(strPass) & "','" & Trim(strUserID) & "','') WHERE USERID='" & Trim(strUserID) & "'"
Cnn.Execute strSql

Exit Sub
ACerr:

Err.Raise Err.Number, Err.Source, Err.Description

End Sub



Name : clsdbDUserAccess

Option Explicit
Private DUAProps As DUserAccessProps

Private Function GetState() As String

Dim DUAData As DUserAccessData
LSet DUAData = DUAProps
GetState = DUAData.Buffer

End Function

Private Sub SetState(Buffer As String)

Dim DUAData As DUserAccessData

DUAData.Buffer = Buffer
LSet DUAProps = DUAData

End Sub

Public Function getAccessDetails(ByVal strUserID As String, intModID As Integer) As String
Dim mObjBuffer As New Buffer
Dim rs As Recordset
Dim DUAData As DUserAccessData
Dim DUAProps As DUserAccessProps
Dim Mysql As String
On Error GoTo ACerr
If intModID = 1 Then
Mysql = "select a.*, (select UserID from duseraccess where userid='" & Trim(MakeStr(strUserID)) & "' and menu_id=a.menu_id) User_id " & _
" from menutable a where a.MODULE_ID<>9 order by a.MENU_SEQ asc "
ElseIf intModID = 2 Then
Mysql = "select a.*, (select UserID from duseraccess where userid='" & Trim(MakeStr(strUserID)) & "' and menu_id=a.menu_id) User_id " & _
" from menutable a Where a.module_id in (0,2) order by a.MENU_SEQ asc "
ElseIf intModID = 3 Then
Mysql = "select a.*, (select UserID from duseraccess where userid='" & Trim(MakeStr(strUserID)) & "' and menu_id=a.menu_id) User_id " & _
" from menutable a Where a.module_id in (0,3) order by a.MENU_SEQ asc "
ElseIf intModID = 4 Then
Mysql = "select a.*, (select UserID from duseraccess where userid='" & Trim(MakeStr(strUserID)) & "' and menu_id=a.menu_id) User_id " & _
" from menutable a Where a.module_id in (0,4) order by a.MENU_SEQ asc "
ElseIf intModID = 5 Then
Mysql = "select a.*, (select UserID from duseraccess where userid='" & Trim(MakeStr(strUserID)) & "' and menu_id=a.menu_id) User_id " & _
" from menutable a Where a.module_id in (0,5) order by a.MENU_SEQ asc "
Else
Mysql = "select a.*, (select UserID from duseraccess where userid='" & Trim(MakeStr(strUserID)) & "' and menu_id=a.menu_id) User_id " & _
" from menutable a Where a.module_id = 0 order by a.MENU_SEQ asc "
End If

Set rs = New Recordset
rs.Open Mysql, Cnn, adOpenStatic
mObjBuffer.Initialize Len(DUAData.Buffer), rs.RecordCount

Do While Not rs.EOF
With DUAProps
.strUserID = IIf(IsNull(rs("USER_ID")), "", rs("USER_ID"))
.lngMenuId = IIf(IsNull(rs("MENU_ID")), 0, rs("MENU_ID"))
.strMenuName = IIf(IsNull(rs("MENUNAME")), "", rs("MENUNAME"))
.strMenuCaption = IIf(IsNull(rs("MENUCAPTION")), "", rs("MENUCAPTION"))
End With
LSet DUAData = DUAProps
mObjBuffer.Add DUAData.Buffer
rs.MoveNext
Loop

rs.Close
Set rs = Nothing
getAccessDetails = mObjBuffer.GetState
Exit Function
ACerr:

Err.Raise Err.Number, Err.Source, Err.Description

End Function


Public Sub Add_User(ByVal Buffer As String)

On Error GoTo ACerr
SetState Buffer
Dim strSql As String



strSql = "INSERT INTO DUSERACCESS (USERID, MENU_ID ) VALUES " & _
"('" & Trim(MakeStr(DUAProps.strUserID)) & "'," & DUAProps.lngMenuId & ")"
Cnn.Execute strSql


Exit Sub
ACerr:

Err.Raise Err.Number, Err.Source, Err.Description

End Sub

Public Sub Delete_All(ByVal lngUserID As String)
Dim strSql As String
On Error GoTo DelErr
strSql = "DELETE FROM DUSERACCESS WHERE USERID= '" & Trim(lngUserID) & "'"
Cnn.Execute strSql
Exit Sub
DelErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub

3.. BusinessLogic Classes and Modules Required


Modules
Name: dataProperties - Share with the Data access module(this two are same)

Public Type DUserProps

strUserID As String * 10
strDescription As String * 50
strPassword As String * 50
intDistrict As Integer
intAccessLevel As Integer
strUserIP As String * 20
strIsActive As String * 1
strAccessLevel As String * 10

End Type

Public Type DUserData
Buffer As String * 150
End Type

Public Type DUserAccessProps

lngMenuId As Long
strMenuName As String * 30
strMenuCaption As String * 50
strUserID As String * 10
End Type

Public Type DUserAccessData
Buffer As String * 94
End Type

Classes

name: Buffer

Option Explicit

Private Type BufferProps
Length As Integer
EstCount As Long
MaxCount As Long
Count As Long
End Type

Private Type BufferData
Buffer As String * 8
End Type

Private Const BUFFER_START = 9
Private mstrBuffer As String
Private mudtProps As BufferProps
Private mlngPos As Long

Public Sub Initialize(Length As Integer, EstimatedCount As Long)

With mudtProps
.Length = Length
.EstCount = EstimatedCount
.MaxCount = EstimatedCount
.Count = 0
mstrBuffer = Space$(BUFFER_START + .MaxCount * .Length)
mlngPos = BUFFER_START
End With

End Sub

Public Sub Add(Data As String)

With mudtProps
If .Count = .MaxCount Then
mstrBuffer = mstrBuffer & _
Space$(mudtProps.EstCount / 2 * mudtProps.Length)
.MaxCount = .MaxCount + mudtProps.EstCount / 2
End If

Mid$(mstrBuffer, mlngPos, .Length) = Data
mlngPos = mlngPos + .Length
.Count = .Count + 1
End With

End Sub

Public Function GetState() As String

Dim udtData As BufferData

LSet udtData = mudtProps
Mid$(mstrBuffer, 1, Len(udtData.Buffer)) = udtData.Buffer
GetState = Left$(mstrBuffer, mlngPos)

End Function

Public Sub SetState(Buffer As String)

Dim udtData As BufferData

udtData.Buffer = Mid$(Buffer, 1, Len(udtData.Buffer))
LSet mudtProps = udtData
mstrBuffer = Buffer

End Sub

Public Property Get Item(Index As Long) As String

Item = Mid$(mstrBuffer, BUFFER_START + (Index - 1) * _
mudtProps.Length, mudtProps.Length)

End Property

Public Function Count() As Long

Count = mudtProps.Count

End Function

Public Function Length() As Long

Length = mudtProps.Length

End Function

Public Property Let Item(Index As Long, Buffer As String)

Mid$(mstrBuffer, BUFFER_START + (Index - 1) * _
mudtProps.Length, mudtProps.Length) = Buffer

End Property


Name: clsMLogin


Option Explicit

Private mcolLogin As Collection
Private mflgEditing As Boolean

Private Sub Class_Initialize()

Set mcolLogin = New Collection

End Sub

Public Function Item(ByVal Index As Variant) As clslogin

Set Item = mcolLogin(Index)

End Function

Public Function Count() As Long

Count = mcolLogin.Count

End Function

Public Function NewEnum() As IUnknown

Set NewEnum = mcolLogin.[_NewEnum]

End Function


Public Sub Add(ByVal Child As clslogin)
mcolLogin.Add Item:=Child
End Sub

Public Sub Save()

Dim objchild As clslogin
Dim objdbex As clsdbexecute
Set objdbex = New clsdbexecute
On Error GoTo SaveErr
objdbex.BeginTrans
For Each objchild In mcolLogin
objchild.Add_User
objchild.DUserAccess.Save
Next
objdbex.CommitTrans
Exit Sub
SaveErr:
objdbex.RollBackTrans
Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Sub Update(ByVal intUserID As String)

Dim objchild As clslogin
Dim objdbex As clsdbexecute
Set objdbex = New clsdbexecute
On Error GoTo UErr
objdbex.BeginTrans
For Each objchild In mcolLogin
objchild.Modify_User (intUserID)
objchild.DUserAccess.Update (intUserID)
Next
objdbex.CommitTrans
Exit Sub
UErr:
objdbex.RollBackTrans
Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Private Sub SetState(Buffer As String)

Dim objBuffer As New Buffer
Dim objchild As clslogin
Dim lngIndex As Long
Dim LdtData As DUserData
Dim LdtProps As DUserProps
Dim objLAccess As clsMDUserAccess
On Error GoTo SetErr
With objBuffer
.SetState Buffer
For lngIndex = 1 To .Count
Set objchild = New clslogin
LdtData.Buffer = .Item(lngIndex)
LSet LdtProps = LdtData
With objchild
.AccessLevel = Trim(LdtProps.intAccessLevel)
.Description = Trim(LdtProps.strDescription)
.District = Trim(LdtProps.intDistrict)
.IsActive = Trim(LdtProps.strIsActive)
.Password = Trim(LdtProps.strPassword)
.User_ID = Trim(LdtProps.strUserID)
.User_IP = Trim(LdtProps.strUserIP)


Set objLAccess = New clsMDUserAccess
objLAccess.getUser .User_ID, .AccessLevel
.DUserAccess = objLAccess

mcolLogin.Add objchild
Set objchild = Nothing
End With

Next

End With

Set objBuffer = Nothing
Exit Sub
SetErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub


Public Sub getLoginDetails(ByVal strUName As String, strPass As String, intmod As Integer)
Dim objdb As clsdbLogin
Set objdb = New clsdbLogin
On Error GoTo GetErr
SetState objdb.getLoginDetails(strUName, strPass, intmod)
Set objdb = Nothing
Exit Sub
GetErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub


Public Function getPassword(ByVal strUserName As String, ByVal intmod As Integer) As String
Dim objdb As clsdbLogin
Set objdb = New clsdbLogin
On Error GoTo GetErr
SetState objdb.getLoginDetails(strUserName, , intmod)
Set objdb = Nothing
Exit Function
GetErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Function



Public Function getUser(ByVal strFilter As String) As String
Dim objdb As clsdbLogin
Set objdb = New clsdbLogin
On Error GoTo GetErr
SetState objdb.searchUser(strFilter)
Set objdb = Nothing
Exit Function
GetErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Function


Name: clsLogin


Private LProps As DUserProps
'local variable(s) to hold property value(s)
Private objDUserAccess As clsMDUserAccess 'local copy


Public Property Let DUserAccess(ByVal vData As clsMDUserAccess)
Set objDUserAccess = vData
End Property


Public Property Get DUserAccess() As clsMDUserAccess
Set DUserAccess = objDUserAccess
End Property


Public Property Let IsActive(ByVal vData As String)
LProps.strIsActive = vData
End Property


Public Property Get IsActive() As String
IsActive = LProps.strIsActive
End Property


Public Property Let User_IP(ByVal vData As String)
LProps.strUserIP = vData
End Property


Public Property Get User_IP() As String
User_IP = LProps.strUserIP
End Property


Public Property Let AccessLevel(ByVal vData As Integer)
LProps.intAccessLevel = vData
End Property


Public Property Get AccessLevel() As Integer
AccessLevel = LProps.intAccessLevel
End Property

Public Property Let AccessLevelName(ByVal vData As String)
LProps.strAccessLevel = vData
End Property


Public Property Get AccessLevelName() As String
AccessLevelName = LProps.strAccessLevel
End Property


Public Property Let District(ByVal vData As Integer)
LProps.intDistrict = vData
End Property


Public Property Get District() As Integer
District = LProps.intDistrict
End Property

Public Property Let User_ID(ByVal vData As String)
LProps.strUserID = vData
End Property


Public Property Get User_ID() As String
User_ID = LProps.strUserID
End Property



Public Property Let Description(ByVal vData As String)
LProps.strDescription = vData
End Property


Public Property Get Description() As String
Description = LProps.strDescription
End Property

Public Property Let Password(ByVal vData As String)
LProps.strPassword = vData
End Property


Public Property Get Password() As String
Password = LProps.strPassword
End Property

Private Function GetState() As String

Dim LData As DUserData
LSet LData = LProps
GetState = LData.Buffer

End Function

Private Sub SetState(Buffer As String)

Dim LData As DUserData
LData.Buffer = Buffer
LSet LProps = LData

End Sub

Public Sub Add_User()

Dim objdb As clsdbLogin

On Error GoTo AddErr
Set objdb = New clsdbLogin

objdb.Add_User (GetState)
Exit Sub
AddErr:
Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Public Sub Modify_User(ByVal intUserID As String)
Dim objdb As clsdbLogin
On Error GoTo AddErr
Set objdb = New clsdbLogin
objdb.Modify_User GetState, intUserID
Exit Sub
AddErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Sub ChangePassword(ByVal strPass As String, strUserID As String)
Dim objdb As clsdbLogin
On Error GoTo AddErr
Set objdb = New clsdbLogin
objdb.ChangePassword strPass, strUserID
Exit Sub
AddErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub



Name: clsMDUserAccess


Option Explicit

Private mcolLoginAccess As Collection
Private mflgEditing As Boolean

Private Sub Class_Initialize()

Set mcolLoginAccess = New Collection

End Sub

Public Function Item(ByVal Index As Variant) As clsDUserAccess

Set Item = mcolLoginAccess(Index)

End Function

Public Function Count() As Long

Count = mcolLoginAccess.Count

End Function

Public Function NewEnum() As IUnknown

Set NewEnum = mcolLoginAccess.[_NewEnum]

End Function


Public Sub Add(ByVal Child As clsDUserAccess)
mcolLoginAccess.Add Item:=Child
End Sub

Public Sub Save()

Dim objchild As clsDUserAccess
On Error GoTo SaveErr
Dim i As Integer
i = 1

For Each objchild In mcolLoginAccess
If i = 1 Then
objchild.Delete_All (objchild.UserID)
End If
objchild.Save
i = i + 1
Next
Exit Sub
SaveErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Sub Update(ByVal intUserID As String)

Dim objchild As clsDUserAccess

On Error GoTo UErr
Set objchild = New clsDUserAccess
objchild.Delete_All (intUserID)
Call Save

Exit Sub
UErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Function getUser(ByVal strUserID As String, intModID As Integer) As String
Dim objdb As clsdbDUserAccess
Set objdb = New clsdbDUserAccess
On Error GoTo GetErr
SetState objdb.getAccessDetails(strUserID, intModID)
Set objdb = Nothing
Exit Function
GetErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Function

Private Sub SetState(Buffer As String)

Dim objBuffer As New Buffer
Dim objchild As clsDUserAccess
Dim lngIndex As Long
Dim DLAData As DUserAccessData
Dim DLAProps As DUserAccessProps
On Error GoTo SetErr
With objBuffer
.SetState Buffer
For lngIndex = 1 To .Count
Set objchild = New clsDUserAccess
DLAData.Buffer = .Item(lngIndex)
LSet DLAProps = DLAData
With objchild
.UserID = Trim(DLAProps.strUserID)
.MenuID = Trim(DLAProps.lngMenuId)
.MenuName = Trim(DLAProps.strMenuName)
.MenuCaption = Trim(DLAProps.strMenuCaption)
mcolLoginAccess.Add objchild
Set objchild = Nothing
End With

Next

End With

Set objBuffer = Nothing
Exit Sub
SetErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub


Name: clsDuserAccess

'local variable(s) to hold property value(s)
Private DUAProps As DUserAccessProps
Public Property Let MenuName(ByVal vData As String)

DUAProps.strMenuName = vData
End Property


Public Property Get MenuName() As String
MenuName = DUAProps.strMenuName
End Property

Public Property Let MenuCaption(ByVal vData As String)
DUAProps.strMenuCaption = vData
End Property


Public Property Get MenuCaption() As String
MenuCaption = DUAProps.strMenuCaption
End Property



Public Property Let MenuID(ByVal vData As Long)
DUAProps.lngMenuId = vData
End Property


Public Property Get MenuID() As Long
MenuID = DUAProps.lngMenuId
End Property



Public Property Let UserID(ByVal vData As String)
DUAProps.strUserID = vData
End Property


Public Property Get UserID() As String
UserID = DUAProps.strUserID
End Property


Private Function GetState() As String

Dim DUAData As DUserAccessData
LSet DUAData = DUAProps
GetState = DUAData.Buffer

End Function

Private Sub SetState(Buffer As String)

Dim DUAData As DUserAccessData
DUAData.Buffer = Buffer
LSet DUAProps = DUAData

End Sub


Public Sub Save()

Dim objchild As clsdbDUserAccess
On Error GoTo SaveErr
Set objchild = New clsdbDUserAccess
'For Each objChild In mcolLoginAccess
objchild.Add_User GetState
' Next
Exit Sub
SaveErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Sub Delete_All(ByVal lngUserID As String)
Dim objdbChild As clsdbDUserAccess
On Error GoTo ModifyErr
Set objdbChild = New clsdbDUserAccess
objdbChild.Delete_All (lngUserID)
Exit Sub
ModifyErr:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub



4.. Forms Required

Name: frmCreateUserAccess
Picture:













Option Explicit
Dim blneditmode As Boolean
Dim obj As clslogin
Dim objM As clsMLogin
Private Function GetFilter() As String
On Error GoTo FErr
Dim strWSql As String
Dim intDis As Integer
intDis = Val(Me.cboDistrictID.Text)
strWSql = ""
If Trim(Me.txtUserName.Text) <> "" Then
strWSql = "Where" & strWSql & " Upper(userid) like '" & UCase(Replace(Trim(Me.txtUserName.Text), "'", "''")) & "%'and district= " & intDis & " and"

Else
strWSql = "Where" & strWSql & " district= " & intDis & " and"
End If


If strWSql <> "" Then
strWSql = Mid(strWSql, 1, Len(strWSql) - 3)
End If
GetFilter = strWSql
Exit Function
FErr:
MsgBox Err.Description, vbInformation
End Function



Private Sub cboDistrict_Click()
Me.cboDistrictID.ListIndex = Me.cboDistrict.ListIndex
End Sub

Private Sub cboDistrictID_Click()
Me.cboDistrict.ListIndex = Me.cboDistrictID.ListIndex
End Sub

Private Sub cboRole_Click()
cboRoleID.ListIndex = cboRole.ListIndex
End Sub

Private Sub cboRoleID_Click()
cboRole.ListIndex = cboRoleID.ListIndex
End Sub

Private Sub chkWallPaper_Click()
On Error GoTo ErrSetWallPaper

If chkWallPaper Then
grdAssign.WallPaper = imgWallPaper

Else
grdAssign.WallPaper = Nothing

End If
Exit Sub

ErrSetWallPaper:
MsgBox "An Error Occurred while setting wallpaper on the grid" & vbCrLf & "Error: " & Err.Description, vbInformation, "User Access"
End Sub

Private Sub cmdCancel_Click()

Me.txtUserName.Text = ""
Me.txtPassword.Text = ""
Me.txtPassword.Enabled = True
Me.txtDesc.Text = ""
Me.cboRoleID.ListIndex = -1
Me.txtIP.Text = ""
Me.txtUserName.BackColor = vbWhite
Me.txtPassword.BackColor = vbWhite
Me.txtDesc.BackColor = vbWhite
Me.cboRole.BackColor = vbWhite
Me.txtIP.BackColor = vbWhite
Me.grdAssign.Rows = 1
blneditmode = False

End Sub

Private Sub cmdCancel_MouseMove
(Button As Integer, Shift As Integer, X As Single, Y As Single)

lblHelp = ">> " & Me.cmdCancel.ToolTipText & " <<" cmdCancel.FontBold = True End Sub Private Sub cmdExit_Click() Unload Me End Sub Private Sub cmdExit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) lblHelp = ">> " & Me.cmdExit.ToolTipText & " <<" cmdExit.FontBold = True End Sub Private Sub cmdSave_Click() Dim blnv As Boolean Dim DPASS As String Dim ObjLogin As clslogin Dim objMlogin As clsMLogin Dim objA As clsDUserAccess Dim objMA As clsMDUserAccess Dim UserID As String Dim i As Integer On Error GoTo SaveErr Set ObjLogin = New clslogin Set objMlogin = New clsMLogin objMlogin.getUser (GetFilter) blnv = validatealls If blnv = True Then MsgBox "Please Enter Valid Information here!!", vbInformation Exit Sub End If 'DPASS = DECRIPT(Me.txtPassword.Text) DPASS = UCase(Trim(Me.txtPassword.Text)) ObjLogin.Password = DPASS ObjLogin.User_ID = UCase(Trim(Me.txtUserName.Text)) ObjLogin.AccessLevel = Me.cboRoleID.Text ObjLogin.User_IP = txtIP.Text ObjLogin.District = Val(Me.cboDistrictID.Text) ObjLogin.Description = txtDesc.Text If Me.chkActive.Value = 1 Then ObjLogin.IsActive = "Y" Else ObjLogin.IsActive = "N" End If Set objMA = New clsMDUserAccess If blneditmode = False Then If objMlogin.Count > 0 Then
MsgBox "User Already defined ", vbInformation, "Enter New User Name and Try again"
Me.txtUserName.SetFocus

Exit Sub
End If

If MsgBox("Sure to Save this User", vbQuestion + vbYesNo, "Confirmation!") = vbYes Then



For i = 1 To grdAssign.Rows - 1
Set objA = New clsDUserAccess
If grdAssign.Cell(flexcpChecked, i, 1) = 1 And grdAssign.Cell(flexcpText, i, 2) <> "" Then
objA.MenuID = CLng(grdAssign.Cell(flexcpText, i, 2))
objA.MenuName = Trim(grdAssign.Cell(flexcpText, i, 3))
objA.UserID = Trim(ObjLogin.User_ID)
End If
objMA.Add objA
Next
ObjLogin.DUserAccess = objMA
Set objMlogin = New clsMLogin
objMlogin.Add ObjLogin
objMlogin.Save
Call cmdSearch_Click
MsgBox "User Added Successful!!", vbOKOnly
Else
Set ObjLogin = Nothing
Set objMlogin = Nothing
Call cmdCancel_Click
Exit Sub

End If
Else

If MsgBox("Sure to Modify this User", vbQuestion + vbYesNo, "Confirmation!") = vbYes Then

ObjLogin.User_ID = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 0))

For i = 1 To grdAssign.Rows - 1

If grdAssign.Cell(flexcpChecked, i, 1) = 1 And grdAssign.Cell(flexcpText, i, 2) <> "" Then
Set objA = New clsDUserAccess
objA.MenuID = CLng(grdAssign.Cell(flexcpText, i, 2))
objA.MenuName = Trim(grdAssign.Cell(flexcpText, i, 3))
objA.UserID = Trim(ObjLogin.User_ID)
objMA.Add objA
End If

Next

ObjLogin.DUserAccess = objMA

Set objMlogin = New clsMLogin
objMlogin.Add ObjLogin
objMlogin.Update (ObjLogin.User_ID)
Call cmdSearch_Click
MsgBox "User Modify Successful!!", vbOKOnly
Else

Set ObjLogin = Nothing
Set objMlogin = Nothing
Call cmdCancel_Click
Exit Sub

End If
End If

Call cmdCancel_Click

Set ObjLogin = Nothing
Set objMlogin = Nothing
Set objMA = Nothing
Set objA = Nothing
Exit Sub
SaveErr:

Set objMA = Nothing
Set objA = Nothing
Set ObjLogin = Nothing
Set objMlogin = Nothing
MsgBox Err.Description, vbInformation
End Sub

Private Sub cmdSave_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

lblHelp = ">> " & Me.cmdSave.ToolTipText & " <<" cmdSave.FontBold = True End Sub Private Sub cmdSearch_Click() On Error GoTo CmdErr Set obj = New clslogin Set objM = New clsMLogin objM.getUser (GetFilter) Dim i As Integer grdSearch.Rows = 1 If objM.Count = 0 Then MsgBox "No Data Found", vbInformation Exit Sub End If For i = 1 To objM.Count Set obj = objM.Item(i) grdSearch.AddItem obj.User_ID & vbTab & Trim(obj.Password) & vbTab & _ Trim(obj.Description) & vbTab & Trim(obj.AccessLevel) & vbTab & Trim(obj.User_IP) & vbTab & Trim(obj.IsActive) Next blneditmode = False Set obj = Nothing 'Set objM = Nothing Exit Sub CmdErr: Set obj = Nothing Set objM = Nothing MsgBox Err.Description, vbInformation End Sub Private Function validatealls() As Boolean Dim bln As Boolean On Error GoTo Errz If isblank(txtUserName) = True Then bln = True ElseIf isblank(txtPassword) = True Then bln = True ElseIf isblank(txtIP) = True Then bln = True ElseIf Me.cboRoleID.Text = "" Then bln = True cboRole.BackColor = &HC0C0FF Else cboRole.BackColor = vbWhite End If validatealls = bln Exit Function Errz: validatealls = False MsgBox Err.Description End Function Private Sub cmdSearch_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) lblHelp = ">> " & Me.cmdSearch.ToolTipText & " <<" cmdSearch.FontBold = True End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then SendKeys "{tab}", True SendKeys "{home}+{end}" End If End Sub Private Sub Form_Load() frmCreateUserAccess.Move 20, 60 blneditmode = False Dim objRole As clsRole Dim objDis As clsDistrict On Error GoTo LErr: Set objRole = New clsRole Call loadCbo(cboRole, objRole.GetRole, 1, 0, cboRoleID) Set objDis = New clsDistrict Call loadCbo(Me.cboDistrict, objDis.GetDistrict, 1, 0, Me.cboDistrictID) 'Me.cboDistrictID.Text = 26 Me.cboDistrictID.Text = 1 Exit Sub LErr: MsgBox Err.Description End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) cmdSave.FontBold = False cmdCancel.FontBold = False cmdExit.FontBold = False cmdSearch.FontBold = False lblHelp = "" End Sub Private Sub Frame2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) cmdSave.FontBold = False cmdCancel.FontBold = False cmdExit.FontBold = False lblHelp = "" End Sub Private Sub frameAccessLevel_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) cmdSave.FontBold = False cmdCancel.FontBold = False cmdExit.FontBold = False cmdSearch.FontBold = False lblHelp = "" End Sub Private Sub frameUser_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) cmdSave.FontBold = False cmdCancel.FontBold = False cmdExit.FontBold = False cmdSearch.FontBold = False lblHelp = "" End Sub Private Sub grdAssign_Click() Dim i Dim intcount As Integer Dim intFirstRow As Integer Dim intLastRow As Integer Dim intOutLineLevel As Integer On Error GoTo aerr intOutLineLevel = grdAssign.RowOutlineLevel(grdAssign.Row) intFirstRow = 0 intLastRow = 0 intcount = 0 For i = grdAssign.Row To grdAssign.Rows - 1 If grdAssign.RowOutlineLevel(i) = intOutLineLevel Or grdAssign.RowOutlineLevel(i) < intcount =" intcount" intcount =" 1" intfirstrow =" i" intcount =" 2" intlastrow =" i" intlastrow =" 0"> 4 Or intOutLineLevel = 4 Then
intLastRow = grdAssign.Rows
End If
End If


End If

Next
For i = intFirstRow To intLastRow - 1
Me.grdAssign.Col = 1

Me.grdAssign.Row = i
If Me.grdAssign.CellChecked = flexChecked Then
Me.grdAssign.CellChecked = flexUnchecked
Else
Me.grdAssign.CellChecked = flexChecked
End If

Next

Exit Sub
aerr:
MsgBox Err.Description, vbInformation
End Sub

Private Sub grdSearch_Click()

Dim bln As Boolean

On Error GoTo SErr


If grdSearch.Rows > 1 Then
GridToText
Else
Exit Sub
End If
If grdSearch.Cell(flexcpBackColor, grdSearch.Row, 0, grdSearch.Row, grdSearch.Cols - 1) <> vbRed Then
bln = grdColorEdit(grdSearch)
If bln Then

Load_Access
chkWallPaper.Value = 1

End If
Else
MsgBox "This is Inactive user!! Please Make user Active First", vbInformation, "User Access Information"

End If

blneditmode = True
Exit Sub
SErr:
MsgBox "Err while clicking" & vbCrLf & "Error: " & Err.Description, vbInformation, "Access level Click"
End Sub

Private Sub GridToText()
Dim strAcc As String
On Error GoTo ErrG
Me.txtUserName.Text = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 0))
'Me.txtPassword.Text = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 1))
Me.txtPassword.Text = "N/A"
Me.txtDesc.Text = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 2))
Me.cboRoleID.Text = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 3))
Me.txtIP.Text = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 4))
strAcc = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 5))
' Me.txtPassword.Enabled = False
If strAcc = "Y" Then
Me.chkActive.Value = 1
Else
Me.chkActive.Value = 0
End If

Exit Sub
ErrG:

MsgBox Err.Description
End Sub

Private Sub Load_Access()
Dim clsMD As clsMDUserAccess
Dim clsD As clsDUserAccess
Set clsMD = New clsMDUserAccess
Set clsD = New clsDUserAccess
Dim strUserID As String
Dim intFirst As Integer
Dim strFirst As String
Dim intSecond As Integer
Dim strSecond As String
Dim intThird As Integer
Dim strThird As String
Dim intFourth As Integer
Dim strFourth As String
Dim intlen As Integer
Dim strLen As String
Dim i As Integer
Dim intCurF As Integer
Dim intCurS As Integer
Dim intCurT As Integer
Dim intCurFo As Integer
intCurF = 0
intCurS = 0
intCurT = 0
intCurFo = 0
On Error GoTo ErrLoadBeds

Me.grdAssign.Rows = 1
Me.grdAssign.Row = 0


'initialize tree control
With grdAssign

' structure

.Cols = 14
.Rows = 0
.FixedCols = 0
.FixedRows = 0
'.Left = 50

' appearance
.GridLines = flexGridNone

.BackColorBkg = .BackColor
.SheetBorder = .BackColor
.ExtendLastCol = True
.Redraw = flexRDBuffered
.outlinecol =" 0"
.outlinebar =" flexOutlineBarCompleteLeaf"
.ellipsis =" flexEllipsisEnd"
.allowselection =" False"
.highlight =" flexHighlightWithFocus"
.scrolltrack =" True"
.autosearch =" flexSearchFromCursor"
.cellchecked =" flexUnchecked"
strUserID = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 0))
.redraw =" flexRDNone"
.tooltiptext = "Click To Select the Desired Access Level for the user"
.strfirst = "Module A"
obj = objM.Item(grdSearch.Row)
clsmd = obj.DUserAccess
i = 1
clsd = clsMD.Item(i)
strlen = CStr(clsD.MenuID)
intlen = Len(strLen)
If intlen = 1 Then
intFirst = CInt(Mid(strLen, 1, 1))
intSecond = 0
intThird = 0
intFourth = 0

ElseIf intlen = 2 Then
intFirst = CInt(Mid(strLen, 1, 1))
intSecond = CInt(Mid(strLen, 2, 1))
intThird = 0
intFourth = 0

ElseIf intlen = 3 Then
intFirst = CInt(Mid(strLen, 1, 1))
intSecond = CInt(Mid(strLen, 2, 1))
intThird = CInt(Mid(strLen, 3, 1))
intFourth = 0
ElseIf intlen = 4 Then
intFirst = CInt(Mid(strLen, 1, 1))
intSecond = CInt(Mid(strLen, 2, 1))
intThird = CInt(Mid(strLen, 3, 1))
intFourth = CInt(Mid(strLen, 4, 1))

End If
If intCurF <> intFirst Then
intCurS = 0
intCurT = 0
intCurFo = 0
.AddItem Trim(strFirst) & vbTab & ""
.Cell(flexcpForeColor, .Rows - 1) = &HC00000 'vbBlue
.IsSubtotal(.Rows - 1) = True
.RowOutlineLevel(.Rows - 1) = 1
If IsNull(clsD.UserID) Or Trim(clsD.UserID) = "" Then
.Cell(flexcpChecked, .Rows - 1, 1) = False
Else
.Cell(flexcpChecked, .Rows - 1, 1) = True
End If
intCurF = intFirst

End If
If intCurS <> intSecond Then
intCurT = 0
intCurFo = 0
.AddItem Trim(clsD.MenuCaption) & vbTab & "" & vbTab & clsD.MenuID & vbTab & Trim(clsD.MenuName)
.Cell(flexcpForeColor, .Rows - 1) = &HC00000 'vbBlue
.IsSubtotal(.Rows - 1) = True
.RowOutlineLevel(.Rows - 1) = 2
If IsNull(clsD.UserID) Or Trim(clsD.UserID) = "" Then
.Cell(flexcpChecked, .Rows - 1, 1) = False
Else
.Cell(flexcpChecked, .Rows - 1, 1) = True
End If
intCurS = intSecond
End If


If intCurT <> intThird Then
intCurFo = 0
.AddItem CStr(clsD.MenuCaption) & vbTab & "" & vbTab & clsD.MenuID & vbTab & Trim(clsD.MenuName)

.Cell(flexcpForeColor, .Rows - 1) = &H5172D2
.IsSubtotal(.Rows - 1) = True
.RowOutlineLevel(.Rows - 1) = 3
If IsNull(clsD.UserID) Or Trim(clsD.UserID) = "" Then
.Cell(flexcpChecked, .Rows - 1, 1) = False
Else
.Cell(flexcpChecked, .Rows - 1, 1) = True
End If
intCurT = intThird
End If


If intCurFo <> intFourth Then
.AddItem CStr(clsD.MenuCaption) & vbTab & "" & vbTab & clsD.MenuID & vbTab & Trim(clsD.MenuName)

.Cell(flexcpForeColor, .Rows - 1) = &HC000&
.IsSubtotal(.Rows - 1) = True
.RowOutlineLevel(.Rows - 1) = 4
If IsNull(clsD.UserID) Or Trim(clsD.UserID) = "" Then
.Cell(flexcpChecked, .Rows - 1, 1) = False
Else
.Cell(flexcpChecked, .Rows - 1, 1) = True
End If
intCurFo = intFourth
End If

Next

.OutlineCol = 0
.OutlineBar = flexOutlineBarCompleteLeaf

.Row = 0
.Redraw = flexRDBuffered

.MergeCol(0) = True
.ColWidth(0) = 3750

.ColWidth(1) = 20
.ColWidth(2) = 0
.ColWidth(3) = 0
.ColWidth(4) = 0
.ColWidth(5) = 0
.ColWidth(6) = 0
.ColWidth(7) = 0
.ColWidth(8) = 0
.ColWidth(9) = 0
.ColWidth(10) = 0
.ColWidth(11) = 0
.ColWidth(12) = 0
.ColWidth(13) = 0


End With
Exit Sub

ErrLoadBeds:
MsgBox "Err while loading Menus" & vbCrLf & "Error: " & Err.Description, vbInformation, "Access level Assignment"

End Sub

Related Posts by Categories