Recent Posts

Saturday, March 29, 2008

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



Read more!

Wednesday, March 26, 2008

Tree view structure from VS Flexgrid in VB 6.0

This article provides full source code on how to get Tree View structure from VS Flex grid in visual basic 6.0. This is a perfect tutorial and visual basic source code for the beginners who want to show the tree view by using VS Flex Grid.

Get the full source code from below and paste in your application and it works for you.

  Private Sub Load_Access()
        Dim clsMD As clsMDUserAccess
        Dim clsD As clsDUserAccess
        clsMD = New clsMDUserAccess
        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 ' << new setting             .OutlineCol = 0             .OutlineBar = flexOutlineBarCompleteLeaf             .Ellipsis = flexEllipsisEnd             ' behavior
            .AllowSelection = False
            .Highlight = flexHighlightWithFocus
            .ScrollTrack = True
            .AutoSearch = flexSearchFromCursor
            '.CellChecked = flexUnchecked

            'fetch data from view

            strUserID = Trim(grdSearch.Cell(flexcpText, grdSearch.Row, 0))

            .Redraw = flexRDNone
            .ToolTipText = "Click To Select the Desired Access Level for the user"
            .AddItem ("Election Module- User Access")


            .Cell(flexcpForeColor, .Rows - 1) = &HC00000   'vbBlue
            .Cell(flexcpFontSize, .Rows - 1) = 10
            .IsSubtotal(.Rows - 1) = True
            .RowHeight(0) = 500


            'initial assignment on variables for checking



            strFirst = "Module A"
            obj = objM.Item(grdSearch.Row)


            clsMD = obj.DUserAccess

            For i = 1 To clsMD.Count

                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 ")

    End Sub




Read more!

Monday, March 24, 2008

To check and uncheck the radio button in web Page from Java Script

function checkRadio(StatID)
{
for (var i=0;i
{
if (document.frmOD.elements[i].type=="radio")
{
if (frmOD.elements[i].value==StatID)
{
frmOD.elements[i].checked="true";
}
}
}
}

function unCheckRadio(StatID)
{
for (var i=0;i
{
if (document.frmOD.elements[i].type=="radio")
{
if (frmOD.elements[i].value==StatID)
{
frmOD.elements[i].checked="false";
}
}
}
}


Read more!

Tuesday, March 18, 2008

Inserting Multiple Rows in one Insert Statement in SQLServer

METHOD 1:

INSERT INTO YourTable (FirstCol, SecondCol)
VALUES (’First’ , 1) , (’Second’ , 2) , (’Third’ , ‘3′), (’Fourth’ , ‘4′) (’and so on’) ;

METHOD 2:

Use YourDB
GO
INSERT INTO MyTable (FirstCol, SecondCol)
SELECT 'First' ,1
UNION ALL
SELECT 'Second' ,2
UNION ALL
SELECT 'Third' ,3
UNION ALL
SELECT 'Fourth' ,4
UNION ALL
SELECT 'Fifth' ,5
GO

METHOD 3:

Insert into yourtable (table1col, table2col)
Select table1col, table2col
From table1 inner join table2 on table1.table1col = table2.table2col


Read more!

Creating Oracle 9i Database Manually

Here is the sample to create the oracle 9i database manually.

The notations

%ORACL_BASE%= the drive and directory where oracle is installed in local machine such as D:\Oracle\


%ORACL_BASE% is the folder associated with the version of oracle such as
D:\Oracle\ora92

SID id the identifier for database system say it MYDB

SpfileSID.ora is the notation for spfile associated with the database system MYDB and is actually denotes the file SPFILEMYDB.ORA in this example.


Steps:
1) run oradim utilily to create oracle agent service from command prompt.
eg oradim - new -sid sidname -intpwd password -maxusers no_of _users -startmode a
2) run orapwd utility to create password file in the default %ORACLE_HOME%\DATABASE folder
3) add folder named oradata and SID in %ORACLE_BASE% directory.
4) add folder named bdump, udump,cdump,pfile,create folder inside %ORACLE_HOME%\admin\SID directory
5) prepare initialisation file initSID.ora OR SPFILESID.ora IN %ORACLE_HOME%\DATABASE direcotry
6) Using Oracle Managed Files set
db_create_file_dest='%ORACLE_BASE%\oradata\SID'
db_create_online_log_dest_n='%ORACLE_BASE%\oradata\SID'
replace n with integer starting 1 upto 5 destinations
7) startup database in nomount stage from prompt
startup nomount
8) run the script below:


