Imports System Imports System.Configuration Imports System.Windows.Forms Imports DevExpress.Persistent.Base Imports DevExpress.ExpressApp Imports DevExpress.ExpressApp.Security Imports DevExpress.ExpressApp.Win Imports SISBusiness.Win Imports DevExpress.ExpressApp.Model.Core Imports DevExpress.ExpressApp.Model Imports DevExpress.Xpo Imports SISBusiness.Module Imports DevExpress.Data.Filtering Imports DevExpress.Persistent.BaseImpl Public Class Program _ Public Shared Sub Main(ByVal arguments() As String) #If EASYTEST Then DevExpress.ExpressApp.Win.EasyTest.EasyTestRemotingRegistration.Register() #End If Application.EnableVisualStyles() Application.SetCompatibleTextRenderingDefault(False) EditModelPermission.AlwaysGranted = System.Diagnostics.Debugger.IsAttached Dim _application As SISBusinessWindowsFormsApplication = New SISBusinessWindowsFormsApplication() #If EASYTEST Then If (Not ConfigurationManager.ConnectionStrings.Item("EasyTestConnectionString") Is Nothing) Then _application.ConnectionString = ConfigurationManager.ConnectionStrings.Item("EasyTestConnectionString").ConnectionString End If #End If If (Not ConfigurationManager.ConnectionStrings.Item("ConnectionString") Is Nothing) Then _application.ConnectionString = ConfigurationManager.ConnectionStrings.Item("ConnectionString").ConnectionString End If If System.Diagnostics.Debugger.IsAttached Then _application.DatabaseUpdateMode = DatabaseUpdateMode.UpdateDatabaseAlways End If Try 'Uncomment this line when using the Middle Tier application server: 'Dim _middleTierClientApplicationConfigurator As DevExpress.ExpressApp.MiddleTier.MiddleTierClientApplicationConfigurator = New DevExpress.ExpressApp.MiddleTier.MiddleTierClientApplicationConfigurator(winApplication) AddHandler _application.CreateCustomUserModelDifferenceStore, AddressOf _application_CreateCustomUserModelDifferenceStore _application.DelayedViewItemsInitialization = True _application.Setup() _application.Start() Catch e As Exception _application.HandleException(e) End Try End Sub Private Shared Sub _application_CreateCustomUserModelDifferenceStore(sender As Object, e As CreateCustomModelDifferenceStoreEventArgs) Dim userDiffs As New UserStore(CType(sender, WinApplication)) e.Store = userDiffs e.Handled = True End Sub Public Class UserStore Inherits ModelDifferenceStore Private Shared ReadOnly xmlHeader As String = "" & System.Environment.NewLine Private application As WinApplication Public Overrides ReadOnly Property Name() As String Get Return "UserStore" End Get End Property Public Sub New(ByVal winApplication As WinApplication) application = winApplication End Sub Private Function FindStoreByAspect(ByVal stores As XPCollection(Of XmlStore), ByVal aspect As String) As XmlStore For Each store As XmlStore In stores If store.Aspect = aspect Then Return store End If Next store Return Nothing End Function Private Function FindXmlUserByCurrentUser() As XmlUser Dim objectSpace As IObjectSpace = application.CreateObjectSpace() Dim currentUser As DevExpress.Persistent.BaseImpl.User = objectSpace.FindObject(Of User)(CriteriaOperator.Parse("UserName=?", SecuritySystem.CurrentUserName)) Dim user As XmlUser = Nothing Try user = objectSpace.FindObject(Of XmlUser)(CriteriaOperator.Parse("User=?", currentUser), True) Catch End Try Return user End Function Public Overrides Sub Load(ByVal model As ModelApplicationBase) Dim xmlReader As New ModelXmlReader() Dim user As XmlUser = FindXmlUserByCurrentUser() If user IsNot Nothing Then For Each store As XmlStore In user.Aspects xmlReader.ReadFromString(model, store.Aspect, store.XmlData) Next store End If End Sub Public Overrides Sub SaveDifference(ByVal model As ModelApplicationBase) Dim objectSpace As IObjectSpace = application.CreateObjectSpace() Dim user As XmlUser = objectSpace.GetObject(FindXmlUserByCurrentUser()) If user Is Nothing Then user = New XmlUser(TryCast(objectSpace, Xpo.XPObjectSpace).Session) user.User = objectSpace.GetObject(CType(SecuritySystem.CurrentUser, DevExpress.Persistent.BaseImpl.User)) End If For i As Integer = 0 To model.AspectCount - 1 Dim xmlWriter As New ModelXmlWriter() Dim aspect As String = model.GetAspect(i) Dim xmlContent As String = xmlWriter.WriteToString(model, i) If (Not String.IsNullOrEmpty(xmlContent)) Then Dim store As XmlStore = FindStoreByAspect(user.Aspects, aspect) If store Is Nothing Then store = New XmlStore(TryCast(objectSpace, Xpo.XPObjectSpace).Session) End If store.User = user store.Aspect = aspect store.XmlData = xmlHeader & xmlContent End If Next i objectSpace.CommitChanges() End Sub End Class End Class