#########DATABASE CREATION USING DIRECTORY PATH NAMES
CREATE DATABASE database_name
logfile
group 1 ('%ORACLE_BASE%\oradata\SID\redo01.dbf') size 10m,
group 2 ('%ORACLE_BASE%\oradata\SID\redo02.dbf') size 10m,
group 3 ('%ORACLE_BASE%\oradata\SID\redo03.dbf') size 10m
maxlogfiles 10
maxlogmembers 3
maxloghistory 1
maxdatafiles 100
maxinstances 1
datafile '%ORACLE_BASE%\oradata\SID\system01.dbf' size 500m
undo tablespace UNDOTBS1
datafile '%ORACLE_BASE%\oradata\SID\undotbs.dbf' size 200m
autoextend on next 5120k maxsize unlimited
default temporary tablespace temp
tempfile %ORACLE_BASE%\oradata\SID\temp01.dbf' size 200m
autoextend on next 5120k maxsize 500m
character set US7ASCII
national character set AL16UTF16
set TIME_ZONE='America/New_York';

#########OMF MANAGED DATABASE CREATION

CREATE DATABASE database_name
logfile
group 1 size 10m,
group 2 size 10m,
group 3 size 10m
maxlogfiles 10
maxlogmembers 3
maxloghistory 1
maxdatafiles 100
maxinstances 1
datafile size 500m
undo tablespace UNDOTBS1
datafile size 200m
autoextend on next 5120k maxsize unlimited
default temporary tablespace temp
tempfile size 200m
autoextend on next 5120k maxsize 500m
character set US7ASCII
national character set AL16UTF16
set TIME_ZONE='America/New_York';

9) run script catalog.sql and catproc.sql as a sys user from %ORACLE_HOME\rdms\admin directory
10) run script pupbld.sql as a system user from %ORACLE_HOME\sqlplus\admin directory

This completes the database manual database creation.


Read more!

Query to view assigned tablespace and its associated datafiles to the database users In ORACLE

########RETURN NULL FOR THE TABLESPACE NOT ASSIGNED TO USERS#######
Here
ts# represents tablespace number
file# represents datafile number

select * from
(select c.username username,'default tablespace' type,a.ts# ts#,a.name tablespace,b.file# file#,b.name name from v$tablespace a, v$datafile b,dba_users c
where a.ts#=b.ts# and
a.name=c.default_tablespace(+)
union all
select c.username,'temporary tablespace' type, a.ts# ts#,a.name tablespace,b.file# file#,b.name name from v$tablespace a, v$tempfile b,dba_users c
where a.ts#=b.ts# and
a.name=c.temporary_tablespace)z
order by z.username,z.type;


Read more!

Sunday, March 16, 2008

Passing data from SubReport to Main Report in Crystal Reports

In subReport Formula field

@Stuff Total

WhilePrintingRecords;
Shared NumberVar OrderTotal := Sum ({Orders.Order Amount})

In MainReport Formula Field

@GetTotalFromSubReport

WhilePrintingRecords;
Shared NumberVar OrderTotal;
NumberVar Total1998Amount;
Total1998Amount := Total1998Amount + OrderTotal;
Total1998Amount


Read more!

Read Write and lock Usb disk Drive Sectors in C#

using System;
using System.Diagnostics;
using System.Collections;
using System.Runtime.InteropServices;

namespace PCSUSBCSharp
{
public class PCSUSBCSharp
{

public enum EMoveMethod : uint
{
Begin = 0,
Current = 1,
End = 2
}

[DllImport("kernel32.dll", SetLastError = true)]
static extern int CloseHandle(IntPtr hObject);

const uint FILE_SHARE_READ = 0x00000001;
const uint FILE_SHARE_WRITE = 0x00000002;
const uint FILE_SHARE_DELETE = 0x00000004;
const uint OPEN_EXISTING = 3;

const uint GENERIC_READ = (0x80000000);
const uint GENERIC_WRITE = (0x40000000);

const uint FILE_FLAG_NO_BUFFERING = 0x20000000;
const uint FILE_READ_ATTRIBUTES = (0x0080);
const uint FILE_WRITE_ATTRIBUTES = 0x0100;
const uint ERROR_INSUFFICIENT_BUFFER = 122;
const uint FILE_BEGIN=0;


private const Int32 INVALID_HANDLE_VALUE = -1;
//s
private const Int32 FILE_ATTRIBUTE_NORMAL=1;

[DllImport("kernel32.dll", SetLastError = true)]
private static extern bool WriteFile(IntPtr handle,
byte[] buffer, ushort count, ref ushort written, IntPtr lpOverlapped);


[DllImport("kernel32.dll", SetLastError = true)]
private static extern bool ReadFile(IntPtr handle,
byte[] buffer, ushort toRead, ref ushort read, IntPtr lpOverLapped);

[DllImport("Kernel32.dll", SetLastError = true, CharSet = CharSet.Auto)]
static extern uint SetFilePointer(
IntPtr hFile,
int lDistanceToMove,
int lpDistanceToMoveHigh,
EMoveMethod dwMoveMethod);


[DllImport("kernel32.dll", SetLastError = true)]
static extern IntPtr CreateFile(
string lpFileName,
uint dwDesiredAccess,
uint dwShareMode,
IntPtr lpSecurityAttributes,
uint dwCreationDisposition,
uint dwFlagsAndAttributes,
IntPtr hTemplateFile);


static private IntPtr OpenVolume(string DeviceName)
{
IntPtr hDevice;
hDevice = CreateFile(
@"\\.\" + DeviceName,
GENERIC_READ | GENERIC_WRITE,
FILE_SHARE_WRITE,
IntPtr.Zero,
OPEN_EXISTING,
0,
IntPtr.Zero);
if ((int)hDevice == -1)
{
throw new Exception(Marshal.GetLastWin32Error().ToString());
}
return hDevice;
}


static private IntPtr OpenFile(string path)
{
IntPtr hFile;
hFile = CreateFile(
path,
FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES,
FILE_SHARE_READ | FILE_SHARE_WRITE,
IntPtr.Zero,
OPEN_EXISTING,
0,
IntPtr.Zero);
if ((int)hFile == -1)
{
throw new Exception(Marshal.GetLastWin32Error().ToString());
}
return hFile;
}


public static bool b9xME;
public static IntPtr hUSBDisk;


public static bool IsUSBOpen()
{
//return (hUSBDisk?true:false);
return (int)(hUSBDisk)!=-1;
}


private static IntPtr OpenUSBDisk(String fileName)
{
if(IsUSBOpen())
return hUSBDisk;
else
{
IntPtr tmpHandle;
tmpHandle=OpenVolume(fileName);
if((int)tmpHandle==-1)
return new IntPtr(-1);
else
return tmpHandle;
}

}


private static void CloseUSBDisk()
{


if((int)hUSBDisk!=-1)
{

CloseHandle(hUSBDisk);
hUSBDisk=new IntPtr(-1);
}
}




public static void ResetDisk(String fileName)
{

if(IsUSBOpen())
CloseUSBDisk();
hUSBDisk=OpenUSBDisk(fileName);
CloseUSBDisk();

}



public static int WriteUSBDisk(byte []buffer, ushort cylinder, ushort sector,ushort head,String fileName)
{
ushort count=0;
bool retValue;
if(!IsUSBOpen())
hUSBDisk=OpenUSBDisk(fileName);
if((int)hUSBDisk==-1)
return NISH_ERROR;
SetFilePointer(hUSBDisk,
512*(18*(cylinder*2+head)+(sector-1)),0,
EMoveMethod.Begin);
retValue=WriteFile(hUSBDisk,buffer, 512,ref count,IntPtr.Zero);
if(retValue)
return NISH_NO_ERROR;
else
return NISH_ERROR;
}



public static int ReadUSBDisk(byte []buffer, ushort cylinder, ushort sector,ushort head,String fileName)
{
ushort count=1;
bool retValue;
if(!IsUSBOpen())
hUSBDisk=OpenUSBDisk(fileName);
if((int)hUSBDisk==-1)
return NISH_ERROR;
SetFilePointer(hUSBDisk,
512*(18*(cylinder*2+head)+(sector-1)),0,
EMoveMethod.Begin);
retValue=ReadFile(hUSBDisk,buffer,512,ref count,IntPtr.Zero);


if(retValue)
return NISH_NO_ERROR;
else
return NISH_ERROR;

}
static int NISH_NO_ERROR=1;
static int NISH_ERROR=0;


}


}


Read more!

Read Write and lock Usb disk Drive Sectors in C#

using System;
using System.Diagnostics;
using System.Collections;
using System.Runtime.InteropServices;

namespace PCSUSBCSharp
{
public class PCSUSBCSharp
{

public enum EMoveMethod : uint
{
Begin = 0,
Current = 1,
End = 2
}

[DllImport("kernel32.dll", SetLastError = true)]
static extern int CloseHandle(IntPtr hObject);

const uint FILE_SHARE_READ = 0x00000001;
const uint FILE_SHARE_WRITE = 0x00000002;
const uint FILE_SHARE_DELETE = 0x00000004;
const uint OPEN_EXISTING = 3;

const uint GENERIC_READ = (0x80000000);
const uint GENERIC_WRITE = (0x40000000);

const uint FILE_FLAG_NO_BUFFERING = 0x20000000;
const uint FILE_READ_ATTRIBUTES = (0x0080);
const uint FILE_WRITE_ATTRIBUTES = 0x0100;
const uint ERROR_INSUFFICIENT_BUFFER = 122;
const uint FILE_BEGIN=0;


private const Int32 INVALID_HANDLE_VALUE = -1;
//s
private const Int32 FILE_ATTRIBUTE_NORMAL=1;

[DllImport("kernel32.dll", SetLastError = true)]
private static extern bool WriteFile(IntPtr handle,
byte[] buffer, ushort count, ref ushort written, IntPtr lpOverlapped);


[DllImport("kernel32.dll", SetLastError = true)]
private static extern bool ReadFile(IntPtr handle,
byte[] buffer, ushort toRead, ref ushort read, IntPtr lpOverLapped);

[DllImport("Kernel32.dll", SetLastError = true, CharSet = CharSet.Auto)]
static extern uint SetFilePointer(
IntPtr hFile,
int lDistanceToMove,
int lpDistanceToMoveHigh,
EMoveMethod dwMoveMethod);


[DllImport("kernel32.dll", SetLastError = true)]
static extern IntPtr CreateFile(
string lpFileName,
uint dwDesiredAccess,
uint dwShareMode,
IntPtr lpSecurityAttributes,
uint dwCreationDisposition,
uint dwFlagsAndAttributes,
IntPtr hTemplateFile);


static private IntPtr OpenVolume(string DeviceName)
{
IntPtr hDevice;
hDevice = CreateFile(
@"\\.\" + DeviceName,
GENERIC_READ | GENERIC_WRITE,
FILE_SHARE_WRITE,
IntPtr.Zero,
OPEN_EXISTING,
0,
IntPtr.Zero);
if ((int)hDevice == -1)
{
throw new Exception(Marshal.GetLastWin32Error().ToString());
}
return hDevice;
}


static private IntPtr OpenFile(string path)
{
IntPtr hFile;
hFile = CreateFile(
path,
FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES,
FILE_SHARE_READ | FILE_SHARE_WRITE,
IntPtr.Zero,
OPEN_EXISTING,
0,
IntPtr.Zero);
if ((int)hFile == -1)
{
throw new Exception(Marshal.GetLastWin32Error().ToString());
}
return hFile;
}


public static bool b9xME;
public static IntPtr hUSBDisk;


public static bool IsUSBOpen()
{
//return (hUSBDisk?true:false);
return (int)(hUSBDisk)!=-1;
}


private static IntPtr OpenUSBDisk(String fileName)
{
if(IsUSBOpen())
return hUSBDisk;
else
{
IntPtr tmpHandle;
tmpHandle=OpenVolume(fileName);
if((int)tmpHandle==-1)
return new IntPtr(-1);
else
return tmpHandle;
}

}


private static void CloseUSBDisk()
{


if((int)hUSBDisk!=-1)
{

CloseHandle(hUSBDisk);
hUSBDisk=new IntPtr(-1);
}
}




public static void ResetDisk(String fileName)
{

if(IsUSBOpen())
CloseUSBDisk();
hUSBDisk=OpenUSBDisk(fileName);
CloseUSBDisk();

}



public static int WriteUSBDisk(byte []buffer, ushort cylinder, ushort sector,ushort head,String fileName)
{
ushort count=0;
bool retValue;
if(!IsUSBOpen())
hUSBDisk=OpenUSBDisk(fileName);
if((int)hUSBDisk==-1)
return NISH_ERROR;
SetFilePointer(hUSBDisk,
512*(18*(cylinder*2+head)+(sector-1)),0,
EMoveMethod.Begin);
retValue=WriteFile(hUSBDisk,buffer, 512,ref count,IntPtr.Zero);
if(retValue)
return NISH_NO_ERROR;
else
return NISH_ERROR;
}



public static int ReadUSBDisk(byte []buffer, ushort cylinder, ushort sector,ushort head,String fileName)
{
ushort count=1;
bool retValue;
if(!IsUSBOpen())
hUSBDisk=OpenUSBDisk(fileName);
if((int)hUSBDisk==-1)
return NISH_ERROR;
SetFilePointer(hUSBDisk,
512*(18*(cylinder*2+head)+(sector-1)),0,
EMoveMethod.Begin);
retValue=ReadFile(hUSBDisk,buffer,512,ref count,IntPtr.Zero);


if(retValue)
return NISH_NO_ERROR;
else
return NISH_ERROR;

}
static int NISH_NO_ERROR=1;
static int NISH_ERROR=0;


}


}


Read more!

Friday, March 14, 2008

Display animated gif image in vb application

'This cannot be done directly by inserting an gif image in the form but we have to
'First Add Microsoft WebBrowser control in the Form

'First Add Microsoft WebBrowser control in the Form


'WebBrowser1.Navigate App.Path + "\Reports\down.htm"
' WebBrowser1.Navigate App.Path + "\images\downArrow1.gif"

' Unfortunately, the WebBrowser also displays a right-hand scroll
' bar--probably not what you want for a decorative image. Believe it
' or not, you can turn this scrollbar off just like you would normally
' via HTML, as in:
strPath = App.Path + "\images\downArrow1.gif"
WebBrowser1.Navigate "about:html body scroll='no'bgcolor='#CCFFFF' img src= " & strPath & " >/img body /html "

Note Below:
This error might give you a problem while doing above

File not found: 'C:\WINDOWS\system32\ieframe.dll\1'


Apparently they have separated the library and code for the browser out of
ieframe.dll in IE7 installed and you are still on IE6.
One suggestion is to changed the reference for "Microsoft Internet Controls" from
the ieframe.dll to shdocvw.dll in the project references (browse for it in the same
folder), saved the project, reopen it, and you no longer receive the errors.


Read more!

Thursday, March 13, 2008

To execute stored Procedure from vb 6.0

This article provides the code and detail information on how to insert data in the sql server database from visual basic 6.0.
The code provided below helps to execute stored procedure written in sql server database.

'To update the data in the database

Dim cmd as ADODB.Command

Dim res As Integer

Set cmd = New ADODB.Command
cmd.ActiveConnection = con ' use your active connection
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "update_empdetails" ' This is the name of stored Procedure

cmd.Parameters.Append cmd.CreateParameter("empid", adVarChar, adParamInput, 6,txt_empid.Text)
cmd.Parameters.Append cmd.CreateParameter("firstname", adVarChar, adParamInput, 30, txt_firstname.Text)
cmd.Parameters.Append cmd.CreateParameter("title", adVarChar, adParamInput, 30, txt_title.Text)
cmd.Parameters.Append cmd.CreateParameter("address", adVarChar, adParamInput, 100, txt_address.Text)
cmd.Parameters.Append cmd.CreateParameter("result", adInteger, adParamOutput)
cmd.Execute

res = cmd("result")

If (res = 1) Then
MsgBox "Updated Successfully"
End If

Set cmd.ActiveConnection = Nothing

' To retrive data from database

Private Sub cmd_get_Click()

str_empid = txt_empid.Text

Set cmd = New ADODB.Command
cmd.ActiveConnection = con
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "empdetails"

cmd.Parameters.Append cmd.CreateParameter("empid", adVarChar, adParamInput, 6, str_empid)

Set rs = cmd.Execute
' if you want use rs.recordcount you can use below code
' or rs.Open cmd, con, adOpenStatic

If Not rs.EOF Then
txt_firstname = rs.Fields(0)
txt_title = rs.Fields(1)
txt_address = rs.Fields(2)
End If

Set cmd.ActiveConnection = Nothing

End Sub


Read more!

Procedure to insert XML Data in Sql Server Database using OPEN XML

Xml file is:


"The Procedure is

CREATE PROCEDURE xmlOrderInsert @order ntext AS
DECLARE @docHandle int, @OID int

EXEC sp_xml_preparedocument @docHandle OUTPUT, @order

--sp_xml_preparedocument makes xml document ready to read
-- @Order holds the xml data eg . set @order='....'


BEGIN TRANSACTION

INSERT INTO Orders( CustomerID, EmployeeID, OrderDate, RequiredDate )
SELECT CustomerID, EmployeeID, OrderDate, RequiredDate
FROM Openxml( @docHandle, '/Order', 3) WITH ( CustomerID nchar(5),
EmployeeID int, OrderDate datetime, RequiredDate datetime )

IF @@ERROR<>0 BEGIN ROLLBACK TRANSACTION RETURN -100 END
SET @OID = SCOPE_IDENTITY()
INSERT INTO [Order Details] ( OrderID, ProductID, UnitPrice, Quantity, Discount )
SELECT @OID AS [PO ID], ProductID, UnitPrice, Quantity, Discount
FROM OpenXml( @docHandle, '/Order/OrderDetails', 1) WITH
( ProductID int, UnitPrice money, Quantity smallint, Discount real )
IF @@ERROR<>0 BEGIN ROLLBACK TRANSACTION RETURN -101 END
COMMIT TRANSACTION
EXEC sp_xml_removedocument @docHandle SELECT @OID AS [Order ID]
GO


' to execute the procedure

exec xmlOrderInsert
@Order='.. '

' this should insert the correct data
'Thanks


Read more!

Wednesday, March 12, 2008

Get xml Data and use for insert in vb 6.0

Dim xDoc As MSXML2.DOMDocument
Set xDoc = New MSXML2.DOMDocument
Dim strData As String

If xDoc.Load("C:\test.xml") Then
' The document loaded successfully.
' Now do something intersting.
strData = xDoc.xml
MsgBox strData

' Now strData can be used anywhere to insert data in Database
' or to manupulate the xml data
Else
' The document failed to load.
End If
Set xDoc = Nothing


Read more!

Some Validations Required In VB

' To allow user to check if the text field is blank show red if it is blank and prompt to Enter

Public Function isblank(ByVal txtbox As TextBox) As Boolean
On Err GoTo Err:


If txtbox.Text = "" Or IsNull(txtbox) Then

txtbox.SetFocus
txtbox.BackColor = &HC0C0FF 'red
isblank = True
Else
txtbox.BackColor = vbWhite
End If
Exit Function
Err:
MsgBox Err.Description
isblank = False
End Function


' To allow user to insert only character in the text field

Public Function ValidateString(strInputString As String)
'Can enter a to z A to Z 0 to 9 and _ only
'97 a 122 z 65A 90Z 48 0 57 9 95 _ codes

Dim iCount As Byte
Dim iAsc As Byte

For iCount = 1 To Len(strInputString)
iAsc = Asc(Mid(strInputString, iCount, 1))
If iAsc >= 97 And iAsc <= 122 Then

ElseIf iAsc >= 65 And iAsc <= 90 Then

ElseIf iAsc >= 48 And iAsc <= 57 Then

ElseIf iAsc = 95 Then

Else
ValidateString = False
Exit Function
End If
Next iCount
ValidateString = True
End Function

' To allow user to validate password entry field

Public Function OnlyValidPass(KeyAscii As Integer) As Integer
If Not (KeyAscii >= 65 And KeyAscii <= 90) And Not (KeyAscii >= 97 And KeyAscii <= 122) And Not (KeyAscii >= 48 And KeyAscii <= 57) And Not (KeyAscii = 13 Or KeyAscii = 8) And Not KeyAscii = 32 And Not KeyAscii = 9 And Not KeyAscii = 46 Then
KeyAscii = 0
Beep
MsgBox "Not a valid char"
End If
OnlyValidPass = KeyAscii

End Function

' To allow user to insert only Numbers and Dots in the text field

Public Function OnlyNumericNDot(KeyAscii As Integer) As Integer
If Not (KeyAscii >= 48 And KeyAscii <= 57) And Not (KeyAscii = 13 Or KeyAscii = 8) And Not (KeyAscii >= 1 And KeyAscii <= 26) And Not KeyAscii = 46 Then
KeyAscii = 0
Beep
MsgBox "Only numbers are allowed", vbInformation, "Data Entry Error"
End If
OnlyNumericNDot = KeyAscii
End Function

' To allow user to insert only Numbers in the text field

Public Function OnlyNumeric(KeyAscii As Integer) As Integer
If Not (KeyAscii >= 48 And KeyAscii <= 57) And Not (KeyAscii = 13 Or KeyAscii = 8) And Not (KeyAscii >= 1 And KeyAscii <= 26) Then
KeyAscii = 0
Beep
MsgBox "Only numbers are allowed", vbInformation, "Data Entry Error"
End If
OnlyNumeric = KeyAscii
End Function

' To allow user to insert only character in the text field

Public Function OnlyChar(KeyAscii As Integer) As Integer
If (KeyAscii >= 48 And KeyAscii <= 57) Then
KeyAscii = 0
Beep
MsgBox "Only Characters are allowed", vbInformation, "Data Entry Error"
End If
OnlyChar = KeyAscii
End Function

' To Block characters to be entered in some places

Function InvalidChar(KeyAscii As Integer) As Integer

If Not (KeyAscii >= 65 And KeyAscii <= 90) And Not (KeyAscii >= 97 And KeyAscii <= 122) And Not (KeyAscii >= 48 And KeyAscii <= 57) And Not (KeyAscii = 13 Or KeyAscii = 8) Then
KeyAscii = 0
MsgBox "Not a valid char"
Beep
End If
InvalidChar = KeyAscii

End Function

' To validate Email

Public Function ValidateEmail(ByVal stremail As String) As Boolean

Dim intPos As Integer
On Error GoTo errval
If Not IsNull(stremail) Then
If Trim(stremail) = "" Then
ValidateEmail = True
Exit Function
End If
End If
intPos = InStr(1, stremail, "@")
If intPos = 0 Or intPos = 1 Then
ValidateEmail = False
Exit Function
End If
If InStr(intPos + 1, stremail, ".") = 0 Then
ValidateEmail = False
Exit Function
End If
ValidateEmail = True
Exit Function
errval:
ValidateEmail = False

End Function

' To Find Combo Box Data

Public Function FindComboData(ByVal cbo As ComboBox, ByVal ID As Integer) As Integer
Dim i As Integer
Dim b As Boolean
b = False
If ID > 0 Then
For i = 0 To cbo.ListCount - 1
If cbo.ItemData(i) = ID Then
b = True
Exit For
End If
Next
End If
If Not b Then
FindComboData = -1
Else
FindComboData = i
End If
End Function

' To Show row Color while Selecting VS Flex Grid Row

Public Function gridcolor(grd As VSFlexGrid) As Boolean

If grd.Rows = 1 Then

Exit Function
End If
Dim i As Integer

Dim lngrow As Long

Dim lngcol As Long
lngrow = grd.Row
lngcol = grd.Col
For i = 1 To grd.Rows - 1
grd.Cell(flexcpBackColor, i, 0, i, grd.Cols - 1) = vbWhite
Next
If grd.Cell(flexcpBackColor, lngrow, 0, lngrow, grd.Cols - 1) = &HC0E0FF Then
grd.Cell(flexcpBackColor, lngrow, 0, lngrow, grd.Cols - 1) = vbWhite
gridcolor = False

Exit Function
End If

If lngrow = 0 Then
Exit Function
Else
grd.Cell(flexcpBackColor, lngrow, 0, lngrow, grd.Cols - 1) = &HC0E0FF
gridcolor = True
End If

End Function


Read more!

Scrolling Form title from right to left with certain interval

'First include the timer in the form.

Private Sub tmrScrollTitle_Timer()
ScrollTitle "Election Commission Nepal", 80, MDIMain
End Sub

Public Sub SetInitialCaption(Cap As String, Spaces As Integer, FormName As Form)
FormName.Caption = Space(Spaces)
FormName.Caption = FormName.Caption + Cap
End Sub


Public Sub ScrollTitle(Cap As String, Spaces As Integer, FormName As Form)
If Not FormName.Caption = "" Then
FormName.Caption = Right(FormName.Caption, (Len(FormName.Caption) - 1))
Else
Call SetInitialCaption(Cap, Spaces, FormName)
End If
End Sub


Read more!

Tuesday, March 11, 2008

Read Excel File from VB 6.0

This article provides full details on how to retrieve the Excel data in Visual Basic 6.0 application. Just use the code provided in this article and it should work for you. Also there are various comments in the code that helps to understand the code by beginners as well.

See below for the code to retrieve the excel data:

Private Sub LoadExcel(ByVal strSheet As String)

On Error GoTo EErr

'This can be done to directly access excel but you need to add reference for excel

'Dim objExcel As Excel.Application
'Dim objSpread As Excel.Workbook

Dim introw As Integer

Dim strSNo As String
Dim strEntryNo As String
Dim strFName As String
Dim strMName As String
Dim strLName As String
Dim strFather As String

Dim objExcel As Object
Dim objSpread As Object
Dim introw As Integer

' Open the Excel spreadsheet
Set objExcel = CreateObject("Excel.Application")
Set objSpread = objExcel.Workbooks.Open(strSheet)

' This is done to avoid unnecessary running excel.exe application in memory
' This closes the excel once it is set to nothing after the work is done
objExcel.UserControl = True

'Decide the row from which you want to start reading the excel
introw = 1
' Now reading the excel file row by row after opening the excel File

Do Until objExcel.Rows.Count = 113

strEntryNo = Trim(objExcel.Cells(introw, 2).Value)
strFName = Trim(objExcel.Cells(introw, 3).Value)
strMName = Trim(objExcel.Cells(introw, 4).Value)
strLName = Trim(objExcel.Cells(introw, 5).Value)
strFather = Trim(objExcel.Cells(introw, 6).Value)
introw = introw + 1
Loop

' This is essential to close the excel file
objExcel.Quit
Set objSpread = Nothing
Set objExcel = Nothing

Exit Sub
EErr:
' This is essential to close the excel file
objExcel.Quit
Set objSpread = Nothing
Set objExcel = Nothing
Err.Raise Err.Number, Err.Source, Err.Description

End Sub


Read more!