VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "VCortexGadget" Attribute VB_GlobalNameSpace = True Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = True Option Explicit ' this module is the gadget aware master program ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' start of events '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Event RecallStatus(ByVal Done As Long, ByVal ToDo As Long, ByRef Cancel As Boolean) Public Event Backtalk(ByVal BT As String) Public Event Backtalk2(ByRef BT As Gadget) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' end of events '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' start of private '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private StayAwake As Boolean, IsAwake As Boolean ' makes brain not unload after last app goes away Private DevelopmentMode As Boolean Private DoneDone As Boolean Private VGBDatabaseNameAndPath As String Private VGBDatabaseName As String Private StopWhateverYourDoing As Boolean Private AbortRead As Boolean Private OSGadget As Gadget Private StatusGadget As Gadget Private VCG_Self As Gadget Private Logged_User As Gadget, AccessLevel As Long, AccessMode As Long Private AppWakeupGadget As Gadget Private Memories() As Gadget, MemoriesCNTR As Long, MemoriesPTR As Long, MAXMemories As Long Private VGBStatus As Gadget Private VGBErrors As Gadget, VGBErrorsCNTR As Long, ErrorsOn As Boolean Private Trace As Gadget, TraceCNTR As Long, TraceOn As Boolean 'Private VGBBusy As Boolean Private GadgetWorkspace As Workspace Private JetDatabasePath As String ' will hode the path to the database Private JetDatabaseName As String ' actual name of the jet db Private JetDatabase As Database ' db object for general use ' open databases kept in an array of databases, this is good stuff Private OpenDB() As Database, OpenDBCNTR As Integer, OpenDBPTR As Integer ' keep up with the recordsets as arrays, too. linked to opendb by dbgadgets ' and appdbgadgets Private OpenRS() As Recordset, OpenRSCNTR As Integer, OpenRSPTR As Integer ' the object, props and methods recordsets are the CURRENT ones ' dbswitch changes these to the specified ones. all disk i/o is the same ' for ever. Private ObjectsRS As Recordset ' GDS Objects recordset Private PropsRS As Recordset, PropertyPTR As Integer ' GDS Properties rs Private MethodsRS As Recordset ' GDS methods recordset Private CanDo() As Gadget, CanDoCntr As Long, CanDoPTR As Long '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' end of private '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' start of public variables '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' this is the all potent gadget Public Type Gadget ' This is the representation of the GADGET Object RS As Recordset ObjectID As Long ' unique id for each object Level As Integer ' Used for placement in the Tree control GAppName As String ' application that created the object Container As String ' don't rightly know how this is used Type As String ' used to sort out Name As String ' name of object, unique Tag As String ' used for many things, especially DDE Requesting and resulting TotalProperties As Long ' total number of properties TotalMethods As Long ' total number of methods PropertyID() As Long ' unique property id Propity() As String ' name of the property Caption() As String ' not really used ValueAlpha() As String ' alpha value of property ValueNum() As Double ' numeric value of property PropSource() As String ' another possible oops, not really used PropType() As Integer ' 0=System, 1=User, 2=Copy as System, 3=Copy as User MethodID() As Long ' unique method id MethType() As String ' don't know Method() As String ' method parser will use to call correct function MethAction() As String ' Status As String End Type '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' end of public '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' start api definitions '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' let's get some api action happening #If Win16 Then Private Declare Function GetWindowsDirectory Lib "Kernel" _ (ByVal lpBuffer As String, _ ByVal nSize As Integer) As Integer Private Declare Function GetPrivateProfileString Lib "Kernel" _ (ByVal lpApplicationName As String, _ ByVal lpKeyName As Any, _ ByVal lpDefault As String, _ ByVal lpReturnedString As String, _ ByVal nSize As Integer, _ ByVal lpFileName As String) As Integer Private Declare Function GetProfileString Lib "Kernel" _ (ByVal sName$, _ ByVal KName$, _ ByVal Def$, _ ByVal Ret$, _ ByVal Size%) As Integer Private Declare Function GetWindow% Lib "user" _ (ByVal hwnd%, _ ByVal wCmd%) Private Declare Function GetModuleHandle Lib "Kernel" _ (ByVal lpModuleName As String) As Integer Private Declare Function GetModuleUsage Lib "Kernel" _ (ByVal hModule As Integer) As Integer #Else Private Declare Function GetPrivateProfileString Lib "Kernel32" Alias "GetPrivateProfileStringA" _ (ByVal lpApplicationName As String, _ ByVal lpKeyName As Any, _ ByVal lpDefault As String, _ ByVal lpReturnedString As String, _ ByVal nSize As Long, _ ByVal lpFileName As String) As Long Private Declare Function GetWindowsDirectory Lib "Kernel32" Alias "GetWindowsDirectoryA" _ (ByVal lpBuffer As String, _ ByVal nSize As Long) As Long Private Declare Function GetProfileString Lib "Kernel32" Alias "GetProfileStringA" _ (ByVal lpAppName As String, _ ByVal lpKeyName As String, _ ByVal lpDefault As String, _ ByVal lpReturnedString As String, _ ByVal nSize As Long) As Long Private Declare Function GetWindow Lib "user32" _ (ByVal hwnd As Long, _ ByVal wCmd As Long) As Long Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowThreadProcessId Lib "user32" _ (ByVal hwnd As Long, _ lpdwProcessId As Long) As Long Private Declare Function BringWindowToTop Lib "user32" _ (ByVal hwnd As Long) As Long Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _ (ByVal hwnd As Long, ByVal _ lpString As String) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _ (ByVal hwnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long) As Long Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal LParam As String) As Long Private Const TH32CS_SNAPPROCESS As Long = 2& Private Const MAX_PATH As Integer = 260 Private Type PROCESSENTRY32 dwSize As Long cntUsage As Long th32ProcessID As Long th32DefaultHeapID As Long th32ModuleID As Long cntThreads As Long th32ParentProcessID As Long pcPriClassBase As Long dwFlags As Long szExeFile As String * MAX_PATH End Type Private Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" _ (ByVal lFlags As Long, _ ByVal lProcessID As Long) As Long Private Declare Function ProcessFirst Lib "Kernel32" Alias "Process32First" _ (ByVal hSnapShot As Long, _ uProcess As PROCESSENTRY32) As Long Private Declare Function ProcessNext Lib "Kernel32" Alias "Process32Next" _ (ByVal hSnapShot As Long, _ uProcess As PROCESSENTRY32) As Long Private Declare Sub CloseHandle Lib "Kernel32" _ (ByVal hPass As Long) ' get window Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal LParam As Long) As Long 'Private Const WM_QUIT = &H12 'code for find window and close, 32 bit 'Dim sTitle As String ' Dim iHwnd As Long ' Dim ihTask As Long ' Dim iReturn As Long ' sTitle = "Untitled - Notepad" ' iHwnd = FindWindow(0&, sTitle) ' iReturn = PostMessage(iHwnd, WM_QUIT, 0&, 0&) ' MsgBox "Notepad has been Closed Down" '32 Bit reboot Private Const EWX_SHUTDOWN = 1 Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Boolean 'success = ExitWindowsEx(EWX_SHUTDOWN, 0) #End If Private InstancesCNTR As Long ' 16 bit reboot 'How do I shut down or reboot Windows from my program? 'In 32-bit VB use the following: 'Declare the API-function ' Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, _ ' ByVal dwReserved As Long) As Boolean ' private Const EWX_SHUTDOWN = 1 ' 'and use ' ' Success = ExitWindowsEx(EWX_SHUTDOWN, 0) ' 'If successful, the function returns true. You can force the shutdown by using EWX_FORCE = 4. 'To make Windows 95 reboot use EWX_REBOOT = 2. To only log off use EWX_LOGOFF = 0. ' 'With 16-bit VB, you do: ' ' Declare Function ExitWindows Lib "user" (ByVal wReturnCode As Long, _ ' ByVal dwReserved As Integer) As Integer ' 'To exit Windows: ' ' RetVal% = ExitWindows(0, 0) ' 'To exit and restart Windows: ' ' RetVal% = ExitWindows(&H42, 0) ' 'To exit Windows and restart the system: ' ' RetVal% = ExitWindows(&H43, 0) ' 'If any application refuses to terminate, zero will be returned. 'If succesful, there will be no return (of course). ' 'Note that SendKeys to close the Program Manager (Win 3.x) will never work because it shows a sys-modal dialog that will stop all applications 'until being answered (therefore SendKeys cannot send the "OK"-press because the "sending" application is stopped). '[Mathias Schiffer ] ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Ebnd api definitions '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' '//////////////////////////////////////////////////////////////////////////////////////////// '//////////////////////////////////////////////////////////////////////////////////////////// ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' begin the braingadget '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function VCIO(VCF As String, VCP1 As String, VCP2 As String, G1 As Gadget, G2 As Gadget, G3 As Gadget) As Gadget ' this is the portal to the VC ' all io passes thru here. the GAPI specification will explain for licensed users ' VCF=Virtual Cortex Function ' VCP1=VC Parameter 1 ' VCP2=VC Parameter 2 ' G1-G3=Gadgets Dim UCaseVCF As String Dim MemPoolName As String Dim TaskResult As Gadget UCaseVCF = UCase(VCF) CheckSuicide Select Case True Case Suicide = True TaskResult.Name = "Suicide" GoTo Suicide Case UCaseVCF = "" ' this is a template Case UCaseVCF = "MEMORIZE" TaskResult = Memorize(G1, VCP2) Case UCaseVCF = "RECALL" TaskResult = Recall(VCP1, VCP2) RaiseEvent Backtalk(VCP1) DoEvents RaiseEvent Backtalk2(TaskResult) DoEvents Case UCaseVCF = "RECALLBYID" TaskResult = RecallByID(Val(VCP1), VCP2) Case UCaseVCF = "FORGET" TaskResult = Forget(VCP1, VCP2) Case UCaseVCF = "FORGETBYID" TaskResult = ForgetByID(Val(VCP1), VCP2) Case UCaseVCF = "DEBUGVGB" TaskResult = DebugVGB(VCP1) Case UCaseVCF = "WAKEUP" TaskResult = WakeUp(G1) Case UCaseVCF = "CONVERTLEGACY" TaskResult = ConvertLegacy(VCP1) End Select Suicide: EndSub: VCIO = TaskResult End Function Friend Function CheckSuicide() If Suicide = True Then WasteTime 1 End End If End Function Friend Function WakeUp(CallerApp As Gadget) As Gadget ' the caller must do this first to initialize Dim starttime As Single starttime = Timer Dim Result As Gadget TraceOn = True SetProperty Trace, NextID("trace") & "Wakeup Start *********************************", "************************" InitVGB CallerApp WakeUp = AppWakeupGadget SetProperty Trace, NextID("trace") & "Wakeup Time", CStr(Timer - starttime) SetProperty Trace, NextID("trace") & "Wakeup End *********************************", "************************" CheckTrace End Function Friend Function DebugVGB(What As String) As Gadget ' for debugging purposes. returns gadgets with indications of the processes Dim MasterGadget As Gadget Select Case True Case UCase(What) = "ERRORS" DebugVGB = VGBErrors Case UCase(What) = "CLEAR ERRORS" VGBErrors = BlankObject VGBErrors.Name = "Errors Cleared " & Now Case UCase(What) = "TRACE" DebugVGB = Trace Case UCase(What) = "TRACE ON" TraceOn = True Case UCase(What) = "TRACE OFF" TraceOn = False Case UCase(What) = "CLEAR TRACE" Trace = BlankObject Trace.Name = "Trace Cleared " & Now Case UCase(What) = "STATUS" DebugVGB = VGBStatus Case UCase(What) = "DEVELOPMENT ON" ' can't go into development mode unless I say so MasterGadget = Recall("Master Gadget", "from " & VGBDatabaseName) If ReadProperty(MasterGadget, "Master Password") = "Grand Poopa Dude" Then DevelopmentMode = True End If Case UCase(What) = "DEVELOPMENT OFF" DevelopmentMode = False End Select End Function Friend Function InitVGB(Params As Gadget) As Gadget ' initialize the core intelligence unit Dim starttime As Single, stoptime As Single Static AlreadyRunning As Boolean starttime = Timer Dim TotStartTime As Single TotStartTime = Timer Dim t, Msg As String, Cntr1 As Long Dim RREsults As Gadget, MResults As Gadget Dim ResultGadget As Gadget Dim LParam As Gadget Dim TGadget As Gadget Dim FirstTime As Boolean Dim LocalError As String Dim Result As String Dim WinDir As String Dim AddedID As Long Dim FIXRWS As Boolean On Error GoTo LocalError DevelopmentMode = False AccessLevel = 0 SetProperty Trace, NextID("trace") & "Virtual Cortex Woke up", "By " & Params.Name If VGBErrorsCNTR = 0 Then VGBErrors.Name = "Error Object " & Now Trace.Name = "Trace " & Now End If Select Case True Case ReadProperty(Params, "Login Name") = "THE MECHANIC" If ReadProperty(Params, "The Tool") = "quantum wrenches in the works" Then ' RenameProperty Params, "Login Name" ' DeleteProperty Params, "The Tool" DevelopmentMode = True End If If AlreadyRunning Then GoTo EndSub End If Case UCase(Params.Name) = "ERRORS ON" ErrorsOn = True Case UCase(Params.Name) = "ERRORS OFF" ErrorsOn = False Case UCase(Params.Name) = "TRACE ON" TraceOn = True Case UCase(Params.Name) = "TRACE OFF" TraceOn = True Case Params.Name = "Reset" ' this is a request for reinitializing from inside here Case Params.Name <> "" ' this is an external app ' only one instance per app, please Case Else AppWakeupGadget = Params SetProperty AppWakeupGadget, "ERROR", "No Name Passed" GoTo EndSub End Select SetVariables RestartInit: VGBStatus.Name = "VGB Status" VGBStatus.Type = "System" SetProperty VGBStatus, "Start", Now() SetProperty VGBStatus, "Start Timer", CStr(starttime) Msg = DetectOS ' returns the operating system stuff SetProperty VGBStatus, "Operating System", Msg FirstTime = False LocalError = "" Result = "Failed" WinDir = AddBackSlash(GetWindowsDir) VGBDatabaseName = VGBDatabaseName SetProperty VGBStatus, "Windows Directory", WinDir VGBDatabaseName = "GDSREG.GDS" VGBDatabaseNameAndPath = WinDir & VGBDatabaseName If Not FileExists(VGBDatabaseNameAndPath) Then FileCopy AddBackSlash(App.Path) & "Empty.mem", VGBDatabaseNameAndPath SetProperty VGBStatus, "System File Copied", Now() End If If Not FileExists(WinDir & "GDSSYS.GDS") Then If Not FileExists(AddBackSlash(App.Path) & "GDSSYS.GDS") Then Msg = "" Msg = Msg & "System File " & CrLf ' Msg = Msg & AddBackSlash(App.Path) & "GDSSYS.GDS" & CrLf Msg = Msg & "Was Not Found!" & CrLf Msg = Msg & "Click OK, make sure the file exists and try again!" & CrLf ' MsgBox Msg, , "Fatal Error" End End If SetProperty VGBStatus, "Fatal Error", "System File Not Found " & Now() SetProperty Trace, NextID("trace") & "Fatal Error", "Virtual Cortex Didn't find System Memories Pool" FileCopy AddBackSlash(App.Path) & "GDSSYS.GDS", WinDir & "gdssys.gds" ' MsgBox "Required System File: GDSSYS.GDS" & CrLf & "NOT Found.", , "Fatal Error" ' End End If ' gds is there, need to open it If Not FileExists(WinDir & "GDSREG.INI") Then ' need to create the .INI file here SetProperty VGBStatus, ".INI File Created", Now() Open WinDir & "GDSREG.INI" For Output As #1 Print #1, "[Options]" Print #1, "SystemDB=" & WinDir & "GDSSYS.GDS" Close #1 SetProperty Trace, NextID("trace") & "Wakeup Created", UCase(WinDir & "GDSREG.INI") End If t = Dir(VGBDatabaseNameAndPath, vbNormal) If LocalError <> "" Then FileCopy AddBackSlash(App.Path) & "Empty.mem", VGBDatabaseNameAndPath LocalError = "" t = Dir(VGBDatabaseNameAndPath, vbNormal) If LocalError <> "" Then Msg = "VG Brain Registry Not Found, " & CrLf Msg = Msg & "Can't Continue" & CrLf FloatMsgBox Msg, " Virtual Cortex Internal Error" SetProperty VGBStatus, "Fatal Error", "Virtual Cortex Didn't find System Memories Pool" SetProperty AppWakeupGadget, "Fatal Error", "VG Brain Registry Not Found, Can't Continue" GoTo EndSub End If End If If Len(t) <> 0 Then ' need to hide this file SetAttr VGBDatabaseNameAndPath, vbHidden End If t = Dir(VGBDatabaseNameAndPath, vbHidden) If Len(t) = 0 Then MsgBox "Can't Continue", vbExclamation, "GDS Internal Error: 666-G1" SetProperty Trace, NextID("trace") & "Fatal Error", "By " & Params.Name SetProperty VGBStatus, "System File Not Found Error", Now() SetProperty VGBStatus, "Last Fatal Error", "System File Not Found Error" SetProperty AppWakeupGadget, "Fatal Error", "VG Brain Registry Not Found, Can't Continue" GoTo EndSub End If #If Win32 Then DBEngine.SystemDB = WinDir & "GDSSYS.GDS" SetProperty VGBStatus, "32 Bit", "True" #End If DBEngine.IniPath = WinDir & "GDSREG.INI" DBEngine.DefaultUser = "VBasic" DBEngine.DefaultPassword = "TLHicky" Set GadgetWorkspace = DBEngine.CreateWorkspace("GDSREG", "VBasic", "TLHicky") OpenDBPTR = 0 OpenDBCNTR = 0 OpenRSPTR = 0 OpenRSCNTR = 0 ReDim OpenDB(0) As Database ReDim OpenRS(OpenRSPTR) As Recordset Set OpenDB(0) = GadgetWorkspace.OpenDatabase(VGBDatabaseNameAndPath) Set ObjectsRS = OpenDB(0).OpenRecordset("Objects", dbOpenTable) ' open GDSREG objectsrs Set OpenRS(0) = ObjectsRS ObjectsRS.MoveLast AppRSGadgetsCNTR = 0 ReDim Preserve AppRSGadgets(AppRSGadgetsCNTR) AppRSGadgets(AppRSGadgetsCNTR) = BlankObject AppRSGadgets(AppRSGadgetsCNTR).ObjectID = 0 AppRSGadgets(AppRSGadgetsCNTR).Name = UCase(App.EXEName) & "-" & VGBDatabaseName & "-0-Objects" AppRSGadgets(AppRSGadgetsCNTR).Type = "AppRSGadget" AppRSGadgets(AppRSGadgetsCNTR).Container = UCase(App.EXEName) SetProperty AppRSGadgets(AppRSGadgetsCNTR), "DB Name", VGBDatabaseName SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Source", "Objects" SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Name", "ObjectsRS" SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Index", CStr(OpenRSPTR) ' open GDSREG props OpenRSPTR = OpenRSPTR + 1 ReDim Preserve OpenRS(OpenRSPTR) As Recordset Set PropsRS = OpenDB(0).OpenRecordset("Props", dbOpenTable) Set OpenRS(OpenRSPTR) = PropsRS PropsRS.MoveLast AppRSGadgetsCNTR = AppRSGadgetsCNTR + 1 ReDim Preserve AppRSGadgets(AppRSGadgetsCNTR) AppRSGadgets(AppRSGadgetsCNTR) = BlankObject AppRSGadgets(AppRSGadgetsCNTR).ObjectID = 0 AppRSGadgets(AppRSGadgetsCNTR).Name = UCase(App.EXEName) & "-" & VGBDatabaseName & "-0-Props" AppRSGadgets(AppRSGadgetsCNTR).Type = "AppRSGadget" AppRSGadgets(AppRSGadgetsCNTR).Container = UCase(App.EXEName) SetProperty AppRSGadgets(AppRSGadgetsCNTR), "DB Name", VGBDatabaseName SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Source", "Props" SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Name", "PropsRS" SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Index", CStr(OpenRSPTR) ' open GDSREG methods OpenRSPTR = OpenRSPTR + 1 ReDim Preserve OpenRS(OpenRSPTR) As Recordset Set MethodsRS = OpenDB(0).OpenRecordset("Methods", dbOpenTable) Set OpenRS(OpenRSPTR) = MethodsRS ' MethodsRS.Movelast OpenRSCNTR = OpenRSPTR ' OpenRS(OpenRSPTR).MoveLast ' OpenRS(OpenRSPTR).Movelast AppRSGadgetsCNTR = AppRSGadgetsCNTR + 1 ReDim Preserve AppRSGadgets(AppRSGadgetsCNTR) AppRSGadgets(AppRSGadgetsCNTR) = BlankObject AppRSGadgets(AppRSGadgetsCNTR).ObjectID = 0 AppRSGadgets(AppRSGadgetsCNTR).Name = UCase(App.EXEName) & "-" & VGBDatabaseName & "-0-Methods" AppRSGadgets(AppRSGadgetsCNTR).Type = "AppRSGadget" AppRSGadgets(AppRSGadgetsCNTR).Container = UCase(App.EXEName) SetProperty AppRSGadgets(AppRSGadgetsCNTR), "DB Name", VGBDatabaseName SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Source", "Methods" SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Name", "MethodsRS" SetProperty AppRSGadgets(AppRSGadgetsCNTR), "RS Index", CStr(OpenRSPTR) SetProperty Trace, NextID("trace") & "InitVGB", "Primary Memories Pool Connected" ' the VGBDatabaseName db is open and available ' load up the gdsreg dbgadget (index=0) ' note: the way the names work is that the dbgadget name is filename + filename index (dbgadgetdef) DBGadgetsCNTR = 0 DBGadgetsPTR = DBGadgetsCNTR ReDim Preserve DBGadgets(DBGadgetsPTR) DBGadgets(DBGadgetsPTR) = BlankObject DBGadgets(DBGadgetsPTR).ObjectID = 0 DBGadgets(DBGadgetsPTR).Name = VGBDatabaseName & "-0" DBGadgets(DBGadgetsPTR).Type = "DBGadget" DBGadgets(DBGadgetsPTR).Container = "GDS Registry" DBGadgets(DBGadgetsPTR).Tag = "InitVGB: " & CStr(Now()) SetProperty DBGadgets(DBGadgetsPTR), "Path", WinDir SetProperty DBGadgets(DBGadgetsPTR), "DB Name", VGBDatabaseName SetProperty DBGadgets(DBGadgetsPTR), "System", "RWSSYS.RWS" SetProperty DBGadgets(DBGadgetsPTR), "AutoOpen", "True" SetProperty DBGadgets(DBGadgetsPTR), "Type", "Jet" SetProperty DBGadgets(DBGadgetsPTR), "Version", "2.0" SetProperty DBGadgets(DBGadgetsPTR), "DU", "VBasic" SetProperty DBGadgets(DBGadgetsPTR), "DP", "TLHicky" ' see if gdsreg is on disk RREsults = Recall(DBGadgets(DBGadgetsPTR).Name, "from " & VGBDatabaseNameAndPath) If RREsults.Name = DBGadgets(DBGadgetsPTR).Name Then ' set the object id ' SetProperty Trace, NextID("trace") & RResults.Name, "Exists" DBGadgets(DBGadgetsPTR).ObjectID = RREsults.ObjectID Else ' write it DBSwitch 0 Msg = WriteMemGadget(DBGadgets(DBGadgetsPTR).ObjectID, DBGadgets(DBGadgetsPTR)) ' SetProperty Trace, NextID("trace") & DBGadgets(DBGadgetsPTR).Name, "Added, Write results: " & Msg End If ' first object is "GDSRegistry" ' need to do a little db fixing here RREsults = Recall("GDSRegistry", "from " & VGBDatabaseNameAndPath) ' t = ReadGadgetByName("GDSRegistry", GDSRegistry) If RREsults.Name <> "GDSRegistry" Then GDSRegistry.Name = "GDSRegistry" GDSRegistry.Type = "GDSRegistry" GDSRegistry.Container = "GDSRegistry" MResults = Memorize(GDSRegistry, "in " & VGBDatabaseNameAndPath) t = ReadGadgetByName("GDSRegistry", GDSRegistry) If t <> "OK" Then MsgBox t, , UCase(App.EXEName) & " Debug Message" GoTo EndSub End If SetProperty GDSRegistry, "Initialization Date", Format(Now, "Long Date") SetProperty GDSRegistry, "Initialization Time", Format(Now, "Long Time") SetProperty GDSRegistry, "GDS Tasks Initialized", "No" MResults = Memorize(GDSRegistry, "in " & VGBDatabaseNameAndPath) ' t = WriteMemGadget(GDSRegistry.ObjectID, GDSRegistry) ' t = ReadGadgetByName("GDSRegistry", GDSRegistry) ' FIXRWS = True End If ' gdsreg is open as db 0 ' next object is blank object t = ReadGadgetByName("BlankObject", BlankObject) If t <> "OK" Or BlankObject.Container <> "BlankObject" Then BlankObject.Name = "BlankObject" BlankObject.Type = "BlankObject" BlankObject.Container = "BlankObject" MResults = Memorize(BlankObject, "in " & VGBDatabaseNameAndPath) End If BlankObject.ObjectID = 0 BlankObject.Type = "" BlankObject.Container = "" ' fix the dbgadget definition index. this is the index for attached databases DBGadgetDef = Recall("DBGadget Definition", "from " & VGBDatabaseName) If DBGadgetDef.Name <> "DBGadget Definition" Then DBGadgetDef = BlankObject DBGadgetDef.Name = "DBGadget Definition" DBGadgetDef.Type = "DBGadget Definition" DBGadgetDef.Container = "GDS Registry" DBGadgetDef.ObjectID = 0 t = SetProperty(DBGadgetDef, "Last DBGadget Name Index", "0") MResults = Memorize(DBGadgetDef, "in " & VGBDatabaseNameAndPath) ' SetProperty Trace, NextID("trace") & "DB Gadget Definition Created", "Because: " & DBGadgetDef.Name & " not found" End If ' now the appdbgadget for this app, Virtual Cortex AppDBGadgetsCNTR = 0 AppDBGadgetsPTR = AppDBGadgetsCNTR ReDim Preserve AppDBGadgets(AppDBGadgetsPTR) AppDBGadgets(AppDBGadgetsPTR) = BlankObject AppDBGadgets(AppDBGadgetsPTR).ObjectID = 0 AppDBGadgets(AppDBGadgetsPTR).Name = UCase(App.EXEName) & "-" & VGBDatabaseName & "-0" AppDBGadgets(AppDBGadgetsPTR).Type = "AppDBGadget" AppDBGadgets(AppDBGadgetsPTR).Container = UCase(App.EXEName) AppDBGadgets(AppDBGadgetsPTR).Tag = "GDS Init" & Now() SetProperty AppDBGadgets(AppDBGadgetsPTR), "DB Name", VGBDatabaseName SetProperty AppDBGadgets(AppDBGadgetsPTR), "Enabled", "True" SetProperty AppDBGadgets(AppDBGadgetsPTR), "Open in this App?", "True" ' see if AppDBGadget is on disk RREsults = Recall(AppDBGadgets(AppDBGadgetsPTR).Name, "from " & VGBDatabaseNameAndPath) If RREsults.Name = AppDBGadgets(AppDBGadgetsPTR).Name Then ' found, just set objectid AppDBGadgets(AppDBGadgetsPTR).ObjectID = RREsults.ObjectID SetProperty Trace, NextID("trace") & "App Gadget", RREsults.Name & " exists" Else AppDBGadgets(AppDBGadgetsPTR).Tag = AppDBGadgets(AppDBGadgetsPTR).Tag & ":" & RREsults.Name MResults = Memorize(AppDBGadgets(AppDBGadgetsPTR), "in " & VGBDatabaseNameAndPath) SetProperty Trace, NextID("trace") & "App Gadget", MResults.Name & " found" End If ' ShowObject Dematerialize(AppDBGadgets(AppDBGadgetsPTR)), "Mem" ' the primary database (VGBDatabaseName) is open and the me app is going ' let's attach the application on the other end ' defined by the passed parameter AppWakeupGadget = AppAttach(Params) ' open all "memories pools" ' these are the db definitions LParam = BlankObject LParam.Name = "DBGadgetsLoad Parameters" t = SetProperty(LParam, "Reset Gadgets", "False") t = DBGadgetsLoad(LParam) ' open all the databases starttime = Timer For Cntr1 = 1 To DBGadgetsCNTR If ReadProperty(DBGadgets(Cntr1), "AutoOpen") = "True" Then ' use autopen prop to control the opening of dbs LParam = DBGadgets(Cntr1) SetProperty Trace, NextID("trace") & "Attaching Memories Pools", "Pool " & CStr(Cntr1) & " = " & LParam.Name t = SetProperty(LParam, "Reset Gadgets", "False") t = SetProperty(LParam, "Caller", "InitVGB") TGadget = OpenJetDataBase(LParam) SetProperty Trace, NextID("trace") & "Attached Memories Pools", "Pool " & CStr(Cntr1) & " = " & LParam.Name End If Next Cntr1 VCG_Self = Recall("VCG_Self", "from " & VGBDatabaseName) If VCG_Self.Name <> "VCG_Self" Then VCG_Self.Name = "VCG_Self" VCG_Self.Type = "Virtual Cortex Self" VCG_Self.Container = "VCG" 'SetProperty VCG_Self, "", "" SetProperty VCG_Self, "Initialized", CStr(Now()) SetProperty VCG_Self, "Mode", "Alpha Test" Memorize VCG_Self, "in " & VGBDatabaseName Else ' Msg = ReadProperty(VCG_Self, "Expires") ' If CDate(Now()) > CDate(Msg) Then ' If ReadProperty(VCG_Self, "Mode") = "Alpha Test" Then ' Msg = "" ' Msg = Msg & "I am hopelessly out of date." & CrLf ' Msg = Msg & "" & CrLf ' Msg = Msg & "If you are an active tester, you need" & CrLf ' Msg = Msg & "to go to The Gadgetorium's site and get" & CrLf ' Msg = Msg & "a new copy. There is certainly one now." & CrLf ' Msg = Msg & "If not, you need to uninstall this and forget it." & CrLf ' Msg = Msg & "" & CrLf ' Msg = Msg & "Note: you haven't lost one datum." & CrLf ' Msg = Msg & "I'll quit now..." & CrLf ' MsgBox Msg, vbExclamation, "Useful Lifetime Exeeded" ' Suicide = True ' End If ' End If End If ' If ReadProperty(VCG_Self, "Has Expired") = "True" Then ' Suicide = True ' End If Logged_User = Recall("Logged_User", "from VCG Memories") If Logged_User.Name <> "Logged_User" Then Logged_User.Name = "Logged_User" Logged_User.Type = "System" Logged_User.Container = "VCG" AccessLevel = 99 ' 100 levels, this is demo End If DBSwitch 0 Result = "OK" GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "InitVGB Trapped Error", "Error: " & LocalError SetProperty VGBErrors, NextID("error") & "InitVGB Trapped Error", "Error: " & LocalError Resume Next EndSub: ' Unload GDSMsg SetProperty Trace, NextID("trace") & "InitVGB", " Complete" AlreadyRunning = True InitVGB = VGBStatus On Error GoTo 0 End Function Friend Function Memorize(What As Gadget, Optional Location As String = "") As Gadget ' Dim BusyGadget As Gadget ' Static AmBusy As Boolean ' If AmBusy = True Then ' BusyGadget.Name = "Busy" ' MemorizeInternal = BusyGadget ' Exit Function ' End If ' AmBusy = True Dim starttime As Single starttime = Timer Dim t, Msg As String Dim RREsults As Gadget Dim Result As Gadget Dim LParam As Gadget Dim TempGadget As Gadget Dim ReturnedGadget As Gadget Dim UcaseParam As String Dim InPathAndFile As String Dim Where As Gadget Dim WherePath As String, WhereName As String Dim MemPoolType As String Dim LocalError As String On Error GoTo LocalError If InStr(Location, "/Type=") = 0 Then Location = Location & "/Type=Jet" End If MemPoolType = Right(Location, Len(Location) - InStr(Location, "/Type=") - 5) Location = Left(Location, InStr(Location, "/") - 1) UcaseParam = UCase(Location) InPathAndFile = AllTrim(Right(Location, Len(UcaseParam) - InStr(UcaseParam, "IN") - 2)) SetProperty Trace, NextID("trace") & "Memorize Start *********************************", "************************" SetProperty Trace, NextID("trace") & "Memorizing", "Name: " & What.Name & " / " & InPathAndFile ' fix the file type attribute 9/2/00 ' this allows the cortex to attach to jet, G-Internet, Text files Select Case True Case Location = "" ' no instructions, put it in # 1 as default DBSwitch 1 Case (Left(UcaseParam, 3) = "IN ") And (InStr(UcaseParam, "\") = 0) And (UCase(MemPoolType) = "JET") ' they said where but without a path t = DBFindIndex(InPathAndFile) If t < 0 Then ' couldn't find this database, need to bomb ' can't add a pool without path info. SetProperty Trace, NextID("trace") & "FXN Memorize Find DB Error", What.Name & " / " & InPathAndFile & " / " & "Find Index Failed" SetProperty VGBErrors, NextID("error") & "FXN Memorize Find DB Error", What.Name & " / " & InPathAndFile & " / " & "Find Index Failed" Result.Name = "Could not Create: " & Location ' FloatMsgBox Result.Name, "Memorize Failure" GoTo EndSub End If DBSwitch Val(t) Case (Left(UcaseParam, 3) = "IN ") And (InStr(UcaseParam, "\") > 0) And (UCase(MemPoolType) = "JET") ' they specified a place with a path ' now we can add a new one as needed TempGadget = BlankObject SetProperty TempGadget, "PathFile", InPathAndFile ' "Where" includes path, current if not there Where = ExtractPathAndFile(TempGadget) ' variables are easier at times like this WherePath = AddBackSlash(UCase(ReadProperty(Where, "Path Only"))) WhereName = UCase(ReadProperty(Where, "File Only")) t = DBFindIndex(WherePath & WhereName) ' SetProperty Trace, NextID("trace") & "Memorize Loc", What.Name & ": " & Location If t < 0 Then ' not found, we need to add the file ' SetProperty Trace, NextID("trace") & "Memorize Adding DB", WherePath & WhereName ' SetProperty StatusGadget, "DB Created", WherePath & WhereName LParam = BlankObject LParam.Name = "Parameters To Database Add Method" LParam.Type = "Parameter" LParam.Container = "AddDatabase" Msg = Location SetProperty LParam, "Long Name", Msg SetProperty LParam, "Mem Pool Type", MemPoolType SetProperty LParam, "SourcePath", AddBackSlash(UCase(App.Path)) SetProperty LParam, "SourceFile", "Empty.mem" SetProperty LParam, "DestPath", WherePath SetProperty LParam, "DestFile", WhereName SetProperty LParam, "Stop on error", "No" SetProperty LParam, "Write Location", "Yes" SetProperty LParam, "Write Location File DBGadgetPTR", CStr(0) SetProperty LParam, "Created by", "Virtual Cortex Memorize" ReturnedGadget = AddDatabase(LParam) If ReadProperty(ReturnedGadget, "Status") <> OK Then SetProperty Trace, NextID("trace") & "FXN Memorize Add DB and Path Error", What.Name & "/" & WherePath & WhereName & " / " & ReadProperty(ReturnedGadget, "Status") SetProperty VGBErrors, NextID("error") & "FXN Memorize Add DB and Path Error", What.Name & "/" & WherePath & WhereName & " / " & ReadProperty(ReturnedGadget, "Status") Result = ReturnedGadget GoTo EndSub End If End If t = DBFindIndex(WherePath & WhereName) If t < 0 Then ' couldn't find this database, need to bomb SetProperty Trace, NextID("trace") & "FXN Memorize Find DB Error: ", What.Name & "/" & Location & " / " & "Find Index Failed" SetProperty VGBErrors, NextID("error") & "FXN Memorize Find DB Error: ", What.Name & "/" & Location & " / " & "Find Index Failed" Result.Name = "Could not Create: " & Location ' FloatMsgBox Result.Name, "Memorize Failure" GoTo EndSub End If RREsults = Recall(What.Name, "from " & WhereName) If RREsults.Name = What.Name Then What.ObjectID = RREsults.ObjectID End If If RREsults.Name = "Found Multiple" Then End If DBSwitch Val(t) End Select t = WriteMemGadget(What.ObjectID, What) Result = What GoTo EndSub LocalError: LocalError = Error ' FloatMsgBox What.Name, "Memorize Error: " & LocalError SetProperty Trace, NextID("trace") & "Trapped Memorize Error: ", What.Name & " / " & Location & " / " & LocalError SetProperty VGBErrors, NextID("error") & "Trapped Memorize Error: ", What.Name & " / " & Location & " / " & LocalError Resume Next EndSub: SetProperty Trace, NextID("trace") & "Memorize Time", CStr(Timer - starttime) SetProperty Trace, NextID("trace") & "Memorize End *********************************", "************************" GDSFreelocks On Error GoTo 0 ' AmBusy = False Memorize = Result DBEngine.Idle dbRefreshCache End Function Friend Function RecallRS(What As String, Optional From As String = "") As Gadget Dim starttime As Single starttime = Timer Dim RSGadget As Gadget Dim RecalledRS As Recordset Dim SQLCmd As String SQLCmd = "SELECT DISTINCT Objects.Name, Props.Property, Props.ValueAlpha" & _ " FROM Objects LEFT JOIN Props ON Objects.ObjectID = Props.ObjectID" & _ " Where (((Props.Property) = 'group'))" & _ " ORDER BY Objects.Name;" Set RecalledRS = OpenDB(1).OpenRecordset(SQLCmd, dbOpenDynaset) RSGadget.Name = "Returned Value" SetProperty RSGadget, "Command", SQLCmd SetProperty RSGadget, "RecalledRS.Recordcount", CStr(RecalledRS.RecordCount) SetProperty RSGadget, "Time", CStr(Timer - starttime) Set RSGadget.RS = RecalledRS RecallRS = RSGadget End Function Friend Function Recall(What As String, Optional From As String = "") As Gadget Dim starttime As Single, stoptime As Single starttime = Timer ' Static CallCNTR As Long Dim tstarttime As Single, tstoptime As Single, ttime As Single Dim t, Msg As String, Cntr1 As Long, CNTR2 As Long Dim Status As Gadget Dim TotDone As Long, TotToDo As Long, RCancel As Boolean Dim LParam As Gadget Dim Result As Gadget Dim StartDBPTR As Integer, LOCDBPTR As Integer Dim UCASESentence As String, TSentence As String Dim FromWhere As String Dim UCASEFrom As String Dim AllNames() As String, AllNamesPTR As Long, AllNamesCNTR As Long Dim AllNamesDBs() As Integer, AllNamesDBsPTR As Long, AllNamesDBsCNTR As Long Dim AllNamesIDs() As Long Dim NameCompare As String Dim CurrentDBName As String Dim PropsBookmark As String Dim PropFound As Boolean Dim PropValueFound As Boolean Dim TotalNamesChecked As Long Dim ThisID As Long Dim IncludeNameInList As Boolean Dim AccumulatedGadgets() As Gadget, AccumulatedGadgetsPTR As Long, AccumulatedGadgetsCNTR As Long Dim ObjectName As String Dim AllProps() As String, AllPropsPTR As Long, AllpropsCNTR As Long Dim Props() As String, PropsPTR As Long, PropsCNTR As Long Dim PropValues() As String Dim CheckPropName As String, CheckPropValue As String Dim TotPropsMatched As Long Dim CurrentProp As String, CurrentPropValue As String Dim RecalledRS As Recordset Dim QuoteChar As String * 1 Dim SQLCmd As String Dim SQLWhere As String Dim SQLOrder As String Dim StartAccesLevel As Long Dim LocalError As String StartAccesLevel = AccessLevel SetProperty Trace, NextID("trace") & "Recall Start *********************************", "************************" SetProperty Trace, NextID("trace") & "Recalling", What & " " & From SQLCmd = "SELECT DISTINCT Objects.Name FROM Objects LEFT JOIN Props ON Objects.ObjectID = Props.ObjectID " ' where (((Props.Property)='group') AND ((Props.ValueAlpha)='user defined')) ORDER BY Objects.Name;" SQLWhere = " WHERE " SQLOrder = " ORDER BY Objects.Name;" On Error GoTo LocalError ' CallCNTR = CallCNTR + 1 StartDBPTR = DBGadgetsPTR What = AllTrim(What) UCASESentence = UCase(What) UCASEFrom = UCase(From) Status.Name = What If InStr(UCASEFrom, VGBDatabaseName) > 0 Then AccessMode = 0 Else AccessMode = AccessLevel End If If UCASEFrom = "FROM VCG MEMORIES" Then AccessLevel = 0 From = VGBDatabaseName UCASEFrom = UCase(From) End If If Left(UCASESentence, 17) = "NAMES CONTAINING " Then ' names containing "joe" with: " Cntr1 = InStr(UCASESentence, DBLQuote) + 1 CNTR2 = InStr(Cntr1, UCASESentence, DBLQuote) NameCompare = Mid(UCASESentence, Cntr1, CNTR2 - Cntr1) End If If InStr(UCASESentence, " WITH: ") > 0 Then ' this one has properties 'TSentence = AllTrim(Right(What, Len(UcaseSentence) - InStr(UcaseSentence, "WITH") - 4)) TSentence = AllTrim(Right(What, Len(UCASESentence) - InStr(UCASESentence, " WITH:") - 5)) If InStr(TSentence, SingleQuote) = 0 Then QuoteChar = SingleQuote End If If InStr(TSentence, DBLQuote) = 0 Then QuoteChar = DBLQuote End If ' Msg = "[" & TSentence & "] " AllProps = Split(TSentence, ",") AllpropsCNTR = UBound(AllProps) For AllPropsPTR = 0 To AllpropsCNTR If InStr(AllProps(AllPropsPTR), "=") > 0 Then PropsCNTR = PropsCNTR + 1 ReDim Preserve Props(PropsCNTR) ReDim Preserve PropValues(PropsCNTR) Props(PropsCNTR) = AllTrim(Left(AllProps(AllPropsPTR), InStr(AllProps(AllPropsPTR), "=") - 1)) PropValues(PropsCNTR) = AllTrim(Right(AllProps(AllPropsPTR), Len(AllProps(AllPropsPTR)) - InStr(AllProps(AllPropsPTR), "="))) If SQLWhere = " WHERE " Then SQLWhere = SQLWhere & " (Props.Property=" & QuoteChar & Props(PropsCNTR) & QuoteChar & ") AND (Props.ValueAlpha=" & QuoteChar & PropValues(PropsCNTR) & QuoteChar & ")" Else SQLWhere = SQLWhere & " AND (Props.Property=" & QuoteChar & Props(PropsCNTR) & QuoteChar & ") AND (Props.ValueAlpha=" & QuoteChar & PropValues(PropsCNTR) & QuoteChar & ")" End If ' Msg = Msg & "[" & PropsCNTR & ": " & Props(PropsCNTR) & "=" & PropValues(PropsCNTR) & "] " & CrLf Else ' no property value, just property name PropsCNTR = PropsCNTR + 1 ReDim Preserve Props(PropsCNTR) ReDim Preserve PropValues(PropsCNTR) Props(PropsCNTR) = AllTrim(AllProps(AllPropsPTR)) PropValues(PropsCNTR) = "" If SQLWhere = " WHERE " Then SQLWhere = SQLWhere & " (Props.Property=" & QuoteChar & Props(PropsCNTR) & QuoteChar & ") AND (Props.ValueAlpha like " & QuoteChar & "*" & QuoteChar & ")" Else SQLWhere = SQLWhere & " AND (Props.Property=" & QuoteChar & Props(PropsCNTR) & QuoteChar & ") AND (Props.ValueAlpha like " & QuoteChar & "*" & QuoteChar & ")" End If ' Msg = Msg & "[" & PropsCNTR & ": " & Props(PropsCNTR) & "=" & PropValues(PropsCNTR) & "] " & CrLf End If Next ' FloatMsgBox Msg, "Properties" End If If InStr(TSentence, ",") > 0 Then ' add an or statememnt to catch anything with a coma in it If InStr(TSentence, "=") > 0 Then CheckPropName = AllTrim(Left(TSentence, InStr(TSentence, "=") - 1)) CheckPropValue = AllTrim(Right(TSentence, Len(TSentence) - InStr(TSentence, "="))) SQLWhere = SQLWhere & " OR ((Props.Property=" & QuoteChar & CheckPropName & QuoteChar & ") AND (Props.ValueAlpha= " & QuoteChar & CheckPropValue & QuoteChar & "))" Else CheckPropName = AllTrim(TSentence) SQLWhere = SQLWhere & " OR ((Props.Property=" & QuoteChar & CheckPropName & QuoteChar & ") AND (Props.ValueAlpha= " & QuoteChar & "*" & QuoteChar & "))" End If End If If Len(From) > 0 Then ' they specified the source db Select Case True Case Left(UCASEFrom, 5) = "FROM " FromWhere = AllTrim(Right(From, Len(UCASEFrom) - 5)) Case Else FromWhere = AllTrim(From) End Select ' SetProperty Trace, NextID("trace") & "Parsed From", FromWhere End If '///////////////////////////////////////////////////////////////////////////////////////////// '///////////////////////////////////////////////////////////////////////////////////////////// '///////////////////////////////////////////////////////////////////////////////////////////// ' not gonna check all databases every time ' if from not specified, then do all Cntr1 = 0 CNTR2 = 0 For LOCDBPTR = 0 To DBGadgetsCNTR Select Case True Case LOCDBPTR = 0 And AccessMode <> 0 GoTo SkipPool: Case FromWhere <> "" t = DBFindIndex(FromWhere) If t < 0 Then SetProperty Trace, NextID("trace") & "Recall Not trapped Error", "DB Findindex failed: " & FromWhere Result.Name = From & " " & NotFound SetProperty Result, "Error", FromWhere & " " & NotFound GoTo EndSub End If LOCDBPTR = Val(t) t = DBSwitch(LOCDBPTR) If t <> OK Then Result.Name = "Recall From Failed DBSwitch" SetProperty Trace, NextID("trace") & "Recall Not trapped Error", "DB Switch failed: " & CStr(t) & "/" & FromWhere SetProperty Result, "DBSwitch Failed", CStr(t) Msg = Msg & "[DB Switch Failed: " & CStr(t) & "] " GoTo EndSub End If CurrentDBName = ReadProperty(DBGadgets(LOCDBPTR), "DB Name") Case Else t = DBSwitch(LOCDBPTR) If t <> OK Then Result.Name = "Recall Failed DBSwitch" SetProperty Trace, NextID("trace") & "Recall Not trapped Error", "DB Switch failed: " & CStr(t) SetProperty Result, "DBSwitch Failed", CStr(t) Msg = Msg & "[DB Switch Failed: " & CStr(t) & "] " GoTo EndSub End If CurrentDBName = ReadProperty(DBGadgets(LOCDBPTR), "DB Name") End Select Select Case True Case Left(UCASESentence, 7) = "SELECT " ' let's sent them a recordset Set Result.RS = OpenDB(OpenDBPTR).OpenRecordset(What, dbOpenDynaset) stoptime = Timer SetProperty Result, "Total Time", CStr(stoptime - starttime) Result.Name = "Select Results" GoTo EndSub Case UCASESentence = "ALL MEMORIES POOLS" If LOCDBPTR > 0 Then Cntr1 = Cntr1 + 1 Msg = ReadProperty(DBGadgets(LOCDBPTR), "Path") Msg = AddBackSlash(Msg) Msg = Msg & ReadProperty(DBGadgets(LOCDBPTR), "DB Name") SetProperty Result, "Name " & CStr(LOCDBPTR), Msg SetProperty Result, "RecordCount " & CStr(LOCDBPTR), CStr(ObjectsRS.RecordCount) End If If LOCDBPTR = DBGadgetsCNTR Then Result.Name = CStr(Cntr1) & " Memories Pools found" stoptime = Timer SetProperty Result, "Total Time", CStr(stoptime - starttime) GoTo EndSub End If Case UCASESentence = "LAST OBJECTID" ObjectsRS.Index = "PrimaryKey" ObjectsRS.MoveLast SetProperty Result, ReadProperty(DBGadgets(LOCDBPTR), "DB Name"), CStr(ObjectsRS!ObjectID) If LOCDBPTR = DBGadgetsCNTR Then Result.Name = "Last Object IDs" GoTo EndSub End If Case UCASESentence = "COUNT OBJECTS" LocalError = "" ObjectsRS.MoveFirst If UCase(LocalError) = UCase("No current record.") Then TotalNamesChecked = TotalNamesChecked + 0 Else ObjectsRS.MoveLast TotalNamesChecked = TotalNamesChecked + ObjectsRS.RecordCount End If Case UCASESentence = "NAMES" ' returns all names in all databases ' ObjectsRS.MoveLast If True = True Then 'ObjectsRS.RecordCount > 5500 Then SQLCmd = "SELECT DISTINCT Objects.Name FROM Objects order by objects.name;" Set RecalledRS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) RecalledRS.MoveLast Result.TotalProperties = Result.TotalProperties + RecalledRS.RecordCount ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) RecalledRS.MoveFirst Do While RecalledRS.EOF = False And LocalError = "" AllNamesCNTR = AllNamesCNTR + 1 Result.Propity(AllNamesCNTR) = "Name " & CStr(AllNamesCNTR) Result.ValueAlpha(AllNamesCNTR) = RecalledRS!Name RecalledRS.MoveNext Loop Else ObjectsRS.Index = "Name" ObjectsRS.MoveFirst Do While ObjectsRS.EOF = False Cntr1 = Cntr1 + 1 If Cntr1 > 200 Then ' ShowRecallStatus (Cntr1) DoEvents End If If UserCancel Then UserCancel = False SetProperty Result, "User Cancel", "True" GoTo SkipRest: End If Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = "Name " & CStr(Result.TotalProperties) Result.ValueAlpha(Result.TotalProperties) = ObjectsRS!Name ' SetProperty Result, "Name " & CStr(Cntr1), ObjectsRS!Name ' SetProperty Result, "DB " & CStr(Cntr1), DBGadgets(LOCDBPTR).Name ObjectsRS.MoveNext If Cntr1 Mod 50 = 0 Then ' SetProperty Status, "Done", CStr(Cntr1) TotDone = Cntr1 TotToDo = 0 RaiseEvent RecallStatus(TotDone, TotToDo, RCancel) If RCancel = True Then Result.Name = What & " Cancelled" GoTo EndSub End If End If Loop If (LOCDBPTR = DBGadgetsCNTR) Or (Len(From) > 0) Then Result.Name = CStr(Cntr1) & " Names Found" stoptime = Timer SetProperty Result, "Read Start", CStr(starttime) SetProperty Result, "Read End", CStr(Timer) SetProperty Result, "Read Total Time", CStr(stoptime - starttime) SetProperty Result, "Read Total Checked", CStr(Cntr1) GoTo EndSub End If End If ' Case Left(UcaseSentence, 11) = "NAMES LIKE " ' TSentence = AllTrim(Right(What, Len(What) - 11)) Case Left(UCASESentence, 9) = "ANY NAME " And InStr(UCASESentence, " WITH: ") > 0 TSentence = AllTrim(Right(What, Len(UCASESentence) - InStr(UCASESentence, "="))) IncludeNameInList = False If Result.Name <> "Found" Then Result.Name = NotFound End If PropsRS.Index = "ValueAlpha" PropsRS.Seek "=", PropValues(1) Do While PropsRS.NoMatch = False If UCase(PropsRS!Property) = UCase(Props(1)) Then IncludeNameInList = True Exit Do End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If If UCase(PropsRS!ValueAlpha) <> UCase(PropValues(1)) Then Exit Do End If Loop If IncludeNameInList = True Then SetProperty Result, What & " " & CStr(LOCDBPTR), PropsRS!Property SetProperty Result, "Value" & " " & CStr(LOCDBPTR), PropsRS!ValueAlpha SetProperty Result, "Result", "Found" Result.Name = "Found" If Len(From) > 0 Then GoTo EndSub End If Else SetProperty Result, TSentence & " " & CStr(LOCDBPTR), NotFound SetProperty Result, TSentence & " " & CStr(LOCDBPTR), NotFound SetProperty Result, "Value" & " " & CStr(LOCDBPTR), "None" SetProperty Result, "Result", NotFound End If If LOCDBPTR = DBGadgetsCNTR Then GoTo EndSub End If Case Left(UCASESentence, 29) = "PROPERTY NAMES WITHOUT LINES" And (DBGadgetsPTR <> 0 Or DevelopmentMode) SQLCmd = "SELECT distinct Props.Property From Props where instr(props.property," & DBLQuote & "-Line #" & DBLQuote & ")=0 ORDER BY Props.Property;" Set RecalledRS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) RecalledRS.MoveLast Result.TotalProperties = Result.TotalProperties + RecalledRS.RecordCount ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) RecalledRS.MoveFirst Do While RecalledRS.EOF = False And LocalError = "" If RecalledRS!Property <> "DU" And RecalledRS!Property <> "DP" Then AllNamesCNTR = AllNamesCNTR + 1 Result.Propity(AllNamesCNTR) = "Property " & CStr(AllNamesCNTR) Result.ValueAlpha(AllNamesCNTR) = RecalledRS!Property ' Result.PropType(AllNamesCNTR) = RecalledRS!PropType End If RecalledRS.Move 1 Loop If LOCDBPTR = DBGadgetsCNTR Then GoTo EndSub End If If Len(From) > 0 Then GoTo EndSub End If Case Left(UCASESentence, 14) = "PROPERTY NAMES" And (DBGadgetsPTR <> 0 Or DevelopmentMode) SQLCmd = "SELECT distinct Props.Property From Props ORDER BY Props.Property;" Set RecalledRS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) RecalledRS.MoveLast Result.TotalProperties = Result.TotalProperties + RecalledRS.RecordCount ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) ' ReDim Preserve Result.PropType(Result.TotalProperties) RecalledRS.MoveFirst Do While RecalledRS.EOF = False And LocalError = "" If RecalledRS!Property <> "DU" And RecalledRS!Property <> "DP" Then AllNamesCNTR = AllNamesCNTR + 1 Result.Propity(AllNamesCNTR) = "Property " & CStr(AllNamesCNTR) Result.ValueAlpha(AllNamesCNTR) = RecalledRS!Property ' Result.PropType(AllNamesCNTR) = RecalledRS!PropType End If RecalledRS.Move 1 Loop If LOCDBPTR = DBGadgetsCNTR Then GoTo EndSub End If If Len(From) > 0 Then GoTo EndSub End If Case Left(UCASESentence, 6) = "NAMES " And InStr(UCASESentence, " WITH: ") > 0 ' we're returning names of gobjects ' query has property qualifiers ' need to get all the properties to evaluate from the What ' "Names with Wife,Type=User,Hair Color=Black" ' If PropsCNTR > 1 Then ' GoTo MultiProps ' End If Msg = SQLCmd & SQLWhere & SQLOrder Set RecalledRS = OpenDB(OpenDBPTR).OpenRecordset(Msg, dbOpenDynaset) Set Result.RS = RecalledRS Do While (RecalledRS.EOF = False) And (LocalError = "") DoEvents If LocalError <> "" Then Exit Do End If IncludeNameInList = True If NameCompare <> "" Then If InStr(UCase(RecalledRS!Name), NameCompare) = 0 Then IncludeNameInList = False End If End If If IncludeNameInList = True Then AllNamesCNTR = AllNamesCNTR + 1 Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = "Name " & CStr(AllNamesCNTR) Result.ValueAlpha(Result.TotalProperties) = RecalledRS!Name ' now db name (pool) End If If Len(From) = 0 Then Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = "Pool " & CStr(AllNamesCNTR) Result.ValueAlpha(Result.TotalProperties) = CurrentDBName TotDone = Result.TotalProperties TotToDo = 0 RaiseEvent RecallStatus(TotDone, TotToDo, RCancel) If RCancel = True Then Result.Name = What & " Cancelled" GoTo EndSub End If 'DoEvents End If RecalledRS.Move 1 Loop If PropsCNTR > 1 And AllNamesCNTR = 0 Then GoTo MultiProps End If Result.Name = CStr(AllNamesCNTR) & " Names Found" If LOCDBPTR = DBGadgetsCNTR Then GoTo EndSub End If If Len(From) > 0 Then GoTo EndSub End If If LocalError = "" Then ' this means that the select worked GoTo skipold End If ' gets to here if there was an error with select MultiProps: ObjectsRS.Index = "PrimaryKey" For PropsPTR = 0 To PropsCNTR IncludeNameInList = False If (Len(Props(PropsPTR)) > 0) And (PropValues(PropsPTR) <> "") Then ' this one has a property and a prop value to check ' check for a value that matches first, seems more effecient PropsRS.Index = "Property" PropsRS.Seek "=", Props(PropsPTR) If PropsRS.NoMatch = False Then PropFound = True SetProperty Result, "Property Seek OK", Props(PropsPTR) Else PropFound = False SetProperty Result, "Property Seek Failed", Props(PropsPTR) End If PropsRS.Index = "ValueAlpha" PropsRS.Seek "=", PropValues(PropsPTR) If PropsRS.NoMatch = True Then SetProperty Result, "Property Value Seek Failed", PropValues(PropsPTR) Else SetProperty Result, "Property Value Seek OK", PropValues(PropsPTR) End If Do While (PropsRS.NoMatch = False) And PropFound ' And (PropValues(PropsPTR) <> "") DoEvents ' this prop value is on disk ' need to chck to see if the property name is the same as the one we're checking TotalNamesChecked = TotalNamesChecked + 1 PropsBookmark = PropsRS.Bookmark ThisID = PropsRS!ObjectID CurrentProp = PropsRS!Property CurrentPropValue = PropsRS!ValueAlpha ' this disk property is same as the one in passed properties ' and the value on disk is same as passed ' need to add this object name if it is not already in list IncludeNameInList = True For Cntr1 = 1 To AllNamesCNTR If (AllNamesIDs(Cntr1) = ThisID) And (AllNamesDBs(Cntr1) = LOCDBPTR) Then ' this name is already in the list, skip it IncludeNameInList = False Exit For End If Next If IncludeNameInList = True Then ' name is not in list, see if it needs to be ' tstarttime = Timer 't = ReadGadgetByID(ThisID) ' check all props records for this object id PropsRS.Index = "ObjectID" PropsRS.Seek "=", ThisID CNTR2 = 0 IncludeNameInList = False TotPropsMatched = 0 Do While PropsRS!ObjectID = ThisID For Cntr1 = 1 To PropsCNTR DoEvents If (UCase(PropsRS!Property) = UCase(Props(Cntr1))) Then If Len(PropValues(Cntr1)) > 0 Then If (UCase(PropsRS!ValueAlpha) = UCase(PropValues(Cntr1))) Then ' this property and value matches the check list TotPropsMatched = TotPropsMatched + 1 Else Exit For End If Else TotPropsMatched = TotPropsMatched + 1 End If End If Next If TotPropsMatched = PropsCNTR Then ' disk property found in list IncludeNameInList = True Exit Do End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If DoEvents Loop End If If NameCompare <> "" And IncludeNameInList Then If InStr(ObjectsRS!Name, NameCompare) = 0 Then IncludeNameInList = False End If End If If IncludeNameInList = True Then ' after all that, we have a winner ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", ThisID AllNamesCNTR = AllNamesCNTR + 1 ReDim Preserve AllNames(AllNamesCNTR) ReDim Preserve AllNamesDBs(AllNamesCNTR) ReDim Preserve AllNamesIDs(AllNamesCNTR) AllNames(AllNamesCNTR) = ObjectsRS!Name AllNamesDBs(AllNamesCNTR) = LOCDBPTR AllNamesIDs(AllNamesCNTR) = ObjectsRS!ObjectID Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = "Name " & CStr(AllNamesCNTR) Result.ValueAlpha(Result.TotalProperties) = ObjectsRS!Name ' now db name (pool) If Len(From) = 0 Then Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = "Pool " & CStr(AllNamesCNTR) Result.ValueAlpha(Result.TotalProperties) = CurrentDBName TotDone = Result.TotalProperties TotToDo = 0 RaiseEvent RecallStatus(TotDone, TotToDo, RCancel) If RCancel = True Then Result.Name = What & " Cancelled" GoTo EndSub End If 'DoEvents End If End If PropsRS.Index = "ValueAlpha" PropsRS.Bookmark = PropsBookmark PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If If UCase(PropsRS!ValueAlpha) <> UCase(PropValues(PropsPTR)) Then Exit Do End If DoEvents Loop End If ' check props without values //////////////////////////////////// If (Len(Props(PropsPTR)) > 0) And (PropValues(PropsPTR) = "") Then ' this property name has a value but the value doesn't ' look property name up in properties table PropsRS.Index = "Property" PropsRS.Seek "=", Props(PropsPTR) Do While (PropsRS.NoMatch = False) ' And (PropValues(PropsPTR) <> "") DoEvents TotalNamesChecked = TotalNamesChecked + 1 ThisID = PropsRS!ObjectID PropsBookmark = PropsRS.Bookmark ' this disk property is same as the one in passed properties ' and the value on disk is same as passed ' read this object if it is not already in list IncludeNameInList = True For Cntr1 = 1 To AllNamesCNTR If (AllNamesIDs(Cntr1) = ThisID) And (AllNamesDBs(Cntr1) = LOCDBPTR) Then ' this name is already in the list IncludeNameInList = False Exit For End If Next If NameCompare <> "" And IncludeNameInList Then If InStr(ObjectsRS!Name, NameCompare) = 0 Then IncludeNameInList = False End If End If If IncludeNameInList = True Then ' name is not in list, see if it needs to be ' tstarttime = Timer 't = ReadGadgetByID(ThisID) ' check all props records for this object id PropsRS.Index = "ObjectID" PropsRS.Seek "=", ThisID CNTR2 = 0 IncludeNameInList = False TotPropsMatched = 0 Do While PropsRS!ObjectID = ThisID For Cntr1 = 1 To PropsCNTR DoEvents If (UCase(PropsRS!Property) = UCase(Props(Cntr1))) Then If Len(PropValues(Cntr1)) > 0 Then If (UCase(PropsRS!ValueAlpha) = UCase(PropValues(Cntr1))) Then ' this property and value matches the check list TotPropsMatched = TotPropsMatched + 1 Else Exit For End If Else TotPropsMatched = TotPropsMatched + 1 End If End If Next If TotPropsMatched = PropsCNTR Then ' disk property found in list IncludeNameInList = True Exit Do End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If DoEvents Loop End If If IncludeNameInList = True Then ' after all that, we have a winner ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", ThisID AllNamesCNTR = AllNamesCNTR + 1 ReDim Preserve AllNames(AllNamesCNTR) ReDim Preserve AllNamesDBs(AllNamesCNTR) ReDim Preserve AllNamesIDs(AllNamesCNTR) AllNames(AllNamesCNTR) = ObjectsRS!Name AllNamesDBs(AllNamesCNTR) = LOCDBPTR AllNamesIDs(AllNamesCNTR) = ObjectsRS!ObjectID Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = "Name " & CStr(AllNamesCNTR) Result.ValueAlpha(Result.TotalProperties) = ObjectsRS!Name ' now db name (pool) If Len(From) = 0 Then Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = "Pool " & CStr(AllNamesCNTR) Result.ValueAlpha(Result.TotalProperties) = CurrentDBName End If If Result.TotalProperties Mod 50 = 0 Then TotDone = Result.TotalProperties TotToDo = 0 RaiseEvent RecallStatus(TotDone, TotToDo, RCancel) If RCancel = True Then Result.Name = What & " Cancelled" GoTo EndSub End If 'DoEvents End If End If PropsRS.Index = "Property" PropsRS.Bookmark = PropsBookmark PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If If UCase(PropsRS!Property) <> UCase(Props(PropsPTR)) Then Exit Do End If ' If (Result.TotalProperties > 300) Then '' OSDetectAndStatus.ProgressGauge.Min = 0 '' OSDetectAndStatus.ProgressGauge.Value = 0 ' OSDetectAndStatus.GageLabel.Caption = "0 %" ' OSDetectAndStatus.Visible = True ' End If If (Result.TotalProperties Mod 200 = 0) Then ' ShowRecallStatus (TotalNamesChecked) DoEvents End If If UserCancel = True Then UserCancel = False SetProperty Result, "User Cancel", "True" GoTo SkipRest: End If DoEvents DoEvents Loop End If Next skipold: ' Case Left(UcaseSentence, 17) = "UNIQUE VALUES OF " ' TSentence = AllTrim(Right(What, Len(UcaseSentence) - InStr(UcaseSentence, "UNIQUE VALUES OF ") - 16)) ' PropsRS.Index = "Property" ' PropsRS.Seek "=", TSentence ' Do While PropsRS.NoMatch = False ' CurrentProp = PropsRS!Property ' CurrentPropValue = PropsRS!ValueAlpha Case NameCompare <> "" ' just a set of names like the one the sent SQLCmd = "SELECT Objects.Name FROM Objects where Objects.name like '*" & NameCompare & "*';" Set RecalledRS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) RecalledRS.MoveLast Result.TotalProperties = Result.TotalProperties + RecalledRS.RecordCount ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) RecalledRS.MoveFirst Do While RecalledRS.EOF = False And LocalError = "" AllNamesCNTR = AllNamesCNTR + 1 Result.Propity(AllNamesCNTR) = "Name " & CStr(AllNamesCNTR) Result.ValueAlpha(AllNamesCNTR) = RecalledRS!Name RecalledRS.Move 1 Loop Result.Name = CStr(AllNamesCNTR) & " Names Found" GoTo EndSub Case Left(UCASESentence, 16) = "COUNT PROPERTIES" TSentence = AllTrim(Right(What, Len(UCASESentence) - InStr(UCASESentence, "COUNT OF ") - 8)) SQLCmd = "SELECT distinct count (property) " & _ "as [TotProps] From Props;" Set RecalledRS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) AllNamesCNTR = AllNamesCNTR + Val(RecalledRS!TotProps) Result.Name = CStr(AllNamesCNTR) & " Properties " & " found" ' GoTo EndSub If LOCDBPTR = DBGadgetsCNTR Then GoTo EndSub End If If Len(From) > 0 Then GoTo EndSub End If Case Left(UCASESentence, 9) = "COUNT OF " TSentence = AllTrim(Right(What, Len(UCASESentence) - InStr(UCASESentence, "COUNT OF ") - 8)) SQLCmd = "SELECT distinct count (valuealpha) " & _ "as [TotProps] From Props " & _ "where props.property='" & TSentence & "';" Set RecalledRS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) AllNamesCNTR = AllNamesCNTR + Val(RecalledRS!TotProps) Result.Name = CStr(AllNamesCNTR) & " Values of " & TSentence & " found" ' GoTo EndSub If LOCDBPTR = DBGadgetsCNTR Then GoTo EndSub End If If Len(From) > 0 Then GoTo EndSub End If Case Left(UCASESentence, 10) = "VALUES OF " ' extract property values ' Msg = Msg & "[DB=" & CStr(LOCDBPTR) & "] " TSentence = AllTrim(Right(What, Len(UCASESentence) - InStr(UCASESentence, "VALUES OF ") - 9)) SQLCmd = "SELECT DISTINCT Props.valuealpha " & _ "From Props " & _ "where props.property='" & TSentence & "' " & _ "ORDER BY Props.valuealpha;" Set RecalledRS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) RecalledRS.MoveLast Result.TotalProperties = RecalledRS.RecordCount ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) RecalledRS.MoveFirst Do While RecalledRS.EOF = False And LocalError = "" AllNamesCNTR = AllNamesCNTR + 1 Result.Propity(AllNamesCNTR) = TSentence & " " & CStr(AllNamesCNTR) ' & CStr(AllNamesCNTR) Result.ValueAlpha(AllNamesCNTR) = RecalledRS!ValueAlpha RecalledRS.Move 1 Loop TotalNamesChecked = AllNamesCNTR Result.Name = CStr(Result.TotalProperties) & " Values of " & TSentence & " found" stoptime = Timer SetProperty Result, "Total Checked", CStr(TotalNamesChecked) SetProperty Result, "Total Time", CStr(stoptime - starttime) If TotalNamesChecked > 0 Then SetProperty Result, "Time/Check", CStr((stoptime - starttime) / TotalNamesChecked) End If If LOCDBPTR = DBGadgetsCNTR Then GoTo EndSub End If If Len(From) > 0 Then GoTo EndSub End If GoTo skipoldvaluesof PropsRS.Index = "Property" PropsRS.Seek "=", TSentence Do While PropsRS.NoMatch = False TotalNamesChecked = TotalNamesChecked + 1 CurrentProp = PropsRS!Property CurrentPropValue = PropsRS!ValueAlpha For Cntr1 = 1 To AllNamesCNTR If AllNames(Cntr1) = PropsRS!ValueAlpha Then Exit For End If Next If Cntr1 > AllNamesCNTR Then AllNamesCNTR = AllNamesCNTR + 1 ReDim Preserve AllNames(AllNamesCNTR) AllNames(AllNamesCNTR) = PropsRS!ValueAlpha Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = TSentence & " " & CStr(Result.TotalProperties) Result.ValueAlpha(Result.TotalProperties) = PropsRS!ValueAlpha End If PropsRS.MoveNext ' Do While (PropsRS!Property = CurrentProp) And (PropsRS!ValueAlpha = CurrentPropValue) ' PropsRS.MoveNext ' If PropsRS.EOF Then ' Exit Do ' End If ' Loop If PropsRS.EOF Then Exit Do End If If UCase(PropsRS!Property) <> UCase(TSentence) Then Exit Do End If If Result.TotalProperties Mod 50 = 0 Then ' FloatMsgBox "Total Done: " & CStr(Result.TotalProperties), "Recall Status" ' SetProperty Status, "Done", CStr(Result.TotalProperties) TotDone = Result.TotalProperties TotToDo = 0 RaiseEvent RecallStatus(TotDone, TotToDo, RCancel) If RCancel = True Then Result.Name = What & " Cancelled" GoTo EndSub End If ' DoEvents End If Loop If (LOCDBPTR = DBGadgetsCNTR) Or (Len(From) > 0) Then Result.Name = CStr(Result.TotalProperties) & " Values of " & TSentence & " found" stoptime = Timer SetProperty Result, "Total Checked", CStr(TotalNamesChecked) SetProperty Result, "Total Time", CStr(stoptime - starttime) If TotalNamesChecked > 0 Then SetProperty Result, "Time/Check", CStr((stoptime - starttime) / TotalNamesChecked) End If 'TotalNamesChecked GoTo EndSub End If skipoldvaluesof: Case InStr(UCASESentence, " WITH: ") > 0 Result.Name = "0 " & What & " found" ObjectName = AllTrim(Left(What, InStr(UCASESentence, "WITH:") - 1)) ' Msg = "Seeking Object: " & ObjectName & " in: " & DBGadgets(LOCDBPTR).Name & CrLf ' FloatMsgBox Msg, "Seek: " & What ObjectsRS.Index = "Name" ObjectsRS.Seek "=", ObjectName Do While ObjectsRS.NoMatch = False TotDone = TotDone + 1 ' Msg = "ObjectRS: " & ObjectsRS!Name & CrLf ' FloatMsgBox Msg, "Found: " & ObjectsRS!Name & " / " & CStr(ObjectsRS!ObjectID) ThisID = ObjectsRS!ObjectID PropsRS.Index = "ObjectID" PropsRS.Seek "=", ThisID AllPropsPTR = 0 Do While PropsRS.NoMatch = False ' Msg = "ObjectRS: " & ObjectsRS!Name & CrLf ' FloatMsgBox Msg, "Found: " & ObjectsRS!Name ' Msg = Msg & "Properties: " & PropsRS!Property & ": " & PropsRS!ValueAlpha & CrLf For PropsPTR = 1 To PropsCNTR If (UCase(PropsRS!Property) = UCase(Props(PropsPTR))) And _ (UCase(PropsRS!ValueAlpha) = UCase(PropValues(PropsPTR))) Then AllPropsPTR = AllPropsPTR + 1 End If Next If AllPropsPTR = PropsCNTR Then ' this is the one with all properties same as passed t = ReadGadgetByID(ThisID) If t = OK Then Result = ReadObjectBuffer GoTo EndSub Else Result.Name = "Error Reading: " & ObjectsRS!Name GoTo EndSub End If End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If If PropsRS!ObjectID <> ThisID Then Exit Do End If Loop ObjectsRS.MoveNext If ObjectsRS.EOF Then Exit Do End If If ObjectsRS!Name <> ObjectName Then Exit Do End If Loop If (LOCDBPTR = DBGadgetsCNTR) Or (Len(From) > 0) Then ' Msg = "Total Done: " & CStr(TotDone) & CrLf ' FloatMsgBox Msg, "Total: " & ObjectName Msg = "" GoTo EndSub End If Case Else ' it is just a gobject name ' need to load all instances, if multiple ObjectsRS.Index = "Name" ObjectsRS.Seek "=", What Do While ObjectsRS.NoMatch = False AllNamesCNTR = AllNamesCNTR + 1 ReDim Preserve AllNames(AllNamesCNTR) ReDim Preserve AllNamesDBs(AllNamesCNTR) ReDim Preserve AllNamesIDs(AllNamesCNTR) AllNames(AllNamesCNTR) = ObjectsRS!Name AllNamesIDs(AllNamesCNTR) = ObjectsRS!ObjectID AllNamesDBs(AllNamesCNTR) = LOCDBPTR ObjectsRS.MoveNext If ObjectsRS.EOF Then Exit Do End If If ObjectsRS!Name <> What Then Exit Do End If Loop End Select If FromWhere <> "" Then Exit For SkipPool: Next LOCDBPTR '///////////////////////////////////////////////////////////////////////////////////////////// '///////////////////////////////////////////////////////////////////////////////////////////// '///////////////////////////////////////////////////////////////////////////////////////////// ' FloatMsgBox "Sentence=" & CStr(What), "Recall Debug" SkipRest: If UCASESentence = "COUNT OBJECTS" Then Result.Name = CStr(TotalNamesChecked) & " " & What & " found" stoptime = Timer SetProperty Result, "Read Total Checked", CStr(TotalNamesChecked) SetProperty Result, "Read Start", CStr(starttime) SetProperty Result, "Read End", CStr(stoptime) SetProperty Result, "Read Total", CStr(stoptime - starttime) GoTo EndSub End If If UCASESentence = "NAMES" Or _ (Left(UCASESentence, 6) = "NAMES " And InStr(UCASESentence, " WITH: ") > 0) Then ' Select Case True ' Case AllNamesCNTR = 0 ' Result.Name = NotFound ' Case AllNamesCNTR = 1 ' Result.Name = "Found One" ' Case AllNamesCNTR > 1 ' Result.Name = "Found Multiple" ' End Select Result.Name = CStr(AllNamesCNTR) & " " & What & " found" stoptime = Timer SetProperty Result, "Read Total Checked", CStr(TotalNamesChecked) SetProperty Result, "Read Start", CStr(starttime) SetProperty Result, "Read End", CStr(stoptime) SetProperty Result, "Read Total Time", CStr(stoptime - starttime) GoTo EndSub End If ' Msg = Msg & "[AllNamesCNTR=" & CStr(AllNamesCNTR) & " ]" ' this fills in names if more than one found If AllNamesCNTR = 1 Then ' found just one gobject, return it If AllNamesDBs(AllNamesCNTR) <> DBGadgetsPTR Then DBSwitch AllNamesDBs(AllNamesCNTR) End If t = ReadGadgetByID(AllNamesIDs(1)) Result = ReadObjectBuffer ' LParam.Name = AllNames(AllNamesCNTR) ' SetProperty LParam, "ReadBy", "Name" ' SetProperty LParam, "Scope", "Current" ' Result = ReadGadget(LParam) Else If AllNamesCNTR = 0 Then Result.Name = NotFound Else Result.Name = "Found Multiple" For AllNamesPTR = 0 To AllNamesCNTR If AllNames(AllNamesPTR) <> "" Then SetProperty Result, "Name " & CStr(AllNamesPTR), AllNames(AllNamesPTR) SetProperty Result, "ID " & CStr(AllNamesPTR), CStr(AllNamesIDs(AllNamesPTR)) SetProperty Result, "DB " & CStr(AllNamesPTR), CStr(AllNamesDBs(AllNamesCNTR)) End If stoptime = Timer SetProperty Result, "Time ", CStr(stoptime - starttime) Next End If End If GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "Recall Trapped Error", What & " / " & LocalError SetProperty VGBErrors, NextID("error") & "Recall Trapped Error", What & " / " & LocalError ' Msg = Msg & "[" & "Trapped: " & LocalError & "] " & CrLf Resume Next EndSub: If StartDBPTR <> DBGadgetsPTR Then DBSwitch StartDBPTR End If ' If Msg <> "" Then ' FloatMsgBox Msg, "VGB recall Debug Message" ' MsgBox "pause" ' End If On Error GoTo 0 SetProperty Trace, NextID("trace") & "Recall Time", CStr(Timer - starttime) SetProperty Trace, NextID("trace") & "Recall End *********************************", "************************" ' CheckTrace UserCancel = False If OSDetectAndStatus.Visible = True Then OSDetectAndStatus.Hide End If ' AmBusy = False Recall = Result DBEngine.Idle dbRefreshCache End Function Friend Function ShowRecallStatus(NumToShow As Long) As Gadget OSDetectAndStatus.Visible = True OSDetectAndStatus.Caption = "Recalling " OSDetectAndStatus.ProgressLabel = "Number Checked" ' OSDetectAndStatus.ProgressGauge.Min = 0 ' OSDetectAndStatus.ProgressGauge.Max = 10 ' OSDetectAndStatus.ProgressGauge.Value = 0 OSDetectAndStatus.GageLabel.Caption = CStr(NumToShow) DoEvents End Function 'Public Function RecallByID(ReadID As Long, From As String) As Gadget ' Dim RG As Gadget ' RG.Name = "Busy" ' Do While RG.Name = "Busy" ' RG = RecallByIDInternal(ReadID, From) ' 'DoEvents ' Loop ' RecallByID = RG 'End Function Friend Function RecallByID(ReadID As Long, From As String) As Gadget ' Dim BusyGadget As Gadget ' Static AmBusy As Boolean ' If AmBusy = True Then ' BusyGadget.Name = "Busy" ' RecallByIDInternal = BusyGadget ' Exit Function ' End If ' AmBusy = True Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Msg As String Dim TempGadget As Gadget Dim LParam As Gadget Dim ReturnedGadget As Gadget Dim Where As Gadget Dim WherePath As String Dim WhereName As String Dim InPathAndFile As String Dim Result As Gadget Dim DB As String Dim UCASEFrom As String Dim LocalError As String On Error GoTo LocalError SetProperty Trace, NextID("trace") & "RecallByID Start *********************************", "************************" SetProperty Trace, NextID("trace") & "RecallByID", CStr(ReadID) & " / " & From UCASEFrom = UCase(From) InPathAndFile = AllTrim(Right(From, Len(UCASEFrom) - InStr(UCASEFrom, "FROM") - 4)) Result.Name = "ERROR: Object read failed to locate the object #: " & CStr(ReadID) Select Case True Case From = "" ' no instructions, put in 1 DBSwitch 1 Case Left(UCASEFrom, 5) = "FROM " And InStr(UCASEFrom, "\") = 0 t = DBFindIndex(InPathAndFile) If t < 0 Then ' couldn't find this database, need to bomb SetProperty Trace, NextID("trace") & "FXN RecallByID Find DB Error: ", CStr(ReadID) & "/" & InPathAndFile & " / " & "Find Index Failed" SetProperty VGBErrors, NextID("error") & "FXN RecallByID Find DB Error: ", CStr(ReadID) & "/" & InPathAndFile & " / " & "Find Index Failed" Result.Name = "Could not Create: " & From FloatMsgBox Result.Name, "RecallByID Failure" GoTo EndSub End If DBSwitch Val(t) Case Left(UCASEFrom, 5) = "FROM " And InStr(UCASEFrom, "\") > 0 ' they specified a place with a path TempGadget = BlankObject SetProperty TempGadget, "PathFile", InPathAndFile ' "Where" includes path, current if not there Where = ExtractPathAndFile(TempGadget) ' variables are easier at times like this WherePath = AddBackSlash(UCase(ReadProperty(Where, "Path Only"))) WhereName = UCase(ReadProperty(Where, "File Only")) t = DBFindIndex(WherePath & WhereName) ' SetProperty Trace, NextID("trace") & "RecallByID Loc", CStr(ReadID) & ": " & From If t < 0 Then ' not found ' need to add it SetProperty Trace, NextID("trace") & "RecallByID Adding DB", WherePath & WhereName ' SetProperty StatusGadget, "DB Created", WherePath & WhereName LParam = BlankObject LParam.Name = "Parameters To Database Add Method" LParam.Type = "Parameter" LParam.Container = "AddDatabase" Msg = From SetProperty LParam, "Long Name", Msg SetProperty LParam, "SourcePath", AddBackSlash(UCase(App.Path)) SetProperty LParam, "SourceFile", "Empty.mem" SetProperty LParam, "DestPath", WherePath SetProperty LParam, "DestFile", WhereName SetProperty LParam, "Stop on error", "No" SetProperty LParam, "Write From", "Yes" SetProperty LParam, "Write From File DBGadgetPTR", CStr(0) SetProperty LParam, "Created by", "Virtual Cortex RecallByID" ReturnedGadget = AddDatabase(LParam) If ReadProperty(ReturnedGadget, "Status") <> OK Then SetProperty Trace, NextID("trace") & "FXN RecallByID Add DB Error", CStr(ReadID) & "/" & From & " / " & ReadProperty(ReturnedGadget, "Status") SetProperty VGBErrors, NextID("error") & "FXN RecallByID Add DB Error", CStr(ReadID) & "/" & From & " / " & ReadProperty(ReturnedGadget, "Status") Result = ReturnedGadget GoTo EndSub End If End If t = DBFindIndex(WherePath & WhereName) If t < 0 Then ' couldn't find this database, need to bomb SetProperty Trace, NextID("trace") & "FXN RecallByID Find DB Error: ", CStr(ReadID) & "/" & From & " / " & "Find Index Failed" SetProperty VGBErrors, NextID("error") & "FXN RecallByID Find DB Error: ", CStr(ReadID) & "/" & From & " / " & "Find Index Failed" Result.Name = "Could not Create: " & From FloatMsgBox Result.Name, "RecallByID Failure" GoTo EndSub End If DBSwitch Val(t) End Select ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", ReadID If ObjectsRS.NoMatch = False Then ' found it t = ReadGadgetByID(ReadID) If t = OK Then Result = ReadObjectBuffer End If End If GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "RecallbyID Trapped: " & LocalError, CStr(ReadID) & " / " & From SetProperty VGBErrors, NextID("error") & "RecallbyID Trapped: " & LocalError, CStr(ReadID) & " / " & From Resume Next EndSub: On Error GoTo 0 SetProperty Trace, NextID("trace") & "RecallByID Time", CStr(Timer - starttime) SetProperty Trace, NextID("trace") & "RecallByID End *********************************", "************************" CheckTrace ' AmBusy = False RecallByID = Result End Function 'Public Function ForgetByID(IDToForget As Long, From As String) As Gadget ' Dim RG As Gadget ' RG.Name = "Busy" ' Do While RG.Name = "Busy" ' RG = ForgetByIDInternal(IDToForget, From) ' 'DoEvents ' Loop ' ForgetByID = RG 'End Function Friend Function ForgetByID(IDToForget As Long, From As String) As Gadget ' Dim BusyGadget As Gadget ' Static AmBusy As Boolean ' If AmBusy = True Then ' BusyGadget.Name = "Busy" ' ForgetByIDInternal = BusyGadget ' Exit Function ' End If ' AmBusy = True Dim t Dim RREsults As Gadget Dim FResults As Gadget Dim LOCDBPTR As Integer Dim FromWhere As String Dim UCASEFrom As String Dim LocalError As String On Error GoTo LocalError LocalError = "" UCASEFrom = AllTrim(UCase(From)) Select Case True Case Left(UCASEFrom, 5) = "FROM " FromWhere = AllTrim(Right(From, Len(UCASEFrom) - 5)) Case Else FromWhere = AllTrim(From) End Select ' set the databse to the correct one, if specified If FromWhere <> "" Then LOCDBPTR = DBFindIndex(FromWhere) If LOCDBPTR < 0 Then SetProperty Trace, NextID("trace") & "ForgetByID Not trapped Error", "DB Findindex failed: " & FromWhere FResults.Name = From & " " & NotFound SetProperty FResults, "Error", From & NotFound GoTo EndSub End If LOCDBPTR = Val(LOCDBPTR) t = DBSwitch(LOCDBPTR) If t <> OK Then FResults.Name = "ForgetByID From Failed DBSwitch" SetProperty Trace, NextID("trace") & "ForgetByID Not trapped Error", "DB Switch failed: " & CStr(t) & "/" & FromWhere SetProperty VGBErrors, NextID("error") & "ForgetByID Not trapped Error", "DB Switch failed: " & CStr(t) & "/" & FromWhere SetProperty FResults, "DBSwitch Failed", CStr(t) GoTo EndSub End If End If t = DeleteGadget(IDToForget) FResults.Name = CStr(t) SetProperty FResults, "Delete Results", CStr(t) GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "ForgetByID Trapped Error", LocalError SetProperty VGBErrors, NextID("error") & "ForgetByID Trapped Error", LocalError Resume Next EndSub: ' AmBusy = False ForgetByID = FResults End Function 'Public Function Forget(Sentence As String, From As String) As Gadget ' Dim RG As Gadget ' RG.Name = "Busy" ' Do While RG.Name = "Busy" ' RG = ForgetInternal(Sentence, From) ' 'DoEvents ' Loop ' Forget = RG 'End Function Friend Function Forget(Sentence As String, From As String) As Gadget ' this will forget things, forgotten things are moved to a database called forgotten ' Dim BusyGadget As Gadget ' Static AmBusy As Boolean ' If AmBusy = True Then ' BusyGadget.Name = "Busy" ' ForgetInternal = BusyGadget ' Exit Function ' End If ' AmBusy = True Dim starttime As Single, stoptime As Single Dim SQLCmd As String starttime = Timer Dim tstarttime As Single, tstoptime As Single, ttime As Single Dim t, Msg As String, Cntr1 As Long, CNTR2 As Long Dim RREsults As Gadget, DResults As Gadget Dim ListOfNamesToForget As Gadget, ListOfNamesToForgetCNTR As Long Dim TotToForget As Long Dim Status As Gadget Dim TotDone As Long, TotToDo As Long, RCancel As Boolean Dim LParam As Gadget Dim CurAppGadgets() As Gadget, CurAppGadgetsCNTR As Long, CurAppGadgetsPTR As Long Dim Result As Gadget Dim StartDBPTR As Integer, LOCDBPTR As Integer Dim UCASESentence As String, TSentence As String Dim UCASEFrom As String Dim FromWhere As String Dim AllNames() As String, AllNamesPTR As Long, AllNamesCNTR As Long Dim AllNamesDBs() As Integer, AllNamesDBsPTR As Long, AllNamesDBsCNTR As Long Dim AllNamesIDs() As Long Dim PropsBookmark As String Dim TotalNamesChecked As Long Dim ThisID As Long Dim IncludeNameInList As Boolean Dim AccumulatedGadgets() As Gadget, AccumulatedGadgetsPTR As Long, AccumulatedGadgetsCNTR As Long Dim ObjectName As String Dim AllProps() As String, AllPropsPTR As Long, AllpropsCNTR As Long Dim Props() As String, PropsPTR As Long, PropsCNTR As Long Dim PropValues() As String Dim CurrentProp As String, CurrentPropValue As String Dim LocalError As String On Error GoTo LocalError SetProperty Trace, NextID("trace") & "Forget Start *********************************", "************************" SetProperty Trace, NextID("trace") & "Forgetting", Sentence StartDBPTR = DBGadgetsPTR Sentence = AllTrim(Sentence) UCASESentence = UCase(Sentence) From = AllTrim(From) UCASEFrom = UCase(From) Status.Name = Sentence ' SetProperty Status, "Forgeting", Sentence Select Case True Case Left(UCASEFrom, 5) = "FROM " FromWhere = AllTrim(Right(From, Len(UCASEFrom) - 5)) Case Else FromWhere = AllTrim(From) End Select If InStr(UCASESentence, " WITH: ") > 0 Then ' this one has properties TSentence = AllTrim(Right(Sentence, Len(UCASESentence) - InStr(UCASESentence, " WITH:") - 5)) AllProps = Split(TSentence, ",") AllpropsCNTR = UBound(AllProps) For AllPropsPTR = 0 To AllpropsCNTR If InStr(AllProps(AllPropsPTR), "=") > 0 Then PropsCNTR = PropsCNTR + 1 ReDim Preserve Props(PropsCNTR) ReDim Preserve PropValues(PropsCNTR) Props(PropsCNTR) = AllTrim(Left(AllProps(AllPropsPTR), InStr(AllProps(AllPropsPTR), "=") - 1)) PropValues(PropsCNTR) = AllTrim(Right(AllProps(AllPropsPTR), Len(AllProps(AllPropsPTR)) - InStr(AllProps(AllPropsPTR), "="))) Msg = Msg & "[" & PropsCNTR & ": " & Props(PropsCNTR) & "=" & PropValues(PropsCNTR) & "] " & CrLf Else ' no property value, just property name PropsCNTR = PropsCNTR + 1 ReDim Preserve Props(PropsCNTR) ReDim Preserve PropValues(PropsCNTR) Props(PropsCNTR) = AllTrim(AllProps(AllPropsPTR)) PropValues(PropsCNTR) = "" Msg = Msg & "[" & PropsCNTR & ": " & Props(PropsCNTR) & "=" & PropValues(PropsCNTR) & "] " & CrLf End If Next End If ' FloatMsgBox Msg, "Forget" If FromWhere <> "" Then Select Case True Case UCASEFrom = "BRAIN" Or _ UCASEFrom = "FROM BRAIN" Or _ UCASEFrom = "FROM: BRAIN" Or _ UCASEFrom = "FROM LONG TERM MEMORY" Case Else LOCDBPTR = DBFindIndex(FromWhere) If LOCDBPTR < 0 Then SetProperty Trace, NextID("trace") & "ForgetByID Not trapped Error", "DB Findindex failed: " & FromWhere Result.Name = From & " " & NotFound SetProperty Result, "Error", From & " " & NotFound GoTo EndSub End If LOCDBPTR = Val(LOCDBPTR) t = DBSwitch(LOCDBPTR) If t <> OK Then Result.Name = "Forget From Failed DBSwitch" SetProperty Trace, NextID("trace") & "Forget Not trapped Error", "DB Switch failed: " & CStr(t) & "/" & FromWhere SetProperty VGBErrors, NextID("error") & "Forget Not trapped Error", "DB Switch failed: " & CStr(t) & "/" & FromWhere SetProperty Result, "DBSwitch Failed", CStr(t) GoTo EndSub End If End Select End If Select Case True Case UCASESentence = "ALL OBJECTS" ' whoa, deleting all SQLCmd = "DELETE Objects.* FROM Objects " ' where (((Props.Property)='group') AND ((Props.ValueAlpha)='user defined')) ORDER BY Objects.Name;" OpenDB(OpenDBPTR).Execute SQLCmd If LocalError <> "" Then Result.Name = LocalError Else Result.Name = "OK" End If Case UCASEFrom = "BRAIN" Or _ UCASEFrom = "FROM BRAIN" Or _ UCASEFrom = "FROM: BRAIN" Or _ InStr(UCASEFrom, "MEMORIES") > 0 Or _ InStr(UCASEFrom, "LONG TERM MEMORY") > 0 ' this is a removal of a memories pool ' this case the first parameter has the db designation ' save the appgadgets for reinit after delete For CurAppGadgetsPTR = 1 To AppGadgetsCNTR CurAppGadgetsCNTR = CurAppGadgetsPTR ReDim Preserve CurAppGadgets(CurAppGadgetsPTR) CurAppGadgets(CurAppGadgetsPTR) = AppGadgets(CurAppGadgetsPTR) Next ' get a list of all gadgets to delete ListOfNamesToForget = Recall("names with: DB name=" & Sentence, "From " & VGBDatabaseName) ListOfNamesToForgetCNTR = Val(ListOfNamesToForget.Name) If ListOfNamesToForgetCNTR = 0 Then Result.Name = "Forget From Brain Failed" SetProperty Trace, NextID("trace") & "Forget Not trapped Error", "No System files found" & CStr(t) & "/" & Sentence SetProperty VGBErrors, NextID("error") & "Forget Not trapped Error", "No System files found" & CStr(t) & "/" & Sentence SetProperty Result, "DB Delete Failed", "No Database Found" GoTo EndSub End If ' delete all the gadgets as needed For Cntr1 = 1 To ListOfNamesToForgetCNTR Msg = ReadProperty(ListOfNamesToForget, "Name " & CStr(Cntr1)) If Msg = NotFound Then Exit For End If RREsults = Recall(Msg, "from " & VGBDatabaseName) SetProperty Result, "Deleting " & CStr(Cntr1), Msg SetProperty Result, "Deleting ID" & CStr(Cntr1), CStr(RREsults.ObjectID) If InStr(UCase(Msg), VGBDatabaseName) Then Result.Name = "System File Deleted" SetProperty Result, "System File", "Deleted" Else DResults = ForgetByID(RREsults.ObjectID, "from " & VGBDatabaseName) SetProperty Result, "Delete Results " & CStr(Cntr1), CStr(DResults.Name) End If Next If Result.Name = "System File Deleted" Then ' they disable me, gotta go DResults = ForgetByID(RREsults.ObjectID, "from " & VGBDatabaseName) For Cntr1 = 0 To OpenDBPTR OpenDB(Cntr1).Close Next GoTo Abort End If ' now we need to start ourselves again DebugVGB "clear trace" LParam.Name = "Reset" RREsults = InitVGB(LParam) For CurAppGadgetsPTR = 1 To CurAppGadgetsCNTR RREsults = WakeUp(CurAppGadgets(CurAppGadgetsPTR)) SetProperty Trace, NextID("trace") & CurAppGadgets(CurAppGadgetsPTR).Name, "Restarted by forget" SetProperty Result, CurAppGadgets(CurAppGadgetsPTR).Name, "Restarted" Next CurAppGadgetsPTR Result.Name = Sentence & " memories pool forgotten" SetProperty Result, "Total Time", CStr(Timer - starttime) GoTo EndSub Case Left(UCASESentence, 4) = "ALL " And InStr(UCASESentence, " WITH: ") > 0 ObjectsRS.Index = "PrimaryKey" PropsRS.Index = "ValueAlpha" PropsRS.Seek "=", PropValues(1) Do While PropsRS.NoMatch = False If UCase(PropsRS!Property) = UCase(Props(1)) Then ObjectsRS.Seek "=", PropsRS!ObjectID AllNamesCNTR = AllNamesCNTR + 1 ReDim Preserve AllNames(AllNamesCNTR) ReDim Preserve AllNamesDBs(AllNamesCNTR) ReDim Preserve AllNamesIDs(AllNamesCNTR) AllNames(AllNamesCNTR) = ObjectsRS!Name AllNamesDBs(AllNamesCNTR) = LOCDBPTR AllNamesIDs(AllNamesCNTR) = PropsRS!ObjectID Result.TotalProperties = Result.TotalProperties + 1 ReDim Preserve Result.Propity(Result.TotalProperties) ReDim Preserve Result.ValueAlpha(Result.TotalProperties) Result.Propity(Result.TotalProperties) = "Name " & CStr(AllNamesCNTR) Result.ValueAlpha(Result.TotalProperties) = ObjectsRS!Name If Result.TotalProperties Mod 50 = 0 Then 'FloatMsgBox "Total Done: " & CStr(Result.TotalProperties), "Forget Status" ' SetProperty Status, "Done", CStr(Result.TotalProperties) TotDone = Result.TotalProperties TotToDo = 0 ' RaiseEvent RecallStatus(TotDone, TotToDo, RCancel) If RCancel = True Then Result.Name = Sentence & " Cancelled" GoTo EndSub End If ' DoEvents End If End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If If PropsRS!ValueAlpha <> PropValues(1) Then Exit Do End If Loop Case Else RREsults = Recall(Sentence, From) If UCase(RREsults.Name) <> UCase(Sentence) Then Result.Name = "Error Forgetting " & Sentence & " " & From SetProperty Result, "Error", "Forget didn't find Object" GoTo EndSub End If Result = ForgetByID(RREsults.ObjectID, From) End Select GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "Forget Trapped: " & LocalError, Sentence & " / " & From SetProperty VGBErrors, NextID("error") & "Forget Trapped: " & LocalError, Sentence & " / " & From Resume Next EndSub: If StartDBPTR <> DBGadgetsPTR Then DBSwitch StartDBPTR End If SetProperty Trace, NextID("trace") & "Forget Time", CStr(Timer - starttime) SetProperty Trace, NextID("trace") & "Forget End *********************************", "************************" On Error GoTo 0 ' AmBusy = False DBEngine.Idle dbRefreshCache Abort: Forget = Result End Function Friend Function StrTimer() As String StrTimer = " [" & CStr(Timer) & "] " End Function Friend Function NextID(V As String) As String Static LastErrorID As String, LastTraceID As String Dim NextIDString As String V = UCase(V) Select Case True Case TraceOn = False And (LastTraceID <> "") NextIDString = LastTraceID Case (V = "ERROR") Or ((V = "LAST ERROR") And (LastErrorID = "")) VGBErrorsCNTR = VGBErrorsCNTR + 1 NextIDString = "[" & CStr(Timer) & "] " & "(" & CStr(VGBErrorsCNTR) & ") " LastErrorID = NextIDString Case V = "LAST ERROR" NextIDString = LastErrorID Case V = "TRACE" Or ((V = "LAST TRACE") And (LastTraceID = "")) TraceCNTR = TraceCNTR + 1 NextIDString = "[" & CStr(Timer) & "] " & "(" & CStr(TraceCNTR) & ") " LastTraceID = NextIDString Case V = "LAST TRACE" NextIDString = LastTraceID End Select NextID = NextIDString End Function Friend Function ProcessTask(Task As Gadget, Param As Gadget) As Gadget ' this is the interface to the gadgetor module ' all calls to tasks go thru this portal Dim starttime As Single, stoptime As Single starttime = Timer Dim Cntr1 As Long, TotTasks As Long Dim ResultsGadget As Gadget SetProperty ResultsGadget, "Status", "Task Processor Start" SetProperty ResultsGadget, "Error", "Task Not Found" Select Case True Case UCase(Task.Name) = UCase("") ' this is a template Case UCase(Task.Name) = UCase("Wake Up") ' start up ' mark instance only InstancesCNTR = InstancesCNTR + 1 Case UCase(Task.Name) = UCase("STOP!") ' STOP ' must stop NOW, questionable if works StopWhateverYourDoing = True Case UCase(Task.Name) = UCase("Send Status") ' Send Status ' must stop NOW ResultsGadget = StatusGadget Case UCase(Task.Name) = UCase("Remember") ' remember ' must remember ResultsGadget = Remember(Task, Param) Case UCase(Task.Name) = UCase("Describe") ' describe ' must describe ResultsGadget = Describe(Task, Param) ' Case UCase(Task.Name) = UCase("Rename") ' rename ' ' must rename ' ResultsGadget = Rename(Task, Param) Case UCase(Task.Name) = UCase("Forget") ' forget ' must forget 'ResultsGadget = Forget(Task, Param) Case UCase(Task.Name) = UCase("Delete") ' delete ' must forget ResultsGadget = Delete(Task, Param) Case UCase(Task.Name) = UCase("Group") ' group ' must group ResultsGadget = Group(Task, Param) Case UCase(Task.Name) = UCase("Cut") ' cut ' must cut ResultsGadget = Cut(Task, Param) Case UCase(Task.Name) = UCase("Copy") ' copy ' must copy ResultsGadget = Copy(Task, Param) Case UCase(Task.Name) = UCase("Paste") ' paste ' must paste ResultsGadget = Cut(Task, Param) Case UCase(Task.Name) = UCase("ReadGadget") ' readgadget ' ResultsGadget = ReadGadget(Param) Case UCase(Task.Name) = UCase("AddDatabase") ' adddatabase ' ResultsGadget = AddDatabase(Param) Case UCase(Task.Name) = UCase("dbswitch") ' low level stuff DBSwitch Val(ReadProperty(Task, "Switch to")) ' switch database Case UCase(Task.Name) = UCase("Show Status") ' show the status screen VGBStatusScreen.Show Case UCase(Task.Name) = UCase("") ' Case UCase(Task.Name) = UCase("") ' Case UCase(Task.Name) = UCase("") ' End Select ' ResultsGadget = Task ' ResultsGadget.Name = "Processor Results" ' SetProperty ResultsGadget, "Status", "Test" ' SetProperty ResultsGadget, "Result", "Returning Task only" If ResultsGadget.Status = "" Then ResultsGadget.Status = CStr(Timer - starttime) & " : Process Time" End If On Error GoTo 0 ProcessTask = ResultsGadget End Function Friend Function Remember(Task As Gadget, Param As Gadget) As Gadget ' this will parse the remember command, build a rememberer task ' and pass it to the rememberer which remembers something Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Msg As String, Msg2 As String, Cntr1 As Long, CNTR2 As Long Dim ResultsGadget As Gadget ' Dim StatusGadget As Gadget Dim LTask As Gadget, LParam As Gadget Dim TGadget As Gadget Dim Criteria As String Dim SplitCriteria() As String Dim TotalParts As Long Dim Prop As String, PropValue As String Dim Props() As String, PropValues() As String Dim PropsCNTR As Long, PropsPTR As Long Dim TotalGadgetsFound As Long Dim AutoCreate As Boolean Dim DoAll As Boolean Dim WhatToRemember As String Dim Command As String Dim LongTermMemoryDBPTR As Integer Dim StartDBPTR As Integer Dim Aliases(5) As String, AliasesPTR As Long, AliasesCNTR As Long Dim LocalError As String, ErrorCNTR As Long On Error GoTo LocalError StartDBPTR = DBGadgetsPTR LongTermMemoryDBPTR = DBFindIndex(VGBDatabaseName) ResultsGadget = Task ResultsGadget.Name = "Remember Started" If LongTermMemoryDBPTR < 0 Then ' no long term memory ' can't be so SetProperty ResultsGadget, "Error", "No Database Found" FloatMsgBox "No Long Term Memory File!", "Severe Error" SetProperty ResultsGadget, "Error", "No Database Found" GoTo EndSub End If ' these are the accepted names of the command string we use Aliases(1) = UCase("Command") Aliases(2) = UCase("Remember") Aliases(3) = UCase("Remember Wut") Aliases(4) = UCase("Criteria") Aliases(5) = UCase("User") AliasesCNTR = UBound(Aliases) DBSwitch LongTermMemoryDBPTR For Cntr1 = 1 To AliasesCNTR Criteria = ReadProperty(Task, Aliases(Cntr1)) If Criteria <> NotFound Then Exit For End If Next SetProperty ResultsGadget, "Criteria", Criteria If Criteria = NotFound Then SetProperty ResultsGadget, "Error", "No Command String to Process" GoTo EndSub End If ' let's doctor up the passed Criteria before splitting Criteria = AllTrim(Criteria) If Right(Criteria, 1) = "," Then Criteria = Left(Criteria, Len(Criteria) - 1) End If If Right(Criteria, 2) = CrLf Then Criteria = Left(Criteria, Len(Criteria) - 2) End If If Right(Criteria, 1) = Cr Then Criteria = Left(Criteria, Len(Criteria) - 1) End If If Right(Criteria, 1) = Lf Then Criteria = Left(Criteria, Len(Criteria) - 1) End If SplitCriteria = Split(Criteria, ",") TotalParts = UBound(SplitCriteria) ReDim Preserve SplitCriteria(TotalParts + 1) ' fix zero based array bs and remove commas For Cntr1 = TotalParts + 1 To 1 Step -1 If AllTrim(SplitCriteria(Cntr1)) <> "," Then SplitCriteria(Cntr1) = AllTrim(SplitCriteria(Cntr1 - 1)) End If Next TotalParts = UBound(SplitCriteria) AutoCreate = False AutoCreate = (ReadProperty(Task, "AutoCreate") = "True") Or (ReadProperty(Task, "AutoCreate") = NotFound) SetProperty StatusGadget, "AutoCreate Flag", CStr(AutoCreate) ' DoAll = InStr(UCase(SplitCriteria(2)), "ALL ") > 0 And _ (InStr(UCase(SplitCriteria(2)), " WITH ") > 0 Or _ InStr(UCase(SplitCriteria(2)), " TYPE") > 0 Or _ InStr(UCase(SplitCriteria(2)), " ALL GADGETS OF TYPE") > 0 Or _ InStr(UCase(SplitCriteria(2)), " GADGET") > 0) ' SetProperty ResultsGadget, "DoAll", CStr(DoAll) ' set status gadget up (client can read status to see what last happened) SetProperty ResultsGadget, "Total Parts", CStr(TotalParts) For Cntr1 = 1 To TotalParts SetProperty ResultsGadget, "Part " & CStr(Cntr1), SplitCriteria(Cntr1) Next StatusGadget = ResultsGadget Command = UCase(SplitCriteria(2)) Select Case True Case InStr(Command, UCase("All Gadgets With Properties")) > 0 ' remember, All Gadgets With Properties, prop1=value1,prop2=value2 ...etc SetProperty StatusGadget, "Case", "InStr(UCase(SplitCriteria(2)), ""All Gadgets With Properties"") > 0" Case InStr(Command, UCase("All Gadgets With Property X")) > 0 Case InStr(Command, UCase("All Gadget Names")) > 0 Or (Command = UCase("All Gadgets")) Or (Command = UCase("All Names")) ' send gadget with all gadget names as properties SetProperty StatusGadget, "Case", "InStr(UCase(SplitCriteria(2)), ""All Gadget Names"") > 0" LocalError = "" ObjectsRS.Index = "Name" ObjectsRS.MoveFirst If LocalError <> "" Then SetProperty ResultsGadget, "Error", LocalError GoTo EndSub End If ResultsGadget = BlankObject ResultsGadget.Name = SplitCriteria(2) Cntr1 = 0 Do While ObjectsRS.EOF = False Cntr1 = Cntr1 + 1 SetProperty ResultsGadget, ObjectsRS!Name, CStr(Cntr1) ObjectsRS.MoveNext If LocalError <> "" Then Exit Do End If Loop Case TotalParts > 2 And (InStr(SplitCriteria(2), "=") = 0) And _ (InStr(SplitCriteria(3), "=") > 0) ' memorize all properties for this gadget ' remember, My Gadget, prop1=prop value1, prop2=prop value2... etc LTask.Name = SplitCriteria(2) LTask.ObjectID = "0" SetProperty LTask, "ReadBy", "Name" TGadget = ReadGadget(LTask) Select Case True Case TGadget.Name = NotFound ' need to create this gadget TGadget = BlankObject TGadget.Name = SplitCriteria(2) TGadget.ObjectID = 0 Case Else ' return the property 'SetProperty TGadget, SplitCriteria(3), SplitCriteria(4) End Select ' now, set all properties to the described values ' a property is like this prop name=prop value ' key in on equal For Cntr1 = 3 To TotalParts If InStr(SplitCriteria(Cntr1), "=") > 0 Then Prop = Left(SplitCriteria(Cntr1), InStr(SplitCriteria(Cntr1), "=") - 1) Prop = AllTrim(Prop) PropValue = Right(SplitCriteria(Cntr1), Len(SplitCriteria(Cntr1)) - InStr(SplitCriteria(Cntr1), "=")) PropValue = AllTrim(PropValue) Select Case True Case UCase(Prop) = "TYPE" TGadget.Type = PropValue Case UCase(Prop) = "CONTAINER" TGadget.Container = PropValue Case Else End Select SetProperty TGadget, Prop, PropValue End If Next Cntr1 WriteMemGadget TGadget.ObjectID, TGadget ResultsGadget = TGadget Case TotalParts >= 2 And (InStr(SplitCriteria(2), "=") > 0) Or _ (InStr(Command, "All Gadgets With") > 0) ' remember the names of all gadgets with given properties ' remember, color,length=12,length units=inches ' or ' remember, All Gadgets With, color=red,length=12,length units=inches ' or, just with the property itself ' remember, All Gadgets With, color,length ' or, a combination of above ' remember, All Gadgets With, color=red,length ' remember, color=red,length=12,length units=inches ResultsGadget = BlankObject ResultsGadget.Name = "Results of " & Criteria SetProperty StatusGadget, "Case", "InStr(UCase(SplitCriteria(2)), ""ALL"") > 0" SetProperty StatusGadget, "Command", SplitCriteria(2) ' ShowGadget StatusGadget CNTR2 = 0 For Cntr1 = 3 To TotalParts SetProperty StatusGadget, "Part: " & CStr(Cntr1), SplitCriteria(Cntr1) If InStr(SplitCriteria(Cntr1), "=") Then 'StatusGadget = BlankObject StatusGadget.Name = "Started Parsing" PropsCNTR = PropsCNTR + 1 ReDim Preserve Props(PropsCNTR) ReDim Preserve PropValues(PropsCNTR) Props(PropsCNTR) = Left(SplitCriteria(Cntr1), InStr(SplitCriteria(Cntr1), "=") - 1) Props(PropsCNTR) = AllTrim(Props(PropsCNTR)) PropValues(PropsCNTR) = Right(SplitCriteria(Cntr1), Len(SplitCriteria(Cntr1)) - InStr(SplitCriteria(Cntr1), "=")) PropValues(PropsCNTR) = AllTrim(PropValues(PropsCNTR)) SetProperty StatusGadget, "Property: " & CStr(PropsCNTR) & " = " & Props(PropsCNTR), PropValues(PropsCNTR) ' ShowGadget StatusGadget End If Next Cntr1 ' here we have all the properties and values in arrays, need to build a list ' of all gadget names wiht these things Case TotalParts = 2 ' simple remember object statement ' remember, object name ' second part is the object to remember ' simple read from disk by name SetProperty StatusGadget, "Case", "TotalParts=2" LTask.Name = Command LTask.ObjectID = "0" SetProperty LTask, "ReadBy", "Name" TGadget = ReadGadget(LTask) Select Case True Case (TGadget.Name = NotFound) And (AutoCreate = False) ' not found and autocreate is a not SetProperty StatusGadget, "Status", Command & " " & NotFound Case (TGadget.Name = NotFound) And (AutoCreate = True) ' need to create it SetProperty StatusGadget, "Status", "TGadget.Name = NotFound And (AutoCreate = True)" TGadget = BlankObject TGadget.ObjectID = 0 TGadget.Name = SplitCriteria(2) WriteMemGadget TGadget.ObjectID, TGadget ResultsGadget = TGadget Case TGadget.Name <> NotFound ' found this gadget SetProperty StatusGadget, "Status", "TGadget.Name <> NotFound" ResultsGadget = TGadget SetProperty StatusGadget, "Found", TGadget.Name End Select Case TotalParts > 2 And (InStr(SplitCriteria(3), "=") = 0) SetProperty StatusGadget, "Case", "TotalParts > 2 And (InStr(SplitCriteria(3), ""="") = 0)" ' asking for property(s) of a gadget ' must handle: ' remember, gadget, prop1, prop2 ...etc ' which properties do they want? LTask.Name = Command LTask.ObjectID = "0" SetProperty LTask, "ReadBy", "Name" TGadget = ReadGadget(LTask) Select Case True Case TGadget.Name = NotFound SetProperty StatusGadget, "Status", "TGadget.Name = NotFound" ResultsGadget = TGadget SetProperty ResultsGadget, "Error", Command & " " & NotFound SetProperty ResultsGadget, "Looking For", Command SetProperty ResultsGadget, "Command", Criteria Case Else ' return the property SetProperty StatusGadget, "Status", "TGadget.Name <> NotFound" ResultsGadget = BlankObject ResultsGadget.Name = Criteria For Cntr1 = 3 To TotalParts SetProperty ResultsGadget, SplitCriteria(Cntr1), ReadProperty(TGadget, SplitCriteria(Cntr1)) SetProperty StatusGadget, SplitCriteria(Cntr1), ReadProperty(TGadget, SplitCriteria(Cntr1)) Next Cntr1 End Select Case InStr(Command, UCase("")) > 0 End Select GoTo EndSub '/////////////////////////////////////////////////////////////////////////////////////////////////// 'OLD STUFF Select Case True Case DoAll Select Case True Case (InStr(UCase(SplitCriteria(2)), "ALL GADGETS OF TYPE") > 0) ' all gadgets of given type LocalError = "" ObjectsRS.Index = "Type" ObjectsRS.Seek "=", SplitCriteria(3) If LocalError <> "" Then SetProperty ResultsGadget, "Error", LocalError GoTo EndSub End If If ObjectsRS.NoMatch = True Then SetProperty ResultsGadget, "Error", SplitCriteria(3) & " " & NotFound GoTo EndSub End If ResultsGadget = BlankObject ResultsGadget.Name = SplitCriteria(2) Cntr1 = 0 Do While ObjectsRS.NoMatch = False Cntr1 = Cntr1 + 1 SetProperty ResultsGadget, ObjectsRS!Name, CStr(Cntr1) ObjectsRS.MoveNext If LocalError <> "" Then SetProperty StatusGadget, Criteria & " Failed", LocalError Exit Do End If If ObjectsRS.EOF Then SetProperty StatusGadget, Criteria & " Exited", "EOF" Exit Do End If If UCase(ObjectsRS!Type) <> UCase(SplitCriteria(3)) Then SetProperty StatusGadget, Criteria & " Exited", UCase(ObjectsRS!Type) & "<>" & (SplitCriteria(3)) Exit Do End If Loop Case (InStr(UCase(SplitCriteria(2)), "GADGET") > 0) And (TotalParts = 2) ' all gadget names LocalError = "" ObjectsRS.Index = "Name" ObjectsRS.MoveFirst If LocalError <> "" Then SetProperty ResultsGadget, "Error", LocalError GoTo EndSub End If ResultsGadget = BlankObject ResultsGadget.Name = SplitCriteria(2) Cntr1 = 0 Do While ObjectsRS.EOF = False Cntr1 = Cntr1 + 1 SetProperty ResultsGadget, ObjectsRS!Name, CStr(Cntr1) ObjectsRS.MoveNext If LocalError <> "" Then Exit Do End If Loop Case (InStr(UCase(SplitCriteria(2)), "GADGET") > 0) And (TotalParts > 2) ' need to get all the properties coralled ResultsGadget = BlankObject ResultsGadget.Name = "Results of " & Criteria SetProperty StatusGadget, "Case", "InStr(UCase(SplitCriteria(2)), ""ALL"") > 0" SetProperty StatusGadget, "Do All Command", SplitCriteria(2) ' ShowGadget StatusGadget CNTR2 = 0 For Cntr1 = 3 To TotalParts SetProperty StatusGadget, "Part: " & CStr(Cntr1), SplitCriteria(Cntr1) ShowGadget StatusGadget If InStr(SplitCriteria(Cntr1), "=") Then 'StatusGadget = BlankObject StatusGadget.Name = "Started Parsing" PropsCNTR = PropsCNTR + 1 ReDim Preserve Props(PropsCNTR) ReDim Preserve PropValues(PropsCNTR) Props(PropsCNTR) = Left(SplitCriteria(Cntr1), InStr(SplitCriteria(Cntr1), "=") - 1) Props(PropsCNTR) = AllTrim(Props(PropsCNTR)) PropValues(PropsCNTR) = Right(SplitCriteria(Cntr1), Len(SplitCriteria(Cntr1)) - InStr(SplitCriteria(Cntr1), "=")) PropValues(PropsCNTR) = AllTrim(PropValues(PropsCNTR)) SetProperty StatusGadget, "Property: " & CStr(PropsCNTR) & " = " & Props(PropsCNTR), PropValues(PropsCNTR) ShowGadget StatusGadget End If Next Cntr1 ' ShowGadget StatusGadget PropsRS.Index = "Property" Cntr1 = 0 For PropsPTR = 1 To PropsCNTR PropsRS.Seek "=", Props(PropsPTR) SetProperty StatusGadget, "BM After Seek", PropsRS.Bookmark Do While PropsRS.NoMatch = False SetProperty StatusGadget, "Seek Found", PropsRS!Property & ":" & PropsRS!ValueAlpha ShowGadget StatusGadget If UCase(PropsRS!ValueAlpha) = UCase(PropValues(PropsPTR)) Then SetProperty StatusGadget, "Reading: " & Props(PropsPTR), PropValues(PropsPTR) SetProperty StatusGadget, "Props ObjectID before Read", CStr(PropsRS!ObjectID) SetProperty StatusGadget, "Props Name before Read", PropsRS!Property SetProperty StatusGadget, "-", "-" TGadget = BlankObject TGadget = ReadDiskGadgetByID(PropsRS!ObjectID) SetProperty StatusGadget, "Props ObjectID After Read", CStr(PropsRS!ObjectID) SetProperty StatusGadget, "Props Name after Read", PropsRS!Property SetProperty StatusGadget, "Found Gadget ID ", CStr(TGadget.ObjectID) SetProperty StatusGadget, "Found Gadget Name", TGadget.Name ShowGadget StatusGadget If TGadget.Name <> NotFound Then SetProperty StatusGadget, "Seek: " & Props(PropsPTR), "Found" SetProperty StatusGadget, "Name", TGadget.Name ShowGadget StatusGadget For Cntr1 = 1 To ResultsGadget.TotalProperties If ResultsGadget.ValueAlpha(Cntr1) = TGadget.Name Then Exit For End If Next If Cntr1 > ResultsGadget.TotalProperties Then SetProperty StatusGadget, "Gadget Added", TGadget.Name ShowGadget StatusGadget TotalGadgetsFound = TotalGadgetsFound + 1 SetProperty ResultsGadget, Format(CStr(TotalGadgetsFound), "#####") & ") ", TGadget.Name End If End If End If SetProperty StatusGadget, "BM Before MoveNext", PropsRS.Bookmark SetProperty StatusGadget, "Property Before MoveNext", PropsRS!Property & " : " & PropsRS!ValueAlpha PropsRS.MoveNext SetProperty StatusGadget, "BM After MoveNext", PropsRS.Bookmark SetProperty StatusGadget, "Property After MoveNext", PropsRS!Property & " : " & PropsRS!ValueAlpha CNTR2 = CNTR2 + 1 SetProperty StatusGadget, "MoveNext Counter", CStr(CNTR2) If PropsRS.EOF Then SetProperty StatusGadget, "Exit Reason", "EOF" Exit Do End If If UCase(PropsRS!Property) <> UCase(Props(PropsPTR)) Then SetProperty StatusGadget, "Exit Reason", UCase(PropsRS!Property) & "<>" & UCase(Props(PropsPTR)) Exit Do End If Loop Next PropsPTR ' Select Case True ' Case UCase(Props(PropsPTR)) = "TYPE" ' TGadget.Type = PropValue ' Case UCase(Props(PropsPTR)) = "CONTAINER" ' TGadget.Container = PropValue ' Case Else ' End Select End Select 'ResultsGadget = TGadget Case TotalParts = 1 ' 1 word command SetProperty StatusGadget, "Case", "TotalParts = 1" Select Case True Case InStr(UCase(Criteria), "TYPE") > 0 Cntr1 = 0 ObjectsRS.Index = "Type" ObjectsRS.MoveFirst Do While ObjectsRS.NoMatch = False Cntr1 = Cntr1 + 1 SetProperty ResultsGadget, Format(CStr(Cntr1), "#####") & ") ", ObjectsRS!Type Msg = ObjectsRS!Type Do While Msg = ObjectsRS!Type ObjectsRS.MoveNext If ObjectsRS.EOF Then GoTo EndSub End If Loop If ObjectsRS.EOF Then Exit Do End If Loop End Select Case TotalParts = 2 And (InStr(UCase(SplitCriteria(2)), "TYPE") > 0) Or (InStr(UCase(SplitCriteria(2)), "ALL TYPE") > 0) ' send types SetProperty StatusGadget, "Case", "TotalParts = 2 And InStr(UCase(SplitCriteria(2)), ""TYPE"") > 0" Cntr1 = 0 ObjectsRS.Index = "Type" ObjectsRS.MoveFirst ResultsGadget = BlankObject ResultsGadget.Name = "All Types" Do While ObjectsRS.NoMatch = False Cntr1 = Cntr1 + 1 SetProperty ResultsGadget, ObjectsRS!Type, CStr(Cntr1) Msg = ObjectsRS!Type Do While Msg = ObjectsRS!Type ObjectsRS.MoveNext If ObjectsRS.EOF Then GoTo EndSub End If Loop If ObjectsRS.EOF Then Exit Do End If Loop Case TotalParts = 2 And InStr(UCase(SplitCriteria(2)), " AS ") > 0 SetProperty StatusGadget, "Case", "TotalParts = 2 And InStr(UCase(SplitCriteria(2)), "" AS "") > 0" ' gotta make clone of 1st gadget as 2nd gadget ' what is 1st gadget name Msg = Left(SplitCriteria(2), InStr(SplitCriteria(2), " AS ")) Case TotalParts = 2 And Not DoAll SetProperty StatusGadget, "Case", "TotalParts = 2 And Not DoAll" ' simple remember object statement ' remember, object name ' second part is the object to remember ' simple read from disk by name LTask.Name = SplitCriteria(2) LTask.ObjectID = "0" SetProperty LTask, "ReadBy", "Name" TGadget = ReadGadget(LTask) Select Case True Case TGadget.Name = NotFound ' need to create it TGadget = BlankObject TGadget.ObjectID = 0 TGadget.Name = SplitCriteria(2) WriteMemGadget TGadget.ObjectID, TGadget ResultsGadget = TGadget Case Else ' found this gadget ResultsGadget = TGadget End Select Case TotalParts = 3 And (InStr(SplitCriteria(3), "=") = 0) And Not DoAll SetProperty StatusGadget, "Case", "TotalParts = 3 And (InStr(SplitCriteria(3), ""="") = 0) And Not DoAll" ' asking for 1 property of a gadget ' remember LTask.Name = SplitCriteria(2) LTask.ObjectID = "0" SetProperty LTask, "ReadBy", "Name" TGadget = ReadGadget(LTask) Select Case True Case TGadget.Name = NotFound ResultsGadget = TGadget SetProperty ResultsGadget, "Command", Criteria Case Else ' return the property ResultsGadget = BlankObject ResultsGadget.Name = SplitCriteria(2) ResultsGadget.Type = "Results of Property Search: " & SplitCriteria(3) SetProperty ResultsGadget, SplitCriteria(3), ReadProperty(TGadget, SplitCriteria(3)) End Select Case TotalParts > 2 And Not DoAll SetProperty StatusGadget, "Case", "TotalParts > 2 And Not DoAll" ' asking to set property(s) of a gadget ' remember, My Gadget, prop1=prop value1, prop2=prop value2... etc LTask.Name = SplitCriteria(2) LTask.ObjectID = "0" SetProperty LTask, "ReadBy", "Name" TGadget = ReadGadget(LTask) Select Case True Case TGadget.Name = NotFound ' need to create this gadget TGadget = BlankObject TGadget.Name = SplitCriteria(2) TGadget.ObjectID = 0 Case Else ' return the property 'SetProperty TGadget, SplitCriteria(3), SplitCriteria(4) End Select ' now, set all properties to the described values ' a property is like this prop name=prop value ' key in on equal For Cntr1 = 3 To TotalParts If InStr(SplitCriteria(Cntr1), "=") > 0 Then Prop = Left(SplitCriteria(Cntr1), InStr(SplitCriteria(Cntr1), "=") - 1) Prop = AllTrim(Prop) PropValue = Right(SplitCriteria(Cntr1), Len(SplitCriteria(Cntr1)) - InStr(SplitCriteria(Cntr1), "=")) PropValue = AllTrim(PropValue) Select Case True Case UCase(Prop) = "TYPE" TGadget.Type = PropValue Case UCase(Prop) = "CONTAINER" TGadget.Container = PropValue Case Else End Select SetProperty TGadget, Prop, PropValue End If Next Cntr1 WriteMemGadget TGadget.ObjectID, TGadget ResultsGadget = TGadget End Select 'ReadGadget (SplitCriteria(2)) GoTo EndSub 'OLD STUFF '/////////////////////////////////////////////////////////////////////////////////////////////////// LocalError: LocalError = Error ErrorCNTR = ErrorCNTR + 1 SetProperty StatusGadget, "Error # " & CStr(ErrorCNTR), LocalError Resume Next EndSub: GDSFreelocks DBSwitch StartDBPTR stoptime = Timer ResultsGadget.Status = CStr(stoptime - starttime) & " : Remember Time" Remember = ResultsGadget ' ShowGadget StatusGadget On Error GoTo 0 End Function Friend Function Evaluate(Sentence As String) As Gadget End Function Friend Function RecallOld(Task As Gadget, Param As Gadget) As Gadget ' this returns a gadget, or not based on the passed definition ' Recall Coffee Cup gets the entire gadget ' Recall Coffee Cup, Color; from VGBDatabaseName gets the color of coffee cup from DBase VGBDatabaseName ' Recall Color gets a list of all gadget names with Color property ' Recall Color=Red... ,PropertyX=Value X gets a list of all gadget names with Color property that is Red ' Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Msg As String, Cntr1 As Long, CNTR2 As Long Dim PropCntr As Long Dim Crit() As String, CritCNTR As Long, CritPTR As Long Dim CritValue() As String Dim LTask As Gadget, LParam As Gadget Dim ResultsGadget As Gadget Dim ResultsArrayCNTR As Long Dim Accumulator As Gadget, AccumulatorCNTR As Long Dim What As String Dim From As String Dim Criteria As String Dim SplitCriteria() As String, SplitCriteriaCNTR As Long, SplitCriteriaPTR As Long Dim Prop As String, PropValue As String Dim Props() As String, PropValues() As String, PropsCNTR As Long, PropsPTR As Long Dim TotalGadgetsFound As Long Dim CompareGadgets() As Gadget, CompareGadgetsCntr As Long, CompareGadgetsPTR As Long Dim LeftSide As String, RightSide As String Dim ComparisonOperator As String Dim AutoCreateGadget As Boolean Dim LOCDBPTR As Integer Dim StartDBPTR As Integer Dim LocalError As String On Error GoTo LocalError LParam = Param ' For ResultsArrayCNTR = 0 To 20 ' ReDim Preserve ResultsArray(ResultsArrayCNTR) ' ResultsArray(ResultsArrayCNTR).Name = "Recall Results " & ResultsArrayCNTR ' For Cntr2 = 1 To 20 ' SetProperty ResultsArray(ResultsArrayCNTR), "Property " & Cntr2, "Setted" ' Next ' Next For Cntr1 = 1 To 1000 SetProperty ResultsGadget, "Property " & Cntr1, "Value " & Cntr1 Next stoptime = Timer SetProperty ResultsGadget, "Time", CStr(stoptime - starttime) GoTo EndSub ' make name first lookup crit For PropCntr = 0 To Param.TotalProperties If UCase(Param.Propity(PropCntr)) = "NAME" Then CritCNTR = CritCNTR + 1 ReDim Preserve Crit(CritCNTR) ReDim Preserve CritValue(CritCNTR) Crit(CritCNTR) = Param.Propity(PropCntr) CritValue(CritCNTR) = Param.ValueAlpha(PropCntr) End If Next For PropCntr = 0 To Param.TotalProperties If (Len(Param.Propity(PropCntr)) > 0) And (UCase(Param.Propity(PropCntr)) <> "NAME") Then CritCNTR = CritCNTR + 1 ReDim Preserve Crit(CritCNTR) ReDim Preserve CritValue(CritCNTR) Crit(CritCNTR) = Param.Propity(PropCntr) CritValue(CritCNTR) = Param.ValueAlpha(PropCntr) End If Next ' here we have all the criteria and thier values For CritPTR = 1 To CritCNTR Select Case True Case UCase(Crit(CritPTR)) = "NAME" ObjectsRS.Index = "Name" ObjectsRS.Seek "=", CritValue(CritPTR) If ObjectsRS.NoMatch = True Then ' no objects by this name ResultsGadget.Name = NotFound SetProperty StatusGadget, "Recall Results", "Failed" SetProperty StatusGadget, CritValue(CritPTR), CritValue(CritPTR) & " " & NotFound GoTo EndSub End If ' got to here means name ok ' load accumulator with names and id's of all gadgets that match all ' criteria Do While ObjectsRS.NoMatch = False ObjectsRS.MoveNext If ObjectsRS.EOF = True Then Exit Do End If If ObjectsRS!Name <> CritValue(CritPTR) Then Exit Do End If Loop End Select Next SetProperty Param, "Been in ME Recall", "Yes" StartDBPTR = DBGadgetsPTR 'starting db LocalError = "" StatusGadget = BlankObject StatusGadget.Name = "Recall " & Param.Name SetProperty StatusGadget, "Status", "Recall Started" LTask = Param LTask.Name = Command What = ReadProperty(Task, "What") If What = NotFound Then What = Param.Name End If What = UCase(What) From = ReadProperty(Task, "From") ' see did they send criteria Criteria = ReadProperty(Task, "Criteria") SetProperty Param, "Criteria", Criteria ' fix any boofs in criteria Criteria = AllTrim(Criteria) If Right(Criteria, 1) = "," Then Criteria = Left(Criteria, Len(Criteria) - 1) End If If Right(Criteria, 2) = CrLf Then Criteria = Left(Criteria, Len(Criteria) - 2) End If If Right(Criteria, 1) = Cr Then Criteria = Left(Criteria, Len(Criteria) - 1) End If If Right(Criteria, 1) = Lf Then Criteria = Left(Criteria, Len(Criteria) - 1) End If ' take it apart SplitCriteria = Split(Criteria, ",") SplitCriteriaCNTR = UBound(SplitCriteria) ReDim Preserve SplitCriteria(SplitCriteriaCNTR + 1) ' fix zero based array bs and remove commas For SplitCriteriaPTR = SplitCriteriaCNTR + 1 To 1 Step -1 If AllTrim(SplitCriteria(SplitCriteriaPTR)) <> "," Then SplitCriteria(SplitCriteriaPTR) = AllTrim(SplitCriteria(SplitCriteriaPTR - 1)) End If Next SplitCriteriaCNTR = UBound(SplitCriteria) ' let's get comparison definitions ' each comparison gadget has 3 properties ' left side (up to comparison operator) ' comparison operator (<>, <=, etc) ' right side (after comparison operator) CNTR2 = 0 ' let's see if we have already set a recordset set up If LocalError <> "" Then Static LOCObjectsRS As Recordset, LOCPropsRS As Recordset Set LOCObjectsRS = ObjectsRS Set LOCPropsRS = PropsRS End If If LOCObjectsRS.Index <> "Name" Then LOCObjectsRS.Index = "Name" End If t = LOCObjectsRS.Fields For SplitCriteriaPTR = 1 To SplitCriteriaCNTR SetProperty StatusGadget, "Part: " & CStr(SplitCriteriaPTR), SplitCriteria(SplitCriteriaPTR) SetProperty Param, "Crit " & Cntr1, SplitCriteria(SplitCriteriaPTR) Select Case True Case InStr(SplitCriteria(SplitCriteriaPTR), "<>") > 0 ' not equal to ComparisonOperator = "<>" Case InStr(SplitCriteria(SplitCriteriaPTR), ">=") > 0 ' greater than or equal to ComparisonOperator = ">=" Case InStr(SplitCriteria(SplitCriteriaPTR), "<=") > 0 ' less than or equal to ComparisonOperator = "<=" Case InStr(SplitCriteria(SplitCriteriaPTR), "=") > 0 ' equal to ComparisonOperator = "=" Case InStr(UCase(SplitCriteria(SplitCriteriaPTR)), UCase("Contains")) > 0 ' contains "contains" ComparisonOperator = "CONTAINS" Case Else ComparisonOperator = "" End Select If ComparisonOperator <> "" Then CompareGadgetsCntr = CompareGadgetsCntr + 1 ReDim Preserve CompareGadgets(CompareGadgetsCntr) ' ReDim Preserve PropValues(PropsCNTR) LeftSide = AllTrim(Left(SplitCriteria(SplitCriteriaPTR), InStr(SplitCriteria(SplitCriteriaPTR), ComparisonOperator) - 1)) SetProperty CompareGadgets(CompareGadgetsCntr), "Left Side", LeftSide SetProperty CompareGadgets(CompareGadgetsCntr), "Comparison Operator", ComparisonOperator RightSide = AllTrim(Right(SplitCriteria(SplitCriteriaPTR), Len(SplitCriteria(SplitCriteriaPTR)) - InStr(SplitCriteria(SplitCriteriaPTR), "="))) SetProperty CompareGadgets(CompareGadgetsCntr), "Right Side", RightSide ' build a statusgadget Msg = ReadProperty(CompareGadgets(CompareGadgetsCntr), "Left Side") Msg = Msg & ReadProperty(CompareGadgets(CompareGadgetsCntr), "Comparison Operator") Msg = Msg & ReadProperty(CompareGadgets(CompareGadgetsCntr), "Right Side") SetProperty StatusGadget, "Comparison: " & CStr(CompareGadgetsCntr), Msg ' ' we've got some kind of comparison to do ' see if compare (right side) is gadget LOCObjectsRS.Seek "=", RightSide If LOCObjectsRS.NoMatch = False Then ' got a hit on this name as gadget End If End If ' If InStr(SplitCriteria(SplitCriteriaPTR), "=") Then ' ' this criterion contains an equal sign, a sign of properties ' 'StatusGadget = BlankObject ' StatusGadget.Name = "Started Parsing" ' PropsCNTR = PropsCNTR + 1 ' ReDim Preserve Props(PropsCNTR) ' ReDim Preserve PropValues(PropsCNTR) ' Props(PropsCNTR) = Left(SplitCriteria(SplitCriteriaPTR), InStr(SplitCriteria(SplitCriteriaPTR), "=") - 1) ' Props(PropsCNTR) = AllTrim(Props(PropsCNTR)) ' PropValues(PropsCNTR) = Right(SplitCriteria(SplitCriteriaPTR), Len(SplitCriteria(SplitCriteriaPTR)) - InStr(SplitCriteria(SplitCriteriaPTR), "=")) ' PropValues(PropsCNTR) = AllTrim(PropValues(PropsCNTR)) ' SetProperty StatusGadget, "Property: " & CStr(PropsCNTR) & " = " & Props(PropsCNTR), PropValues(PropsCNTR) ' ' ShowGadget StatusGadget ' End If Next SplitCriteriaPTR ' we now have comparisons parsed into different gadgets ' we need to figure out which table and table index to use ' GoTo EndSub If Criteria <> NotFound Then ' they gave us criteria ' SplitCriteria = Split(Criteria) End If ' make if not found? AutoCreateGadget = UCase(ReadProperty(Task, "Auto Create")) = "TRUE" ' cases possible ' Gadget ' All Names ' Name < ' Name <= ' Name = ' Name >= ' Name > ' Name <> ' Name Contains ' <, <=, =, >=, > Select Case True Case What = UCase("Gadget") ' 1 or more gadgets per criteria ' must Have at least one criterion to work For SplitCriteriaPTR = 1 To SplitCriteriaCNTR Select Case True Case UCase(Left(SplitCriteria(SplitCriteriaPTR), 4)) = UCase("Name") ' they want names and the want them now Select Case True Case InStr(SplitCriteria(SplitCriteriaPTR), "<>") > 0 ' not equal to Case InStr(SplitCriteria(SplitCriteriaPTR), ">=") > 0 ' greater than or equal to Case InStr(SplitCriteria(SplitCriteriaPTR), "<=") > 0 ' less than or equal to Case InStr(UCase(SplitCriteria(SplitCriteriaPTR)), UCase("Contains")) > 0 ' name contains Case InStr(SplitCriteria(SplitCriteriaPTR), "=") > 0 ' equal to ' Case InStr(SplitCriteria(SplitCriteriaPTR), "<>") > 0 ' Case InStr(SplitCriteria(SplitCriteriaPTR), "<>") > 0 ' Case InStr(SplitCriteria(SplitCriteriaPTR), "<>") > 0 End Select Case InStr(SplitCriteria(SplitCriteriaPTR), "=") > 0 ' Select Case True End Select ResultsGadget.Name = "Results of " & Criteria SetProperty StatusGadget, "Case", "InStr(UCase(SplitCriteria(2)), ""ALL"") > 0" SetProperty StatusGadget, "Command", SplitCriteria(2) ' ShowGadget StatusGadget Case InStr(SplitCriteria(1), "Name =") > 0 ' they want names and the want them now Case InStr(Criteria, "=") > 0 End Select Next Case What = UCase("Gadget Names") For LOCDBPTR = 1 To DBGadgetsCNTR If From = "ALL" Then DBSwitch LOCDBPTR Else ' switch to the one they want to check End If Msg = ReadProperty(DBGadgets(LOCDBPTR), "Path") Msg = AddBackSlash(Msg) & ReadProperty(DBGadgets(LOCDBPTR), "DB Name") LocalError = "" ObjectsRS.Index = "Name" ObjectsRS.MoveFirst If LocalError <> "" Then SetProperty ResultsGadget, "Error", LocalError GoTo EndSub End If ResultsGadget = BlankObject ' ResultsGadget.Name = SplitCriteria(2) Cntr1 = 0 Do While ObjectsRS.EOF = False Cntr1 = Cntr1 + 1 SetProperty ResultsGadget, ObjectsRS!Name, Msg ObjectsRS.MoveNext If LocalError <> "" Then Exit Do End If Loop If From <> "ALL" Then Exit For End If Next Case What = UCase("All Gadgets With Properties") End Select GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: RecallOld = ResultsGadget stoptime = Timer DBSwitch StartDBPTR SetProperty StatusGadget, "Time in Recall", CStr(stoptime - starttime) ' FloatMsgBox "Recall Time: " & CStr(stoptime - starttime), ucase(App.EXEName) & " Timing Status" End Function Friend Function Describe(Task As Gadget, Param As Gadget) As Gadget End Function Friend Function Rename(Crit As String) As Gadget ' this will rename the first to second name ' syntax: Rename,[property], Name1, Name2 ' remember to check all is's to update properties Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Msg As String, Cntr1 As Long Dim LocalError As String Dim ResultsGadget As Gadget Dim LTask As Gadget, LParam As Gadget Dim TGadget As Gadget Dim Sentence As String Dim SplitSentence() As String Dim TotalParts As Long Dim LongTermMemoryDBPTR As Integer Dim StartDBPTR As Integer On Error GoTo LocalError StartDBPTR = DBGadgetsPTR ' LongTermMemoryDBPTR = DBFindIndex(VGBDatabaseName) ' SetProperty ResultsGadget, "Error", "No Database Found" ' ResultsGadget.Name = "Remember Started" ' Sentence = ReadProperty(Task, "Rename") ' SetProperty ResultsGadget, "Sentence", Sentence ' If Sentence = NotFound Then ' Sentence = ReadProperty(Task, "Remember Wut") ' If Sentence = NotFound Then ' Sentence = ReadProperty(Task, "Parameters") ' End If ' End If ' If Sentence = NotFound Then ' SetProperty ResultsGadget, "Error", "No Command String to Process" ' GoTo EndSub ' End If ' SetProperty ResultsGadget, "Sentence", Sentence ' ' figure out what they said ' SplitSentence = Split(Sentence, ",") ' TotalParts = UBound(SplitSentence) ' ReDim Preserve SplitSentence(TotalParts + 1) ' For Cntr1 = TotalParts + 1 To 1 Step -1 ' SplitSentence(Cntr1) = AllTrim(SplitSentence(Cntr1 - 1)) ' Next ' GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: Rename = ResultsGadget On Error GoTo 0 End Function Friend Function Delete(Task As Gadget, Param As Gadget) As Gadget End Function Friend Function Group(Task As Gadget, Param As Gadget) As Gadget End Function Friend Function Cut(Task As Gadget, Param As Gadget) As Gadget End Function Friend Function Copy(Task As Gadget, Param As Gadget) As Gadget End Function Friend Function Paste(Task As Gadget, Param As Gadget) As Gadget End Function 'Public Function StartGadgetor() As Gadget ' Dim Result As Gadget ' Result.Name = "Start Results" ' StartGadgetor = Result 'End Function Friend Function Ramorize(Task As Gadget, Param As Gadget) As Gadget ' save the param in memories array Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Msg As String, MemPTR As Long, Cntr1 As Long Dim MemProp As String, MemPropValue As String, MemPropPTR As Long Dim TaskProp As String, TaskPropValue As String, TaskPropPTR As Long Dim Result As Gadget Result = Task For MemPTR = 1 To MemoriesCNTR If Memories(MemPTR).Name = Param.Name Then Exit For End If Next Select Case True Case MemPTR > MemoriesCNTR MemoriesCNTR = MemoriesCNTR + 1 MemPTR = MemoriesCNTR ReDim Preserve Memories(MemoriesCNTR) Memories(MemoriesCNTR) = Param SetProperty Result, "Status", "Added" Case Else ' found this one. update the properties only ' first, delete all properties in the memory gadget Memories(MemPTR).TotalProperties = 0 ReDim Preserve Memories(MemPTR).Propity(0) ReDim Preserve Memories(MemPTR).ValueAlpha(0) For TaskPropPTR = 1 To Task.TotalProperties TaskProp = Task.Propity(TaskPropPTR) TaskPropValue = Task.ValueAlpha(TaskPropPTR) MemPropValue = SetProperty(Memories(MemPTR), TaskProp, TaskPropValue) Next TaskPropPTR SetProperty Result, "Status", "Updated" End Select SetProperty Result, "Index", CStr(MemPTR) stoptime = Timer SetProperty Result, "Total Time", CStr(stoptime - starttime) Ramorize = Result End Function Friend Sub SetCoreVariables() ' database OpenDBPTR = 0 OpenDBCNTR = 0 AppGadgetsPTR = 0 DBGadgetsPTR = 0 ReDim OpenRS(0) ReDim OpenDB(0) End Sub ' this is the set of core tasks and miscellaneous functions '''''''''''''''''''''''''''' ' Gadgetorium Visual Basic global routines file for CORE (and seven modules ago). ' This file can be loaded into a code module. ' note: see glbldefs to see all the global variable definitions ' Use public sub GlobalInit to initialize GDS Global variables, th. ' ' ' Listing of OPAG-Callable Functions (Tell Gadgetor) ' ' ' '''''''''''''''''''''''''''' 'Public Function CountObjects(CountBy As Field, Criterion As Variant) As Long ' Dim TotalFound As Integer ' ObjectsRS.Index = CountBy ' ObjectsRS.Seek "=", Criterion ' ' TotalFound = 0 ' Do While ObjectsRS.EOF <> True ' If ObjectsRS!Type = "Cellable" Then ' TotalFound = TotalFound + 1 ' End If ' ObjectsRS.MoveNext ' Loop ' CountObjects = TotalFound 'End Function Friend Function ReadGadget(Param As Gadget) As Gadget ' Tell Gadgetor, ReadGadget, Dim StartDBPTR As Integer Dim Cntr1 As Integer Dim StatGadget As Gadget Dim ReadResults As Gadget Dim Accum() As Gadget, AccumCNTR As Long Dim DebugGadget As Gadget Dim LParam As Gadget LParam = Param DebugGadget = Param SetProperty DebugGadget, "DB: ", CStr(DBGadgetsPTR) StartDBPTR = DBGadgetsPTR Select Case True Case (UCase(ReadProperty(Param, "ReadBy")) = "NAME") And _ (UCase(ReadProperty(Param, "SCOPE")) = "CURRENT") ReadGadget = ReadDiskGadgetByName(LParam) Case UCase(ReadProperty(Param, "ReadBy")) = "NAME" For Cntr1 = 0 To DBGadgetsCNTR DBSwitch Cntr1 ReadResults = ReadDiskGadgetByName(LParam) If ReadResults.Name <> NotFound Then AccumCNTR = AccumCNTR + 1 ReDim Preserve Accum(AccumCNTR) Accum(AccumCNTR) = ReadResults SetProperty StatGadget, "DB " & AccumCNTR, DBGadgets(Cntr1).Name End If Next Select Case True Case AccumCNTR = 0 ReadGadget = ReadResults Case AccumCNTR = 1 ReadGadget = Accum(AccumCNTR) Case Else ReadGadget.Name = "Multiple Locations" For Cntr1 = 1 To AccumCNTR ' SetProperty ReadResults, "Name " & Cntr1, Accum(Cntr1).Name SetProperty ReadResults, "DB " & Cntr1, ReadProperty(StatGadget, "DB " & Cntr1) Next ReadGadget = ReadResults End Select DBSwitch StartDBPTR GoTo EndSub Case UCase(ReadProperty(Param, "ReadBy")) = "ID" ReadGadget = ReadDiskGadgetByID(LParam.ObjectID) Case Param.Name <> BlankObject.Name ReadGadget = ReadDiskGadgetByName(LParam) End Select ' ShowGadget DebugGadget EndSub: If StartDBPTR <> DBGadgetsPTR Then DBSwitch StartDBPTR End If End Function Friend Function ChangeGadgetName(Task As Gadget, Param As Gadget) As Gadget ' change an objects name, based on objectid Dim LocalError As String, Cntr1 As Integer Dim ObjectToChangeID As Long Dim NewName As String LocalError = "" On Error GoTo LocalError ObjectToChangeID = Param.ObjectID NewName = ReadProperty(Param, "New Name") ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", ObjectToChangeID If ObjectsRS.NoMatch Then MsgBox "I can't find the object to change the name of.", , UCase(App.EXEName) & "Debug Message" GoTo EndSub: End If GadgetWorkspace.BeginTrans ObjectsRS.Edit ObjectsRS!Name = NewName LocalError = "" ObjectsRS.Update If LocalError <> "" Then Cntr1 = 0 Do While Cntr1 <= 20 LocalError = "" WasteTime 0.1 ObjectsRS.Update If LocalError = "" Then Exit Do End If Cntr1 = Cntr1 + 1 Loop End If If InStr(LocalError, "LOCKED") > 0 Then MsgBox "Change Object Nane: Record Locked" End If GadgetWorkspace.CommitTrans GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: On Error GoTo 0 GDSFreelocks End Function Friend Function ReadGDSGadget(ObjectToReadName As String, ObjectToReadInto As Gadget) As String ' read an object from the GDSReg database ' be careful, this reads only 1st instance of object Dim t, Result As String Dim StartAppPTR As Integer Dim StartAppDBGadgetsPTR As Integer Dim StartObjectsRS As Recordset Dim StartPropsRS As Recordset ' Dim StartMethodsRS As Recordset Dim StartOpenDBPTR As Integer If Suicide Then On Error Resume Next End If OpenDBPTR = StartOpenDBPTR StartAppPTR = AppGadgetsPTR StartAppDBGadgetsPTR = DBGadgetsPTR Set StartObjectsRS = ObjectsRS Set StartPropsRS = PropsRS ' Set StartMethodsRS = MethodsRS StartOpenDBPTR = OpenDBPTR DBSwitch 0 t = ReadGadgetByName(ObjectToReadName, ObjectToReadInto) ' If t <> "OK" Then ' MsgBox "Error Reading GDS Registry object: " & ObjectToReadName, , ucase(App.EXEName) & " Debug Message" ' End If AppGadgetsPTR = StartAppPTR ' Set ObjectsRS = StartObjectsRS ' Set PropsRS = StartPropsRS ' Set MethodsRS = StartMethodsRS DBSwitch StartAppDBGadgetsPTR ReadGDSGadget = t On Error GoTo 0 End Function Friend Function GODReadGDSObjectByID(ObjectToReadID As Long) As String ' read a GDSReg object by ID Dim t, Result As String Dim StartAppPTR As Integer Dim StartAppDBGadgetsPTR As Integer Dim StartObjectsRS As Recordset Dim StartPropsRS As Recordset Dim StartMethodsRS As Recordset Dim StartOpenDBPTR As Integer If Suicide Then On Error Resume Next End If StartAppPTR = AppGadgetsPTR StartAppDBGadgetsPTR = DBGadgetsPTR StartOpenDBPTR = OpenDBPTR DBSwitch 0 t = ReadGadgetByID(ObjectToReadID) If t <> "OK" Then MsgBox "Error Reading GDS Registry object: " & ObjectToReadID, , UCase(App.EXEName) & " Debug Message" End If AppGadgetsPTR = StartAppPTR DBSwitch StartAppDBGadgetsPTR GODReadGDSObjectByID = t On Error GoTo 0 GDSFreelocks End Function Friend Function WriteGDSGadget(ObjectToWriteID As Long, ObjectToWriteFrom As Gadget) As String ' write a GDS Object (unknown ID creates new object) Dim t, Result As String Dim StartAppPTR As Integer Dim StartAppDBGadgetsPTR As Integer Dim StartObjectsRS As Recordset Dim StartPropsRS As Recordset ' Dim StartMethodsRS As Recordset Dim StartOpenDBPTR As Integer Dim StartBookMark As String, StartKey As String Dim LocalError As String On Error GoTo LocalError StartBookMark = ObjectsRS.Bookmark StartKey = ObjectsRS.Index StartAppPTR = AppGadgetsPTR StartAppDBGadgetsPTR = DBGadgetsPTR Set StartObjectsRS = ObjectsRS Set StartPropsRS = PropsRS ' Set StartMethodsRS = MethodsRS StartOpenDBPTR = OpenDBPTR If ObjectToWriteFrom.Name = UCase(App.EXEName) & "-" & "RWS.RWS" Then If UCase(App.EXEName) = "RWS_VIEW" Then MsgBox "Writing: " & ObjectToWriteFrom.Name End If End If t = DBSwitch(0) If t <> OK Then MsgBox "Switching to Registry Database (1) Failed", , UCase(App.EXEName) & " Debug Message" End If t = WriteMemGadget(ObjectToWriteID, ObjectToWriteFrom) If t <> "OK" Then MsgBox "Error Writing GDS Registry object: " & ObjectToWriteFrom.Name, , UCase(App.EXEName) & " Debug Message" End If Result = t AppGadgetsPTR = StartAppPTR GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: If StartAppDBGadgetsPTR <= AppDBGadgetsCNTR Then t = DBSwitch(StartAppDBGadgetsPTR) If DBGadgetsPTR <> StartAppDBGadgetsPTR Then ' MsgBox "DB Pointer Wrong" End If End If WriteGDSGadget = Result ObjectsRS.Index = StartKey ObjectsRS.Bookmark = StartBookMark GDSFreelocks On Error GoTo 0 End Function Friend Function WriteMemGadget(GadgetToWriteID As Long, GadgetToWriteFrom As Gadget) As String ' This one will write the Gadgettowrite from Gadget to disk as GadgetToWriteID ' if GadgetToWriteID doesn't exist, a new is created ' added the deletion of properties from disk that do not exist in the gadgettowrite Dim starttime As Single, stoptime As Single starttime = Timer Static WriteCNTR As Long WriteCNTR = WriteCNTR + 1 Static MemPropsRS As Recordset Static LastMemPropsQuery As String Dim t, Msg As String, PropertyNDX As Long, Cntr1 As Integer, CNTR2 As Integer Dim ExistingGadget As Gadget Dim MemPoolName As String Dim DeletePropIDs() As Long, DeletePropIDsCNTR As Long, DeletePropIDsPTR As Long Dim SavedPropIDs() As Long, SavedPropIDsCNTR As Long, SavedPropIDsPTR As Long Dim ThisMemPropsQuery As String Dim Crit As String Dim ShowedOnce As Boolean Dim LGadget As Gadget Dim Result As String Dim WriteGadget As Boolean Dim GadgetAdded As Boolean Dim GadgetsStartRec As String, ResetGadgets As Boolean Dim PropsStartRec As String, ResetProps As Boolean Dim UpdateNeeded As Boolean Dim AddThisProp As Boolean Dim LocalError As String Dim StartBookMark As String, StartKey As String Dim StartPropBookmark As String, StartPropKey As String Dim TempPropBookmark As String, TempPropKey As String LocalError = "" On Error GoTo LocalError ThisMemPropsQuery = "Select * from props where props.objectid=" & CStr(GadgetToWriteFrom.ObjectID) & " order by props.valuealpha;" 'ThisMemPropsQuery = "Select * from props where props.objectid=" & CStr(GadgetToWriteFrom.ObjectID) & ";" If ThisMemPropsQuery <> LastMemPropsQuery Then Set MemPropsRS = OpenDB(OpenDBPTR).OpenRecordset(ThisMemPropsQuery, dbOpenDynaset) MemPropsRS.MoveLast End If LastMemPropsQuery = ThisMemPropsQuery Msg = CStr(Len(GadgetToWriteFrom.Name)) SetProperty Trace, NextID("trace") & "WriteMemGadget", GadgetToWriteFrom.Name & " (L=" & Msg & ")" & " / Type: " & GadgetToWriteFrom.Type & " / ID: " & CStr(GadgetToWriteFrom.ObjectID) SetProperty Trace, NextID("trace") & "WriteMemGadget", "Writing [" & GadgetToWriteFrom.Name & "] to DB: " & DBGadgets(DBGadgetsPTR).Name WriteGadget = False ShowedOnce = False Result = "OK" GadgetAdded = False ' take care of null values in fields If Len(GadgetToWriteFrom.Type) = 0 Then GadgetToWriteFrom.Type = "None" End If If Len(GadgetToWriteFrom.GAppName) = 0 Then GadgetToWriteFrom.GAppName = UCase(App.EXEName) End If If Len(GadgetToWriteFrom.Container) = 0 Then GadgetToWriteFrom.Container = "None" End If If Len(GadgetToWriteFrom.Tag) = 0 Then ' not required GadgetToWriteFrom.Tag = 0 End If If Len(GadgetToWriteFrom.Level) = 0 Then GadgetToWriteFrom.Level = 0 End If If ObjectsRS.RecordCount = 0 Then ' creating a new Gadget in empty db If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget NOT an Error", "Checking Reccount: " & LocalError End If GadgetAdded = True WriteGadget = True GoTo WriteNow End If If LocalError = "" Then StartBookMark = ObjectsRS.Bookmark StartKey = ObjectsRS.Index StartPropBookmark = PropsRS.Bookmark StartPropKey = PropsRS.Index ' If LocalError <> "" Then ' SetProperty Trace, NextID("trace") & "WriteMemGadget NOT an Error", "setting Start Positions: " & LocalError ' End If End If LocalError = "" ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", GadgetToWriteID If ObjectsRS.NoMatch = True Then ' creating a new Gadget GadgetAdded = True WriteGadget = True GoTo WriteNow Else ' writing a Gadget that exists ' see if the objectid's are ok If UCase(GadgetToWriteFrom.Name) = UCase(ObjectsRS!Name) Then If (GadgetToWriteID > 0) And (GadgetToWriteFrom.ObjectID <> ObjectsRS!ObjectID) Then ' got us a situation here SetProperty Trace, NextID("trace") & "WriteMemGadget ERROR", "Passed ID: " & CStr(GadgetToWriteFrom.ObjectID) & "Disk ID: " & CStr(ObjectsRS!ObjectID) Result = "Error: GadgetIDs Goof" GoTo EndSub End If End If End If ' do we really need to write the Gadget to the object table? LocalError = "" Select Case True Case WriteGadget = True Case ObjectsRS![Name] <> GadgetToWriteFrom.Name WriteGadget = True Case ObjectsRS![Type] <> GadgetToWriteFrom.Type WriteGadget = True Case ObjectsRS![Container] <> GadgetToWriteFrom.Container WriteGadget = True Case ObjectsRS![Level] <> GadgetToWriteFrom.Level WriteGadget = True Case ObjectsRS![GAppName] <> UCase(App.EXEName) WriteGadget = True Case ObjectsRS![Tag] <> GadgetToWriteFrom.Tag If IsNull(ObjectsRS![Tag]) Then If GadgetToWriteFrom.Tag <> "" Then WriteGadget = True End If Else If ObjectsRS![Tag] <> GadgetToWriteFrom.Tag Then WriteGadget = True End If End If End Select If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Check if Write Error", LocalError End If LocalError = "" If WriteGadget = False Then GoTo SkipWriteGadget End If ' we need to write the Gadget for some reason WriteNow: GadgetWorkspace.BeginTrans If GadgetAdded = True Then ObjectsRS.AddNew Else ObjectsRS.Edit End If ' let's set the fields LocalError = "" ObjectsRS![Name] = GadgetToWriteFrom.Name If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Name Error", LocalError End If LocalError = "" ObjectsRS![Type] = GadgetToWriteFrom.Type If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Type Error", LocalError End If LocalError = "" ObjectsRS![GAppName] = GadgetToWriteFrom.GAppName If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget GAppName Error", LocalError End If LocalError = "" ObjectsRS![Container] = GadgetToWriteFrom.Container If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Container Error", LocalError End If LocalError = "" ObjectsRS![Tag] = GadgetToWriteFrom.Tag If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Tag Error", LocalError End If LocalError = "" ObjectsRS![Level] = GadgetToWriteFrom.Level If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Level Error", LocalError End If LocalError = "" ObjectsRS.Update ' MsgBox Timer - starttime, , "Memory Gadget Write" ' starttime = Timer If LocalError <> "" Then If LocalError = "Disk I/O error during read." Then ' error number 3040, trappable data access errors off of trappable errors in help ErrorCNTR = ErrorCNTR + 1 ReDim Preserve ErrorObjects(ErrorCNTR) Msg = "" ErrorObjects(ErrorCNTR) = BlankObject ErrorObjects(ErrorCNTR).Name = "Error Gadget: " & CStr(Date) & " @ " & CStr(Time) ErrorObjects(ErrorCNTR).Type = "Error" ErrorObjects(ErrorCNTR).Container = "ObjectsRS" ErrorObjects(ErrorCNTR).Tag = "Not Logged" t = SetProperty(ErrorObjects(ErrorCNTR), "App ExeName", UCase(App.EXEName)) t = SetProperty(ErrorObjects(ErrorCNTR), "Error", LocalError) t = SetProperty(ErrorObjects(ErrorCNTR), "AppGadget", AppGadgets(AppGadgetsPTR).Name) t = SetProperty(ErrorObjects(ErrorCNTR), "DB", DBGadgets(DBGadgetsPTR).Name) ' WriteErrorLog End If End If If LocalError <> "" Then Cntr1 = 0 Do While Cntr1 <= 50 ' DoEvents If Cntr1 = 50 Then GlobalErrorsCNTR = GlobalErrorsCNTR + 1 ReDim Preserve GlobalErrors(GlobalErrorsCNTR) GlobalErrors(GlobalErrorsCNTR) = BlankObject GlobalErrors(GlobalErrorsCNTR).Name = UCase(App.EXEName) & ": Write Memory Gadget Error" GlobalErrors(GlobalErrorsCNTR).Type = "Error" GlobalErrors(GlobalErrorsCNTR).Container = "Error" GlobalErrors(GlobalErrorsCNTR).Tag = CStr(Now()) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Writing", GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID)) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "App", UCase(App.EXEName)) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Occurred", "Gadget Update: " & GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID)) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Date", CStr(Now())) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error", LocalError) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Retry Counter", CStr(Cntr1)) Else ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Retry Counter", CStr(Cntr1)) End If LocalError = "" WasteTime 0.1 ObjectsRS.Update If LocalError = "" Then Exit Do End If GDSFreelocks If Cntr1 Mod 20 = 0 Then ' DoEvents End If Cntr1 = Cntr1 + 1 Loop End If If InStr(UCase(LocalError), "LOCKED") > 0 Then ' FloatMsgBox "Write Memory Gadget: Lock Error", "Error Writing Gadget" End If ObjectsRS.Bookmark = ObjectsRS.LastModified GadgetToWriteFrom.ObjectID = ObjectsRS![ObjectID] GadgetWorkspace.CommitTrans GDSFreelocks SkipWriteGadget: ' now do the props MemPoolName = ReadProperty(DBGadgets(DBGadgetsPTR), "DB Name") If GadgetAdded = False Then ' read the old one from disk and use a memory version to manipulate ' since we are going to do many iterations through this thing ExistingGadget = RecallByID(GadgetToWriteID, "from " & MemPoolName) If ExistingGadget.ObjectID <> GadgetToWriteID Then SetProperty Trace, NextID("trace") & "WriteMemGadget DB Trapped", "Error: Recall Object failed to find the disk object: " & CStr(GadgetToWriteID) & " Got: " & CStr(ExistingGadget.ObjectID) SetProperty VGBErrors, NextID("error") & "WriteMemGadget DB Trapped", "Error: Recall Object failed to find the disk object: " & CStr(GadgetToWriteID) & " Got: " & CStr(ExistingGadget.ObjectID) Result = "Error Locating Existing (Disk) Object" GoTo EndSub End If End If CNTR2 = 0 SavedPropIDsCNTR = GadgetToWriteFrom.TotalProperties ReDim SavedPropIDs(SavedPropIDsCNTR) ' let's delete all properties that are not in the ' to write from and are in the existing gadget For Cntr1 = 1 To ExistingGadget.TotalProperties For CNTR2 = 1 To GadgetToWriteFrom.TotalProperties If (GadgetToWriteFrom.Propity(CNTR2) = ExistingGadget.Propity(Cntr1)) Then Exit For End If Next CNTR2 Select Case True Case CNTR2 > GadgetToWriteFrom.TotalProperties ' needs deleted PropsRS.Index = "PropertyID" PropsRS.Seek "=", ExistingGadget.PropertyID(Cntr1) If PropsRS.NoMatch = False Then DeletePropIDsCNTR = DeletePropIDsCNTR + 1 PropsRS.Delete Else Result = "Error Locating Existing (Disk) Object's Property: " & ExistingGadget.Propity(Cntr1) GoTo EndSub End If End Select Next Cntr1 If DeletePropIDsCNTR > 0 Then ExistingGadget = RecallByID(GadgetToWriteID, "from " & MemPoolName) End If ' now we need to save all the properties in the to write from one For Cntr1 = 1 To GadgetToWriteFrom.TotalProperties UpdateNeeded = False AddThisProp = False For CNTR2 = 1 To ExistingGadget.TotalProperties If (GadgetToWriteFrom.Propity(Cntr1) = ExistingGadget.Propity(CNTR2)) Then Exit For End If Next CNTR2 Select Case True Case ExistingGadget.TotalProperties = 0 UpdateNeeded = True PropsRS.AddNew Case (GadgetToWriteFrom.Propity(Cntr1) <> ExistingGadget.Propity(CNTR2)) ' needs added UpdateNeeded = True PropsRS.AddNew Case (GadgetToWriteFrom.Propity(Cntr1) = ExistingGadget.Propity(CNTR2)) ' they have the same property ' simply update if necessary If PropsRS.NoMatch = False Then If UCase(GadgetToWriteFrom.ValueAlpha(Cntr1)) <> UCase(ExistingGadget.ValueAlpha(CNTR2)) Then UpdateNeeded = True End If If UCase(GadgetToWriteFrom.Propity(Cntr1)) <> UCase(ExistingGadget.Propity(CNTR2)) Then UpdateNeeded = True End If If UCase(GadgetToWriteFrom.PropSource(Cntr1)) <> UCase(ExistingGadget.PropSource(CNTR2)) Then UpdateNeeded = True End If If (GadgetToWriteFrom.PropType(Cntr1) <> ExistingGadget.PropType(CNTR2)) Then UpdateNeeded = True End If If UpdateNeeded Then PropsRS.Index = "PropertyID" PropsRS.Seek "=", ExistingGadget.PropertyID(CNTR2) If (PropsRS.NoMatch = True) Or PropsRS!Property <> GadgetToWriteFrom.Propity(Cntr1) Then Result = "Error Locating Existing (Disk) Object's Property: " & ExistingGadget.Propity(Cntr1) GoTo EndSub End If PropsRS.Edit End If End If End Select If UpdateNeeded Then SavedPropIDsPTR = SavedPropIDsPTR + 1 SavedPropIDs(SavedPropIDsPTR) = PropsRS!PropertyID PropsRS!ObjectID = GadgetToWriteFrom.ObjectID PropsRS!Property = GadgetToWriteFrom.Propity(Cntr1) 'PropsRS!Caption = GadgetToWriteFrom.Caption(Cntr1) PropsRS!ValueAlpha = GadgetToWriteFrom.ValueAlpha(Cntr1) If Len(GadgetToWriteFrom.ValueAlpha(Cntr1)) > PropsRS!ValueAlpha.Size Then SetProperty Trace, NextID("trace") & "Write Error", GadgetToWriteFrom.Propity(Cntr1) & " Value Too Long: " & GadgetToWriteFrom.ValueAlpha(Cntr1) SetProperty VGBErrors, NextID("error") & "Write Error", GadgetToWriteFrom.Propity(Cntr1) & " Value Too Long: " & GadgetToWriteFrom.ValueAlpha(Cntr1) End If PropsRS!ValueNum = GadgetToWriteFrom.ValueNum(Cntr1) PropsRS!PropSource = GadgetToWriteFrom.PropSource(Cntr1) PropsRS!PropType = GadgetToWriteFrom.PropType(Cntr1) LocalError = "" ' starttime = Timer PropsRS.Update ' MsgBox "Added: " & AddThisProp & CrLf & Timer - starttime, , "One prop update" If LocalError <> "" Then ' got an error on update SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error", "Field: " & GadgetToWriteFrom.Propity(Cntr1) & "/" & GadgetToWriteFrom.ValueAlpha(Cntr1) End If End If Next Cntr1 'existinggadget If DeletePropIDsCNTR > 0 Then ' we deleted some properties End If If SavedPropIDsPTR = GadgetToWriteFrom.TotalProperties Then GoTo EndSub End If GoTo SkipOldPropsCode MemPropsRS.MoveFirst ' these are in valuealpha order Do While MemPropsRS.EOF = False For Cntr1 = 1 To GadgetToWriteFrom.TotalProperties Next MemPropsRS.MoveNext Loop GoTo SkipOldPropsCode ' DoEvents '!!!! questionable sanity, 12/31/98 LocalError = "" PropsRS.Index = "ObjectID" PropertyNDX = 0 ' we need to delete any properties not in current object PropsRS.Seek "=", GadgetToWriteID Do Until PropsRS!ObjectID <> GadgetToWriteID For Cntr1 = 1 To GadgetToWriteFrom.TotalProperties If UCase(GadgetToWriteFrom.Propity(Cntr1)) = UCase(PropsRS!Property) Then Exit For End If If Cntr1 > GadgetToWriteFrom.TotalProperties Then ' delete this property from disk PropsRS.Delete End If Next PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If Loop ' starttime = Timer For PropertyNDX = 1 To GadgetToWriteFrom.TotalProperties ' start at first property for this Gadget GadgetWorkspace.BeginTrans UpdateNeeded = False LocalError = "" PropsRS.Seek "=", GadgetToWriteID If PropsRS.NoMatch = True Then AddThisProp = True Else AddThisProp = False Do Select Case True Case UCase(GadgetToWriteFrom.Propity(PropertyNDX)) = "IS" Or _ UCase(GadgetToWriteFrom.Propity(PropertyNDX)) = "DOES" ' special case of is ' need to see if this is a new one If (PropsRS!ObjectID = GadgetToWriteFrom.ObjectID) And _ (PropsRS!Property = GadgetToWriteFrom.Propity(PropertyNDX)) Then ' this is the same property If PropsRS!ValueAlpha = GadgetToWriteFrom.ValueAlpha(PropertyNDX) Then UpdateNeeded = False Else ' need to see if there is another like this with same value For CNTR2 = 1 To GadgetToWriteFrom.TotalProperties If (GadgetToWriteFrom.Propity(CNTR2) = GadgetToWriteFrom.Propity(PropertyNDX)) And _ GadgetToWriteFrom.ValueAlpha(CNTR2) = GadgetToWriteFrom.ValueAlpha(PropertyNDX) Then Exit For End If Next If CNTR2 > GadgetToWriteFrom.TotalProperties Then ' need to add this property if it is not already a property TempPropBookmark = PropsRS.Bookmark PropsRS.Seek "=", GadgetToWriteID Do While PropsRS.NoMatch = False If (PropsRS!ObjectID = GadgetToWriteFrom.ObjectID) And _ (PropsRS!Property = GadgetToWriteFrom.Propity(PropertyNDX)) Then If PropsRS!ValueAlpha = GadgetToWriteFrom.ValueAlpha(PropertyNDX) Then UpdateNeeded = False TempPropBookmark = PropsRS.Bookmark Exit Do End If End If PropsRS.MoveNext If PropsRS.EOF Then AddThisProp = True TempPropBookmark = PropsRS.Bookmark Exit Do End If If PropsRS!ObjectID <> GadgetToWriteID Then AddThisProp = True TempPropBookmark = PropsRS.Bookmark Exit Do End If Loop End If End If End If Case Else If (PropsRS!ObjectID = GadgetToWriteFrom.ObjectID) And _ ((UCase(PropsRS!Property)) = UCase(GadgetToWriteFrom.Propity(PropertyNDX))) Then If UCase(PropsRS!ValueAlpha) = UCase(GadgetToWriteFrom.ValueAlpha(PropertyNDX)) Then UpdateNeeded = False Else PropsRS.Edit UpdateNeeded = True End If Exit Do End If End Select PropsRS.MoveNext If PropsRS.EOF Then AddThisProp = True Exit Do End If If PropsRS!ObjectID <> GadgetToWriteFrom.ObjectID Then AddThisProp = True Exit Do End If Loop End If If AddThisProp = True Then UpdateNeeded = True PropsRS.AddNew End If LocalError = "" If UpdateNeeded Then PropsRS!ObjectID = GadgetToWriteFrom.ObjectID PropsRS!Property = GadgetToWriteFrom.Propity(PropertyNDX) 'PropsRS!Caption = GadgetToWriteFrom.Caption(PropertyNDX) PropsRS!ValueAlpha = GadgetToWriteFrom.ValueAlpha(PropertyNDX) If Len(GadgetToWriteFrom.ValueAlpha(PropertyNDX)) > PropsRS!ValueAlpha.Size Then SetProperty Trace, NextID("trace") & "Write Error", GadgetToWriteFrom.Propity(PropertyNDX) & " Value Too Long: " & GadgetToWriteFrom.ValueAlpha(PropertyNDX) SetProperty VGBErrors, NextID("error") & "Write Error", GadgetToWriteFrom.Propity(PropertyNDX) & " Value Too Long: " & GadgetToWriteFrom.ValueAlpha(PropertyNDX) End If PropsRS!ValueNum = GadgetToWriteFrom.ValueNum(PropertyNDX) PropsRS!PropSource = GadgetToWriteFrom.PropSource(PropertyNDX) PropsRS!PropType = GadgetToWriteFrom.PropType(PropertyNDX) LocalError = "" ' starttime = Timer PropsRS.Update ' MsgBox "Added: " & AddThisProp & CrLf & Timer - starttime, , "One prop update" If LocalError <> "" Then ' got an error on update SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error", "Field: " & GadgetToWriteFrom.Propity(PropertyNDX) & "/" & GadgetToWriteFrom.ValueAlpha(PropertyNDX) Cntr1 = 0 Do While Cntr1 <= 50 ' DoEvents If Cntr1 = 50 Then GlobalErrorsCNTR = GlobalErrorsCNTR + 1 ReDim Preserve GlobalErrors(GlobalErrorsCNTR) GlobalErrors(GlobalErrorsCNTR) = BlankObject GlobalErrors(GlobalErrorsCNTR).Name = UCase(App.EXEName) & ": Write Memory Gadget Error" GlobalErrors(GlobalErrorsCNTR).Type = "Error" GlobalErrors(GlobalErrorsCNTR).Container = "Error" GlobalErrors(GlobalErrorsCNTR).Tag = CStr(Now()) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Writing", GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID) & "/" & PropsRS!Property) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "App", UCase(App.EXEName)) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Occurred", "Property Update: " & GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID) & "/" & PropsRS!Property) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Date", CStr(Now())) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error", LocalError) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Retry Counter", CStr(Cntr1)) Else t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Retry Counter", CStr(Cntr1)) End If LocalError = "" WasteTime 0.1 PropsRS.Update If LocalError = "" Then Exit Do End If GDSFreelocks If Cntr1 Mod 20 = 0 Then ' DoEvents End If Cntr1 = Cntr1 + 1 Loop End If End If GadgetWorkspace.CommitTrans GDSFreelocks Next SkipOldPropsCode: GoTo EndSub LocalError: LocalError = Error If (InStr(UCase(LocalError), "YOU TRIED") = 0) And (InStr(UCase(LocalError), "SUBSCRIPT OUT") = 0) And (InStr(UCase(LocalError), "NO CURRENT RECORD") = 0) Then SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error Start ", CStr(WriteCNTR) & " ///////////////" SetProperty Trace, NextID("trace") & "Trapped WriteMemGadget Error: ", GadgetToWriteFrom.Name & "/" & LocalError SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error: ", GadgetToWriteFrom.Name & "/" & LocalError SetProperty VGBErrors, NextID("error") & "WriteMemGadget", GadgetToWriteFrom.Name & " (L=" & Msg & ")" & " / Type: " & GadgetToWriteFrom.Type & " / ID: " & CStr(GadgetToWriteFrom.ObjectID) SetProperty VGBErrors, NextID("error") & "WriteMemGadget", "Writing [" & GadgetToWriteFrom.Name & "] to DB: " & DBGadgets(DBGadgetsPTR).Name SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error End ", CStr(WriteCNTR) & " ///////////////" End If Resume Next EndSub: If (ObjectsRS.EditMode <> dbEditNone) Or (PropsRS.EditMode <> dbEditNone) Then ' FloatMsgBox "Recordset is Still in editmode", UCase(App.EXEName) & " Debug Message" SetProperty Trace, NextID("trace") & "NT WriteMemGadget Error", "A Recordset is Still in EditMode: ObjectsRS: " & CStr(ObjectsRS.EditMode) & "PropsRS: " & CStr(PropsRS.EditMode) End If LocalError = "" Do While LocalError = "" GadgetWorkspace.CommitTrans Loop If LocalError = "" Then ' GlobalErrorsCNTR = GlobalErrorsCNTR + 1 ' ReDim Preserve GlobalErrors(GlobalErrorsCNTR) ' GlobalErrors(GlobalErrorsCNTR) = BlankObject ' GlobalErrors(GlobalErrorsCNTR).Name = UCase(App.EXEName) & ": CommitTrans still open - " & Now ' GlobalErrors(GlobalErrorsCNTR).Type = "Error" ' GlobalErrors(GlobalErrorsCNTR).Container = "Error" ' GlobalErrors(GlobalErrorsCNTR).Tag = CStr(Now()) ' ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Writing", GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID)) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "App", UCase(App.EXEName)) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Occurred", "Gadget Update: " & GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID)) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Date", CStr(Now())) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error", "CommitTrans still open") End If If StartKey <> "" Then ObjectsRS.Index = StartKey ObjectsRS.Bookmark = StartBookMark PropsRS.Index = StartPropKey PropsRS.Bookmark = StartPropBookmark End If WriteMemGadget = Result GDSFreelocks On Error GoTo 0 stoptime = Timer ' GadgetWorkspace.Refresh ' If GadgetToWriteFrom.TotalProperties > 3000 Then ' MsgBox stoptime - starttime & CrLf & GadgetToWriteFrom.TotalProperties, , "Memory Object Write" ' End If SetProperty Trace, NextID("trace") & "WriteMemGadget Time", CStr(Timer - starttime) End Function Friend Function WriteMemGadgetOLD(GadgetToWriteID As Long, GadgetToWriteFrom As Gadget) As String ' This one will write the Gadgettowrite from Gadget to disk as GadgetToWriteID ' if GadgetToWriteID doesn't exist, a new is created ' added the deletion of properties from disk that do not exist in the gadgettowrite Static WriteCNTR As Long WriteCNTR = WriteCNTR + 1 Dim t, Msg As String, PropertyNDX As Long, Cntr1 As Integer, CNTR2 As Integer Dim Crit As String Dim ShowedOnce As Boolean Dim LGadget As Gadget Dim starttime As Single starttime = Timer Dim Result As String Dim WriteGadget As Boolean Dim GadgetAdded As Boolean Dim GadgetsStartRec As String, ResetGadgets As Boolean Dim PropsStartRec As String, ResetProps As Boolean Dim UpdateNeeded As Boolean Dim AddThisProp As Boolean Dim LocalError As String Dim StartBookMark As String, StartKey As String Dim StartPropBookmark As String, StartPropKey As String Dim TempPropBookmark As String, TempPropKey As String ' Dim TempRS As Recordset LocalError = "" ' GadgetWorkspace.Refresh On Error GoTo LocalError Msg = CStr(Len(GadgetToWriteFrom.Name)) SetProperty Trace, NextID("trace") & "WriteMemGadget", GadgetToWriteFrom.Name & " (L=" & Msg & ")" & " / Type: " & GadgetToWriteFrom.Type & " / ID: " & CStr(GadgetToWriteFrom.ObjectID) SetProperty Trace, NextID("trace") & "WriteMemGadget", "Writing [" & GadgetToWriteFrom.Name & "] to DB: " & DBGadgets(DBGadgetsPTR).Name WriteGadget = False ShowedOnce = False Result = "OK" GadgetAdded = False ' take care of null values in fields If Len(GadgetToWriteFrom.Type) = 0 Then GadgetToWriteFrom.Type = "None" End If If Len(GadgetToWriteFrom.GAppName) = 0 Then GadgetToWriteFrom.GAppName = UCase(App.EXEName) End If If Len(GadgetToWriteFrom.Container) = 0 Then GadgetToWriteFrom.Container = "None" End If If Len(GadgetToWriteFrom.Tag) = 0 Then ' not required GadgetToWriteFrom.Tag = 0 End If If Len(GadgetToWriteFrom.Level) = 0 Then GadgetToWriteFrom.Level = 0 End If If ObjectsRS.RecordCount = 0 Then ' creating a new Gadget in empty db If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget NOT an Error", "Checking Reccount: " & LocalError End If GadgetAdded = True WriteGadget = True GoTo WriteNow End If If LocalError = "" Then StartBookMark = ObjectsRS.Bookmark StartKey = ObjectsRS.Index StartPropBookmark = PropsRS.Bookmark StartPropKey = PropsRS.Index If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget NOT an Error", "setting Start Positions: " & LocalError End If End If ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", GadgetToWriteID If ObjectsRS.NoMatch = True Then ' creating a new Gadget GadgetAdded = True WriteGadget = True GoTo WriteNow Else ' writing a Gadget that exists ' see if the objectid's are ok If UCase(GadgetToWriteFrom.Name) = UCase(ObjectsRS!Name) Then If (GadgetToWriteID > 0) And (GadgetToWriteFrom.ObjectID <> ObjectsRS!ObjectID) Then ' got us a situation here SetProperty Trace, NextID("trace") & "WriteMemGadget ERROR", "Passed ID: " & CStr(GadgetToWriteFrom.ObjectID) & "Disk ID: " & CStr(ObjectsRS!ObjectID) ' LGadget = BlankObject ' LGadget.Name = "WMO Error @ " & Format(Now, "mm/dd/yyyy") & Format(Now, "Long Time") ' LGadget.Type = "GDS Error" ' LGadget.Container = "WriteMemGadget" ' t = SetProperty(LGadget, "From Name", GadgetToWriteFrom.Name) ' t = SetProperty(LGadget, "From ID ", CStr(GadgetToWriteFrom.ObjectID)) ' t = SetProperty(LGadget, "To Name", ObjectsRS!Name) ' t = SetProperty(LGadget, "To ID", CStr(ObjectsRS!ObjectID)) ' t = SetProperty(LGadget, "Action", "Aborted Write") ' t = WriteMemGadget(0, LGadget) '' If Not ExecutingSchedule Then '' ShowGadget LGadget '' End If Result = "Error: GadgetIDs Goof" ' GadgetWorkspace.CommitTrans GoTo EndSub End If End If ' ObjectsRS.Edit End If ' do we really need to write the Gadget to the object table? LocalError = "" Select Case True Case WriteGadget = True Case ObjectsRS![Name] <> GadgetToWriteFrom.Name WriteGadget = True Case ObjectsRS![Type] <> GadgetToWriteFrom.Type WriteGadget = True Case ObjectsRS![Container] <> GadgetToWriteFrom.Container WriteGadget = True Case ObjectsRS![Level] <> GadgetToWriteFrom.Level WriteGadget = True Case ObjectsRS![GAppName] <> UCase(App.EXEName) WriteGadget = True Case ObjectsRS![Tag] <> GadgetToWriteFrom.Tag If IsNull(ObjectsRS![Tag]) Then If GadgetToWriteFrom.Tag <> "" Then WriteGadget = True End If Else If ObjectsRS![Tag] <> GadgetToWriteFrom.Tag Then WriteGadget = True End If End If End Select If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Check if Write Error", LocalError End If LocalError = "" If WriteGadget = False Then GoTo SkipWriteGadget End If ' we need to write the Gadget for some reason WriteNow: GadgetWorkspace.BeginTrans If GadgetAdded = True Then ObjectsRS.AddNew Else ObjectsRS.Edit End If ' let's set the fields LocalError = "" ObjectsRS![Name] = GadgetToWriteFrom.Name If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Name Error", LocalError End If LocalError = "" ObjectsRS![Type] = GadgetToWriteFrom.Type If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Type Error", LocalError End If LocalError = "" ObjectsRS![GAppName] = GadgetToWriteFrom.GAppName If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget GAppName Error", LocalError End If LocalError = "" ObjectsRS![Container] = GadgetToWriteFrom.Container If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Container Error", LocalError End If LocalError = "" ObjectsRS![Tag] = GadgetToWriteFrom.Tag If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Tag Error", LocalError End If LocalError = "" ObjectsRS![Level] = GadgetToWriteFrom.Level If LocalError <> "" Then SetProperty Trace, NextID("trace") & "WriteMemGadget Level Error", LocalError End If LocalError = "" ObjectsRS.Update ' MsgBox Timer - starttime, , "Memory Gadget Write" ' starttime = Timer If LocalError <> "" Then If LocalError = "Disk I/O error during read." Then ' error number 3040, trappable data access errors off of trappable errors in help ErrorCNTR = ErrorCNTR + 1 ReDim Preserve ErrorObjects(ErrorCNTR) Msg = "" ErrorObjects(ErrorCNTR) = BlankObject ErrorObjects(ErrorCNTR).Name = "Error Gadget: " & CStr(Date) & " @ " & CStr(Time) ErrorObjects(ErrorCNTR).Type = "Error" ErrorObjects(ErrorCNTR).Container = "ObjectsRS" ErrorObjects(ErrorCNTR).Tag = "Not Logged" t = SetProperty(ErrorObjects(ErrorCNTR), "App ExeName", UCase(App.EXEName)) t = SetProperty(ErrorObjects(ErrorCNTR), "Error", LocalError) t = SetProperty(ErrorObjects(ErrorCNTR), "AppGadget", AppGadgets(AppGadgetsPTR).Name) t = SetProperty(ErrorObjects(ErrorCNTR), "DB", DBGadgets(DBGadgetsPTR).Name) ' WriteErrorLog End If End If If LocalError <> "" Then Cntr1 = 0 Do While Cntr1 <= 50 ' DoEvents If Cntr1 = 50 Then GlobalErrorsCNTR = GlobalErrorsCNTR + 1 ReDim Preserve GlobalErrors(GlobalErrorsCNTR) GlobalErrors(GlobalErrorsCNTR) = BlankObject GlobalErrors(GlobalErrorsCNTR).Name = UCase(App.EXEName) & ": Write Memory Gadget Error" GlobalErrors(GlobalErrorsCNTR).Type = "Error" GlobalErrors(GlobalErrorsCNTR).Container = "Error" GlobalErrors(GlobalErrorsCNTR).Tag = CStr(Now()) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Writing", GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID)) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "App", UCase(App.EXEName)) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Occurred", "Gadget Update: " & GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID)) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Date", CStr(Now())) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error", LocalError) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Retry Counter", CStr(Cntr1)) Else ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Retry Counter", CStr(Cntr1)) End If LocalError = "" WasteTime 0.1 ObjectsRS.Update If LocalError = "" Then Exit Do End If GDSFreelocks If Cntr1 Mod 20 = 0 Then ' DoEvents End If Cntr1 = Cntr1 + 1 Loop End If If InStr(UCase(LocalError), "LOCKED") > 0 Then ' FloatMsgBox "Write Memory Gadget: Lock Error", "Error Writing Gadget" End If ObjectsRS.Bookmark = ObjectsRS.LastModified GadgetToWriteFrom.ObjectID = ObjectsRS![ObjectID] GadgetWorkspace.CommitTrans GDSFreelocks SkipWriteGadget: ' DoEvents '!!!! questionable sanity, 12/31/98 LocalError = "" PropsRS.Index = "ObjectID" PropertyNDX = 0 ' we need to delete any properties not in current object PropsRS.Seek "=", GadgetToWriteID Do Until PropsRS!ObjectID <> GadgetToWriteID For Cntr1 = 1 To GadgetToWriteFrom.TotalProperties If UCase(GadgetToWriteFrom.Propity(Cntr1)) = UCase(PropsRS!Property) Then Exit For End If If Cntr1 > GadgetToWriteFrom.TotalProperties Then ' delete this property from disk PropsRS.Delete End If Next PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If Loop ' starttime = Timer For PropertyNDX = 1 To GadgetToWriteFrom.TotalProperties ' start at first property for this Gadget GadgetWorkspace.BeginTrans UpdateNeeded = False LocalError = "" PropsRS.Seek "=", GadgetToWriteID If PropsRS.NoMatch = True Then AddThisProp = True Else AddThisProp = False Do Select Case True Case UCase(GadgetToWriteFrom.Propity(PropertyNDX)) = "IS" Or _ UCase(GadgetToWriteFrom.Propity(PropertyNDX)) = "DOES" ' special case of is ' need to see if this is a new one If (PropsRS!ObjectID = GadgetToWriteFrom.ObjectID) And _ (PropsRS!Property = GadgetToWriteFrom.Propity(PropertyNDX)) Then ' this is the same property If PropsRS!ValueAlpha = GadgetToWriteFrom.ValueAlpha(PropertyNDX) Then UpdateNeeded = False Else ' need to see if there is another like this with same value For CNTR2 = 1 To GadgetToWriteFrom.TotalProperties If (GadgetToWriteFrom.Propity(CNTR2) = GadgetToWriteFrom.Propity(PropertyNDX)) And _ GadgetToWriteFrom.ValueAlpha(CNTR2) = GadgetToWriteFrom.ValueAlpha(PropertyNDX) Then Exit For End If Next If CNTR2 > GadgetToWriteFrom.TotalProperties Then ' need to add this property if it is not already a property TempPropBookmark = PropsRS.Bookmark PropsRS.Seek "=", GadgetToWriteID Do While PropsRS.NoMatch = False If (PropsRS!ObjectID = GadgetToWriteFrom.ObjectID) And _ (PropsRS!Property = GadgetToWriteFrom.Propity(PropertyNDX)) Then If PropsRS!ValueAlpha = GadgetToWriteFrom.ValueAlpha(PropertyNDX) Then UpdateNeeded = False TempPropBookmark = PropsRS.Bookmark Exit Do End If End If PropsRS.MoveNext If PropsRS.EOF Then AddThisProp = True TempPropBookmark = PropsRS.Bookmark Exit Do End If If PropsRS!ObjectID <> GadgetToWriteID Then AddThisProp = True TempPropBookmark = PropsRS.Bookmark Exit Do End If Loop End If End If End If Case Else If (PropsRS!ObjectID = GadgetToWriteFrom.ObjectID) And _ ((UCase(PropsRS!Property)) = UCase(GadgetToWriteFrom.Propity(PropertyNDX))) Then If UCase(PropsRS!ValueAlpha) = UCase(GadgetToWriteFrom.ValueAlpha(PropertyNDX)) Then UpdateNeeded = False Else PropsRS.Edit UpdateNeeded = True End If Exit Do End If End Select PropsRS.MoveNext If PropsRS.EOF Then AddThisProp = True Exit Do End If If PropsRS!ObjectID <> GadgetToWriteFrom.ObjectID Then AddThisProp = True Exit Do End If Loop End If If AddThisProp = True Then UpdateNeeded = True PropsRS.AddNew End If LocalError = "" If UpdateNeeded Then PropsRS!ObjectID = GadgetToWriteFrom.ObjectID PropsRS!Property = GadgetToWriteFrom.Propity(PropertyNDX) 'PropsRS!Caption = GadgetToWriteFrom.Caption(PropertyNDX) PropsRS!ValueAlpha = GadgetToWriteFrom.ValueAlpha(PropertyNDX) If Len(GadgetToWriteFrom.ValueAlpha(PropertyNDX)) > PropsRS!ValueAlpha.Size Then SetProperty Trace, NextID("trace") & "Write Error", GadgetToWriteFrom.Propity(PropertyNDX) & " Value Too Long: " & GadgetToWriteFrom.ValueAlpha(PropertyNDX) SetProperty VGBErrors, NextID("error") & "Write Error", GadgetToWriteFrom.Propity(PropertyNDX) & " Value Too Long: " & GadgetToWriteFrom.ValueAlpha(PropertyNDX) End If PropsRS!ValueNum = GadgetToWriteFrom.ValueNum(PropertyNDX) PropsRS!PropSource = GadgetToWriteFrom.PropSource(PropertyNDX) PropsRS!PropType = GadgetToWriteFrom.PropType(PropertyNDX) LocalError = "" ' starttime = Timer PropsRS.Update ' MsgBox "Added: " & AddThisProp & CrLf & Timer - starttime, , "One prop update" If LocalError <> "" Then ' got an error on update SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error", "Field: " & GadgetToWriteFrom.Propity(PropertyNDX) & "/" & GadgetToWriteFrom.ValueAlpha(PropertyNDX) Cntr1 = 0 Do While Cntr1 <= 50 ' DoEvents If Cntr1 = 50 Then GlobalErrorsCNTR = GlobalErrorsCNTR + 1 ReDim Preserve GlobalErrors(GlobalErrorsCNTR) GlobalErrors(GlobalErrorsCNTR) = BlankObject GlobalErrors(GlobalErrorsCNTR).Name = UCase(App.EXEName) & ": Write Memory Gadget Error" GlobalErrors(GlobalErrorsCNTR).Type = "Error" GlobalErrors(GlobalErrorsCNTR).Container = "Error" GlobalErrors(GlobalErrorsCNTR).Tag = CStr(Now()) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Writing", GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID) & "/" & PropsRS!Property) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "App", UCase(App.EXEName)) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Occurred", "Property Update: " & GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID) & "/" & PropsRS!Property) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Date", CStr(Now())) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error", LocalError) t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Retry Counter", CStr(Cntr1)) Else t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Retry Counter", CStr(Cntr1)) End If LocalError = "" WasteTime 0.1 PropsRS.Update If LocalError = "" Then Exit Do End If GDSFreelocks If Cntr1 Mod 20 = 0 Then ' DoEvents End If Cntr1 = Cntr1 + 1 Loop End If End If GadgetWorkspace.CommitTrans GDSFreelocks Next GoTo EndSub LocalError: LocalError = Error If (InStr(UCase(LocalError), "YOU TRIED") = 0) And (InStr(UCase(LocalError), "SUBSCRIPT OUT") = 0) And (InStr(UCase(LocalError), "NO CURRENT RECORD") = 0) Then SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error Start ", CStr(WriteCNTR) & " ///////////////" SetProperty Trace, NextID("trace") & "Trapped WriteMemGadget Error: ", GadgetToWriteFrom.Name & "/" & LocalError SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error: ", GadgetToWriteFrom.Name & "/" & LocalError SetProperty VGBErrors, NextID("error") & "WriteMemGadget", GadgetToWriteFrom.Name & " (L=" & Msg & ")" & " / Type: " & GadgetToWriteFrom.Type & " / ID: " & CStr(GadgetToWriteFrom.ObjectID) SetProperty VGBErrors, NextID("error") & "WriteMemGadget", "Writing [" & GadgetToWriteFrom.Name & "] to DB: " & DBGadgets(DBGadgetsPTR).Name SetProperty VGBErrors, NextID("error") & "Trapped WriteMemGadget Error End ", CStr(WriteCNTR) & " ///////////////" End If Resume Next EndSub: If (ObjectsRS.EditMode <> dbEditNone) Or (PropsRS.EditMode <> dbEditNone) Then ' FloatMsgBox "Recordset is Still in editmode", UCase(App.EXEName) & " Debug Message" SetProperty Trace, NextID("trace") & "NT WriteMemGadget Error", "A Recordset is Still in EditMode: ObjectsRS: " & CStr(ObjectsRS.EditMode) & "PropsRS: " & CStr(PropsRS.EditMode) End If LocalError = "" Do While LocalError = "" GadgetWorkspace.CommitTrans Loop If LocalError = "" Then ' GlobalErrorsCNTR = GlobalErrorsCNTR + 1 ' ReDim Preserve GlobalErrors(GlobalErrorsCNTR) ' GlobalErrors(GlobalErrorsCNTR) = BlankObject ' GlobalErrors(GlobalErrorsCNTR).Name = UCase(App.EXEName) & ": CommitTrans still open - " & Now ' GlobalErrors(GlobalErrorsCNTR).Type = "Error" ' GlobalErrors(GlobalErrorsCNTR).Container = "Error" ' GlobalErrors(GlobalErrorsCNTR).Tag = CStr(Now()) ' ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Writing", GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID)) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "App", UCase(App.EXEName)) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Occurred", "Gadget Update: " & GadgetToWriteFrom.Name & "/" & CStr(GadgetToWriteFrom.ObjectID)) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error Date", CStr(Now())) ' t = SetProperty(GlobalErrors(GlobalErrorsCNTR), "Error", "CommitTrans still open") End If If StartKey <> "" Then ObjectsRS.Index = StartKey ObjectsRS.Bookmark = StartBookMark PropsRS.Index = StartPropKey PropsRS.Bookmark = StartPropBookmark End If WriteMemGadgetOLD = Result GDSFreelocks On Error GoTo 0 ' GadgetWorkspace.Refresh ' MsgBox Timer - starttime, , "Memory Object Write" SetProperty Trace, NextID("trace") & "WriteMemGadget Time", CStr(Timer - starttime) End Function Friend Function GODLoadObjectChildren(RO As Long) ' This will load all the given object's chilren object names into loadedchildren() array ' and pass it back to caller ' note, this routine DOES NOT CLEAR passed array! It appends items to end. ' also, the passed name goes into first available element Dim t, TempObject As Gadget, Result As String Dim ChildrenNDX As Integer, px As Integer, py As Integer If CurrentObject.ObjectID <> RO Then t = ReadGadgetByID(RO) If t <> "OK" Then MsgBox t, , UCase(App.EXEName) & " Debug Message" Exit Function End If TempObject = ReadObjectBuffer Else TempObject = CurrentObject End If ' add the first one (the one that was passed ChildrenNDX = UBound(LoadedChildren()) ChildrenNDX = ChildrenNDX + 1 ' Load the passed object name in next element ReDim Preserve LoadedChildren(ChildrenNDX) ReDim Preserve LoadedChildrenIDs(ChildrenNDX) LoadedChildren(ChildrenNDX) = TempObject.Name LoadedChildrenIDs(ChildrenNDX) = TempObject.ObjectID 'load all children For px = 1 To TempObject.TotalProperties Select Case True Case UCase(TempObject.Propity(px)) = "CHILD" Dim NewObject As Long NewObject = Val(TempObject.ValueAlpha(px)) t = GODLoadObjectChildren(NewObject) End Select Next EndGLOC: GODLoadObjectChildren = Result End Function Friend Function ReadGadgetByName(ObjectToReadName As String, GORReadObjectBuffer As Gadget) As String ' read an object by name into passed gadget ' Note: reads only 1st encountered objet with this name ' also, if GORReadObjectBuffer has property "type" this will get that type only Dim Crit As String, t, GadgetNDX As Integer, starttime As Single, stoptime As Single Dim StartBookMark As String Dim StartKey As String Dim IDToRead As Long Dim ContainerToFind As String, TypeToFind As String starttime = Timer Dim SourceRS As Recordset, SourceMethodRS As Recordset Dim NewRS As String, OldPropRS As String Dim Result As String Result = OK ' get this, since I have provided a read by id function, all this thing has to do ' is look up the name, get the id and sic read object by id on it. ' this only gets the first object of a name, do not use if you need to get ' anything but the first object with the given name. On Error GoTo LocalError ContainerToFind = ReadProperty(GORReadObjectBuffer, "Container") If ContainerToFind = "" Then ContainerToFind = NotFound End If TypeToFind = ReadProperty(GORReadObjectBuffer, "Type") If TypeToFind = "" Then TypeToFind = NotFound End If StartKey = ObjectsRS.Index StartBookMark = ObjectsRS.Bookmark ObjectsRS.Index = "Name" ObjectsRS.Seek "=", ObjectToReadName If ObjectsRS.NoMatch Then GORReadObjectBuffer.Name = "" Result = "ERROR: Object read failed to locate the object named:" & ObjectToReadName GoTo EndGORO End If Select Case True Case (TypeToFind = NotFound) And (ContainerToFind = NotFound) ' nothing to do Case (TypeToFind <> NotFound) And (ContainerToFind = NotFound) ' find type only Do While ObjectsRS.NoMatch = False If ObjectsRS!Type = TypeToFind Then Exit Do End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " of Type: " & TypeToFind Exit Do End If If ObjectsRS!Name <> ObjectToReadName Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " of Type: " & TypeToFind Exit Do End If Loop Case (TypeToFind = NotFound) And (ContainerToFind <> NotFound) ' find container only Do While ObjectsRS.NoMatch = False If ObjectsRS!Container = ContainerToFind Then Exit Do End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " in container: " & ContainerToFind Exit Do End If If ObjectsRS!Name <> ObjectToReadName Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " in container: " & ContainerToFind Exit Do End If Loop Case (TypeToFind <> NotFound) And (ContainerToFind <> NotFound) ' find type and container Do While ObjectsRS.NoMatch = False If (ObjectsRS!Type = TypeToFind) And (ObjectsRS!Container = ContainerToFind) Then Exit Do End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " Cont: " & ContainerToFind & " Type:" & TypeToFind End If If ObjectsRS!Name <> ObjectToReadName Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " Cont: " & ContainerToFind & " Type:" & TypeToFind Exit Do End If Loop End Select If Result = OK Then IDToRead = ObjectsRS!ObjectID t = ReadGadgetByID(IDToRead) If t = "OK" Then GORReadObjectBuffer = ReadObjectBuffer Else Result = t End If End If GoTo EndGORO: LocalError: Resume Next EndGORO: ReadGadgetByName = Result stoptime = Timer ObjectsRS.Index = StartKey ObjectsRS.Bookmark = StartBookMark On Error GoTo 0 GDSFreelocks 'MsgBox "Time to load object: " & GORReadObjectBuffer.Name & "-" & CrLf & stoptime - starttime End Function Friend Function ReadDiskGadgetByName(Param As Gadget) As Gadget ' read an object by name into passed gadget ' Note: reads only 1st encountered object with this name ' also, if param has property "type" this will get that type only ' ditto for container Dim t, Msg As String Dim Crit As String, GadgetNDX As Integer, starttime As Single, stoptime As Single Dim ObjectToReadName As String ', ReadObjectBuffer As Gadget Dim ReadObjectBuffer As Gadget Dim StartBookMark As String Dim StartKey As String Dim IDToRead As Long Dim ContainerToFind As String, TypeToFind As String starttime = Timer Dim SourceRS As Recordset, SourceMethodRS As Recordset Dim NewRS As String, OldPropRS As String Dim Result As String ObjectToReadName = ReadProperty(Param, "Name") If ObjectToReadName = NotFound Then ObjectToReadName = Param.Name End If Result = OK ' get this, since I have provided a read by id function, all this thing has to do ' is look up the name, get the id and sic read object by id on it. ' this only gets the first object of a name, do not use if you need to get ' anything but the first object with the given name. On Error GoTo LocalError ContainerToFind = ReadProperty(Param, "Container") TypeToFind = ReadProperty(Param, "Type") StartKey = ObjectsRS.Index StartBookMark = ObjectsRS.Bookmark ObjectsRS.Index = "Name" ObjectsRS.Seek "=", ObjectToReadName If ObjectsRS.NoMatch Then ReadObjectBuffer.Name = NotFound Msg = "ERROR: Object read failed to locate the object named:" & ObjectToReadName t = SetProperty(ReadObjectBuffer, "Error:", Msg) GoTo EndSub End If Select Case True Case (TypeToFind = NotFound) And (ContainerToFind = NotFound) ' they didn't specify a container or a type ' nothing to do Case (TypeToFind <> NotFound) And (ContainerToFind = NotFound) ' find type only Do While ObjectsRS.NoMatch = False If ObjectsRS!Type = TypeToFind Then Exit Do End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " of Type: " & TypeToFind Exit Do End If If ObjectsRS!Name <> ObjectToReadName Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " of Type: " & TypeToFind Exit Do End If Loop Case (TypeToFind = NotFound) And (ContainerToFind <> NotFound) ' find container only Do While ObjectsRS.NoMatch = False If ObjectsRS!Container = ContainerToFind Then Exit Do End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " in container: " & ContainerToFind Exit Do End If If ObjectsRS!Name <> ObjectToReadName Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " in container: " & ContainerToFind Exit Do End If Loop Case (TypeToFind <> NotFound) And (ContainerToFind <> NotFound) ' find type and container Do While ObjectsRS.NoMatch = False If (ObjectsRS!Type = TypeToFind) And (ObjectsRS!Container = ContainerToFind) Then Exit Do End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " Cont: " & ContainerToFind & " Type:" & TypeToFind End If If ObjectsRS!Name <> ObjectToReadName Then Result = "ERROR: Read failed to locate object: " & ObjectToReadName & " Cont: " & ContainerToFind & " Type:" & TypeToFind Exit Do End If Loop End Select If Result = OK Then IDToRead = ObjectsRS!ObjectID ReadObjectBuffer = ReadDiskGadgetByID(IDToRead) End If GoTo EndSub: LocalError: Resume Next EndSub: ReadDiskGadgetByName = ReadObjectBuffer stoptime = Timer ObjectsRS.Index = StartKey ObjectsRS.Bookmark = StartBookMark On Error GoTo 0 GDSFreelocks 'MsgBox "Time to load object: " & ReadObjectBuffer.Name & "-" & CrLf & stoptime - starttime End Function Friend Function ReadGadgetByID(ObjectToReadID As Long) As String Static MemPropsRS As Recordset Dim starttime As Single, stoptime As Single Dim Cntr As Integer, TotAllObjects As Integer, AOPntr As Integer Dim StartBookMark As Variant, StartKey As String Dim StartPropBookmark As Variant, StartPropKey As String Dim GadgetNDX As Integer starttime = Timer Dim Result As String Dim SQLCmd As String Dim RS As Recordset Dim LocalError As String On Error GoTo LocalError ReadObjectBuffer = BlankObject StartBookMark = ObjectsRS.Bookmark StartKey = ObjectsRS.Index StartPropBookmark = PropsRS.Bookmark StartPropKey = PropsRS.Index ' On Error GoTo LocalError Result = "OK" ' ReadObjectBuffer.ObjectID = 0 ' If UBound(AllObjects()) > 0 Then ' TotAllObjects = UBound(AllObjects()) ' If TotAllObjects < ObjectsRS.RecordCount Then GoTo SkipMem ' For Cntr = 1 To TotAllObjects ' If AllObjects(Cntr).ObjectID = ObjectToReadID Then ' ReadObjectBuffer = AllObjects(Cntr) ' Exit For ' End If ' Next ' If Cntr <= TotAllObjects Then ' GoTo EndGORO ' End If ' End If SkipMem: ' don't seek if already there ' this is the new Universal Object ID Change ' PropsRS.Index = "ValueAlpha" ' PropsRS.Seek "=", ObjectToReadID ' Do While PropsRS.NoMatch = False ' If PropsRS!Property = "ugid" Then ' ObjectToReadID = PropsRS!ObjectID ' Exit Do ' End If ' PropsRS.MoveNext ' If PropsRS.EOF Then ' Exit Do ' End If ' If PropsRS!Property <> "ugid" Then ' Exit Do ' End If ' Loop If ObjectsRS![ObjectID] <> ObjectToReadID Then ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", ObjectToReadID End If If ObjectsRS![ObjectID] <> ObjectToReadID Then ReadObjectBuffer.Name = "" SetProperty Trace, NextID("trace") & "NT ReadGadgetByID Error", "Object read failed to locate the object #: " & ObjectToReadID SetProperty VGBErrors, NextID("error") & "NT RedGadgetByID Error", "Object read failed to locate the object #: " & ObjectToReadID Result = "ERROR: Object read failed to locate the object #: " & ObjectToReadID GoTo EndGORO End If ' GadgetWorkspace.BeginTrans removed 03/21/00 ReadObjectBuffer.ObjectID = ObjectsRS![ObjectID] ReadObjectBuffer.Level = ObjectsRS![Level] ReadObjectBuffer.GAppName = ObjectsRS![GAppName] ReadObjectBuffer.Container = ObjectsRS![Container] ReadObjectBuffer.Type = ObjectsRS![Type] ReadObjectBuffer.Name = ObjectsRS![Name] ' GadgetWorkspace.CommitTrans removed 03/21/00 GDSFreelocks 'GoTo OldWay starttime = Timer SQLCmd = "select * from props where props.objectid=" & ReadObjectBuffer.ObjectID & " order by props.propertyID;" Set RS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) RS.MoveLast GadgetNDX = RS.RecordCount ReadObjectBuffer.TotalProperties = GadgetNDX ReDim ReadObjectBuffer.PropertyID(GadgetNDX) ReDim ReadObjectBuffer.Propity(GadgetNDX) ReDim ReadObjectBuffer.Caption(GadgetNDX) ReDim ReadObjectBuffer.ValueAlpha(GadgetNDX) ReDim ReadObjectBuffer.ValueNum(GadgetNDX) ReDim ReadObjectBuffer.PropSource(GadgetNDX) ReDim ReadObjectBuffer.PropType(GadgetNDX) GadgetNDX = 0 RS.MoveFirst Do While RS.EOF = False GadgetNDX = GadgetNDX + 1 ReadObjectBuffer.PropertyID(GadgetNDX) = RS!PropertyID ReadObjectBuffer.Propity(GadgetNDX) = RS!Property ReadObjectBuffer.ValueAlpha(GadgetNDX) = RS!ValueAlpha ReadObjectBuffer.ValueNum(GadgetNDX) = RS!ValueNum ReadObjectBuffer.PropSource(GadgetNDX) = RS!PropSource ReadObjectBuffer.PropType(GadgetNDX) = RS!PropType RS.MoveNext Loop ' stoptime = Timer 'MsgBox "Time to load object By ID: " & CrLf & ReadObjectBuffer.Name & "-" & CrLf & stoptime - starttime & CrLf & "Props: " & ReadObjectBuffer.TotalProperties GoTo SkipProps OldWay: PropsRS.Index = "ObjectID" PropsRS.Seek "=", ObjectToReadID GadgetNDX = 0 If PropsRS.NoMatch = True Then ReDim ReadObjectBuffer.PropertyID(GadgetNDX) ReDim ReadObjectBuffer.Propity(GadgetNDX) ReDim ReadObjectBuffer.Caption(GadgetNDX) ReDim ReadObjectBuffer.ValueAlpha(GadgetNDX) ReDim ReadObjectBuffer.ValueNum(GadgetNDX) ReDim ReadObjectBuffer.PropSource(GadgetNDX) ReDim ReadObjectBuffer.PropType(GadgetNDX) GoTo SkipProps End If ' flush out the old stuff ' SQLCmd = "SELECT all count (objectid) " & _ "as [TotProps] From Props " & _ "where props.objectid=" & CStr(ObjectToReadID) & " and (Props.ValueAlpha <> 'VBasic') And (Props.ValueAlpha <> 'TLHicky');" 'starttime = Timer ' Set MemPropsRS = OpenDB(OpenDBPTR).OpenRecordset(SQLCmd, dbOpenDynaset) 'AllNamesCNTR = AllNamesCNTR + Val(MemPropsRS!TotProps) ' GadgetNDX = MemPropsRS!TotProps 'stoptime = Timer 'MsgBox stoptime - starttime GadgetNDX = 0 Do Until (PropsRS!ObjectID <> ObjectToReadID) If (PropsRS!ValueAlpha <> "VBasic") And (PropsRS!ValueAlpha <> "TLHicky") Then GadgetNDX = GadgetNDX + 1 End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If Loop ReDim ReadObjectBuffer.PropertyID(GadgetNDX) ReDim ReadObjectBuffer.Propity(GadgetNDX) ReDim ReadObjectBuffer.Caption(GadgetNDX) ReDim ReadObjectBuffer.ValueAlpha(GadgetNDX) ReDim ReadObjectBuffer.ValueNum(GadgetNDX) ReDim ReadObjectBuffer.PropSource(GadgetNDX) ReDim ReadObjectBuffer.PropType(GadgetNDX) ' suck in the new Props PropsRS.Seek "=", ObjectToReadID If (PropsRS.NoMatch Or PropsRS.EOF) Then GoTo SkipProps End If GadgetNDX = 0 Do Until (PropsRS!ObjectID <> ObjectToReadID) If (PropsRS!ValueAlpha <> "VBasic") And (PropsRS!ValueAlpha <> "TLHicky") Then ' GadgetWorkspace.BeginTrans removed 03/21/00 GadgetNDX = GadgetNDX + 1 ReadObjectBuffer.PropertyID(GadgetNDX) = PropsRS!PropertyID ' GDSFreelocks ReadObjectBuffer.Propity(GadgetNDX) = PropsRS!Property ' GDSFreelocks ReadObjectBuffer.ValueAlpha(GadgetNDX) = PropsRS!ValueAlpha ' GDSFreelocks ReadObjectBuffer.ValueNum(GadgetNDX) = PropsRS!ValueNum ' GDSFreelocks ReadObjectBuffer.PropSource(GadgetNDX) = PropsRS!PropSource ' GDSFreelocks ReadObjectBuffer.PropType(GadgetNDX) = PropsRS!PropType ' GDSFreelocks ' GadgetWorkspace.CommitTrans removed 03/21/00 Else ' MsgBox "Debug" End If ' GDSFreelocks PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If ' If PropsRS!ObjectID <> ObjectToReadID Then ' Exit Do ' End If Loop ReadObjectBuffer.TotalProperties = GadgetNDX SkipProps: GoTo EndGORO: ' ' flush old methods down the toilet ' GadgetNDX = 0 ' ReDim ReadObjectBuffer.MethodID(GadgetNDX) ' ReDim ReadObjectBuffer.MethType(GadgetNDX) ' ReDim ReadObjectBuffer.Method(GadgetNDX) ' ReDim ReadObjectBuffer.MethAction(GadgetNDX) ' MethodsRS.Index = "Objectid" ' MethodsRS.Seek "=", ObjectToReadID ' ' suck in the methods ' If (MethodsRS.NoMatch Or MethodsRS.EOF) Then ' GoTo EndGORO ' End If ' Do Until (MethodsRS!ObjectID <> ObjectToReadID) ' GadgetNDX = GadgetNDX + 1 ' ReDim Preserve ReadObjectBuffer.MethodID(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.MethType(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.Method(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.MethAction(GadgetNDX) ' ReadObjectBuffer.MethodID(GadgetNDX) = MethodsRS!MethodID ' ReadObjectBuffer.MethType(GadgetNDX) = MethodsRS!MethType ' ReadObjectBuffer.Method(GadgetNDX) = MethodsRS!Method ' ReadObjectBuffer.MethAction(GadgetNDX) = MethodsRS!MethAction ' GDSFreelocks ' PropsRS.MoveNext ' If MethodsRS.EOF Then ' Exit Do ' End If ' Loop GoTo EndGORO: LocalError: ' MsgBox Error LocalError = Error SetProperty Trace, NextID("trace") & "Trapped ReadGadgetByID Error", ObjectToReadID & " / " & LocalError SetProperty VGBErrors, NextID("error") & "Trapped ReadGadgetByID Error", ObjectToReadID & " / " & LocalError Resume Next EndGORO: ObjectsRS.Index = StartKey ObjectsRS.Bookmark = StartBookMark PropsRS.Index = StartPropKey PropsRS.Bookmark = StartPropBookmark ReadGadgetByID = Result stoptime = Timer GDSFreelocks ' MsgBox "Time to load object By ID: " & CrLf & ReadObjectBuffer.Name & "-" & CrLf & stoptime - starttime & CrLf & "Props: " & ReadObjectBuffer.TotalProperties End Function Friend Function ReadDiskGadgetByID(ObjectToReadID As Long) As Gadget ' read a gadget from the current db and return it to caller Dim starttime As Single, stoptime As Single Dim ReadObjectBuffer As Gadget Dim Cntr As Integer, TotAllObjects As Integer, AOPntr As Integer Dim StartBookMark As String, StartKey As String Dim StartPropBookmark As String, StartPropKey As String Dim GadgetNDX As Integer starttime = Timer Dim Result As String On Error GoTo LocalError ReadObjectBuffer = BlankObject ReadObjectBuffer.Name = NotFound StartBookMark = ObjectsRS.Bookmark StartKey = ObjectsRS.Index StartPropBookmark = PropsRS.Bookmark StartPropKey = PropsRS.Index ' On Error GoTo LocalError Result = "OK" ' ReadObjectBuffer.ObjectID = 0 If UBound(AllObjects()) > 0 Then TotAllObjects = UBound(AllObjects()) If TotAllObjects < ObjectsRS.RecordCount Then GoTo SkipMem For Cntr = 1 To TotAllObjects If AllObjects(Cntr).ObjectID = ObjectToReadID Then ReadObjectBuffer = AllObjects(Cntr) Exit For End If Next If Cntr <= TotAllObjects Then GoTo EndGORO End If SkipMem: End If ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", ObjectToReadID If ObjectsRS.NoMatch = True Then ReadObjectBuffer.Name = NotFound Result = "ERROR: Object read failed to locate the object #: " & ObjectToReadID GoTo EndGORO End If If ObjectsRS!ObjectID <> ObjectToReadID Then FloatMsgBox "Readbyid Boof! ID in=" & CStr(ObjectToReadID) & " Out=" & CStr(ObjectsRS!ObjectID), "ERROR!!!!" End If GadgetWorkspace.BeginTrans ReadObjectBuffer.ObjectID = ObjectsRS![ObjectID] ReadObjectBuffer.Level = ObjectsRS![Level] ReadObjectBuffer.GAppName = ObjectsRS![GAppName] ReadObjectBuffer.Container = ObjectsRS![Container] ReadObjectBuffer.Type = ObjectsRS![Type] ReadObjectBuffer.Name = ObjectsRS![Name] GadgetWorkspace.CommitTrans GDSFreelocks PropsRS.Index = "ObjectID" PropsRS.Seek "=", ObjectToReadID GadgetNDX = 0 If PropsRS.NoMatch = True Then ReDim ReadObjectBuffer.PropertyID(GadgetNDX) ReDim ReadObjectBuffer.Propity(GadgetNDX) ReDim ReadObjectBuffer.Caption(GadgetNDX) ReDim ReadObjectBuffer.ValueAlpha(GadgetNDX) ReDim ReadObjectBuffer.ValueNum(GadgetNDX) ReDim ReadObjectBuffer.PropSource(GadgetNDX) ReDim ReadObjectBuffer.PropType(GadgetNDX) GoTo SkipProps End If ' flush out the old stuff GadgetNDX = 0 Do Until (PropsRS!ObjectID <> ObjectToReadID) If (PropsRS!ValueAlpha <> "VBasic") And (PropsRS!ValueAlpha <> "TLHicky") Then GadgetNDX = GadgetNDX + 1 End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If Loop ReDim ReadObjectBuffer.PropertyID(GadgetNDX) ReDim ReadObjectBuffer.Propity(GadgetNDX) ReDim ReadObjectBuffer.Caption(GadgetNDX) ReDim ReadObjectBuffer.ValueAlpha(GadgetNDX) ReDim ReadObjectBuffer.ValueNum(GadgetNDX) ReDim ReadObjectBuffer.PropSource(GadgetNDX) ReDim ReadObjectBuffer.PropType(GadgetNDX) ' suck in the new Props PropsRS.Seek "=", ObjectToReadID If (PropsRS.NoMatch Or PropsRS.EOF) Then GoTo SkipProps End If GadgetNDX = 0 Do Until (PropsRS!ObjectID <> ObjectToReadID) If (PropsRS!ValueAlpha <> "VBasic") And (PropsRS!ValueAlpha <> "TLHicky") Then GadgetWorkspace.BeginTrans GadgetNDX = GadgetNDX + 1 ' ReDim Preserve ReadObjectBuffer.PropertyID(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.Propity(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.Caption(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.ValueAlpha(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.ValueNum(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.PropSource(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.PropType(GadgetNDX) GDSFreelocks ReadObjectBuffer.PropertyID(GadgetNDX) = PropsRS!PropertyID GDSFreelocks ReadObjectBuffer.Propity(GadgetNDX) = PropsRS!Property GDSFreelocks ReadObjectBuffer.ValueAlpha(GadgetNDX) = PropsRS!ValueAlpha GDSFreelocks ReadObjectBuffer.ValueNum(GadgetNDX) = PropsRS!ValueNum GDSFreelocks ReadObjectBuffer.PropSource(GadgetNDX) = PropsRS!PropSource GDSFreelocks ReadObjectBuffer.PropType(GadgetNDX) = PropsRS!PropType GDSFreelocks GadgetWorkspace.CommitTrans End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If Loop SkipProps: ReadObjectBuffer.TotalProperties = GadgetNDX ' flush old methods down the toilet GadgetNDX = 0 ReDim ReadObjectBuffer.MethodID(GadgetNDX) ReDim ReadObjectBuffer.MethType(GadgetNDX) ReDim ReadObjectBuffer.Method(GadgetNDX) ReDim ReadObjectBuffer.MethAction(GadgetNDX) ' MethodsRS.Index = "Objectid" ' MethodsRS.Seek "=", ObjectToReadID ' ' suck in the methods ' If (MethodsRS.NoMatch Or MethodsRS.EOF) Then ' GoTo EndGORO ' End If ' Do Until (MethodsRS!ObjectID <> ObjectToReadID) ' GadgetNDX = GadgetNDX + 1 ' ReDim Preserve ReadObjectBuffer.MethodID(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.MethType(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.Method(GadgetNDX) ' ReDim Preserve ReadObjectBuffer.MethAction(GadgetNDX) ' ReadObjectBuffer.MethodID(GadgetNDX) = MethodsRS!MethodID ' ReadObjectBuffer.MethType(GadgetNDX) = MethodsRS!MethType ' ReadObjectBuffer.Method(GadgetNDX) = MethodsRS!Method ' ReadObjectBuffer.MethAction(GadgetNDX) = MethodsRS!MethAction ' GDSFreelocks ' PropsRS.MoveNext ' If MethodsRS.EOF Then ' Exit Do ' End If ' Loop GoTo EndGORO: LocalError: ' MsgBox Error Resume Next EndGORO: ObjectsRS.Index = StartKey ObjectsRS.Bookmark = StartBookMark PropsRS.Index = StartPropKey PropsRS.Bookmark = StartPropBookmark ReadDiskGadgetByID = ReadObjectBuffer stoptime = Timer GDSFreelocks If ReadObjectBuffer.ObjectID <> ObjectToReadID Then FloatMsgBox "Readbyid Boof! ID in=" & CStr(ObjectToReadID) & " Readobjectbuffer Out=" & CStr(ReadObjectBuffer.ObjectID), "ERROR!!!!" End If On Error GoTo 0 ' MsgBox "Time to load object By ID: " & CrLf & ReadObjectBuffer.Name & "-" & CrLf & stoptime - starttime & CrLf & "Props: " & ReadObjectBuffer.TotalProperties End Function Friend Function GODReadContainedAndLinked(Param As Gadget, MasterGadgets() As Gadget, ContainedGadgets() As Gadget, LinkedGadgets() As Gadget) As Gadget ' this routine will read gadget object(s), all contained and/or linked ' objects into the respective arrays of gadgets Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Msg As String, Msg2 As String, Cntr1 As Integer, CNTR2 As Integer Dim SourcesRead As Integer, ContainersRead As Integer, LinksRead As Integer Dim SourcesWrote As Integer, ContainersWrote As Integer, LinksWrote As Integer Dim AddedLinkedToCNTR As Integer, FoundLinkedToCNTR As Integer Dim DoEventCNTR As Integer Dim TempGadget As Gadget Dim SourceDBGadgetPTR As Integer Dim DestDBGadgetPTR As Integer Dim ContainerToMove As String Dim LinkProp As String, LinkType As String Dim TransportMode As String Dim ResultsGadget As Gadget Dim CurrContainedObject As Gadget Dim LoadMasterGadgetsPTR As Integer, LoadMasterGadgetsCNTR As Integer Dim MasterGadgetsPTR As Integer, MasterGadgetsCNTR As Integer Dim SourceExisted As Boolean Dim ContainedGadgetsPTR As Integer, ContainedGadgetsCNTR As Integer Dim LinkedGadgetsPTR As Integer, LinkedGadgetsCNTR As Integer Dim DestGadget As Gadget Dim OldColName As String Dim NewColName As String Dim ExcludeTypes() As String, ExcludeTypesCNTR As Integer Dim ThisRS As Recordset Dim StartDBGPTR As Integer StartDBGPTR = DBGadgetsPTR ' begin a resultsgadget ResultsGadget = BlankObject ResultsGadget.Name = "Results of Container Loader" ResultsGadget.Type = "Function Status" ResultsGadget.Container = "Results" t = SetProperty(ResultsGadget, "Status", "Started") t = SetProperty(ResultsGadget, "StartTimer", CStr(starttime)) ' load excluded types For Cntr1 = 1 To 1000 If DoEventCNTR Mod 15 = 0 Then DoEventCNTR = 0 ' DoEvents Else DoEventCNTR = DoEventCNTR + 1 End If Msg = "Exclude Type" & CStr(Cntr1) Msg2 = UCase(ReadProperty(Param, Msg)) If Msg2 <> NotFound Then ExcludeTypesCNTR = ExcludeTypesCNTR + 1 ReDim Preserve ExcludeTypes(ExcludeTypesCNTR) ExcludeTypes(ExcludeTypesCNTR) = UCase(Msg2) Else Exit For End If Next ' set up source/destination variables ' see if there is a link property (a property that points to another object) MasterGadgetsCNTR = UBound(MasterGadgets) ContainedGadgetsCNTR = UBound(ContainedGadgets) LinkProp = ReadProperty(Param, "Take Link Property") If LinkProp = NotFound Then LinkProp = "None" End If LinkType = ReadProperty(Param, "Take Link Type") Msg = ReadProperty(Param, "Source Database") SourceDBGadgetPTR = DBFindIndex(Msg) LoadMasterGadgetsCNTR = Val(ReadProperty(Param, "Total Source Objects")) If LoadMasterGadgetsCNTR = 0 Then t = SetProperty(ResultsGadget, "Error", "No Master Gadget Specified") GoTo EndSub End If 'Read //////////////////////////////////////////////////////////////////////////////////////////// ' read source, contained and linked to objects ' MasterGadgetsCNTR = 1 For LoadMasterGadgetsPTR = 1 To LoadMasterGadgetsCNTR SourcesRead = SourcesRead + 1 ' switch to source db Msg = DBSwitch(SourceDBGadgetPTR) If Msg <> OK Then MsgBox Msg, , UCase(App.EXEName) & " Debug Message" t = SetProperty(ResultsGadget, "Error", Msg) GoTo NextMasterGadgets End If ' check to see if there is a seal of approval to check Msg = ReadProperty(Param, "Verification Object") '= "Seal of Approval" TempGadget = BlankObject If Msg <> NotFound Then t = ReadGadgetByName(Msg, TempGadget) If t <> OK Then Msg2 = "Failed to find: " & Msg MsgBox Msg2, vbExclamation, "Error: DB Verify Failure" t = SetProperty(ResultsGadget, "Error", "DB Verify Failure") GoTo EndSub End If End If Msg = ReadProperty(Param, "Source Object ID" & CStr(LoadMasterGadgetsPTR)) t = ReadGadgetByID(Val(Msg)) If t <> OK Then ' could not find this object GoTo NextMasterGadgets End If Msg = "Add" For Cntr1 = 1 To MasterGadgetsCNTR If MasterGadgets(Cntr1).ObjectID = ReadObjectBuffer.ObjectID Then Msg = "Found" Exit For End If Next If Msg = "Add" Then MasterGadgetsCNTR = MasterGadgetsCNTR + 1 ReDim Preserve MasterGadgets(MasterGadgetsCNTR) MasterGadgets(MasterGadgetsCNTR) = ReadObjectBuffer End If ' place the oid of original in tag of MasterGadgets to use later MasterGadgets(MasterGadgetsCNTR).Tag = MasterGadgets(MasterGadgetsCNTR).ObjectID Set ThisRS = OpenDB(OpenDBPTR).OpenRecordset("Objects", dbOpenTable) ', dbForwardOnly) ' need to fix up the links in the contained objects ThisRS.Index = "Container" ThisRS.Seek "=", MasterGadgets(MasterGadgetsCNTR).Tag Do While ThisRS.NoMatch = False ' DoEvents If ThisRS!Name = MasterGadgets(MasterGadgetsCNTR).Name Then GoTo NextRecord: End If t = ReadGadgetByID(ThisRS!ObjectID) CurrContainedObject = ReadObjectBuffer If t <> OK Then MsgBox "Error Reading Contained Object: " & t, , UCase(App.EXEName) & " Debug Message" GoTo NextMasterGadgets End If Msg = "Include" For Cntr1 = 1 To ExcludeTypesCNTR If UCase(CurrContainedObject.Type) = ExcludeTypes(Cntr1) Then Msg = "Exclude" Exit For End If Next If Msg = "Exclude" Then GoTo NextRecord End If Msg = "Add" For Cntr1 = 1 To ContainedGadgetsCNTR If ContainedGadgets(Cntr1).ObjectID = ReadObjectBuffer.ObjectID Then If ContainedGadgets(Cntr1).Container = CStr(MasterGadgets(LoadMasterGadgetsPTR).ObjectID) Then Msg = "Skip" Exit For End If End If Next If Msg = "Add" Then ContainersRead = ContainersRead + 1 ContainedGadgetsCNTR = ContainedGadgetsCNTR + 1 ReDim Preserve ContainedGadgets(ContainedGadgetsCNTR) ContainedGadgets(ContainedGadgetsCNTR) = CurrContainedObject ContainedGadgets(ContainedGadgetsCNTR).Tag = MasterGadgets(MasterGadgetsCNTR).ObjectID If LinkProp <> "None" Then t = ReadProperty(ContainedGadgets(ContainedGadgetsCNTR), LinkProp) If (t <> NotFound) And t <> "None" Then ' there is a linked property t = ReadGadgetByID(Val(t)) If t <> OK Then MsgBox "Error Reading Linked Object: " & t, , UCase(App.EXEName) & " Debug Message" Else LinksRead = LinksRead + 1 LinkedGadgetsCNTR = LinkedGadgetsCNTR + 1 ReDim Preserve LinkedGadgets(LinkedGadgetsCNTR) LinkedGadgets(LinkedGadgetsCNTR) = ReadObjectBuffer LinkedGadgets(LinkedGadgetsCNTR).ObjectID = 0 LinkedGadgets(LinkedGadgetsCNTR).Tag = ReadObjectBuffer.ObjectID End If End If End If End If NextRecord: ThisRS.MoveNext If ThisRS.EOF Then Exit Do If ThisRS!Container <> MasterGadgets(MasterGadgetsCNTR).Tag Then Exit Do Loop t = SetProperty(ResultsGadget, "Total Contained" & CStr(LoadMasterGadgetsPTR), CStr(ContainedGadgetsCNTR)) t = SetProperty(ResultsGadget, "Total Linked" & CStr(LoadMasterGadgetsPTR), CStr(LinkedGadgetsCNTR)) ' t = SetProperty(ResultsGadget, "Read Timer", CStr(Timer)) ' t = SetProperty(ResultsGadget, "Read Time", CStr(Timer - starttime)) ' DoEvents NextMasterGadgets: If AbortRead Then GoTo EndSub Next LoadMasterGadgetsPTR t = SetProperty(ResultsGadget, "Status", "Done") EndSub: DBSwitch 1 stoptime = Timer t = SetProperty(ResultsGadget, "Masters Loaded", CStr(SourcesRead)) t = SetProperty(ResultsGadget, "Contained Gadgets Loaded", CStr(ContainersRead)) t = SetProperty(ResultsGadget, "Linked Gadgets Loaded", CStr(LinksRead)) ' t = SetProperty(ResultsGadget, "Contained Gadgets Loaded", CStr(ContainersRead)) t = SetProperty(ResultsGadget, "StopTimer", CStr(stoptime)) t = SetProperty(ResultsGadget, "Total Time", CStr(stoptime - starttime)) ' MsgBox stoptime - starttime GODReadContainedAndLinked = ResultsGadget AbortRead = False DBSwitch StartDBGPTR On Error GoTo 0 End Function Friend Function GODReadContainerObject(ObjectToReadName As String, _ ContainerToUse As String, _ GORReadObjectBuffer As Gadget) As String ' read Dim Crit As String, t, GadgetNDX As Integer, starttime As Single, stoptime As Single Dim IDToRead As Long starttime = Timer Dim SourceRS As Recordset, SourceMethodRS As Recordset Dim NewRS As String, OldPropRS As String Dim Result As String Result = "OK" GORReadObjectBuffer.Name = "" ObjectsRS.Index = "Container" ObjectsRS.Seek "=", ContainerToUse If ObjectsRS.NoMatch Then Result = "ERROR: Object read failed to locate the object named:" & ObjectToReadName & " in: " & ContainerToUse GoTo EndGORO End If With ObjectsRS Do Until .EOF If UCase(!Name) = UCase(ObjectToReadName) Then ' we have a winner Exit Do End If .MoveNext If .EOF Then Result = "NOT FOUND" GoTo EndGORO End If If !Container <> ContainerToUse Then Result = "NOT FOUND" GoTo EndGORO End If Loop End With IDToRead = ObjectsRS!ObjectID t = ReadGadgetByID(IDToRead) If t = "OK" Then GORReadObjectBuffer = ReadObjectBuffer Else Result = t End If EndGORO: GODReadContainerObject = Result stoptime = Timer GDSFreelocks 'MsgBox "Time to load object: " & GORReadObjectBuffer.Name & "-" & CrLf & stoptime - starttime End Function Friend Function CopyDatabase(Param As Gadget) As Gadget ' this is the remotely requested db creater ' it will really clone any db (not currently open) End Function Friend Function AddDatabase(Param As Gadget) As Gadget ' this will add a database to the system ' Caller provides: ' "SourcePath" ' "SourceFile" ' "DestPath" ' "DestFile" ' "Stop on error" ' "Write Param" ' "Write Param File DBGadgetPTR" ' "Created by" ' and this creates/adds the dbgadget and appdbgadgets for this app ' note: a new database is a copy of the db specified in the sourcefile property Dim starttime As Single, stoptime As Single, tracetime As Single starttime = Timer Dim t, Msg As String, Cntr1 As Integer Dim RREsults As Gadget, MResults As Gadget Dim AppPath As String Dim SourcePath As String Dim SourceFile As String Dim SourceFileName As String Dim DestPath As String Dim DestFile As String Dim DestFileName As String Dim LocalError As String Dim ResultsGadget As Gadget Dim LParam As Gadget Dim StartDBGadgetsPTR As Integer StartDBGadgetsPTR = DBGadgetsPTR ResultsGadget.Name = "Started" SetProperty ResultsGadget, "Status", OK LParam = Recall(Param.Name, "from " & VGBDatabaseNameAndPath) If LParam.Name = Param.Name Then Param.ObjectID = LParam.ObjectID End If SourceFile = ReadProperty(Param, "SourceFile") SourcePath = AddBackSlash(ReadProperty(Param, "SourcePath")) SourceFileName = SourcePath & SourceFile DestFile = ReadProperty(Param, "DestFile") DestPath = AddBackSlash(ReadProperty(Param, "DestPath")) DestFileName = DestPath & DestFile SetProperty Trace, NextID("trace") & "AddDatabase", "SourceFileName: " & SourceFileName & "/ DestFileName: " & DestFileName ' Result = "OK" On Error GoTo LocalError: If Not FileExists(SourceFileName) Then t = SetProperty(Param, "Error", SourceFileName & ": Blank File NOT FOUND" & Msg) SetProperty Trace, NextID("trace") & "AddDatabase ERROR", SourceFileName & ": File NOT FOUND" SetProperty VGBErrors, NextID("error") & "AddDatabase ERROR", SourceFileName & ": File NOT FOUND" Msg = "No Blank File!" & CrLf Msg = Msg & "Please make sure that " & SourceFile & " is in directory:" & CrLf Msg = Msg & SourcePath & CrLf Msg = Msg & "and retry create database function." ' FloatMsgBox Msg, UCase(App.EXEName) & " [No Blank Database Error]" t = SetProperty(ResultsGadget, "Error", SourceFileName & ": Blank File NOT FOUND" & Msg) t = SetProperty(ResultsGadget, "Status", "Error") GoTo EndSub End If If FileExists(DestFileName) Then ' need to register and leave LParam = BlankObject Msg = ReadProperty(Param, "User Name") If Msg = NotFound Then Msg = "" End If ' !!! need to add the ability to use indexed list of databases with ' us maintaining the relationships If Msg <> "" Then ' this means that they have a long name ' we will create another indexed db and assign it to this long name ' or not End If t = SetProperty(LParam, "DB Path", DestPath) t = SetProperty(LParam, "DB Name", DestFile) t = SetProperty(LParam, "DB Path and Name", DestFileName) Msg = ReadProperty(Param, "Show DB to User") If Msg = NotFound Then Msg = "True" End If t = SetProperty(LParam, "Show DB to User", Msg) t = SetProperty(LParam, "DB GadgetsPTR Template", "1") t = SetProperty(LParam, "Created by", ReadProperty(Param, "Created by")) RegisterDatabase LParam ' we now have this database in dbgadgets and in appgadgets t = SetProperty(Param, "Error", "Dest File Exists" & Msg) Msg = "" Msg = Msg & "File: " & DestFileName & CrLf Msg = Msg & "is already on disk." & CrLf & CrLf Msg = Msg & "Existing File Registered" & CrLf If ReadProperty(Param, "Stop on error") = "Yes" Then If Not ExecutingSchedule Then t = MsgBox(Msg, vbOK + vbExclamation, "Error: Requested File Already Exists") End If End If t = SetProperty(ResultsGadget, "Status", SourceFileName & ": Already On Disk") SetProperty Trace, NextID("trace") & "AddDatabase", DestFileName & ": File Exists, registering" GoTo RegisterOnly End If ' here we know that the file doesn't exist on disk LocalError = "" FileCopy SourceFileName, DestFileName If LocalError <> "" Then ' copy got an error Msg = "" Msg = Msg & "Copying Empty File to:" & CrLf Msg = Msg & DestFileName & CrLf t = SetProperty(Param, "Local Error", "After DB Copy: " & LocalError) If ReadProperty(Param, "Stop on error") = "Yes" Then t = MsgBox(Msg, vbOKOnly + vbExclamation, "Error: " & LocalError) End If GoTo EndSub End If If Not FileExists(DestFileName) Then ' something wierd happened, copy didn't get error but file is not there t = SetProperty(Param, "Copy Error", ": " & "File not found after copy had no error") SetProperty Trace, NextID("trace") & "AddDatabase Copy ERROR", DestFileName & ": NOT FOUND after copy" SetProperty VGBErrors, NextID("error") & "AddDatabase Copy ERROR", DestFileName & ": NOT FOUND after copy" ' MsgBox "Database Creation failed: " & LocalError, , ucase(App.EXEName) & " Debug Error" Msg = "Database Creation failed. VB Error: " & LocalError If ReadProperty(Param, "Stop on error") = "Yes" Then MsgBox Msg, , UCase(App.EXEName) & " Debug Message" End If t = SetProperty(ResultsGadget, "Error", SourceFileName & ": Blank File NOT FOUND" & Msg) GoTo EndSub End If ' copy succeeded, need to register this new db RegisterOnly: LParam = BlankObject t = SetProperty(LParam, "DB Path", DestPath) t = SetProperty(LParam, "DB Name", DestFile) t = SetProperty(LParam, "DB Path and Name", DestFileName) t = SetProperty(LParam, "DB GadgetsPTR Template", "1") Msg = ReadProperty(Param, "Show DB to User") If Msg = NotFound Then Msg = "True" End If t = SetProperty(LParam, "Show DB to User", Msg) t = SetProperty(LParam, "Created by", ReadProperty(Param, "Created by")) RegisterDatabase LParam Cntr1 = DBFindIndex(DestFileName) If Cntr1 < 0 Then SetProperty Trace, NextID("trace") & "AddDatabase DBSwitch ERROR", DestFileName & ": Index NOT FOUND" SetProperty VGBErrors, NextID("error") & "AddDatabase DBSwitch ERROR", DestFileName & ": Index NOT FOUND" ResultsGadget.Name = "Error" SetProperty ResultsGadget, "Status", "Error Switching to Database" GoTo EndSub End If ' t = DBSwitch(Cntr1) ' MResults = Memorize(LParam, "in " & VGBDatabaseNameAndPath) ResultsGadget.Name = OK SetProperty ResultsGadget, "Status", OK GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "AddDatabse Error", "" & Param.Name & "/" & "Error: " & LocalError SetProperty VGBErrors, NextID("error") & "AddDatabse Error", "" & Param.Name & "/" & "Error: " & LocalError Resume Next EndSub: If DBGadgetsPTR <> StartDBGadgetsPTR Then DBSwitch StartDBGadgetsPTR End If On Error GoTo 0 GDSFreelocks AddDatabase = ResultsGadget End Function Friend Function RegisterDatabase(Param As Gadget) As Gadget ' add a database to the dbgadgets pool ' Param properties ' "DB Path" ' "DB Name" ' "DB Path and Name" ' "DB GadgetsPTR Template" ' "Created by" Dim t, Msg As String, Cntr1 As Integer Dim RREsults As Gadget, MResults As Gadget Dim TotDbs As Integer Dim ThisDBGadget As Gadget Dim ThisDBName As String Dim DBPTRToUse As Integer Dim StartAppPTR As Integer, StartDBPTR As Integer Dim MYAppPTR As Integer Dim MyDBPTR As Integer Dim CheckDBPathAndName As String Dim AppDBPathAndName As String Dim DBPathAndName As String Dim LocalError As String Dim Result As String Dim ResultsGadget As Gadget Dim RegResults As Gadget Dim OpenResults As Gadget SetProperty Trace, NextID("trace") & "RegisterDatabase Start *********************************", "***" StartAppPTR = AppGadgetsPTR StartDBPTR = DBGadgetsPTR If DBGadgetsPTR > 0 Then DBSwitch 0 End If ' this is the one to do CheckDBPathAndName = UCase(ReadProperty(Param, "DB Path and Name")) ' find an app that is me For MYAppPTR = 1 To AppGadgetsCNTR If AppGadgets(MYAppPTR).Name = UCase(App.EXEName) Then Exit For End If Next MYAppPTR If MYAppPTR > AppGadgetsCNTR Then FloatMsgBox "RegisterDatabase Function didn't find itself", UCase(App.EXEName) & " Error" ' need to cread an error object End If ' check dbgadgets for this db (path and name), if exists, flag status found For MyDBPTR = 0 To DBGadgetsCNTR ThisDBName = ReadProperty(DBGadgets(MyDBPTR), "DB Name") DBPathAndName = ReadProperty(DBGadgets(MyDBPTR), "Path") If Right(DBPathAndName, 1) <> "\" Then DBPathAndName = DBPathAndName & "\" End If DBPathAndName = DBPathAndName & ThisDBName If UCase(DBPathAndName) = CheckDBPathAndName Then ' this db is this dbgadget SetProperty Param, "DBGadgetsPTR", CStr(MyDBPTR) SetProperty Param, "DBGadgetStatus", "Found" Exit For End If Next MyDBPTR ' was this dbgadget found? If MyDBPTR > DBGadgetsCNTR Then ' not found, need to create and add the dbgadget to the disk ' create the blank object DBGadgetsCNTR = DBGadgetsCNTR + 1 MyDBPTR = DBGadgetsCNTR ReDim Preserve DBGadgets(DBGadgetsCNTR) t = SetProperty(Param, "DBGadgetsPTR", CStr(MyDBPTR)) t = SetProperty(Param, "DBGadgetStatus", "Added") ' see if there is a specific dbgadgets object to use as template t = ReadProperty(Param, "DB GadgetsPTR Template") ' this is if no specific dbgadget was given for the object template ' use dbgadget #1, if not If Val(t) = 0 Then t = 1 End If DBPTRToUse = Val(t) ' set new dbgadget to the template one DBGadgets(MyDBPTR) = DBGadgets(DBPTRToUse) ' it's new gadget, save as such (id=0 forces save new object) DBGadgets(MyDBPTR).ObjectID = 0 DBGadgets(MyDBPTR).Tag = "RegisterDatabase: MyDBPTR>DBGadgetsCNTR " & Now ' get a new dbgadget index t = ReadProperty(DBGadgetDef, "Last DBGadget Name Index") t = Val(t) + 1 Msg = SetProperty(DBGadgetDef, "Last DBGadget Name Index", CStr(t)) ' save the index to definition file MResults = Memorize(DBGadgetDef, VGBDatabaseNameAndPath) ' use the thisdbname variable to refer to this db, duh ThisDBName = UCase(ReadProperty(Param, "DB Name")) ' the dbgadgets name is the dbname + index (allows for same name, different dirs) DBGadgets(MyDBPTR).Name = ThisDBName & "-" & CStr(t) DBGadgets(MyDBPTR).Type = "DBGadget" DBGadgets(MyDBPTR).Container = "AppGadget" ' fix up all the properties of the new dbgadget t = SetProperty(DBGadgets(MyDBPTR), "DB Name", ThisDBName) Msg = ReadProperty(Param, "DB Path") t = SetProperty(DBGadgets(MyDBPTR), "Path", UCase(Msg)) Msg = Format(Date, "mm/dd/yyyy") & " " & Format(Time, "Long Time") t = SetProperty(DBGadgets(MyDBPTR), "Date Created", Msg) Msg = ReadProperty(Param, "Created by") t = SetProperty(DBGadgets(MyDBPTR), "Created by", Msg) t = SetProperty(DBGadgets(MyDBPTR), "AutoOpen", "True") DBPathAndName = ReadProperty(DBGadgets(MyDBPTR), "Path") If Right(DBPathAndName, 1) <> "\" Then DBPathAndName = DBPathAndName & "\" End If DBPathAndName = DBPathAndName & ThisDBName ' this db is this dbgadget t = SetProperty(Param, "DBGadgetsPTR", CStr(MyDBPTR)) t = SetProperty(Param, "DBGadgetStatus", "Added") ' bronze it MResults = Memorize(DBGadgets(MyDBPTR), VGBDatabaseNameAndPath) ' t = WriteGDSGadget(DBGadgets(MyDBPTR).ObjectID, DBGadgets(MyDBPTR)) End If ' here, this db already has a db gadget defined ' is it already registered to this app? ' set the appdbgadget (these are db's for this app only) ' the appdbgadget is used to flag enabled per application ' format: appname + dbgadget name (has index number) Msg = UCase(App.EXEName) & "-" & UCase(DBGadgets(MyDBPTR).Name) For Cntr1 = 0 To AppDBGadgetsCNTR If AppDBGadgets(Cntr1).Name = Msg Then t = SetProperty(Param, "AppDBGadgetStatus", "Found") AppDBGadgetsPTR = Cntr1 Exit For End If Next If Cntr1 > AppDBGadgetsCNTR Then ' not found, added AppDBGadgetsCNTR = AppDBGadgetsCNTR + 1 AppDBGadgetsPTR = AppDBGadgetsCNTR ReDim Preserve AppDBGadgets(AppDBGadgetsPTR) AppDBGadgets(AppDBGadgetsPTR) = BlankObject AppDBGadgets(AppDBGadgetsPTR).Name = UCase(App.EXEName) & "-" & DBGadgets(MyDBPTR).Name AppDBGadgets(AppDBGadgetsPTR).ObjectID = 0 AppDBGadgets(AppDBGadgetsPTR).Type = "AppDBGadget" AppDBGadgets(AppDBGadgetsPTR).Container = UCase(App.EXEName) AppDBGadgets(AppDBGadgetsPTR).Tag = "RegisterDatabase/AppDBGadgetsPTR > AppDBGadgetsCNTR" Msg = ReadProperty(Param, "Show DB to User") If Msg = NotFound Then Msg = "True" End If t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "DB Name", ThisDBName) t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "Show DB to User", Msg) t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "DBGadgets ID", CStr(DBGadgets(MyDBPTR).ObjectID)) t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "Enabled", "True") t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "Open in this App?", "True") t = SetProperty(Param, "AppDBGadgetStatus", "Added") Else t = ReadProperty(AppDBGadgets(AppDBGadgetsPTR), "Enabled") If t = NotFound Then t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "Enabled", "True") End If End If MResults = Memorize(AppDBGadgets(AppDBGadgetsPTR), VGBDatabaseNameAndPath) ' t = WriteGDSGadget(AppDBGadgets(AppDBGadgetsPTR).ObjectID, AppDBGadgets(AppDBGadgetsPTR)) ' these are the recordsets for this app only For Cntr1 = 0 To AppRSGadgetsCNTR If UCase(ReadProperty(AppRSGadgets(Cntr1), "DB Name")) = ThisDBName Then If AppRSGadgets(Cntr1).Container = UCase(App.EXEName) Then Exit For End If End If Next If Cntr1 > AppRSGadgetsCNTR Then ' need to create all new app rs ojects For Cntr1 = 1 To 3 Select Case True Case Cntr1 = 1 Msg = "Objects" Case Cntr1 = 2 Msg = "Props" Case Cntr1 = 3 Msg = "Methods" End Select AppRSGadgetsCNTR = AppRSGadgetsCNTR + 1 AppRSGadgetsPTR = AppRSGadgetsCNTR ReDim Preserve AppRSGadgets(AppRSGadgetsCNTR) AppRSGadgets(AppRSGadgetsCNTR) = BlankObject AppRSGadgets(AppRSGadgetsCNTR).ObjectID = 0 AppRSGadgets(AppRSGadgetsCNTR).Name = UCase(App.EXEName) & "-" & DBGadgets(MyDBPTR).Name & "-" & Msg AppRSGadgets(AppRSGadgetsCNTR).Type = "AppRSGadget" AppRSGadgets(AppRSGadgetsCNTR).Container = UCase(App.EXEName) t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "DB Name", ThisDBName) t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "RS Name", Msg & "RS") t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "RS Source", Msg) t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "RS Index", "?") t = ReadGadgetByName(AppRSGadgets(AppRSGadgetsCNTR).Name, ReadObjectBuffer) If t = OK Then AppRSGadgets(AppRSGadgetsCNTR).ObjectID = ReadObjectBuffer.ObjectID End If MResults = Memorize(AppRSGadgets(AppRSGadgetsCNTR), "in " & VGBDatabaseNameAndPath) ' t = WriteGDSGadget(AppRSGadgets(AppRSGadgetsCNTR).ObjectID, AppRSGadgets(AppRSGadgetsCNTR)) Next Cntr1 End If ' this db is registered, need to open it? ResultsGadget = OpenJetDataBase(DBGadgets(MyDBPTR)) GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "Register DB Trapped", "Error: " & Param.Name & " / " & LocalError SetProperty VGBErrors, NextID("error") & "Register DB Trapped", "Error: " & Param.Name & " / " & LocalError ' MsgBox "Error in RegisterDatabase" & CrLf & LocalError, , UCase(App.EXEName) & " Debug Message" Resume Next EndSub: On Error GoTo 0 DBSwitch StartDBPTR SetProperty Trace, NextID("trace") & "RegisterDatabase End *********************************", "***" RegisterDatabase = ResultsGadget End Function Friend Function GODDeleteDatabase(Param As Gadget) As String ' delete a database! WARNING: Permanent operation. DB is Gone, Gone, Gone and Gone ' provide the database name and path in Param: ' "DBPath And Name" Dim t, Msg As String, Cntr1 As Integer, CNTR2 As Integer Dim LParam As Gadget Dim ResultsGadget As Gadget Dim DBPath As String, DBName As String, DBPathAndName As String Dim LDBFile As String Dim PromptUser As Boolean Dim StartDBGadgetsPTR As Integer Dim NumObjects As Long, NumProps As Long Dim TempDBGadgetsPTR As Integer Dim ClosedDBGadgetPTR As Integer Dim Result As String Dim LocalError As String LocalError = "" On Error GoTo LocalError Result = "Error" StartDBGadgetsPTR = DBGadgetsPTR DBPathAndName = ReadProperty(Param, "DBPath And Name") LParam = BlankObject t = SetProperty(LParam, "PathFile", DBPathAndName) ResultsGadget = ExtractPathAndFile(LParam) DBPath = UCase(ReadProperty(ResultsGadget, "Path Only")) DBName = UCase(ReadProperty(ResultsGadget, "File Only")) LDBFile = DBPath & UCase(ReadProperty(ResultsGadget, "File Name Without Extension")) LDBFile = LDBFile & ".LDB" PromptUser = (ReadProperty(Param, "Prompt User") = "True") For TempDBGadgetsPTR = 1 To DBGadgetsCNTR If ReadProperty(DBGadgets(TempDBGadgetsPTR), "DB Name") = DBName Then If UCase(AddBackSlash(ReadProperty(DBGadgets(TempDBGadgetsPTR), "Path"))) = DBPath Then Exit For End If End If Next If TempDBGadgetsPTR > DBGadgetsCNTR Then If PromptUser Then Msg = "Error Locating DB: " MsgBox Msg & DBPathAndName End If Result = Msg GoTo EndSub End If If TempDBGadgetsPTR < 2 Then If PromptUser Then Msg = "" Msg = Msg & "Sorry, Can't Delete a System File" & CrLf MsgBox Msg, vbExclamation, "Error: Can't Perform Delete" End If Result = Msg GoTo EndSub End If If Not FileExists(DBPathAndName) Then If PromptUser Then Msg = "File Not Found: " & CrLf Msg = Msg & DBPathAndName MsgBox "Error Locating DB: " & DBPathAndName End If Result = Msg GoTo EndSub End If Cntr1 = DBFindIndex(DBPathAndName) If Cntr1 < 0 Then '!!!!!!!! fix this End If t = DBSwitch(Cntr1) If t = OK Then NumObjects = ObjectsRS.RecordCount NumProps = PropsRS.RecordCount End If DBSwitch 1 If PromptUser Then Msg = "" Msg = Msg & Space(13) & "WARNING!" & CrLf Msg = Msg & "DELETING IS PERMANENT!" & CrLf Msg = Msg & " IT CANNOT BE UNDONE!" & CrLf & CrLf Msg = Msg & "You are about to Delete Database:" & CrLf Msg = Msg & DBPathAndName & CrLf Msg = Msg & "" & CrLf Msg = Msg & "Total Objects in Database: " & CStr(NumObjects) & CrLf Msg = Msg & "" & CrLf Msg = Msg & "Are You ABSOLUTELY Sure About this?" & CrLf t = MsgBox(Msg, vbExclamation + vbYesNo + vbDefaultButton2, "Confirm DELETE Database") If t <> vbYes Then Result = "Aborted By User" GoTo EndSub End If End If GDSMsg.Caption = "Deleting Database" GDSMsg.CommandClose.Visible = False GDSMsg.Show GDSMsg.WindowState = NORMAL GDSMsg.MsgText.Visible = True GDSMsg.MsgText = "" GDSMsg.MsgText = GDSMsg.MsgText & "Please wait while I delete the Database and Reinitialize the System. This will take a few seconds" & CrLf ' DoEvents ' well, let's delete it ' which one is it? ' Screen.MousePointer = NORMAL ClosedDBGadgetPTR = TempDBGadgetsPTR OpenDB(TempDBGadgetsPTR).Close LocalError = "" ' now erase file Kill DBPathAndName If LocalError <> "" Then If PromptUser Then MsgBox LocalError, , UCase(App.EXEName) & " Debug Message" End If Result = LocalError Else Result = OK End If If FileExists(LDBFile) Then Kill LDBFile End If GDSMsg.Caption = "Reinitializing System" LParam.Name = "Reset" InitVGB LParam ' GDSRegistry.ListIndex = GDSRegistry.ListIndex - 1 Unload GDSMsg ' If PromptUser Then ' MsgBox "File Deleted, System Reinitialized", vbInformation, "Delete Complete" ' End If GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: On Error GoTo 0 ' Screen.MousePointer = NORMAL GODDeleteDatabase = Result End Function Friend Function OpenJetDataBase(DBGadgetToUse As Gadget) As Gadget ' open a db based on the dbgadget passed Dim t, Msg As String, Msg2 As String, Cntr1 As Integer, CNTR2 As Integer, Cntr3 As Integer Dim RREsults As Gadget, MResults As Gadget Dim StartDBGPTR As Integer Dim starttime As Single Dim OpenThisDB As String starttime = Timer Dim DBProp As String, AppPath As String Dim LocDBGadget As Gadget Dim DBPathAndName As String Dim ThisDBName As String Dim CurrOpenDBPTR As Integer Dim ForceOpenDBPTR As Integer Dim CorrectDBGPTR As Integer Dim WriteAppDBCntr As Integer Dim Result As String Dim ResultsGadget As Gadget Dim LocalError As String StartDBGPTR = DBGadgetsPTR On Error GoTo LocalError ' DoEvents Result = OK ' work with local copy of dbgadget LocDBGadget = DBGadgetToUse SetProperty Trace, NextID("trace") & "OpenJetDataBase", DBGadgetToUse.Name ' this allows us to open a given database in a forced array index Msg = ReadProperty(LocDBGadget, "Force OpenDBPTR") If Msg = NotFound Then ForceOpenDBPTR = -1 Else ForceOpenDBPTR = Val(Msg) End If ThisDBName = ReadProperty(LocDBGadget, "DB Name") If ThisDBName = NotFound Then If Not ExecutingSchedule Then FloatMsgBox "DB Name Not Found", UCase(App.EXEName) & " Debug Message" End If End If DBPathAndName = ReadProperty(LocDBGadget, "Path") If Right(DBPathAndName, 1) <> "\" Then DBPathAndName = DBPathAndName & "\" End If DBPathAndName = DBPathAndName & ThisDBName DBPathAndName = UCase(DBPathAndName) ' set the dbgadgetsptr to this dbgadget For DBGadgetsPTR = 0 To DBGadgetsCNTR If DBGadgets(DBGadgetsPTR).Name = DBGadgetToUse.Name Then CorrectDBGPTR = DBGadgetsPTR Exit For End If Next If DBGadgetsPTR > DBGadgetsCNTR Then ' severe error if this dbgadget isn't found FloatMsgBox " Error: " & DBGadgetToUse.Name & " Not found in DB Definitions", UCase(App.EXEName) & " Debug Message" End If OpenThisDB = "Open This DB" If ForceOpenDBPTR < 0 Then For Cntr1 = 0 To OpenDBCNTR LocalError = "" If UCase(OpenDB(Cntr1).Name) = UCase(DBPathAndName) Then ' this db is already open If LocalError = "" Then OpenThisDB = "Do Not Open This DB" Exit For End If End If Next Cntr1 Else ' DBSwitch 1 End If LocalError = "" ' the db is not open, let's see if it is flagged to open in this app ' autoopen in dbgadgets doesn't override appdbgadget setting For Cntr1 = 1 To AppDBGadgetsCNTR WriteAppDBCntr = 0 ' check name to see if this is it If ReadProperty(AppDBGadgets(Cntr1), "DB Name") = ThisDBName Then ' AppDBGadgets(Cntr1).Name = Msg Then ' this is the correct appdbgadget, should we open it? Msg2 = ReadProperty(AppDBGadgets(Cntr1), "Open in this App?") Select Case True Case (UCase(ThisDBName) = "RWS.RWS" And OpenThisDB = "Open This DB") Or (ForceOpenDBPTR > 0) Exit For Case ForceOpenDBPTR > 0 ' this makes us open it temporarily ' Case ReadProperty(LocDBGadget, "AutoOpen") And Msg = "Open This DB" ' ' don't do anything, let it open file ' Exit For Case Msg2 = "False" ' don't open this file for this application OpenThisDB = "Do Not Open" CorrectDBGPTR = 1 ' we need to create an opendb array object as to maintain the ' 1 to 1 relationship of open db's to dbgadgets OpenDBCNTR = OpenDBCNTR + 1 ReDim Preserve OpenDB(OpenDBCNTR) Exit For Case (Msg2 = NotFound) And (OpenThisDB = "Open This DB") ' this is an old database. flag hasn't been updated yet ' and it is not already open ' ask user if they want to open this one every time ' flag it thus CorrectDBGPTR = 1 t = SetProperty(AppDBGadgets(Cntr1), "Open in this App?", "True") ' we need to create an opendb array object as to maintain the ' 1 to 1 relationship of open db's to dbgadgets OpenDBCNTR = OpenDBCNTR + 1 ReDim Preserve OpenDB(OpenDBCNTR) WriteAppDBCntr = Cntr1 Exit For End Select End If Next Cntr1 ' ///////////////////////////////////////////////////// ' do the actual open If (OpenThisDB = "Open This DB") Then Msg = ReadProperty(LocDBGadget, "Path") JetDatabasePath = Msg If Right(JetDatabasePath, 1) <> "\" Then JetDatabasePath = JetDatabasePath & "\" End If If (CurDir <> JetDatabasePath) And _ (CurDir <> Left(JetDatabasePath, Len(JetDatabasePath) - 1)) Then ChDrive Left(JetDatabasePath, 1) ChDir Right(JetDatabasePath, Len(JetDatabasePath) - 2) End If CurrentObject = LocDBGadget JetDatabaseName = JetDatabasePath & ThisDBName ' open the file LocalError = "" DBEngine.IniPath = App.Path DBEngine.DefaultUser = ReadProperty(CurrentObject, "DU") DBEngine.DefaultPassword = ReadProperty(CurrentObject, "DP") Set JetDatabase = GadgetWorkspace.OpenDatabase(JetDatabaseName) If LocalError <> "" Then ' got an error ResultsGadget.Name = "Error:" & LocalError LocalError = "" GoTo EndSub End If If ForceOpenDBPTR < 0 Then OpenDBCNTR = OpenDBCNTR + 1 OpenDBPTR = OpenDBCNTR ReDim Preserve OpenDB(OpenDBPTR) Else OpenDBPTR = ForceOpenDBPTR End If Set OpenDB(OpenDBPTR) = JetDatabase CurrOpenDBPTR = OpenDBPTR ' now open all the recordsets For CNTR2 = 0 To AppRSGadgetsCNTR OpenDBPTR = CurrOpenDBPTR DBGadgetsPTR = CorrectDBGPTR If CurrOpenDBPTR <> OpenDBPTR Then MsgBox "Open DBPTR Changed", , UCase(App.EXEName) & " Debug Message" End If If CorrectDBGPTR <> DBGadgetsPTR Then MsgBox "DBG Changed", , UCase(App.EXEName) & " Debug Message" End If If ReadProperty(AppRSGadgets(CNTR2), "DB Name") = ThisDBName Then t = ReadProperty(AppRSGadgets(CNTR2), "RS Index") Select Case True Case ReadProperty(AppRSGadgets(CNTR2), "RS Source") = "Objects" If t = "?" Or (ForceOpenDBPTR >= 0) Then Set ObjectsRS = OpenDB(OpenDBPTR).OpenRecordset("Objects", dbOpenTable) ObjectsRS.MoveFirst ' MsgBox ObjectsRS.RecordCount ObjectsRS.LockEdits = False If ForceOpenDBPTR < 0 Then ' need to add this one OpenRSCNTR = OpenRSCNTR + 1 OpenRSPTR = OpenRSCNTR ReDim Preserve OpenRS(OpenRSCNTR) Set OpenRS(OpenRSPTR) = ObjectsRS ' ObjectsRS.MoveFirst t = SetProperty(AppRSGadgets(CNTR2), "RS Index", CStr(OpenRSCNTR)) ' t = WriteGDSGadget(AppRSGadgets(Cntr2).ObjectID, AppRSGadgets(Cntr2)) Else ' force situation (force open in given index) ' need to find the correct apprsgadget for this record set ' it was created upon startup Msg = UCase(App.EXEName) & "-" & DBGadgetToUse.Name & "-" & "Objects" For Cntr3 = 0 To AppRSGadgetsCNTR If AppRSGadgets(Cntr3).Name = Msg Then Exit For End If Next Cntr3 If Cntr3 > OpenRSCNTR Then OpenRSCNTR = OpenRSCNTR + 1 OpenRSPTR = OpenRSCNTR ReDim Preserve OpenRS(OpenRSCNTR) Else OpenRSPTR = Cntr3 End If Set OpenRS(OpenRSPTR) = ObjectsRS ' ObjectsRS.MoveFirst t = SetProperty(AppRSGadgets(CNTR2), "RS Index", CStr(OpenRSPTR)) ' t = WriteGDSGadget(AppRSGadgets(Cntr2).ObjectID, AppRSGadgets(Cntr2)) End If ' ShowObject Dematerialize(AppRSGadgets(Cntr2)), "m" Else Set ObjectsRS = OpenRS(Val(t)) ObjectsRS.MoveFirst End If ' MsgBox ObjectsRS.RecordCount Case ReadProperty(AppRSGadgets(CNTR2), "RS Source") = "Props" If t = "?" Or (ForceOpenDBPTR >= 0) Then Set PropsRS = OpenDB(OpenDBPTR).OpenRecordset("Props", dbOpenTable) PropsRS.MoveFirst PropsRS.LockEdits = False If ForceOpenDBPTR < 0 Then ' need to add this one OpenRSCNTR = OpenRSCNTR + 1 OpenRSPTR = OpenRSCNTR ReDim Preserve OpenRS(OpenRSCNTR) Set OpenRS(OpenRSPTR) = PropsRS PropsRS.MoveFirst t = SetProperty(AppRSGadgets(CNTR2), "RS Index", CStr(OpenRSCNTR)) ' t = WriteGDSGadget(AppRSGadgets(Cntr2).ObjectID, AppRSGadgets(Cntr2)) Else ' force situation (force open in given index) ' need to find the correct apprsgadget for this record set ' it was created upon startup Msg = UCase(App.EXEName) & "-" & DBGadgetToUse.Name & "-" & "Props" For Cntr3 = 0 To AppRSGadgetsCNTR If AppRSGadgets(Cntr3).Name = Msg Then Exit For End If Next Cntr3 If Cntr3 > OpenRSCNTR Then OpenRSCNTR = OpenRSCNTR + 1 OpenRSPTR = OpenRSCNTR ReDim Preserve OpenRS(OpenRSCNTR) Else OpenRSPTR = Cntr3 End If ' OpenRSPTR = Val(ReadProperty(AppRSGadgets(Cntr2), "RS Index")) Set OpenRS(OpenRSPTR) = PropsRS PropsRS.MoveFirst t = SetProperty(AppRSGadgets(CNTR2), "RS Index", CStr(OpenRSPTR)) ' t = WriteGDSGadget(AppRSGadgets(Cntr2).ObjectID, AppRSGadgets(Cntr2)) End If Else Set PropsRS = OpenRS(Val(t)) PropsRS.MoveFirst End If Case ReadProperty(AppRSGadgets(CNTR2), "RS Source") = "Methods" If t = "?" Or (ForceOpenDBPTR >= 0) Then Set MethodsRS = OpenDB(OpenDBPTR).OpenRecordset("Methods", dbOpenTable) ' MethodsRS.MoveFirst MethodsRS.LockEdits = False If ForceOpenDBPTR < 0 Then ' need to add this one OpenRSCNTR = OpenRSCNTR + 1 OpenRSPTR = OpenRSCNTR ReDim Preserve OpenRS(OpenRSCNTR) Set OpenRS(OpenRSPTR) = MethodsRS ' MethodsRS.MoveFirst t = SetProperty(AppRSGadgets(CNTR2), "RS Index", CStr(OpenRSCNTR)) ' t = WriteGDSGadget(AppRSGadgets(Cntr2).ObjectID, AppRSGadgets(Cntr2)) Else ' force situation (force open in given index) ' need to find the correct apprsgadget for this record set ' it was created upon startup Msg = UCase(App.EXEName) & "-" & DBGadgetToUse.Name & "-" & "Methods" For Cntr3 = 0 To AppRSGadgetsCNTR If AppRSGadgets(Cntr3).Name = Msg Then Exit For End If Next Cntr3 If Cntr3 > OpenRSCNTR Then OpenRSCNTR = OpenRSCNTR + 1 OpenRSPTR = OpenRSCNTR ReDim Preserve OpenRS(OpenRSCNTR) Else OpenRSPTR = Cntr3 End If ' OpenRSPTR = Val(ReadProperty(AppRSGadgets(Cntr2), "RS Index")) Set OpenRS(OpenRSPTR) = MethodsRS ' MethodsRS.MoveFirst t = SetProperty(AppRSGadgets(CNTR2), "RS Index", CStr(OpenRSPTR)) ' t = WriteGDSGadget(AppRSGadgets(Cntr2).ObjectID, AppRSGadgets(Cntr2)) End If ' ShowObject Dematerialize(AppRSGadgets(Cntr2)), "m" ' If t <> OK Then ' If Not ExecutingSchedule Then ' MsgBox t, , "Open DB" ' End If ' End If Else Set MethodsRS = OpenRS(Val(t)) ' MethodsRS.MoveFirst End If End Select End If Next CNTR2 ' ////////////////////////////////////////////////////////////////////////// 'removed 5/18/00 If WriteAppDBCntr > 0 Then ' ' MResults = Memorize(AppDBGadgets(WriteAppDBCntr), "in " & VGBDatabaseNameAndPath) ' 'Msg = WriteGDSGadget(AppDBGadgets(WriteAppDBCntr).ObjectID, AppDBGadgets(WriteAppDBCntr)) ' End If ' DBSwitch 0 ' For Cntr2 = 0 To AppRSGadgetsCNTR ' LocDBGadget = BlankObject ' t = ReadGadgetByName(AppRSGadgets(Cntr2).Name, LocDBGadget) ' If t = OK Then ' AppRSGadgets(Cntr2).ObjectID = LocDBGadget.ObjectID ' End If ' MResults = Memorize(AppRSGadgets(Cntr2), "in " & VGBDatabaseNameAndPath) ' 't = WriteGDSGadget(AppRSGadgets(Cntr2).ObjectID, AppRSGadgets(Cntr2)) ' Next End If GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "Open DB Error", "Error: " & DBGadgetToUse.Name & "/" & LocalError SetProperty VGBErrors, NextID("error") & "Open DB Error", "Error: " & DBGadgetToUse.Name & "/" & LocalError If Not ExecutingSchedule And LocalError <> "Object variable or With block variable not set" Then ' MsgBox "Open DB Error: " & LocalError, , ucase(App.EXEName) & " Debug Message" End If Resume Next EndSub: DBSwitch CorrectDBGPTR Msg = "DB Open Time: " & Timer - starttime & CrLf GDSFreelocks If LocalError <> "" Then Result = LocalError End If On Error GoTo 0 OpenJetDataBase = ResultsGadget ' DoEvents ' MsgBox Msg End Function Friend Function GODAddObject(AddContainer As String, _ AddObjectType As String, _ AddName As String, _ AddMode As String) As Long Dim t, Msg As String, Crit As String, AddIt As Boolean, Cntr1 As Integer Dim ObjectWasAdded As Boolean, AddedObjectID As Long Dim PropType As Integer, Property As String, PropertyValue As String, PropSource As String Dim UserResponse As String, ManualAdd As Boolean Dim LocalError As String LocalError = "" On Error GoTo LocalError ManualAdd = False AddIt = UCase(AddMode) = "UNCONDITIONAL" If UCase(AddName) = "ASK FOR" Or _ UCase(AddMode) = "ASK FOR" Then ManualAdd = True Msg = "Enter a Name for the New Object." & CrLf Msg = Msg & "Or" & CrLf Msg = Msg & "Enter 'CLONE' to duplicate: " & AddName & CrLf UserResponse = InputBox(Msg, "Manual Object Add") Select Case True Case UserResponse = "" AddedObjectID = -9999 GoTo EndGOAO Case UCase(UserResponse) = "CLONE" MsgBox "Fix This" Msg = "Enter a New Name for the cloned object:" ' UserResponse = InputBox(Msg, "Manual Object Add", Heaven16.ObjectList) If UserResponse = "" Then AddedObjectID = -9999 GoTo EndGOAO End If AddName = UserResponse ' look up name and write it as objectid 0 ' AddedObjectID = GODCloneObject(Currentform.Data_Objects.Recordset!ObjectID, _ AddName) GoTo EndGOAO End Select AddName = UserResponse If AddObjectType = "" Then AddObjectType = InputBox("Enter an Object Type:", "Manual Object Add") End If End If If AddContainer = "" Then AddContainer = "User" End If If AddObjectType = "" Then AddObjectType = "User" End If ObjectsRS.Index = "Name" ObjectsRS.Seek "=", AddName AddIt = (ObjectsRS.NoMatch = True) Or AddIt If UCase(AddMode) = "RETAIN" And ObjectsRS.NoMatch = False Then ' need to see if this object is exactly like the one sent AddIt = False Do While ObjectsRS!Name = AddName If ObjectsRS!Container <> AddContainer Or _ ObjectsRS!Type <> AddObjectType Then AddIt = True End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Exit Do End If Loop End If GadgetWorkspace.BeginTrans Select Case True Case AddIt = True ObjectsRS.AddNew ObjectWasAdded = True Case AddIt = False If ObjectsRS!Name <> AddName Then ObjectsRS.Seek "=", AddName If ObjectsRS.NoMatch Then MsgBox "ERROR in object add function, can't find the original object", , "GDS Error" AddedObjectID = -99 GadgetWorkspace.CommitTrans GoTo EndGOAO: End If End If ObjectsRS.Edit ObjectWasAdded = False End Select ObjectsRS![GAppName] = UCase(App.EXEName) ObjectsRS![Container] = AddContainer ObjectsRS![Type] = AddObjectType ObjectsRS![Name] = AddName LocalError = "" ObjectsRS.Update If LocalError <> "" Then Cntr1 = 0 Do While Cntr1 <= 50 GDSFreelocks LocalError = "" WasteTime 0.1 ObjectsRS.Update If LocalError = "" Then Exit Do End If Cntr1 = Cntr1 + 1 Loop End If GadgetWorkspace.CommitTrans If InStr(LocalError, "LOCKED") > 0 Then Msg = "Add Object Record Locked" & CrLf Msg = Msg & LocalError MsgBox Msg, , UCase(App.EXEName) & " Debug Error" End If ObjectsRS.Bookmark = ObjectsRS.LastModified AddedObjectID = ObjectsRS![ObjectID] GoTo EndGOAO: LocalError: LocalError = UCase(Error) Resume Next EndGOAO: LocalError = "" Do While LocalError = "" GadgetWorkspace.CommitTrans Loop GODAddObject = AddedObjectID GDSFreelocks On Error GoTo 0 End Function Friend Function GODAddObjectFromDNA(ByVal ObjectToUseID As Long, _ ByVal Objectparent As String, _ ByVal PromptUser As Boolean, _ ByVal X As Single, _ ByVal Y As Single) As String ' this routine will generically add any new object given the object and DNA ' it will also add all DNA objects (as children) listed in the DNA object ' There was a time when I felt like cryin' ' Felt like cryin', cryin' the blues ' All because of a lot of women like you Dim t, Msg As String, Prompt As String, Result As String Dim px As Integer, py As Integer, ObjectNameExists As Boolean Dim ObjectAddedThisPass As Gadget, AddedObjectID As Long Dim AddContainer As String Dim AddObjectType As String Dim AddName As String, CheckName As String Dim AddMode As String Dim PropType As Integer Dim Property As String Dim PropertyValue As String Dim PropSource As String Dim AddPropType As Integer Dim AddProperty As String Dim AddPropertyValue As String Dim AddPropSource As String Dim DNA As Gadget, DNAName As String Dim ThisLevel As Integer On Error GoTo 0 Result = "OK" DNAName = GODReadProperty(ObjectToUseID, "DNA") ' read the DNA object to get the parameters for this add ' get the name of the DNA object t = ReadGadgetByName(DNAName, DNA) If t <> "OK" Then MsgBox t, , UCase(App.EXEName) & " Debug Message" GoTo EndGAOFT: End If ' get the add level (nodes only) ThisLevel = Val(GODReadProperty(DNA.ObjectID, "Add Level")) If ThisLevel = 0 Then ThisLevel = 1 ' get the prompt for adding Prompt = GODReadProperty(DNA.ObjectID, "Add Prompt") ' set the parent Select Case True Case InStr(UCase(Prompt), "ERROR") > 0 _ And InStr(UCase(Prompt), "NOT FOUND") > 0 MsgBox "Cannot Add This Object Type", vbOKOnly, "FYI" GoTo EndGAOFT Case Objectparent <> "?" Case ThisLevel > 1 Objectparent = GODReadProperty(ObjectToUseID, "Parent") Case ThisLevel = 1 Objectparent = "None" End Select If InStr(UCase(Objectparent), "TIMES") > 0 Then MsgBox Objectparent, , UCase(App.EXEName) & " Debug Message" End If If InStr(UCase(Objectparent), "ERROR") > 0 Then Objectparent = "None" End If If Objectparent <> "None" Then t = ReadGadgetByID(Val(Objectparent)) Prompt = Prompt & " for: " & CrLf & ReadObjectBuffer.Name & "?" Else Prompt = Prompt & "?" End If If PromptUser = True Then t = MsgBox(Prompt, vbOKCancel, "Confirm Add Object") Else t = vbOK End If If t = vbCancel Then Result = "Cancelled" GoTo EndGAOFT End If ' they want to add 'add the object AddContainer = GODReadProperty(DNA.ObjectID, "Container") AddObjectType = GODReadProperty(DNA.ObjectID, "ObjectType") AddName = GODReadProperty(DNA.ObjectID, "Default Name") If InStr(UCase(AddName), "ERROR") > 0 Then MsgBox "Name Error:" & AddName GoTo EndGAOFT: End If py = 0 CheckName = AddName ' get rid of ambiguous object names ' Do ' ObjectNameExists = False ' Crit = "Name='" & Checkname & "'" ' Screen.ActiveForm.Data_Objects.Recordset.FindFirst Crit ' If Screen.ActiveForm.Data_Objects.Recordset.NoMatch = False Then ' ObjectNameExists = True ' End If ' If ObjectNameExists = False Then ' AddName = Checkname ' Exit Do ' Else ' py = py + 1 ' Checkname = "" ' Checkname = AddName & " #" & Str(py) ' End If ' Loop Until True = False ' MsgBox AddName AddMode = "Unconditional" AddedObjectID = GODAddObject(AddContainer, _ AddObjectType, _ AddName, _ AddMode) ' update recordset ' Screen.ActiveForm.Data_Objects.Recordset.Requery ' change the level to the correct value t = ReadGadgetByID(AddedObjectID) ' use a temporary, local gadget to hold this new object ObjectAddedThisPass = ReadObjectBuffer ObjectAddedThisPass.Level = ThisLevel t = WriteMemGadget(ObjectAddedThisPass.ObjectID, ObjectAddedThisPass) ' Add all Props Dim AddNow As Boolean Result = ObjectAddedThisPass.ObjectID CurrentObject = ReadObjectBuffer For px = 1 To DNA.TotalProperties AddNow = False Select Case True Case UCase(DNA.Propity(px)) = "CHILD" ' this property is a child dna, need to add it Dim NewObject As Long NewObject = Val(DNA.ValueAlpha(px)) t = GODAddObjectFromDNA(NewObject, _ AllTrim(Str(AddedObjectID)), _ False, X, Y) ' need to add the reference to this object as property ' this depends on which name was selected by add from dna ' function GODAddObjectFromDNA returns added object's objectid ' AddProperty = "Child" ' AddPropertyValue = AllTrim(Str(t)) ' AddPropSource = "User" ' AddPropType = 0 ' t = GODAddOneProperty(AddedObjectID, _ AddPropType, _ AddProperty, _ AddPropertyValue, _ AddPropSource) Case DNA.PropType(px) = 0 'system, don't add to new object Case DNA.PropType(px) = 1 ' user AddPropType = 1 AddNow = True Case DNA.PropType(px) = 2 And UCase(DNA.ValueAlpha(px)) <> "CHILD" ' copy as system AddNow = True AddPropType = 0 Case DNA.PropType(px) = 3 ' copy as user AddNow = True AddPropType = 1 End Select If AddNow = True Then AddProperty = DNA.Propity(px) AddPropertyValue = DNA.ValueAlpha(px) AddPropSource = "User" t = GODAddOneProperty(AddedObjectID, _ AddPropType, _ AddProperty, _ AddPropertyValue, _ AddPropSource) End If Next ' .selecteditem.parent AddPropType = 0 AddProperty = "Parent" If ObjectAddedThisPass.Level > 1 Then AddPropertyValue = Objectparent Else AddPropertyValue = "None" End If AddPropSource = "User" t = GODAddOneProperty(AddedObjectID, _ AddPropType, _ AddProperty, _ AddPropertyValue, _ AddPropSource) If (AddPropertyValue = Objectparent) And Objectparent <> "None" Then ' need to add this object as child to its parent AddPropType = 0 AddProperty = "Child" AddPropertyValue = CStr(AddedObjectID) AddPropSource = "User" t = GODAddOneProperty(CLng(Val(Objectparent)), _ AddPropType, _ AddProperty, _ AddPropertyValue, _ AddPropSource) End If ' Screen.ActiveForm.Data_Objects.Recordset.Requery ' Screen.ActiveForm.Data_ALLProperties.Recordset.Requery t = ReadGadgetByID(AddedObjectID) CurrentObject = ReadObjectBuffer EndGAOFT: GODAddObjectFromDNA = Result GDSFreelocks End Function Friend Function DeleteGadget(ObjectToDeleteID As Long) As String ' this will delete one object and all Props and methods ' the caller must handle relationships, dependencies and links Dim t, Result As String, SQLCmd As String Dim starttime As Single starttime = Timer Dim DelCntr As Long Dim ContainerToDelete As String Dim LocalError As String Dim TempRS As Recordset Set TempRS = OpenDB(OpenDBPTR).OpenRecordset("Objects", dbOpenTable) LocalError = "" On Error GoTo LocalError ObjectsRS.Index = "PrimaryKey" ObjectsRS.Seek "=", ObjectToDeleteID If ObjectsRS.NoMatch = True Then Result = NotFound GoTo EndSub End If ObjectsRS.Delete Result = OK GoTo EndSub ' Do While ObjectsRS.NoMatch = False ' LocalError = "" ' ObjectsRS.Delete ' If LocalError <> "" Then '' MsgBox "Delete failed: " & t, , ucase(App.EXEName) & " Debug Message" ' End If ' DelCntr = DelCntr + 1 ' If DelCntr Mod 20 = 0 Then '' DoEvents ' End If ' TempRS.ObjectsRS ' If ObjectsRS.EOF Then Exit Do ' If ObjectsRS!ObjectID <> ObjectsRS Then Exit Do ' Loop TempRS.Index = "Container" ContainerToDelete = CStr(ObjectToDeleteID) TempRS.Seek "=", ContainerToDelete Do While TempRS.NoMatch = False LocalError = "" TempRS.Delete If LocalError <> "" Then ' MsgBox "Delete failed: " & t, , ucase(App.EXEName) & " Debug Message" End If DelCntr = DelCntr + 1 If DelCntr Mod 10 = 0 Then ' DoEvents End If TempRS.MoveNext If TempRS.EOF Then Exit Do If TempRS!Container <> ContainerToDelete Then Exit Do Loop PropsRS.Index = "ObjectID" ContainerToDelete = CStr(ObjectToDeleteID) PropsRS.Seek "=", ObjectToDeleteID If PropsRS.NoMatch = False Then If Not ExecutingSchedule Then MsgBox "Delete Failed to remove Properties", , UCase(App.EXEName) & " Debug Message" End If End If If LocalError = "" Then Result = OK Else Result = LocalError End If ' GoTo EndSub Result = "OK" SQLCmd = "" SQLCmd = SQLCmd & "DELETE DISTINCTROW Objects.*, Objects.ObjectID " SQLCmd = SQLCmd & "From Objects " SQLCmd = SQLCmd & "WHERE ((Objects.ObjectID=" & ObjectToDeleteID & "));" ' MsgBox SQLCmd OpenDB(OpenDBPTR).Execute SQLCmd SQLCmd = "" SQLCmd = SQLCmd & "DELETE DISTINCTROW Props.ObjectID, " SQLCmd = SQLCmd & "Props.Property, " SQLCmd = SQLCmd & "Props.ValueAlpha " SQLCmd = SQLCmd & "From Props " SQLCmd = SQLCmd & "WHERE Props.ObjectID=" & ObjectToDeleteID & ";" ' MsgBox SQLCmd OpenDB(OpenDBPTR).Execute SQLCmd ' now delete all references to this objects as child or parent Dim StringID StringID = AllTrim(Str(ObjectToDeleteID)) SQLCmd = "" SQLCmd = SQLCmd & "DELETE DISTINCTROW Props.ObjectID, " SQLCmd = SQLCmd & "Props.Property, " SQLCmd = SQLCmd & "Props.ValueAlpha " SQLCmd = SQLCmd & "From Props " SQLCmd = SQLCmd & "WHERE (Props.property='Parent' or " SQLCmd = SQLCmd & "Props.property='Child') and Props.valuealpha='" & StringID & "';" ' MsgBox SQLCmd OpenDB(OpenDBPTR).Execute SQLCmd SQLCmd = "" SQLCmd = SQLCmd & "Delete DISTINCTROW Methods.ObjectID " SQLCmd = SQLCmd & "From Methods " SQLCmd = SQLCmd & "WHERE ObjectID=" & ObjectToDeleteID & ";" OpenDB(OpenDBPTR).Execute SQLCmd ' need to delete all objects that have this object as their container SQLCmd = "" SQLCmd = SQLCmd & "DELETE DISTINCTROW Objects.*, Objects.ObjectID " SQLCmd = SQLCmd & "From Objects " SQLCmd = SQLCmd & "WHERE ((Objects.Container='" & ObjectToDeleteID & "'));" OpenDB(OpenDBPTR).Execute SQLCmd ' MsgBox SQLCmd GoTo EndSub: LocalError: LocalError = Error$ Result = LocalError SetProperty Trace, NextID("trace") & "DeleteGadget Trapped Error", LocalError SetProperty VGBErrors, NextID("error") & "DeleteGadget Trapped Error", LocalError If Not ExecutingSchedule Then MsgBox LocalError, , UCase(App.EXEName) & " Debug Message" End If Resume Next EndSub: DeleteGadget = Result GDSFreelocks If Not ExecutingSchedule Then ' MsgBox "Deleted: " & DelCntr & CrLf & Timer - starttime End If End Function Friend Function GODAddOneProperty(ByVal AddObjectID As Long, _ ByVal AddPropType As Integer, _ ByVal AddProperty As String, _ ByVal AddPropertyValue As String, _ ByVal AddPropSource As String) ' this guy will change a property if it exists or, add it if it doesn't ' there is a better way by adding properties to a memory object and using WriteMemGadget Dim Crit As String, AddThisProperty As Boolean, EditThisProperty As Boolean Dim Cntr1 As Integer Dim PropsStartRec As String Dim ResetProps As Boolean Dim LocalError As String LocalError = "" On Error GoTo LocalError ' read the one to add ' new way AddThisProperty = True '/////////////////// ' REMOVE THIS MAYBE ' PropsRS.Index = "ObjectID" ' PropsRS.Seek "=", AddObjectID ' Do While PropsRS!ObjectID = AddObjectID ' If PropsRS!Property = AddProperty Then ' AddThisProperty = False ' End If ' PropsRS.MoveNext ' If PropsRS.EOF Then Exit Do ' Loop '///////////////////////// GadgetWorkspace.BeginTrans Select Case True Case AddThisProperty = True PropsRS.AddNew Case AddThisProperty = False ' this property does exist, need to edit PropsRS.Edit Case Else MsgBox "Property Add is Not in Add or Edit Mode", , UCase(App.EXEName) & " Debug Message" End Select PropsRS![ObjectID] = AddObjectID PropsRS!Property = AddProperty PropsRS!ValueAlpha = AddPropertyValue PropsRS!ValueNum = Val(AddPropertyValue) PropsRS!PropSource = AddPropSource PropsRS!PropType = AddPropType ' below added 8/26/98 to fix locking problems LocalError = "" PropsRS.Update If LocalError <> "" Then Cntr1 = 0 Do While Cntr1 <= 10 LocalError = "" WasteTime 0.1 PropsRS.Update If LocalError = "" Then Exit Do End If Cntr1 = Cntr1 + 1 Loop End If If InStr(LocalError, "LOCKED") > 0 Then MsgBox "Add One Property: Record Locked" End If GadgetWorkspace.CommitTrans PropsRS.Bookmark = PropsRS.LastModified GODAddOneProperty = PropsRS!PropertyID GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: On Error GoTo 0 GDSFreelocks End Function Friend Function GODChangePropertyByID(ChangeObjectID As Long, _ SetProperty As String, _ ChangePropertyValue As String) As String ' a new way to change a property, also kind of outdated Dim t, X As Long, Results As String, Cntr1 As Integer Dim starttime As Single, stoptime As Single Dim LocalError As String LocalError = "" On Error GoTo LocalError starttime = Timer Results = "OK" PropsRS.Index = "Objectid" PropsRS.Seek "=", ChangeObjectID If PropsRS.NoMatch Then Results = "ERROR: OBJECT NOT FOUND" GoTo EndSub: End If GadgetWorkspace.BeginTrans Do While PropsRS.EOF = False If PropsRS!Property = SetProperty And _ PropsRS!ObjectID = ChangeObjectID Then PropsRS.Edit PropsRS!ValueAlpha = ChangePropertyValue PropsRS!ValueNum = Val(ChangePropertyValue) LocalError = "" PropsRS.Update If LocalError <> "" Then Cntr1 = 0 Do While Cntr1 <= 30 LocalError = "" WasteTime 0.1 PropsRS.Update If LocalError = "" Then Exit Do End If Cntr1 = Cntr1 + 1 Loop End If Results = OK Exit Do End If If InStr(LocalError, "LOCKED") > 0 Then MsgBox "Change Property by ID: Record Locked" End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If If PropsRS.EOF Or PropsRS!ObjectID <> ChangeObjectID Then Results = "ERROR: PROPERTY NOT FOUND" Exit Do End If Loop GadgetWorkspace.CommitTrans GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: On Error GoTo 0 GODChangePropertyByID = Results GDSFreelocks End Function Friend Function GODChangePropertyName(ChangeObject As Gadget, _ OldPropertyName As String, _ NewPropertyName As String) As String ' sometimes we need to change a property name Dim t, Msg As String, Cntr1 As Integer Dim Results As String Dim LocalError As String On Error GoTo LocalError PropsRS.Index = "ObjectId" PropsRS.Seek "=", ChangeObject.ObjectID Results = OldPropertyName & ": " & NotFound If PropsRS.NoMatch Then Results = "Error: " & OldPropertyName & " not found for object: " & ChangeObject.Name If Not ExecutingSchedule Then MsgBox Results, , "Error in Change Property Name" End If GoTo EndSub End If GadgetWorkspace.BeginTrans Do While PropsRS.NoMatch = False If UCase(PropsRS!Property) = UCase(OldPropertyName) Then PropsRS.Edit PropsRS!Property = NewPropertyName PropsRS.Update If LocalError <> "" Then Cntr1 = 0 Do While Cntr1 <= 20 LocalError = "" WasteTime 0.1 PropsRS.Update If LocalError = "" Then Results = OK Exit Do End If Cntr1 = Cntr1 + 1 Loop End If If LocalError = "" Then Results = OK Else Results = LocalError End If Exit Do End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do If PropsRS!ObjectID <> ChangeObject.ObjectID Then Exit Do Loop GadgetWorkspace.CommitTrans GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: On Error GoTo 0 GDSFreelocks GODChangePropertyName = Results End Function Friend Function DeleteProperty(ChangeObject As Gadget, PropertyName As String) As String ' removes a property from disk AND memory object Dim t, Msg As String, Cntr1 As Integer Dim Results As String Dim LocalError As String On Error GoTo LocalError PropsRS.Index = "ObjectId" PropsRS.Seek "=", ChangeObject.ObjectID If PropsRS.NoMatch Then Results = "Error: " & PropertyName & " not found for object: " & ChangeObject.Name If Not ExecutingSchedule Then MsgBox Results, , "Error in Delete Property" End If GoTo EndSub End If Do While PropsRS.NoMatch = False If UCase(PropsRS!Property) = UCase(PropertyName) Then PropsRS.Delete If LocalError <> "" Then Cntr1 = 0 Do While Cntr1 <= 20 LocalError = "" WasteTime 0.1 PropsRS.Delete If LocalError = "" Then Exit Do End If Cntr1 = Cntr1 + 1 Loop End If If LocalError = "" Then Results = OK Else Results = LocalError End If Exit Do End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do If PropsRS!ObjectID <> ChangeObject.ObjectID Then Exit Do Loop GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: On Error GoTo 0 GDSFreelocks DeleteProperty = Results End Function Friend Function SetProperty(ChangeObject As Gadget, _ ChangePropertyName As String, _ ChangePropertyValue As String) As String ' this will change a property for the given object ' only changes memory value, not disk. ' make this hit gadgetor for properties if fail local ' need to seet up the bufferring in gadgetor so the satellites can ' pre-request memory to be filled and recalled at will Dim t, X As Long, Results As String, PropNDX As Integer, Cntr1 As Long Dim starttime As Single, stoptime As Single Dim TotalSame As Integer Dim LocalError As String If Suicide Then On Error Resume Next Else On Error GoTo LocalError End If starttime = Timer Results = "Error" ' this causes change in existing ones other than "is" For X = 1 To ChangeObject.TotalProperties Select Case True Case UCase(ChangePropertyName) = "IS" ' Case (UCase(ChangeObject.Propity(X)) = UCase(ChangePropertyName)) And _ (UCase(ChangeObject.ValueAlpha(X)) <> UCase(ChangePropertyValue)) And _ (UCase(ChangePropertyName) = "IS") ' need to see if any other "is" has same value For Cntr1 = 1 To ChangeObject.TotalProperties If (UCase(ChangeObject.Propity(Cntr1)) = UCase(ChangePropertyName)) And _ (UCase(ChangeObject.ValueAlpha(Cntr1)) = UCase(ChangePropertyValue)) And _ (UCase(ChangePropertyName) = "IS") Then X = Cntr1 PropNDX = X ChangeObject.ValueAlpha(X) = ChangePropertyValue ChangeObject.ValueNum(X) = Val(ChangePropertyValue) Results = "OK" Exit For End If Next If Cntr1 > ChangeObject.TotalProperties Then Results = "Error" End If Exit For Case (UCase(ChangeObject.Propity(X)) = UCase(ChangePropertyName)) PropNDX = X ChangeObject.ValueAlpha(X) = ChangePropertyValue ChangeObject.ValueNum(X) = Val(ChangePropertyValue) Results = "OK" Exit For End Select Next If Results = "Error" Then ' didn't find old one, create one ChangeObject.TotalProperties = ChangeObject.TotalProperties + 1 X = ChangeObject.TotalProperties ReDim Preserve ChangeObject.Propity(X) ChangeObject.Propity(X) = ChangePropertyName ReDim Preserve ChangeObject.Caption(X) ChangeObject.Caption(X) = "None" ReDim Preserve ChangeObject.ValueAlpha(X) ChangeObject.ValueAlpha(X) = ChangePropertyValue ReDim Preserve ChangeObject.ValueNum(X) ChangeObject.ValueNum(X) = Val(ChangePropertyValue) ReDim Preserve ChangeObject.PropSource(X) ChangeObject.PropSource(X) = "None" ReDim Preserve ChangeObject.PropType(X) ChangeObject.PropType(X) = 99 Results = "OK" GoTo EndGOCP End If GoTo EndGOCP LocalError: LocalError = Error ' FloatMsgBox "Set Property Error: " & LocalError, "Error: " & ChangeObject.Name & "/" & ChangePropertyName & "/" & ChangePropertyValue SetProperty Trace, NextID("trace") & "Set Property Error", "Error: " & LocalError & ChangeObject.Name & "/" & ChangePropertyName & "/" & ChangePropertyValue SetProperty VGBErrors, NextID("error") & "Set Property Error", "Error: " & LocalError & ChangeObject.Name & "/" & ChangePropertyName & "/" & ChangePropertyValue Resume Next EndGOCP: SetProperty = Results stoptime = Timer t = ChangePropertyName & " changed to: " & ChangePropertyValue & CrLf On Error GoTo 0 ' MsgBox t & " Time to change Memory Property=" & stoptime - starttime & CrLf & Results If (stoptime - starttime) > 10 Then FloatMsgBox " Time to change Memory Property=" & stoptime - starttime, UCase(App.EXEName) & " Debug Error Too Long to change" ' MsgBox t & " Time to change Memory Property=" & stoptime - starttime & CrLf & Results End If End Function Friend Function SetPropertyType(ChangeObject As Gadget, _ SetProperty As String, _ ChangePropertyType As Integer) As String ' this will change preperty type to new value memory only ' the property type affects how a property is used Dim t, X As Long, Results As String Dim starttime As Single, stoptime As Single Dim TotalSame As Integer For X = 1 To ChangeObject.TotalProperties If UCase(ChangeObject.Propity(X)) = UCase(SetProperty) Then ChangeObject.PropType(X) = ChangePropertyType Exit For End If Next GDSFreelocks End Function 'Friend Function GODChangeMemoryProperty(ChangeObject As Gadget, _ ' SetProperty As String, _ ' ChangePropertyValue As String) As String ' ' this will change a property for the given object ' ' only changes memory value, not disk. ' Dim t, x As Long, Results As String, PropNDX As Integer ' Dim starttime As Single, stoptime As Single ' Dim TotalSame As Integer ' starttime = Timer ' Results = "Error" ' ' check for ambiguous property names ' TotalSame = 0 ' For x = 1 To ChangeObject.TotalProperties ' If UCase(ChangeObject.Propity(x)) = UCase(SetProperty) Then ' TotalSame = TotalSame + 1 ' End If ' Next ' If TotalSame > 1 Then ' Results = "ERROR! Property " & SetProperty & " found " & TotalSame & " Times" ' '////////////////// ' 'REMOVE THIS '' MsgBox "Error in Change Memory Property: " & Results ' ' REMOVE THIS ' ' ///////////////// ' ' GoTo EndGOCP ' End If ' For x = 1 To ChangeObject.TotalProperties ' If UCase(ChangeObject.Propity(x)) = UCase(SetProperty) Then ' PropNDX = x ' ChangeObject.ValueAlpha(x) = ChangePropertyValue ' ChangeObject.ValueNum(x) = Val(ChangePropertyValue) ' Results = "OK" ' Exit For ' End If ' Next ' ' '////////////////// ' 'REMOVE THIS ' For x = 1 To ChangeObject.TotalProperties ' If UCase(ChangeObject.Propity(x)) = UCase(SetProperty) Then ' TotalSame = TotalSame + 1 ' End If ' Next ' TotalSame = 0 ' If TotalSame > 1 Then ' Results = "ERROR! Property " & SetProperty & " found " & TotalSame & " Times" ' '////////////////// ' 'REMOVE THIS ' MsgBox "Error in Change Memory Property: " & Results ' ' REMOVE THIS ' ' ///////////////// ' ' GoTo EndGOCP ' End If ' '////////////////// ' 'REMOVE THIS ' ' ' ' If InStr(UCase(Results), "ERROR") Then ' Results = Results & ": Property: " & SetProperty & " not found for: " & ChangeObject.Name ' GoTo EndGOCP ' End If ' 'EndGOCP: ' GODChangeMemoryProperty = Results ' GDSFreelocks ' stoptime = Timer ' t = SetProperty & " changed to: " & ChangePropertyValue & CrLf '' MsgBox t & " Time to change Memory Property=" & stoptime - starttime & CrLf & Results 'End Function Friend Function TransportGadgetsOLD(Param As Gadget) As Gadget ' this routine will copy and/or move gadget object(s) from one database to another ' the Param Object contains all the stuff needed Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Msg As String, Msg2 As String, Cntr1 As Integer, CNTR2 As Integer Dim SourcesRead As Integer, ContainersRead As Integer, LinksRead As Integer Dim SourcesWrote As Integer, ContainersWrote As Integer, LinksWrote As Integer Dim AddedLinkedToCNTR As Integer, FoundLinkedToCNTR As Integer Dim DoEventCNTR As Integer Dim TempGadget As Gadget Dim SourceDBGadgetPTR As Integer Dim DestDBGadgetPTR As Integer Dim ContainerToMove As String Dim LinkProp As String, LinkType As String, Relink As Boolean Dim TransportMode As String Dim ResultsGadget As Gadget Dim Compare As Boolean Dim CurrContainedObject As Gadget Dim SourceGadget As Gadget, SourceGadgetPTR As Integer, SourceGadgetCNTR As Integer Dim SourceExisted As Boolean Dim ContainedObjects() As Gadget, ContainedObjectsPTR As Integer, ContainedObjectsCNTR As Integer Dim LinkedToObjects() As Gadget, LinkedToObjectsPTR As Integer, LinkedToObjectsCNTR As Integer Dim DestGadget As Gadget Dim OldColName As String Dim NewColName As String Dim ExcludeTypes() As String, ExcludeTypesCNTR As Integer Dim ThisRS As Recordset ' begin a resultsgadget ResultsGadget = BlankObject ResultsGadget.Name = "Results of Object Transporter" ResultsGadget.Type = "Function Status" ResultsGadget.Container = "Results" t = SetProperty(ResultsGadget, "Status", "Started") t = SetProperty(ResultsGadget, "StartTimer", CStr(starttime)) Compare = UCase(ReadProperty(Param, "Compare")) = "TRUE" ' load excluded types For Cntr1 = 1 To 1000 If DoEventCNTR Mod 15 = 0 Then DoEventCNTR = 0 ' DoEvents Else DoEventCNTR = DoEventCNTR + 1 End If Msg = "Exclude Type" & CStr(Cntr1) Msg2 = UCase(ReadProperty(Param, Msg)) If Msg2 <> NotFound Then ExcludeTypesCNTR = ExcludeTypesCNTR + 1 ReDim Preserve ExcludeTypes(ExcludeTypesCNTR) ExcludeTypes(ExcludeTypesCNTR) = UCase(Msg2) Else Exit For End If Next ' set up source/destination variables ' see if there is a link property (a prperty that points to another object) LinkProp = ReadProperty(Param, "Take Link Property") If LinkProp = NotFound Then LinkProp = "None" End If LinkType = ReadProperty(Param, "Take Link Type") Relink = (ReadProperty(Param, "Relink") = "True") Msg = ReadProperty(Param, "Source Database") SourceDBGadgetPTR = DBFindIndex(Msg) Msg = ReadProperty(Param, "Destination Database") DestDBGadgetPTR = DBFindIndex(Msg) SourceGadgetCNTR = Val(ReadProperty(Param, "Total Source Objects")) 'Read //////////////////////////////////////////////////////////////////////////////////////////// ' read source, links and linked to objects For SourceGadgetPTR = 1 To SourceGadgetCNTR SourcesRead = SourcesRead + 1 ' switch to source db Msg = DBSwitch(SourceDBGadgetPTR) If Msg <> OK Then MsgBox Msg, , UCase(App.EXEName) & " Debug Message" t = SetProperty(ResultsGadget, "Error", Msg) GoTo NextSourceGadget End If ' check to see if there is a seal of approval to check Msg = ReadProperty(Param, "Verification Object") '= "Seal of Approval" TempGadget = BlankObject If Msg <> NotFound Then t = ReadGadgetByName(Msg, TempGadget) If t <> OK Then Msg2 = "Failed to find: " & Msg MsgBox Msg2, vbExclamation, "Error: DB Verify Failure" t = SetProperty(ResultsGadget, "Error", "DB Verify Failure") GoTo EndSub End If End If Msg = ReadProperty(Param, "Source Object" & CStr(SourceGadgetPTR)) t = ReadGadgetByID(Val(Msg)) If t <> OK Then ' could not find this object GoTo NextSourceGadget End If SourceGadget = ReadObjectBuffer ' place the oid of original in tag of SourceGadget to use later SourceGadget.Tag = SourceGadget.ObjectID ContainedObjectsCNTR = 0 ReDim Preserve ContainedObjects(ContainedObjectsCNTR) LinkedToObjectsCNTR = 0 ReDim Preserve LinkedToObjects(LinkedToObjectsCNTR) Set ThisRS = OpenDB(OpenDBPTR).OpenRecordset("Objects", dbOpenTable) ', dbForwardOnly) ' need to fix up the links in the contained objects ThisRS.Index = "Container" ThisRS.Seek "=", SourceGadget.Tag Do While ThisRS.NoMatch = False ' DoEvents If ThisRS!Name = SourceGadget.Name Then GoTo NextRecord: End If t = ReadGadgetByID(ThisRS!ObjectID) CurrContainedObject = ReadObjectBuffer If t <> OK Then MsgBox "Error Reading Contained Object: " & t, , UCase(App.EXEName) & " Debug Message" GoTo NextSourceGadget End If Msg = "Include" For Cntr1 = 1 To ExcludeTypesCNTR If UCase(CurrContainedObject.Type) = ExcludeTypes(Cntr1) Then Msg = "Exclude" Exit For End If Next If Msg = "Exclude" Then GoTo NextRecord End If ContainersRead = ContainersRead + 1 ContainedObjectsCNTR = ContainedObjectsCNTR + 1 ReDim Preserve ContainedObjects(ContainedObjectsCNTR) ContainedObjects(ContainedObjectsCNTR) = CurrContainedObject ContainedObjects(ContainedObjectsCNTR).ObjectID = 0 ContainedObjects(ContainedObjectsCNTR).Tag = CurrContainedObject.ObjectID CurrContainedObject.ObjectID = 0 ' we're defaulting to a write, right? If LinkProp <> "None" Then t = ReadProperty(ContainedObjects(ContainedObjectsCNTR), LinkProp) If (t <> NotFound) And t <> "None" Then ' there is a linked property t = ReadGadgetByID(Val(t)) If t <> OK Then MsgBox "Error Reading Linked Object: " & t, , UCase(App.EXEName) & " Debug Message" Else LinksRead = LinksRead + 1 LinkedToObjectsCNTR = LinkedToObjectsCNTR + 1 ReDim Preserve LinkedToObjects(LinkedToObjectsCNTR) LinkedToObjects(LinkedToObjectsCNTR) = ReadObjectBuffer LinkedToObjects(LinkedToObjectsCNTR).ObjectID = 0 LinkedToObjects(LinkedToObjectsCNTR).Tag = ReadObjectBuffer.ObjectID End If End If End If NextRecord: ThisRS.MoveNext If ThisRS.EOF Then Exit Do If ThisRS!Container <> SourceGadget.Tag Then Exit Do Loop t = SetProperty(ResultsGadget, "Read Timer", CStr(Timer)) t = SetProperty(ResultsGadget, "Read Time", CStr(Timer - starttime)) 'Read //////////////////////////////////////////////////////////////////////////////////////////// 'Write //////////////////////////////////////////////////////////////////////////////////////////// ' now we spit them into the dest db ' activate dest db Msg = DBSwitch(DestDBGadgetPTR) If Msg <> OK Then MsgBox Msg, , UCase(App.EXEName) & " Debug Message" t = SetProperty(ResultsGadget, "Error", Msg) GoTo NextSourceGadget End If ' does source object exist? DestGadget = BlankObject t = ReadGadgetByName(SourceGadget.Name, DestGadget) If (t = OK) And (DestGadget.Type <> SourceGadget.Type) Then ' seems to be a goof MsgBox "Strange Error in Transport Objects Routine: Read OK but Objects Not Same Type", , UCase(App.EXEName) & " Debug Message" GoTo NextSourceGadget End If If t = OK Then ' destination contains object with same name SourceGadget.ObjectID = DestGadget.ObjectID SourceExisted = True Else ' totally new, dude SourceGadget.ObjectID = 0 SourceExisted = False End If ' write the source object to the destination db SourcesWrote = SourcesWrote + 1 t = WriteMemGadget(SourceGadget.ObjectID, SourceGadget) ' reflect new container (oid that was assigned as it was written to disk) SourceGadget.Container = CStr(SourceGadget.ObjectID) ' need to write again t = WriteMemGadget(SourceGadget.ObjectID, SourceGadget) ' save the contained objects For ContainedObjectsPTR = 1 To ContainedObjectsCNTR Msg = NotFound If SourceExisted = True Then ' don't do anything Exit For End If ' note: this was hard coded and needs fixed ContainedObjects(ContainedObjectsPTR).Container = CStr(SourceGadget.ObjectID) If ContainedObjects(ContainedObjectsPTR).Type = "Report Column" Then OldColName = ContainedObjects(ContainedObjectsPTR).Name t = Right(OldColName, Len(OldColName) - InStr(OldColName, ":")) NewColName = CStr(SourceGadget.ObjectID) & "-COL:" & t ContainedObjects(ContainedObjectsPTR).Name = NewColName t = ReadGadgetByName(NewColName, TempGadget) If t = OK Then ContainedObjects(ContainedObjectsPTR).ObjectID = TempGadget.ObjectID Msg = "Found" Else ContainedObjects(ContainedObjectsPTR).ObjectID = 0 End If End If Msg = (ReadProperty(ContainedObjects(ContainedObjectsPTR), LinkProp)) If Msg <> NotFound Then For LinkedToObjectsPTR = 1 To LinkedToObjectsCNTR If Msg = LinkedToObjects(LinkedToObjectsPTR).Tag Then ' need to see if this object already exists in dest db ' Read each linked to object into a temp gadget TempGadget = BlankObject TempGadget.Name = "Object Read Parameter" t = SetProperty(TempGadget, "Container", LinkedToObjects(LinkedToObjectsPTR).Container) t = SetProperty(TempGadget, "Type", LinkedToObjects(LinkedToObjectsPTR).Type) t = ReadGadgetByName(LinkedToObjects(LinkedToObjectsPTR).Name, TempGadget) If t = OK Then ' this is an old one, already in the dest db FoundLinkedToCNTR = FoundLinkedToCNTR + 1 LinkedToObjects(LinkedToObjectsPTR).ObjectID = TempGadget.ObjectID Else ' brand new linked-to object AddedLinkedToCNTR = AddedLinkedToCNTR + 1 LinkedToObjects(LinkedToObjectsPTR).ObjectID = 0 LinksWrote = LinksWrote + 1 t = WriteMemGadget(LinkedToObjects(LinkedToObjectsPTR).ObjectID, LinkedToObjects(LinkedToObjectsPTR)) End If Msg = CStr(LinkedToObjects(LinkedToObjectsPTR).ObjectID) t = SetProperty(ContainedObjects(ContainedObjectsPTR), LinkProp, Msg) Exit For End If Next End If t = WriteMemGadget(ContainedObjects(ContainedObjectsPTR).ObjectID, ContainedObjects(ContainedObjectsPTR)) ContainersWrote = ContainersWrote + 1 ' DoEvents Next ContainedObjectsPTR ' fixup the links ' skip thru linked to array For LinkedToObjectsPTR = 1 To LinkedToObjectsCNTR If SourceExisted = True Then ' don't do anything Exit For End If ' need to see if this object already exists in dest db ' Read each linked to object into a temp gadget TempGadget = BlankObject TempGadget.Name = "Object Read Parameter" t = SetProperty(TempGadget, "Container", LinkedToObjects(LinkedToObjectsPTR).Container) t = SetProperty(TempGadget, "Type", LinkedToObjects(LinkedToObjectsPTR).Type) t = ReadGadgetByName(LinkedToObjects(LinkedToObjectsPTR).Name, TempGadget) If t = OK Then ' this is an old one, already in the dest db FoundLinkedToCNTR = FoundLinkedToCNTR + 1 LinkedToObjects(LinkedToObjectsPTR).ObjectID = TempGadget.ObjectID Else ' brand new linked-to object AddedLinkedToCNTR = AddedLinkedToCNTR + 1 LinkedToObjects(LinkedToObjectsPTR).ObjectID = 0 LinksWrote = LinksWrote + 1 t = WriteMemGadget(LinkedToObjects(LinkedToObjectsPTR).ObjectID, LinkedToObjects(LinkedToObjectsPTR)) End If ' find and change all objects with this linked to object as link's link value to reflect ' the new linkid. ' Give me ambiguity or, give me something else. ' For ContainedObjectsPTR = 1 To ContainedObjectsCNTR ' Msg = (ReadProperty(ContainedObjects(ContainedObjectsPTR), LinkProp)) ' If Msg = LinkedToObjects(LinkedToObjectsPTR).Tag Then ' 'LinkedToObjectsPTR ' Msg = CStr(LinkedToObjects(LinkedToObjectsPTR).ObjectID) ' t = SetProperty(ContainedObjects(ContainedObjectsPTR), LinkProp, Msg) ' ' write the co ' t = WriteGadget(ContainedObjects(ContainedObjectsPTR).ObjectID, ContainedObjects(ContainedObjectsPTR)) ' DoEvents ' End If ' DoEvents ' Next ContainedObjectsPTR Next LinkedToObjectsPTR ' here we have established the new master object, all contained obects and linked-to properties ' for this source DoEvents ' MsgBox Timer - starttime NextSourceGadget: t = SetProperty(ResultsGadget, "Write Timer", CStr(Timer)) ' If Compare = True Then ' TempGadget = BlankObject ' TempGadget.Name = SourceGadget.Name ' Msg = ReadProperty(Param, "Show") ' If Msg = "True" Then ' t = SetProperty(TempGadget, "Show", "True") ' Else ' t = SetProperty(TempGadget, "Show", "False") ' End If ' Msg = UCase(ReadProperty(Param, "Output File Name")) ' If Msg = NotFound Then ' Msg = AddBackSlash(CurDir) ' t = SetProperty(TempGadget, "Output File Name", Msg & "TRANSPRT.LOG") ' Else ' t = SetProperty(TempGadget, "Output File Name", Msg) ' End If ' t = SetProperty(TempGadget, "Report OID1", SourceGadget.Tag) ' t = SetProperty(TempGadget, "DB PTR1", CStr(SourceDBGadgetPTR)) ' t = SetProperty(TempGadget, "Report OID2", CStr(SourceGadget.ObjectID)) ' t = SetProperty(TempGadget, "DB PTR2", CStr(DestDBGadgetPTR)) ' Msg = ReadProperty(Param, "Log Errors Only") ' t = SetProperty(TempGadget, "Log Errors Only", Msg) ' TempGadget = PrintReportComparison(TempGadget) ' End If t = SetProperty(ResultsGadget, "Compare Timer", CStr(Timer)) If AbortRead Then GoTo EndSub Next SourceGadgetPTR Compare = False If AbortRead Then GoTo EndSub If True = False Then ' let's see the results t = SetProperty(ResultsGadget, "Source Object Name", SourceGadget.Name) DBSwitch SourceDBGadgetPTR TempGadget = BlankObject TempGadget.Name = "Compare Results" TempGadget.Container = "Compare Results" t = ReadGadgetByID(Val(ContainedObjects(ContainedObjectsPTR).Tag)) TempGadget = ReadObjectBuffer Msg = (ReadProperty(TempGadget, LinkProp)) t = SetProperty(ResultsGadget, "DB1 Database", OpenDB(SourceDBGadgetPTR).Name) t = SetProperty(ResultsGadget, "DB1 Object (disk value) Name", TempGadget.Name & " (" & TempGadget.ObjectID & ")") t = SetProperty(ResultsGadget, "DB1 Link To OID", Msg) t = SetProperty(ResultsGadget, "DB1 Link Results", "Started") t = SetProperty(ResultsGadget, "DB1 Link Results", Msg) If Msg <> NotFound And Msg <> "None" Then t = ReadGadgetByID(Val(Msg)) If t <> OK Then t = SetProperty(ResultsGadget, "DB1 Link Results", Msg & " " & NotFound) MsgBox "Link ID: " & Msg, " NOT FOUND" Else ' Msg = "Object: " & tempgadget.Name & " Linked to: (" & Msg & ") " & ReadObjectBuffer.Name Msg = "Object: " & TempGadget.Name & " Linked to: " & ReadObjectBuffer.Name t = SetProperty(ResultsGadget, "DB1 Link Results", Msg) End If End If t = SetProperty(ResultsGadget, "DB2 Link Results", " Started") t = SetProperty(ResultsGadget, "DB2 Database", "") t = SetProperty(ResultsGadget, "DB2 Object (disk value) Name", "") t = SetProperty(ResultsGadget, "DB2 Link To OID", "") ' ShowObject Dematerialize(ResultsGadget), "m" DBSwitch DestDBGadgetPTR TempGadget = BlankObject TempGadget.Name = "Compare Results" TempGadget.Container = "Compare Results" t = SetProperty(TempGadget, "Container", ContainedObjects(ContainedObjectsPTR).Container) t = SetProperty(TempGadget, "Type", ContainedObjects(ContainedObjectsPTR).Type) t = ReadGadgetByName(ContainedObjects(ContainedObjectsPTR).Name, TempGadget) If t <> OK Then MsgBox "Read Container Function Failed" End If Msg = (ReadProperty(TempGadget, LinkProp)) t = SetProperty(ResultsGadget, "DB2 Database", OpenDB(DestDBGadgetPTR).Name) t = SetProperty(ResultsGadget, "DB2 Object (disk value) Name", TempGadget.Name & " (" & TempGadget.ObjectID & ")") t = SetProperty(ResultsGadget, "DB2 Link To OID", Msg) t = SetProperty(ResultsGadget, "DB2 Link Results", Msg) If Msg <> NotFound And Msg <> "None" Then t = ReadGadgetByID(Val(Msg)) If t <> OK Then t = SetProperty(ResultsGadget, "DB2 Link Results", Msg & " " & NotFound) MsgBox "Link ID: " & Msg, " NOT FOUND" Else ' Msg = "Object: " & tempgadget.Name & " Linked to: (" & Msg & ") " & ReadObjectBuffer.Name Msg = "Object: " & TempGadget.Name & " Linked to: " & ReadObjectBuffer.Name t = SetProperty(ResultsGadget, "DB2 Link Results", Msg) End If End If If ReadProperty(ResultsGadget, "DB1 Link Results") <> ReadProperty(ResultsGadget, "DB2 Link Results") Then ShowGadget ResultsGadget End If End If t = SetProperty(ResultsGadget, "Status", "Done") EndSub: DBSwitch 1 stoptime = Timer t = SetProperty(ResultsGadget, "StopTimer", CStr(stoptime)) t = SetProperty(ResultsGadget, "Total Time", CStr(stoptime - starttime)) ' MsgBox stoptime - starttime TransportGadgetsOLD = ResultsGadget AbortRead = False On Error GoTo 0 End Function Friend Function TransportGadgets(Task As Gadget, Param As Gadget) As Gadget ' this routine will copy and/or move gadget object(s) from one database to another ' the Param Object contains all the stuff needed ' Source ' (DB) Database - speaks for itself ' Must already exist ' Provide Path and Name ' (MEM) Memory - any system gadget array (app, db, appdb, task etc) ' (DDE) Transfer - maybe not, we'll see ' Dest ' (DB) Database ' Must already exist ' Provide Path and Name ' MemGadget(x,y) Gadget Buffer (will allow caching objects for upped speed) ' (DDE) OPAG via dde ' Provide Index of output dde variable ' (MEM) ' (DEL) Oblivion (delete only) ' XPT Option ' (C) Copy ' (M) Move ' (D) Delete ' Data Options ' (Type) include only given type ' (Container) ditto container ' (Exclude1....ExcludeX) ' PropName1...PropNameX ' PropValue1..PropValueX ' Send (Name, Property, Gadget) ' Send Prop ' Dim LocalRS() As Recordset, LocalRSCNTR As Integer ' Dim LocalRSPTR As Integer ' Dim starttime As Single, stoptime As Single ' Dim starttime2 As Single, stoptime2 As Single ' starttime = Timer ' Dim t, Msg As String, Msg2 As String, Cntr1 As Integer, Cntr2 As Integer ' Dim PropName As String, PropValue As String ' Dim ReturnDDEIndex As Integer ' Dim TypeToSend As String ' Dim ContainerToSend As String ' Dim DBIndex As String, DBIndexValue As String ' Dim QueReqTemplate As Gadget ' Dim QueRequest As Gadget ' Dim QueParam As Gadget ' Dim DoEventCNTR As Integer ' Dim TempGadget As Gadget ' Dim StartDBGadgetPTR As Integer ' Dim SourceDBGadgetPTR As Integer ' Dim DestDBGadgetPTR As Integer ' Dim TransportMode As String ' Dim ResultsGadget As Gadget ' Dim FilterGadget As Gadget ' Dim SourceGadget As Gadget, SourceGadgetPTR As Integer, SourceGadgetCNTR As Integer ' Dim SourceName As String ' Dim SourceType As String ' Dim DestinationType As String ' Dim SourceExisted As Boolean ' Dim SaveGadget As Boolean ' Dim DestGadget As Gadget ' Dim ExcludeTypes() As String, ExcludeTypesCNTR As Integer ' Dim LocalError As String ' StartDBGadgetPTR = DBGadgetsPTR ' ' begin a resultsgadget ' ResultsGadget = BlankObject ' ResultsGadget.Name = "Transport Results" ' ResultsGadget.Type = "Function Status" ' ResultsGadget.Container = "TransportGadgets" ' t = SetProperty(ResultsGadget, "Status", "Started") ' t = SetProperty(ResultsGadget, "Time: TransportGadgets Start", CStr(starttime)) ' ReturnDDEIndex = Val(ReadProperty(Param, "DDERetIndex")) ' RequestPUDisabled(ReturnDDEIndex) = True ' ' this is a loop to perform the following in sequece ' ' 1) read from source ' ' 2) output to dest ' ' set source gadget ' ' where are the objects coming from? ' SourceType = UCase(ReadProperty(Param, "Source Type")) ' DestinationType = UCase(ReadProperty(Param, "Destination Type")) ' ' set indexes ' DBIndex = ReadProperty(Param, "DBIndex") ' DBIndexValue = ReadProperty(Param, "DBIndexValue") ' ' set Que stuff ' QueReqTemplate = Task ' QueReqTemplate.Name = "SendTo" ' QueReqTemplate.Type = "Task" ' QueReqTemplate.Container = "TransportGadgets" ' QueReqTemplate.Tag = Param.Tag ' t = SetProperty(QueReqTemplate, "Source", "MEM") ' this is the number sent ' t = SetProperty(QueReqTemplate, "#", CStr(0)) ' this is the number sent ' t = SetProperty(QueReqTemplate, "Time: TXG Start", CStr(Timer)) ' t = SetProperty(QueReqTemplate, "DDEIndex", CStr(ReturnDDEIndex)) ' t = SetProperty(QueReqTemplate, "Send Name", "Transport Result") ' t = SetProperty(QueReqTemplate, "Send Type", "Result") ' QueParam = BlankObject ' ' make a filter gadget ' FilterGadget = Param ' SetProperty FilterGadget, DBIndex, DBIndexValue ' ' Select Case True ' Case SourceType = "DB" ' ' coming from database ' ' find source db ptr ' SourceName = ReadProperty(Param, "Source Name") ' SourceDBGadgetPTR = DBFindIndex(SourceName) '' If Val(SourceDBGadgetPTR) = 0 Then '' ' didn't find database, can't do '' GoTo EndSub '' End If ' ' set up the recordset to use ' ' create/use the dde one, if that's where we are ' If ReturnDDEIndex > 0 Then ' LocalRSPTR = ReturnDDEIndex ' If LocalRSPTR > LocalRSCNTR Then ' LocalRSCNTR = LocalRSCNTR + 1 ' ReDim Preserve LocalRS(LocalRSCNTR) ' Set LocalRS(LocalRSCNTR) = OpenDB(OpenDBPTR).OpenRecordset("Objects", dbOpenTable) ' If LocalError <> "" Then ' MsgBox "Error:" & LocalError, , UCase(App.EXEName) & " Debug Message" ' End If ' End If ' End If ' LocalRS(LocalRSCNTR).Index = DBIndex ' LocalRS(LocalRSCNTR).Seek "=", DBIndexValue ' If LocalRS(LocalRSCNTR).NoMatch = True Then ' t = SetProperty(ResultsGadget, "Time TXG Stop", CStr(Timer)) ' QueRequest = QueReqTemplate '' QueRequest.Tag = Now ' t = SetProperty(QueRequest, "#", CStr(0)) ' this is the number sent ' t = SetProperty(QueRequest, "Time: TXG Stop", CStr(Timer)) ' t = SetProperty(QueRequest, "DDEIndex", CStr(ReturnDDEIndex)) ' t = SetProperty(QueRequest, "Status", "No Records") ' QueParam = ResultsGadget ' Que QueRequest, QueParam ' GoTo EndSub ' End If ' Case SourceType = "MEM" ' ' work this out later ' End Select ' ' big loop ' Do While True = True ' DoEvents '' RequestPU ' SourceGadget.Name = NotFound ' ' load from source ' Select Case True ' Case SourceType = "DB" ' ' read and accept/reject as per filter ' Cntr1 = Cntr1 + 1 ' ' read it ' DBSwitch SourceDBGadgetPTR ' SourceGadget = ReadDiskGadgetByID(LocalRS(LocalRSCNTR)!ObjectID) ' ' DBSwitch StartDBGadgetPTR ' Case SourceType = "MEM" ' ' ' work this out later ' End Select ' ' here we have a source gadget loaded ' ' need to filter it to proscribed criteria ' SaveGadget = True ' If SourceGadget.Name = NotFound Then ' SaveGadget = False ' End If ' SaveGadget = GadgetFilter(SourceGadget, FilterGadget) 'returns true if gadget is ok ' DoEvents ' Select Case True ' Case DestinationType = "DB" ' ' write to disk ' If SaveGadget = True Then ' Cntr2 = Cntr2 + 1 ' DBSwitch DestDBGadgetPTR ' TempGadget = BlankObject ' SetProperty TempGadget, "Name", SourceGadget.Name ' DestGadget = ReadDiskGadgetByName(TempGadget) ' If DestGadget.Name = NotFound Then ' SourceGadget.ObjectID = 0 ' Else ' If DestGadget.Type = SourceGadget.Type _ ' And DestGadget.Container = SourceGadget.Container Then ' SourceGadget.ObjectID = DestGadget.ObjectID ' Else ' SourceGadget.ObjectID = 0 ' End If ' End If ' t = WriteMemGadget(SourceGadget.ObjectID, SourceGadget) ' DBSwitch StartDBGadgetPTR ' End If ' Case DestinationType = "MEM" And SaveGadget ' ' Case DestinationType = "DDE" And SaveGadget ' DoEvents '' t = SetProperty(ResultsGadget, "Stop", CStr(Timer)) ' Cntr2 = Cntr2 + 1 ' QueRequest = QueReqTemplate '' QueRequest.Tag = Now ' SetProperty QueRequest, "#", CStr(Cntr2) ' this is the number sent '' SetProperty QueRequest, "Stop", CStr(Timer) ' SetProperty QueRequest, "DDEIndex", CStr(ReturnDDEIndex) ' SetProperty QueRequest, "Sending Gadget", SourceGadget.Name '' t = SetProperty(QueRequest, "Status", "OK") '' SendResultGadget QueRequest, SourceGadget ' starttime2 = Timer '' TPU QueRequest, SourceGadget ' TPU QueRequest, SourceGadget ' stoptime2 = Timer '' MsgBox stoptime2 - starttime2 ' End Select ' If SourceType = "DB" Then ' 'move one and check for exit ' Msg2 = "Continue" ' LocalRS(LocalRSCNTR).MoveNext ' If LocalRS(LocalRSCNTR).EOF Then ' ' out of records ' Msg2 = "EOF" ' End If ' If DBIndexValue <> "ALL" And (UCase(DBIndex) = "TYPE") Then ' If LocalRS(LocalRSCNTR)!Type <> DBIndexValue Then ' Msg2 = "No More " & TypeToSend ' End If ' End If ' If ContainerToSend <> "ALL" And (UCase(DBIndex) = "CONTAINER") Then ' If LocalRS(LocalRSCNTR)!Type <> ContainerToSend Then ' Msg2 = "No More " & ContainerToSend ' End If ' End If ' If Msg2 <> "Continue" Then ' SetProperty ResultsGadget, "Time: TXG Start", CStr(starttime) ' t = SetProperty(ResultsGadget, "Time: TXG Stop", CStr(Timer)) ' QueRequest = QueReqTemplate '' QueRequest.Tag = Now ' SetProperty QueRequest, "Total Sent", CStr(Cntr2) ' this is the number sent ' SetProperty QueRequest, "Time: TXG Start", CStr(starttime) ' SetProperty QueRequest, "Time: TXG Stop", CStr(Timer) ' SetProperty QueRequest, "DDEIndex", CStr(ReturnDDEIndex) ' SetProperty QueRequest, "Status", Msg2 ' SetProperty QueRequest, "Send Name", "Transport End" ' For Cntr1 = 1 To 10000 ' PropName = "Set I/O Property Name #" & CStr(Cntr1) ' PropValue = ReadProperty(Param, PropName) ' If PropValue = NotFound Then ' Exit For ' End If ' SetProperty QueRequest, PropName, PropValue ' PropName = "Set I/O Property Value #" & CStr(Cntr1) ' PropValue = ReadProperty(Param, PropName) ' SetProperty QueRequest, PropName, PropValue ' Next ' QueParam = ResultsGadget ' SetProperty QueParam, "Tag", QueRequest.Tag ' TPU QueRequest, QueParam ' GoTo EndSub ' End If ' End If ' MainLoop ' Loop ' big outside loop ' ' GoTo EndSub 'LocalError: ' LocalError = Error '' MsgBox "Error:" & LocalError, , ucase(App.EXEName) & " Debug Message" ' Resume Next 'EndSub: ' If DBGadgetsPTR <> StartDBGadgetPTR Then ' DBSwitch StartDBGadgetPTR ' End If ' stoptime = Timer ' t = SetProperty(ResultsGadget, "Time: TXG StopTimer", CStr(stoptime)) ' t = SetProperty(ResultsGadget, "Time: TXG Total Time", CStr(stoptime - starttime)) '' MsgBox stoptime - starttime ' TransportGadgets = ResultsGadget ' AbortRead = False ' On Error GoTo 0 ' DoEvents ' RequestPUDisabled(ReturnDDEIndex) = False End Function 'Friend Function GODPropertyAssigned(PropertyName As String, PropertyValue As String, ResultArray As PropertyObjects) As Long ' ' check to see if the propery/value combination exists. ' ' returns the objectid of the found object or 0 if failed ' Dim t, PropertyObjectID As Long ' Dim ndx As Integer ' PropertyObjectID = 0 ' PropsRS.Index = "Property" ' PropsRS.Seek "=", PropertyName ' If PropsRS.NoMatch Then ' GoTo EndSub ' End If ' Do While PropsRS!Property = PropertyName ' If PropsRS!ValueAlpha = PropertyValue Then ' PropertyObjectID = PropsRS!ObjectID ' ndx = ndx + 1 ' ReDim Preserve ResultArray.Propity(ndx) ' ReDim Preserve ResultArray.AssignedObjectID(ndx) ' ResultArray.Propity(ndx) = PropertyName ' ResultArray.AssignedObjectID(ndx) = PropertyObjectID ' End If ' PropsRS.MoveNext ' Loop 'EndSub: ' GODPropertyAssigned = PropertyObjectID ' GDSFreelocks 'End Function Friend Function GODReadProperty(RO As Long, ReadProperty As String) ' reads an object from disk object, semi-obsolete, don't use in new apps ' use ReadProperty instead Dim GORPStart As Single, GORPStop As Single Dim t Dim ObjectName As String, X As Integer Dim TempObject As Gadget Dim Result As String Dim TotProps As Integer, TotalSame As Integer Result = "ERROR: " & RO & ":" & ReadProperty & " NOT Found" If CurrentObject.ObjectID <> RO Then t = ReadGadgetByID(RO) If t <> "OK" Then MsgBox "Failed to read property: " & ReadProperty, vbOKOnly End If TempObject = ReadObjectBuffer Else TempObject = CurrentObject End If TotProps = TempObject.TotalProperties ' need to check for duplicate property names TotalSame = 0 For X = 1 To TotProps If UCase(TempObject.Propity(X)) = UCase(ReadProperty) Then TotalSame = TotalSame + 1 End If Next If TotalSame > 1 Then Result = "ERROR: " & RO & ":" & ReadProperty & " found: " & TotalSame & " Times." GoTo EndGORPL: End If For X = 1 To TotProps If UCase(TempObject.Propity(X)) = UCase(ReadProperty) Then Result = TempObject.ValueAlpha(X) Exit For End If Next EndGORPL: GODReadProperty = Result ' GORPStop = Timer ' MsgBox "Time to read Property: " & ReadProperty & " was " & GORPStop - GORPStart End Function Friend Function ReadProperty(MemObject As Gadget, ReadPropertyName As String) As String ' reads a property value from a memory objects, returns "NOT FOUND" if failed Dim GORPStart As Single, GORPStop As Single Dim TotProps As Integer, PropCntr As Integer, TotalSame As Integer Dim Result As String Dim LocalError As String On Error GoTo LocalError Result = "NOT FOUND" ' GORPStart = Timer TotProps = MemObject.TotalProperties ' need to check for duplicate property names ' TotalSame = 0 ' For PropCntr = 1 To TotProps ' If (UCase(MemObject.Propity(PropCntr)) = UCase(ReadPropertyName)) And (UCase(ReadPropertyName) <> "IS") Then ' TotalSame = TotalSame + 1 ' End If ' Next ' If TotalSame > 1 Then ' Result = "ERROR: " & MemObject.Name & ": " & ReadPropertyName & " found: " & TotalSame & " Times." ' '/////////////////////// ' 'REMOVE THIS ' MsgBox "READMEMORY Property: " & ReadPropertyName & " Found " & TotalSame & "Times" ' GoTo EndSub: ' End If ReadPropertyName = UCase(ReadPropertyName) For PropCntr = 1 To TotProps If UCase(MemObject.Propity(PropCntr)) = (ReadPropertyName) Then Result = MemObject.ValueAlpha(PropCntr) Exit For End If Next '/////////////////////////// ' REMOVE THIS ' TotalSame = 0 ' For PropCntr = 1 To TotProps ' If UCase(MemObject.Propity(PropCntr)) = UCase(ReadPropertyName) And (UCase(ReadPropertyName) <> "IS") Then ' TotalSame = TotalSame + 1 ' End If ' Next ' If TotalSame > 1 Then ' Result = "ERROR: " & MemObject.Name & ": " & ReadPropertyName & " found: " & TotalSame & " Times." ' '/////////////////////// ' 'REMOVE THIS ' MsgBox "READMEMORY Property: " & ReadPropertyName & " " & TotalSame ' GoTo EndSub: ' End If GoTo EndSub LocalError: FloatMsgBox "Read Property Error: ", "Virtual Cortex ReadProperty Error" Resume Next EndSub: ReadProperty = Result On Error GoTo 0 ' GORPStop = Timer ' GDSFreelocks ' MsgBox "Time to read Property: " & ReadPropertyName & " was " & GORPStop - GORPStart End Function Friend Function GODCloneObject(SourceObjectID As Long, _ CloneObjectName As String) As Long ' will clone an object from disk to new name ' can do the same thing with WriteMemGadget with id of 0 Dim t, Msg As String Dim AddedObjectID As Long t = ReadGadgetByID(SourceObjectID) AddedObjectID = GODAddObject(ReadObjectBuffer.Container, _ ReadObjectBuffer.Type, _ CloneObjectName, _ "Retain") ReadObjectBuffer.Name = CloneObjectName t = WriteMemGadget(AddedObjectID, ReadObjectBuffer) GoTo EndCGO: EndCGO: ' If Heaven16.Visible Then ' Currentform.Data_OBJProperties.Refresh ' End If GODCloneObject = AddedObjectID GDSFreelocks End Function Friend Function GodWriteScreenAsObject(Param As Gadget) As Gadget ' writes a screen as a GDS compliant object. ' required adherence to strict layout. Dim t, Msg As String, Cntr1 As Integer, CNTR2 As Integer Dim ResultsGadget As Gadget Dim OKToWriteObject As Boolean Dim TotProps As Integer Dim StartPropNDX As Integer, EndPropNDX As Integer Dim lPropName As String, lPropNamePtr As Integer Dim lPropValue As String, lPropValuePtr As Integer Dim PropValueRequired As Boolean Dim lTop As String, lLeft As String Dim vTop As String, vleft As String Dim lDBGadgetsPTR As Integer Dim StartDBGadgetsPTR As Integer Dim LGadget As Gadget Dim LocalError As String Dim FormName As String, FormIndex As Integer On Error GoTo LocalError StartDBGadgetsPTR = DBGadgetsPTR OKToWriteObject = True ' which form? FormName = ReadProperty(Param, "Form Name") If FormName = NotFound Then FormName = Screen.ActiveForm.Name End If For FormIndex = 0 To Forms.Count - 1 If Forms(FormIndex).Name = FormName Then Exit For End If Next ' use the passed parameter to define this object ' make sure caller sets these things LGadget = BlankObject LGadget.ObjectID = Param.ObjectID LGadget.Name = Param.Name LGadget.Type = Param.Type LGadget.Container = Param.Container t = ReadProperty(Param, "StartPropNDX") If t = NotFound Then StartPropNDX = 0 Else StartPropNDX = Val(t) End If t = ReadProperty(Param, "EndPropNDX") If t = NotFound Then EndPropNDX = Val(Forms(FormIndex).TotIndex) Else EndPropNDX = Val(t) End If For Cntr1 = StartPropNDX To EndPropNDX PropValueRequired = False LocalError = "" t = Forms(FormIndex).PropValue(Cntr1) 'PropLabel(Cntr1) If LocalError = "" Then lPropName = Left(Forms(FormIndex).PropLabel(Cntr1), Len(Forms(FormIndex).PropLabel(Cntr1)) - 2) lPropValue = Forms(FormIndex).PropValue(Cntr1) PropValueRequired = Forms(FormIndex).Required(Cntr1).Value = Checked ' lTop = Forms(FormIndex).PropLabel(Cntr1).Top ' lLeft = Forms(FormIndex).PropLabel(Cntr1).Left ' vTop = Forms(FormIndex).PropValue(Cntr1).Top ' vleft = Forms(FormIndex).PropValue(Cntr1).Left ' t = SetProperty(LGadget, lPropName & " lTop", lTop) ' t = SetProperty(LGadget, lPropName & " lLeft", lLeft) ' t = SetProperty(LGadget, lPropName & " vTop", vTop) ' t = SetProperty(LGadget, lPropName & " vLeft", vleft) ' TotProps = TotProps + 5 ' Msg = Msg & CStr(Cntr1) & ") " & Left(PropLabel(Cntr1), Len(PropLabel(Cntr1)) - 2) & ": " & PropValue(Cntr1) & CrLf Else ' find the culprit (not a textbox control) For CNTR2 = 0 To Forms(FormIndex).Controls.Count - 1 If Val(Forms(FormIndex).Controls(CNTR2).Tag) = Cntr1 Then lPropName = Left(Forms(FormIndex).PropLabel(Cntr1), Len(Forms(FormIndex).PropLabel(Cntr1)) - 2) lPropValue = Forms(FormIndex).Controls(CNTR2) PropValueRequired = Forms(FormIndex).Required(Cntr1).Value = Checked ' lTop = Forms(FormIndex).PropLabel(Cntr1).Top ' lLeft = Forms(FormIndex).PropLabel(Cntr1).Left ' vTop = Forms(FormIndex).Controls(Cntr2).Top ' vleft = Forms(FormIndex).Controls(Cntr2).Left ' t = SetProperty(LGadget, lPropName & " lTop", lTop) ' t = SetProperty(LGadget, lPropName & " lLeft", lLeft) ' t = SetProperty(LGadget, lPropName & " vTop", vTop) ' t = SetProperty(LGadget, lPropName & " vLeft", vleft) ' TotProps = TotProps + 5 End If Next ' Msg = t & CrLf End If If PropValueRequired And Len(AllTrim(lPropValue)) = 0 Then OKToWriteObject = False Exit For End If t = SetProperty(LGadget, lPropName, lPropValue) Next ' which database? t = ReadProperty(Param, "DBGadgetsPTR") If t = NotFound Then lDBGadgetsPTR = DBGadgetsPTR Else lDBGadgetsPTR = Val(t) End If If DBGadgetsPTR <> lDBGadgetsPTR Then t = DBSwitch(lDBGadgetsPTR) End If ' save the object If OKToWriteObject Then Cntr1 = LGadget.ObjectID Msg = SetProperty(LGadget, "(Source Form)", FormName) t = WriteMemGadget(LGadget.ObjectID, LGadget) If (Cntr1 > 0) And (Cntr1 <> LGadget.ObjectID) Then MsgBox "Error Writing Screen to Disk", , UCase(App.EXEName) & " Debug Message" End If Msg = SetProperty(LGadget, "Write Status", CStr(t)) Msg = SetProperty(LGadget, "ObjectID Before Write", CStr(Cntr1)) Msg = SetProperty(LGadget, "ObjectID After Write", CStr(LGadget.ObjectID)) Else Msg = SetProperty(LGadget, "Write Status", "Error") Msg = SetProperty(LGadget, "Write Error", "Required Field: " & lPropName & " is Empty") Msg = SetProperty(LGadget, "Write Error Field Index", CStr(Cntr1)) ' Msg = SetProperty(LGadget, "Write Error Description", lPropName) End If GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: ResultsGadget = LGadget GodWriteScreenAsObject = ResultsGadget If DBGadgetsPTR <> StartDBGadgetsPTR Then t = DBSwitch(StartDBGadgetsPTR) End If On Error GoTo 0 End Function Friend Function GODReadObjectAsScreen(Param As Gadget) As Gadget ' reads a screen as a GDS compliant object. ' required adherence to strict layout. Dim t, Msg As String, Cntr1 As Integer, CNTR2 As Integer Dim ResultsGadget As Gadget Dim StartDBGadgetsPTR As Integer Dim lDBGadgetsPTR As Integer Dim LGadget As Gadget Dim lPropName As String, lPropValue As String Dim StartPropNDX As Integer, EndPropNDX As Integer Dim LocalError As String Dim FormName As String, FormIndex As Integer Dim DefaultValue As String StartDBGadgetsPTR = DBGadgetsPTR On Error GoTo LocalError DefaultValue = ReadProperty(Param, "Default Prop Value") If DefaultValue = NotFound Then DefaultValue = "" End If ' which form? FormName = ReadProperty(Param, "Form Name") If FormName = NotFound Then FormName = Screen.ActiveForm.Name End If For FormIndex = 0 To Forms.Count - 1 If Forms(FormIndex).Name = FormName Then Exit For End If Next ' which database? t = ReadProperty(Param, "DBGadgetsPTR") If t = NotFound Then lDBGadgetsPTR = DBGadgetsPTR Else lDBGadgetsPTR = Val(t) End If If DBGadgetsPTR <> lDBGadgetsPTR Then t = DBSwitch(lDBGadgetsPTR) End If ' ObjectIDToLoad = Val(ReadProperty(Param, "ObjectID")) Select Case True Case Param.ObjectID = 0 And (Param.Name = "" Or Param.Name = BlankObject.Name) ' basically clear screen LGadget = Param Case Param.ObjectID > 0 t = ReadGadgetByID(Param.ObjectID) LGadget = ReadObjectBuffer Case Param.Name <> "" t = ReadGadgetByName(Param.Name, LGadget) End Select ' ShowObject Dematerialize(LGadget), "m " ' this thing can read between 2 property index values ' defaults to all properties on screen t = ReadProperty(Param, "StartPropNDX") If t = NotFound Then StartPropNDX = 0 Else StartPropNDX = Val(t) End If t = ReadProperty(Param, "EndPropNDX") If t = NotFound Then EndPropNDX = Val(Forms(FormIndex).TotIndex) Else EndPropNDX = Val(t) End If For Cntr1 = StartPropNDX To EndPropNDX LocalError = "" t = Forms(FormIndex).PropLabel(Cntr1) lPropName = Left(Forms(FormIndex).PropLabel(Cntr1), Len(Forms(FormIndex).PropLabel(Cntr1)) - 2) t = ReadProperty(LGadget, lPropName) LocalError = "" Forms(FormIndex).PropValue(Cntr1) = t If LocalError = "" Then If t <> NotFound Then Forms(FormIndex).PropValue(Cntr1) = t Else Forms(FormIndex).PropValue(Cntr1) = DefaultValue End If Else For CNTR2 = 0 To Forms(FormIndex).Controls.Count - 1 If Forms(FormIndex).Controls(CNTR2).Tag <> "" Then If Val(Forms(FormIndex).Controls(CNTR2).Tag) = Cntr1 Then ' this is the control If t <> NotFound Then Forms(FormIndex).Controls(CNTR2) = t Else Forms(FormIndex).Controls(CNTR2) = DefaultValue End If End If End If Next End If If t = OK Then End If ' For Cntr2 = 1 To LGadget.TotalProperties ' lPropName = Left(Forms(FormIndex).PropLabel(Cntr1), Len(Forms(FormIndex).PropLabel(Cntr1)) - 2) DoEvents Next GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: DBSwitch StartDBGadgetsPTR On Error GoTo 0 End Function 'Public Sub HandlePopUp(CurrentControl As Control, PUPIndex As Integer) ' MsgBox CurrentControl.Name 'End Sub 'Public Function SynchScreenAndMDB() As String ' Static LastObjectName As String ' Dim Crit, Msg, t ' Dim ndx As Long ' Dim NewRS As String ' Dim ObjectName As String ' Dim Results As String ' Results = "OK" ' Set Currentform = Screen.ActiveForm ' Set CurrentControl = Screen.ActiveForm.ActiveControl ' ObjectName = CurrentControl.Name ' ' If LastObjectName = ObjectName Then ' 'adios ' SynchScreenAndMDB = "OK" ' GoTo EndSSAMDB: ' End If ' Results = ReadGadgetByName(ObjectName, CurrentObject) '' CurrentObjectName = CurrentObject.Name '' CurrentObjectID = CurrentObject.ObjectID ' GoTo EndSSAMDB: ' Crit = "Name='" & ObjectName & "'" ' Currentform.Data_Objects.Recordset.FindFirst Crit ' If Currentform.Data_Objects.Recordset.NoMatch = True Then '' MsgBox "Program goof, didn't find the Object to Synchronize: " & ObjectName ' Results = "ERROR: Program goof, didn't find the Object to Synchronize: " & ObjectName ' GoTo EndSSAMDB: ' End If ' ' NewRS = "" ' NewRS = NewRS & "SELECT DISTINCTROW " ' NewRS = NewRS & "Props.ObjectID, " ' NewRS = NewRS & "Props.PropertyID, " ' NewRS = NewRS & "Props.Property, " ' NewRS = NewRS & "Props.Caption, " ' NewRS = NewRS & "Props.ValueAlpha, " ' NewRS = NewRS & "Props.ValueNum, " ' NewRS = NewRS & "Props.PropSource, " ' NewRS = NewRS & "Props.PropType " ' NewRS = NewRS & "From Props " ' NewRS = NewRS & "Where ObjectID=" & Currentform.Data_Objects.Recordset![ObjectID] & " " ' NewRS = NewRS & "ORDER BY Props.Property;" ' If Currentform.Data_OBJProperties.RecordSource = NewRS Then ' GoTo EndSSAMDB: ' End If ' Currentform.Data_OBJProperties.RecordSource = NewRS ' Currentform.Data_OBJProperties.Refresh ' LastObjectName = Currentform.Data_Objects.Recordset![Name] ' ' ReDim PropertyNames(0), PropertyValues(0) ' PropertyNames(0) = Currentform.Data_Objects.Recordset![Name] ' PropertyValues(0) = AllTrim(Str(Currentform.Data_Objects.Recordset![ObjectID])) ' Msg = PropertyNames(0) & ": " & PropertyValues(0) & CrLf ' ndx = 0 ' Currentform.Data_OBJProperties.Recordset.MoveFirst ' Do Until Currentform.Data_OBJProperties.Recordset.EOF ' ndx = ndx + 1 ' ReDim Preserve PropertyNames(ndx) ' ReDim Preserve PropertyValues(ndx) ' PropertyNames(ndx) = Currentform.Data_OBJProperties.Recordset![Property] ' PropertyValues(ndx) = Currentform.Data_OBJProperties.Recordset![ValueAlpha] '' Msg = Msg & PropertyNames(NDX) & ": " & PropertyValues(NDX) & CrLf ' Currentform.Data_OBJProperties.Recordset.MoveNext ' Loop '' MsgBox Msg 'EndSSAMDB: ' SynchScreenAndMDB = Results ' GDSFreelocks '' ReadGadgetByName ObjectName, CurrentObject 'End Function 'Public Function IsFRMObjectInGadgetor(CheckForm As Form, CheckControl As Control) ' ' see if a control on a form is already defined as a GDS Gadget ' ' can't remember last time i used this ' Dim Crit As String ' Dim CurrentControlType As String ' CurrentControlType = "" ' CurrentControlType = GetControlTypeOf(CheckForm, CheckControl) ' If CurrentControlType = "" Then '' MsgBox "Couldn't determine typeof " & CheckControl.Name ' IsFRMObjectInGadgetor = "ERROR! Couldn't get Typeof " & CheckControl ' Exit Function ' End If ' Crit = "Name='" & CheckControl.Name & "'" ' CheckForm.Data_Objects.Recordset.FindFirst Crit ' If CheckForm.Data_Objects.Recordset.NoMatch = True Then ' IsFRMObjectInGadgetor = "NO" ' Else ' IsFRMObjectInGadgetor = "YES" ' End If 'End Function 'Public Sub Global16JETInit(JetName) ' ' initialization of variables used everywhere I write code ' ' getting big change here, 8/5/98 ' ' GDSINT function replaces in 99.99% of time ' Dim t, Msg, SQLCmd As String, starttime As Single, stoptime As Single ' Dim AddedID As Long ' Dim QueryRS As Recordset ' Dim Crit As String ' Dim LocalError As String ' LocalError = "" ' On Error GoTo LocalError '' GDSFirst '' SetVariables ' ' need to set up the jet database ' ' see if the ini file exists '' APPINIFileName = App.Path & "\" & ucase(App.EXEName) & ".ini" ' JetDatabaseName = JetName ' ChDir App.Path ' ' If Not FileExists(JetDatabaseName) Then ' MsgBox " Call Real World Solutions for assistance.", , "Something isn't right!" ' End ' End If ' GODMode = "Disk" ' If Not FileExists(APPINIFileName) Then ' ' need to create the .INI file here ' Open APPINIFileName For Output As #1 ' Print #1, "[Data]" ' Print #1, "Application=" & ucase(App.EXEName) ' Print #1, "Path=" & CurDir ' Print #1, "Whozits=Jet" ' Print #1, "Open=" & CurDir & "\" & JetDatabaseName ' Print #1, "GODMode=" & GODMode ' Print #1, "[Options]" ' Print #1, "SystemDB=" & CurDir & "\RWSSYS.RWS" ' Close #1 ' Msg = "" ' Msg = Msg & "Auto Configuration of Initialization File:" & CrLf ' Msg = Msg & APPINIFileName & CrLf ' Msg = Msg & "[Data]" & CrLf ' Msg = Msg & "Application=" & ucase(App.EXEName) & CrLf ' Msg = Msg & "Path=" & CurDir & CrLf ' Msg = Msg & "Open=" & CurDir & "\" & JetDatabaseName & CrLf ' Msg = Msg & "Mode=" & GODMode '' MsgBox Msg, vbOKOnly, "Just in case you actually give a whiz." '' Fileform.Show ' End If ' JetDatabasePath = GetINIParameter(APPINIFileName, "Data", "Path") ' If Right(JetDatabasePath, 1) <> "\" Then ' JetDatabasePath = JetDatabasePath & "\" ' End If ' If (CurDir <> JetDatabasePath) And _ ' (CurDir <> Left(JetDatabasePath, Len(JetDatabasePath) - 1)) Then ' ChDrive Left(JetDatabasePath, 1) ' ChDir Right(JetDatabasePath, Len(JetDatabasePath) - 2) ' End If ' If (CurDir <> JetDatabasePath) And _ ' (CurDir <> Left(JetDatabasePath, Len(JetDatabasePath) - 1)) Then ' Msg = Msg & "Directory Error! I Could not set Directory to " & CrLf ' Msg = Msg & JetDatabasePath & CrLf & CrLf ' Msg = Msg & "This is the 2nd time I have tried." & CrLf ' Msg = Msg & "Something is very wrong here." & CrLf ' Msg = Msg & "I'm really confused, apparently." & CrLf ' Msg = Msg & "I need some serious therapy." & CrLf ' Msg = Msg & "I'm shutting down, now. Try again, please." & CrLf ' Msg = Msg & "If This problem persists, call for help!" & CrLf ' MsgBox Msg & JetDatabasePath, vbOKOnly, "I just can't go on..." ' CloseEverything ' End ' End If ' ' opendb(0).name ' APPProgramHomeDir = CurDir ' SelectedDrive = Left(CurDir(), 1) & ":" ' SelectedPath = CurDir ' OpenDBCNTR = OpenDBCNTR + 1 ' OpenDBPTR = OpenDBCNTR ' ReDim Preserve OpenDB(OpenDBPTR) ' DBEngine.IniPath = APPINIFileName ' DBEngine.DefaultUser = "VBasic" ' DBEngine.DefaultPassword = "TLHicky" '' Set GadgetWorkspace = DBEngine.CreateWorkspace(JetName, "VBasic", "TLHicky") ' Set JetDatabase = GadgetWorkspace.OpenDatabase(JetDatabaseName) ' Set OpenDB(OpenDBPTR) = JetDatabase ' Set ObjectsRS = JetDatabase.OpenRecordset("Objects", dbOpenTable) ', dbForwardOnly) ' ObjectsRS.Index = "PrimaryKey" ' If ObjectsRS.RecordCount = 0 Then ' Msg = "Something is apparently wrong with your System." & CrLf ' Msg = Msg & "I detected that there are zero records when it is impossible." & CrLf ' Msg = Msg & "Well, not impossible since I see that it is so." & CrLf ' Msg = Msg & "I need to take a few moments and relax, take a deep breath" & CrLf ' Msg = Msg & "and see if I can fix this propblem. Please say OK so I can" & CrLf ' Msg = Msg & "Start." & CrLf ' MsgBox Msg, vbOKOnly, "Whenever you are ready." ' GDSFreelocks ' JetDatabase.Close ' DBEngine.RepairDatabase JetDatabaseName ' DoEvents '' Set JetDatabase = OpenDataBase(JetDatabaseName) ' Set ObjectsRS = JetDatabase.OpenRecordset("Objects", dbOpenTable) ', dbForwardOnly) ' ObjectsRS.Index = "PrimaryKey" ' End If ' If ObjectsRS.RecordCount = 0 Then ' Msg = "Something is apparently really wrong with your System." & CrLf ' Msg = Msg & "I detected zero System records twice." & CrLf ' Msg = Msg & "I need to take a leave of absence." & CrLf ' Msg = Msg & "If this occurs upon starting me again, call for tech support." & CrLf ' Msg = Msg & "I will shut down when you say so." & CrLf ' MsgBox Msg, vbOKOnly, "Whenever you are ready." ' GDSFreelocks ' JetDatabase.Close ' End ' End If ' Set PropsRS = JetDatabase.OpenRecordset("Props", dbOpenTable) ', dbForwardOnly) ' PropsRS.Index = "ObjectID" ' Set MethodsRS = JetDatabase.OpenRecordset("Methods", dbOpenTable) ', dbForwardOnly) ' MethodsRS.Index = "ObjectID" '' StartTime = Timer ' GODMode = GetINIParameter(APPINIFileName, "Data", "GODMODE") ' ' need to define a blank object as a template '' t = ReadGadgetByName("BlankObject", BlankObject) '' If t <> "OK" Or BlankObject.Container <> "BlankObject" Then '' AddedID = GODAddObject("BlankObject", _ '' "BlankObject", _ '' "BlankObject", _ '' "UNCONDITIONAL") '' t = ReadGadgetByName("BlankObject", BlankObject) '' If t <> "OK" Then '' MsgBox t '' End If '' End If '' BlankObject.ObjectID = 0 ' ' the application gadget contains the application-specific properties ' ' need to define the multiple database scenario '' Set ObjectsRS = OpenRS(0) '' t = ReadGadgetByName(ucase(App.EXEName), CurrentObject) '' If t <> "OK" Then '' AppGadget = BlankObject '' AppGadget.Type = "AppGadget" '' AppGadget.Container = "GDS Registry" '' AppGadget.GAppName = ucase(App.EXEName) '' AppGadget.Name = ucase(App.EXEName) '' Msg = SetProperty(GDSRegistry, "Installed", "True") '' Msg = SetProperty(GDSRegistry, "DataBase", JetName) '' Msg = SetProperty(GDSRegistry, "Active", "True") '' Msg = SetProperty(AppGadget, "") '' End If '' AppGadget = CurrentObject ' t = ReadGadgetByName("DBF Definition", CurrentObject) ' If t <> "OK" Then ' ' End If ' GoTo EndSub 'LocalError: ' LocalError = Error ' Resume Next 'EndSub: ' GDSFreelocks ' On Error GoTo 0 'End Sub Friend Function UtilitiesRepair(Param As Gadget) As Gadget ' repair passed jet database Dim t, Msg As String Dim LParam As Gadget Dim LOCDBPTR As Integer Dim LocalError As String Dim PingParam As Gadget Dim Result As String Dim ResultsGadget As Gadget Dim DBName As String DBName = OpenDB(LOCDBPTR).Name Result = "OK" On Error GoTo LocalError t = SetProperty(Param, "Status", "Started") t = SetProperty(Param, "Errors", "None") LocalError = "" LOCDBPTR = Val(ReadProperty(Param, "DBGadgetsPtr")) Msg = DBSwitch(LOCDBPTR) If Msg <> "OK" Then t = SetProperty(Param, "Errors", DBName & " Disabled") GoTo EndSub End If OpenDB(LOCDBPTR).Close t = SetProperty(Param, "Status", DBName & " Closed") LocalError = "" DBEngine.RepairDatabase JetDatabaseName If LocalError <> "" Then Result = LocalError Msg = "The Following Error Occurred:" & CrLf Msg = Msg & LocalError & CrLf Msg = Msg & "Repair Function Did Not Complete!" & CrLf MsgBox Msg, vbExclamation, "Errors Encountered" Result = LocalError GoTo ReopenFile End If ReopenFile: ' reopen it? If ReadProperty(Param, "Reopen") = "True" Then LParam = DBGadgets(LOCDBPTR) t = SetProperty(LParam, "Reset Gadgets", "False") Msg = ReadProperty(Param, "Force OpenDBPTR") If Msg <> NotFound Then t = SetProperty(LParam, "Force OpenDBPTR", Msg) End If ResultsGadget = OpenJetDataBase(LParam) t = SetProperty(Param, "Status Final", OpenDB(LOCDBPTR).Name & " Reopened") End If GoTo EndSub LocalError: LocalError = Error$ Msg = ReadProperty(Param, "Errors") If Len(Msg) + Len(LocalError) > 128 Then Msg = "" End If Msg = Msg & "/" & LocalError t = SetProperty(Param, "Error", Msg) Resume Next EndSub: On Error GoTo 0 ' Global16JETInit (DBName) Abort: ' InitVGB UtilitiesRepair = Param ChDrive App.Path ChDir App.Path On Error GoTo 0 GDSFreelocks End Function Friend Function UtilitiesCompact(Param As Gadget) As Gadget ' compact jet database Dim t, Msg As String, LocalError As String Dim DBName As String Dim LParam As Gadget Dim LOCDBPTR As Integer Dim PingParam As Gadget Dim Result As String Dim ResultsGadget As Gadget Result = "OK" On Error GoTo LocalError t = SetProperty(Param, "Status", "Started") t = SetProperty(Param, "Errors", "None") LocalError = "" LOCDBPTR = Val(ReadProperty(Param, "DBGadgetsPtr")) DBName = OpenDB(LOCDBPTR).Name Msg = DBSwitch(LOCDBPTR) If Msg <> "OK" Then t = SetProperty(Param, "Errors", DBName & " Disabled") GoTo EndSub End If OpenDB(LOCDBPTR).Close ChDrive ReadProperty(DBGadgets(LOCDBPTR), "Path") ChDir ReadProperty(DBGadgets(LOCDBPTR), "Path") If FileExists("Compact.GDS") Then SetAttr "Compact.GDS", vbNormal Kill "Compact.GDS" End If DBEngine.CompactDatabase DBName, "Compact.GDS" If LocalError <> "" Then Msg = "The Following Error Occurred:" & CrLf Msg = Msg & LocalError & CrLf Msg = Msg & "Compact Function Did Not Complete!" & CrLf MsgBox Msg, vbExclamation, "Errors Encountered" Result = LocalError GoTo ReopenFile End If If FileExists("GDS.BAK") Then SetAttr "GDS.BAK", vbNormal Kill "GDS.BAK" If FileExists("GDS.LDB") Then Kill "GDS.LDB" End If End If Name DBName As "GDS.BAK" Name "Compact.GDS" As DBName If FileExists("Compact.LDB") Then SetAttr "Compact.LDB", vbNormal Kill "Compact.LDB" End If ReopenFile: ' reopen it? If ReadProperty(Param, "Reopen") = "True" Then LParam = DBGadgets(LOCDBPTR) t = SetProperty(LParam, "Reset Gadgets", "False") Msg = ReadProperty(Param, "Force OpenDBPTR") If Msg <> NotFound Then t = SetProperty(LParam, "Force OpenDBPTR", Msg) End If ResultsGadget = OpenJetDataBase(LParam) t = SetProperty(Param, "Status Final", OpenDB(LOCDBPTR).Name & " Reopened") End If ' MsgBox "", vbInformation, "Compact Complete" GoTo EndSub LocalError: LocalError = Error$ Msg = ReadProperty(Param, "Errors") If Len(Msg) + Len(LocalError) > 128 Then Msg = "" End If Msg = Msg & "/" & LocalError t = SetProperty(Param, "Error", Msg) Resume Next EndSub: On Error GoTo 0 ' InitVGB Abort: ' Global16JETInit (DBName) ChDrive App.Path ChDir App.Path UtilitiesCompact = Param GDSFreelocks End Function Friend Function LenTest() Dim Msg As String, Cntr1 As Long Dim LocalError As String On Error GoTo LocalError LocalError = "" Do Msg = Msg & "a" Loop Until LocalError <> "" MsgBox Len(Msg), , UCase(App.EXEName) & " Debug Message" GoTo EndSub LocalError: LocalError = Error Resume Next EndSub: End Function Friend Function CloseOPAG(Param As Gadget) ' ' closes passed OPAG (Object Processing Application Gadget) ' Dim t, Msg As String, Cntr1 As Integer ' Dim LParam As Gadget ' Dim LocalError As String ' LocalError = "" ' On Error GoTo LocalError '' removed for Core '' If MainForm.ScheduleStatus = "Executing" Then '' MsgBox "Schedule is being executed, can't terminate", vbExclamation, "Scheduler Busy" '' GoTo EndSub '' End If ' ' If DDEInputCNTR <= 2 Then ' MsgBox "The Scheduler is not Running", vbExclamation, "Error: Scheduler Not Running" ' GoTo EndSub ' End If '' For Cntr1 = 3 To DDEInputCNTR '' If DDEControlObject(Cntr1).Name = "RWS_SKED Destination" Then '' Exit For '' End If '' Next ' LParam = BlankObject ' LParam.ObjectID = 0 ' DDEPing LParam ' If InStr(ReadProperty(LParam, "Status"), " Off Line") > 0 Then ' MsgBox "The Scheduler Application is not responding, can't terminate", vbExclamation, "Error: Application offline" ' GoTo EndSub ' End If ' Msg = "Are you sure you want to Termiate the Scheduler Application?" & CrLf ' Msg = Msg & "Note: Any Scheduled Operations will not occur" ' t = MsgBox(Msg, vbYesNo + vbDefaultButton2 + vbQuestion, "Confirm Application Shutdown") ' If t <> vbYes Then ' GoTo EndSub: ' End If ' Cntr1 = 3 ' OPAG_IO.DDEInput(AppDDEIndex).Text = "" '' DDEInputDisabled = False ' DoEvents ' WasteTime 1 ' If OPAG_IO.DDEInput(Cntr1).Text = "" Then ' MsgBox "Scheduler did not respond, assuming it is not running" ' End If ' If InStr(OPAG_IO.DDEInput(Cntr1).Text, "Can't Stop") > 0 Then ' MsgBox "Scheduler is busy, Can't Terminate Now.", vbExclamation, "Scheduler Application Can't Stop" ' GoTo EndSub ' End If '' DDEPing BlankObject '' MainForm.ScheduleStatus = "Not Loaded" ' GoTo EndSub 'LocalError: ' LocalError = Error ' Resume Next 'EndSub: '' Screen.MousePointer = NORMAL ' On Error GoTo 0 ' GDSFreelocks End Function Friend Sub WriteLockTest() Dim t, Msg As String, DBToUse As Integer Dim TotDone As Long Dim TempRS As Recordset DBToUse = Val(InputBox("Enter Database #:", UCase(App.EXEName) & ": Write Test Parameters", "8")) If DBToUse = 0 Then GoTo EndSub Set TempRS = OpenDB(DBToUse).OpenRecordset("Objects", dbOpenTable) DBSwitch DBToUse Do While True = True TempRS.MoveFirst Do While TempRS.EOF = False TotDone = TotDone + 1 t = ReadGadgetByID(TempRS!ObjectID) t = WriteMemGadget(ReadObjectBuffer.ObjectID, ReadObjectBuffer) ' TempRS.MoveNext ' DoEvents If AbortRead Then Exit Do Loop If AbortRead Then Exit Do Loop EndSub: DBSwitch 1 End Sub Friend Function GDSFreelocks() DBEngine.Idle dbFreeLocks End Function Friend Function NOPU(Task As Gadget, Param As Gadget) As Gadget ' dummy function for non opag processing units End Function Friend Function OpenRecordsetTest(Param As Gadget) As Gadget ' this will tell you a total number of recorsets you can open ' increase the cnt1 til you get an error Dim t, Msg As String, Cntr1 As Integer Dim starttime As Single, stoptime As Single Dim LocRS() As Recordset starttime = Timer For Cntr1 = 1 To 200 ReDim Preserve LocRS(Cntr1) Set LocRS(Cntr1) = OpenDB(OpenDBPTR).OpenRecordset("Objects", dbOpenTable) Next stoptime = Timer MsgBox stoptime - starttime, , "Set Recordset test" For Cntr1 = 1 To 200 LocRS(Cntr1).Close Next End Function '/////////////////////////////////////////////////////////// '////////////////////////////////////////////////////////// ' Gadgetor Internal Tasks, not available to external programs Friend Function AppAttach(AppToUse As Gadget) As Gadget ' this loads all appgadgets from the VGBDatabaseName file ' and creates them if necessary Dim t, Msg As String, Cntr1 As Integer Dim RREsults As Gadget, MResults As Gadget Dim AppPath As String, AppName As String, AppPathAndName As String Dim Dirty As Boolean Dim StartAppPTR As Integer, StartDBPTR As Integer Dim LParam As Gadget Dim NOPAGPath As String Dim UserInput As String, Default As String Dim LocalError As String On Error GoTo LocalError SetProperty Trace, NextID("trace") & "AppAttach", AppToUse.Name StartDBPTR = DBGadgetsPTR StartAppPTR = AppGadgetsPTR If StartDBPTR <> 0 Then DBSwitch 0 End If AppPath = AddBackSlash(ReadProperty(AppToUse, "AppPath")) AppName = ReadProperty(AppToUse, "AppName") If AppName = NotFound Then AppName = AppToUse.Name End If LParam = BlankObject ' see if the app gadget exists For AppGadgetsPTR = 1 To AppGadgetsCNTR If AppGadgets(AppGadgetsPTR).Name = AppName Then ' already loaded Exit For End If Next If (AppGadgetsPTR > AppGadgetsCNTR) Or (AppGadgetsCNTR = 0) Then ' not loaded, do so AppGadgetsCNTR = AppGadgetsCNTR + 1 AppGadgetsPTR = AppGadgetsCNTR ReDim Preserve AppGadgets(AppGadgetsCNTR) RREsults = Recall(AppName, "From " & VGBDatabaseNameAndPath) If RREsults.Name = AppName Then ' SetProperty Trace, NextID("trace") & "Attached App", AppName & " Exists" ' found on disk AppToUse.ObjectID = RREsults.ObjectID SetProperty AppToUse, "Registered Date", ReadProperty(RREsults, "Registered Date") SetProperty AppToUse, "Registered Time", ReadProperty(RREsults, "Registered Time") Else ' SetProperty Trace, NextID("trace") & "Attached App", AppName & " Added" SetProperty AppToUse, "Registered Date", Format(Now, "Long Date") SetProperty AppToUse, "Registered Time", Format(Now, "Long Time") End If AppGadgets(AppGadgetsPTR) = AppToUse ' save the passed object to disk MResults = Memorize(AppGadgets(AppGadgetsPTR), "in " & VGBDatabaseNameAndPath) End If ' here we have the app on disk and in memory ' we're done GoTo EndSub ' CurrentObject = Recall(App.EXEName) ' If UCase(CurrentObject.Name) <> UCase(App.EXEName) Then ' ' the me isn't here, make it '' MsgBox "Adding Application: " & ucase(App.EXEName), , "Application Setup" ' ' no apps are registered ' ' can register me now ' AppGadgetsCNTR = AppGadgetsCNTR + 1 ' AppGadgetsPTR = AppGadgetsCNTR ' ReDim Preserve AppGadgets(AppGadgetsCNTR) ' AppGadgets(AppGadgetsPTR) = BlankObject ' AppGadgets(AppGadgetsPTR).ObjectID = 0 ' AppGadgets(AppGadgetsPTR).Name = UCase(App.EXEName) ' AppGadgets(AppGadgetsPTR).Container = "GDS Registry" ' AppGadgets(AppGadgetsPTR).Type = "AppGadget" ' AppGadgets(AppGadgetsPTR).GAppName = UCase(App.EXEName) ' t = SetProperty(AppGadgets(AppGadgetsPTR), "AppPath", App.Path) ' t = SetProperty(AppGadgets(AppGadgetsPTR), "AppINIFile", UCase(App.EXEName) & ".INI") ' t = SetProperty(AppGadgets(AppGadgetsPTR), "Long Name", "None") ' t = SetProperty(AppGadgets(AppGadgetsPTR), "Site Name", "None") ' t = SetProperty(AppGadgets(AppGadgetsPTR), "Registered Date", Format(Now, "Long Date")) ' t = SetProperty(AppGadgets(AppGadgetsPTR), "Registered Time", Format(Now, "Long Time")) ' t = SetProperty(AppGadgets(AppGadgetsPTR), "Status", "Initializing") ' t = SetProperty(AppGadgets(AppGadgetsPTR), "Last Activated Date", Format(Now, "Long Date")) ' t = SetProperty(AppGadgets(AppGadgetsPTR), "Last Activated Time", Format(Now, "Long Time")) ' t = SetProperty(AppGadgets(AppGadgetsPTR), "NetID", "None") ' Else ' Msg = "Add" ' For Cntr1 = 1 To AppGadgetsCNTR ' If AppGadgets(Cntr1).Name = UCase(App.EXEName) Then ' Msg = "No" ' AppGadgetsPTR = Cntr1 ' Exit For ' End If ' Next ' If Msg = "Add" Then ' AppGadgetsCNTR = AppGadgetsCNTR + 1 ' AppGadgetsPTR = AppGadgetsCNTR ' ReDim Preserve AppGadgets(AppGadgetsCNTR) ' AppGadgets(AppGadgetsPTR) = CurrentObject ' End If ' t = SetProperty(AppGadgets(AppGadgetsPTR), "Status", "Initializing") ' End If ' ' this are fixups ' ' all gds apps are opags, after all ' ' opags are (o)bject (p)rocessing (a)pplication (g)adgets ' If ReadProperty(AppGadgets(AppGadgetsPTR), "App Type") = NotFound Then ' t = SetProperty(AppGadgets(AppGadgetsPTR), "App Type", "OPAG") '' t = WriteMemGadget(AppGadgets(AppGadgetsPTR).ObjectID, AppGadgets(AppGadgetsPTR)) ' End If '' If ReadProperty(AppGadgets(AppGadgetsPTR), "App Type") = "OPAG" Then '' t = SetProperty(AppGadgets(AppGadgetsPTR), "App Type", "OPAG") '' t = WriteMemGadget(AppGadgets(AppGadgetsPTR).ObjectID, AppGadgets(AppGadgetsPTR)) '' End If ' t = WriteMemGadget(AppGadgets(AppGadgetsPTR).ObjectID, AppGadgets(AppGadgetsPTR)) ' ' reset the arrays to 0? ' If ReadProperty(AppToUse, "Reset Gadgets") = "True" Then ' ReDim AppGadgets(0) ' AppGadgetsCNTR = 0 ' AppGadgetsPTR = 0 ' End If ' ObjectsRS.Index = "Type" ' ObjectsRS.Seek "=", "AppGadget" ' Do While ObjectsRS.NoMatch = False ' Msg = "Add" ' For AppGadgetsPTR = 0 To AppGadgetsCNTR ' If AppGadgets(AppGadgetsPTR).Name = ObjectsRS!Name Then ' Msg = "No" ' Exit For ' End If ' Next ' If Msg = "Add" Then ' AppGadgetsCNTR = AppGadgetsCNTR + 1 ' AppGadgetsPTR = AppGadgetsCNTR ' ReDim Preserve AppGadgets(AppGadgetsCNTR) ' t = ReadGadgetByID(ObjectsRS!ObjectID) ' AppGadgets(AppGadgetsPTR) = ReadObjectBuffer ' End If ' ObjectsRS.MoveNext ' If ObjectsRS.EOF Then Exit Do ' If ObjectsRS!Type <> "AppGadget" Then Exit Do ' Loop ' ' set the meappptr ' For AppGadgetsPTR = 0 To AppGadgetsCNTR ' If AppGadgets(AppGadgetsPTR).Name = UCase(App.EXEName) Then ' MeAppPTR = AppGadgetsPTR ' Exit For ' End If ' Next ' If AppGadgetsPTR > AppGadgetsCNTR Then ' ' problem, no me. bad juju '' MsgBox "AppGadgetsPTR > AppGadgetsCNTR: No Me Application", , ucase(App.EXEName) & " Debug Message" ' GoTo EndSub ' End If GoTo EndSub LocalError: LocalError = Error ' MsgBox "App Load Errror: " & Error, , UCase(App.EXEName) & " Debug Message" SetProperty Trace, NextID("trace") & "Trapped App Attach", "Error: " & AppToUse.Name & " / " & LocalError SetProperty VGBErrors, NextID("error") & "Trapped App Attach", "Error: " & AppToUse.Name & " / " & LocalError Resume Next EndSub: GDSFreelocks If DBGadgetsPTR <> StartDBPTR Then DBSwitch StartDBPTR End If ' SetProperty Trace, NextID("trace") & "App Attached", AppPath & AppName SetProperty AppGadgets(AppGadgetsPTR), "Status ", "Recognized @ " & Now AppAttach = AppGadgets(AppGadgetsPTR) On Error GoTo 0 End Function Friend Function AppGadgetsLaunch(Param As Gadget) ' must start all dependent applications Dim t, Msg As String, Cntr1 As Integer Dim DateTimeNow As Variant Dim ExpireDateTime As Variant Dim LocAppPTR As Integer Dim LGadget As Gadget Dim LaunchIndex As Integer Dim LaunchOIDS() As Long, LaunchOIDSCNTR As Integer Dim LaunchOK As Boolean Dim ShellAppPath As String Dim ShellName As String, ShellDelay As Integer Dim ThisNetID As String Dim MSGFormVisible As Boolean MSGFormVisible = False ' see if we need to display something For Cntr1 = 0 To Forms.Count - 1 If UCase(Forms(Cntr1).Name) = "GDSMSG" Then If Forms(Cntr1).Visible Then MSGFormVisible = True Exit For End If End If Next LaunchIndex = -1 ' fix this to open the passed appgadget ' is it running? ' do non opags first ' these are sequence dependent ' get the load sequence Do LaunchIndex = LaunchIndex + 1 For LocAppPTR = 1 To AppGadgetsCNTR If ReadProperty(AppGadgets(LocAppPTR), "App Type") <> "OPAG" And _ ReadProperty(AppGadgets(LocAppPTR), "Auto Start") = "True" Then If Val(ReadProperty(AppGadgets(LocAppPTR), "Shell Sequence")) = LaunchIndex Then LaunchOIDSCNTR = LaunchOIDSCNTR + 1 ReDim Preserve LaunchOIDS(LaunchOIDSCNTR) LaunchOIDS(LaunchOIDSCNTR) = LocAppPTR End If End If Next Loop Until LaunchIndex >= AppGadgetsCNTR ' got all the non opags in sequence, start 'em LGadget = BlankObject LGadget.Name = "AppActivate Param" For LaunchIndex = 1 To LaunchOIDSCNTR If ReadProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "Auto Start") <> "True" Then ' this is not an autostart app GoTo NextApp1 End If ShellAppPath = UCase(ReadProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "AppPath")) If Right(ShellAppPath, 1) <> "\" Then ShellAppPath = ShellAppPath & "\" End If ShellName = UCase(AppGadgets(LaunchOIDS(LaunchIndex)).Name & ".EXE") If MSGFormVisible Then GDSMsg.MsgText2 = "Checking: " & ReadProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "Long Name") WasteTime 0.5 End If ShellDelay = Val(ReadProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "Shell Delay")) ThisNetID = ReadProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "NetID") If Not FileExists(ShellAppPath & ShellName) Then GoTo NextApp1 End If If ThisNetID <> "None" Then ' this is a net dde app, not on this GoTo NextApp1 End If t = SetProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "Status", "Not Running") ' ShowObject Dematerialize(AppGadgets(LaunchOIDS(LaunchIndex))), "m" LGadget = BlankObject LGadget.Name = "App Detect Param" t = SetProperty(LGadget, "Application", ShellName) t = GDSAppActive(LGadget) If t = False Then ' this app is not running, need to fire it up GDSMsg.MsgText2 = "Launching: " & ReadProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "Long Name") Shell ShellAppPath & ShellName, vbNormalNoFocus DateTimeNow = Format(Date, "mm/dd/yyyy") DateTimeNow = DateTimeNow & " " & Format(Time, "Long time") ExpireDateTime = CDate(DateAdd("s", 60, DateTimeNow)) Do WasteTime 3 DateTimeNow = Format(Date, "mm/dd/yyyy") DateTimeNow = DateTimeNow & " " & Format(Time, "Long time") LaunchOK = GDSAppActive(LGadget) Select Case True Case LaunchOK t = SetProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "Status", "Running") t = SetProperty(AppGadgets(AppGadgetsPTR), "Last Activated Date", Format(Now, "Long Date")) t = SetProperty(AppGadgets(AppGadgetsPTR), "Last Activated Time", Format(Now, "Long Time")) WasteTime 3 Exit Do Case CDate(DateTimeNow) > CDate(ExpireDateTime) t = SetProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "Status", "Launch Failed") Exit Do End Select Loop Else t = SetProperty(AppGadgets(LaunchOIDS(LaunchIndex)), "Status", "Running") End If ' ShowObject Dematerialize(AppGadgets(LaunchOIDS(LaunchIndex))), "m" ' MsgBox t NextApp1: Next ' now do opags For LocAppPTR = 1 To AppGadgetsCNTR If AppGadgets(LocAppPTR).Name <> UCase(App.EXEName) And _ ReadProperty(AppGadgets(LocAppPTR), "App Type") = "OPAG" And _ ReadProperty(AppGadgets(LocAppPTR), "Auto Start") = "True" Then ' If ReadProperty(AppGadgets(LocAppPTR), "Auto Start") = "True" Then ' ' this is not an autostart app ' GoTo NextApp2 ' End If ShellAppPath = UCase(ReadProperty(AppGadgets(LocAppPTR), "AppPath")) If Right(ShellAppPath, 1) <> "\" Then ShellAppPath = ShellAppPath & "\" End If ShellName = UCase(AppGadgets(LocAppPTR).Name & ".exe") ShellDelay = Val(ReadProperty(AppGadgets(LocAppPTR), "Shell Delay")) ThisNetID = ReadProperty(AppGadgets(LocAppPTR), "NetID") If Not FileExists(ShellAppPath & ShellName) Then GoTo NextApp2 End If If ThisNetID <> "None" Then ' this is a net dde app, not on this GoTo NextApp2 End If t = SetProperty(AppGadgets(LocAppPTR), "Status", "Not Running") LGadget = BlankObject LGadget.Name = "App Detect Param" t = SetProperty(LGadget, "Application", ShellName) t = GDSAppActive(LGadget) If t = False Then ' app is not running, needs started Shell ShellAppPath & ShellName, vbNormalNoFocus DateTimeNow = Format(Date, "mm/dd/yyyy") DateTimeNow = DateTimeNow & " " & Format(Time, "Long time") ExpireDateTime = CDate(DateAdd("s", 60, DateTimeNow)) Do WasteTime 3 DateTimeNow = Format(Date, "mm/dd/yyyy") DateTimeNow = DateTimeNow & " " & Format(Time, "Long time") LaunchOK = GDSAppActive(LGadget) Select Case True Case LaunchOK t = SetProperty(AppGadgets(LocAppPTR), "Status", "Running") WasteTime 3 Exit Do Case CDate(DateTimeNow) > CDate(ExpireDateTime) Exit Do End Select Loop Else t = SetProperty(AppGadgets(LocAppPTR), "Status", "Running") End If End If NextApp2: Next EndSub: End Function Friend Function DBGadgetsLoad(Param As Gadget) Dim starttime As Single starttime = Timer Dim t, Msg As String, Cntr1 As Integer, CNTR2 As Integer, Cntr3 As Integer Dim AppRSName As String Dim StartDBPTR As Integer Dim LParam As Gadget Dim CurrDBName As String Dim CurrDBGadget As Gadget Dim ThisDBName As String Dim DBCheckName As String Dim DelOIDS() As Long, DelOIDSCNTR As Integer Dim DelNames() As String Dim CurrAppRSGadget As Gadget Dim TBookmark As String Dim TempRS As Recordset Set TempRS = OpenDB(OpenDBPTR).OpenRecordset("Objects", dbOpenTable) Dim LocalError As String On Error GoTo LocalError StartDBPTR = DBGadgetsPTR SetProperty Trace, NextID("trace") & "DBGadgetsLoad Start", "Name: " & Param.Name If DBGadgetsPTR > 0 Then DBSwitch 0 End If LParam = BlankObject ' reset the arrays to 0? If ReadProperty(Param, "Reset Gadgets") = "True" Then ReDim DBGadgets(0) DBGadgetsCNTR = 0 DBGadgetsPTR = 0 End If ' let's see if there are no dbgadgets ' i don't think this situation occurs any more ObjectsRS.Index = "Type" ObjectsRS.Seek "=", "DBGadget" If ObjectsRS.NoMatch = True Then ' none found, create registry one DBGadgetsCNTR = DBGadgetsCNTR + 1 ReDim Preserve DBGadgets(DBGadgetsCNTR) DBGadgets(DBGadgetsCNTR) = BlankObject DBGadgets(DBGadgetsCNTR).Name = VGBDatabaseName & "-0" DBGadgets(DBGadgetsCNTR).Type = "DBGadget" DBGadgets(DBGadgetsCNTR).Container = "AppGadget" End If ' go with it, open dbs and remove any missing files Do While ObjectsRS.NoMatch = False SetProperty Trace, NextID("trace") & "DBGadgetsLoad Load Loop", "File Name: " & ObjectsRS!Name Msg = "Add" TBookmark = ObjectsRS.Bookmark ' already loaded? For DBGadgetsPTR = 0 To DBGadgetsCNTR If DBGadgets(DBGadgetsPTR).Name = ObjectsRS!Name Then Msg = "No" Exit For End If Next If Msg = "Add" Then ' see if the file exists and delete objects not represented by a real file t = ReadGadgetByID(ObjectsRS!ObjectID) CurrDBGadget = ReadObjectBuffer ThisDBName = ReadProperty(CurrDBGadget, "DB Name") DBCheckName = ReadProperty(CurrDBGadget, "Path") If Right(DBCheckName, 1) <> "\" Then DBCheckName = DBCheckName & "\" End If DBCheckName = DBCheckName & ThisDBName SetProperty Trace, NextID("trace") & "DBGadgetsLoad Checking File", "Name: " & DBCheckName If Not FileExists(DBCheckName) Then ' this file is gone from disk ' remove the dbgadgets, appdbgadgets and apprs gadgets associate with it ' this is the dbgadget SetProperty Trace, NextID("trace") & "DBGadgetsLoad Delete DB", "Name: " & DBCheckName Msg = "No Add" DelOIDSCNTR = DelOIDSCNTR + 1 ReDim Preserve DelOIDS(DelOIDSCNTR) DelOIDS(DelOIDSCNTR) = CurrDBGadget.ObjectID ReDim Preserve DelNames(DelOIDSCNTR) DelNames(DelOIDSCNTR) = CurrDBGadget.Name ' find all the appdb gadgets and delete them Msg = UCase(App.EXEName) & "-" & CurrDBGadget.Name TempRS.Index = "Type" TempRS.Seek "=", "AppDBGadget" Do While TempRS.NoMatch = False t = ReadGadgetByID(TempRS!ObjectID) If ReadProperty(ReadObjectBuffer, "DB Name") = ThisDBName Then DelOIDSCNTR = DelOIDSCNTR + 1 ReDim Preserve DelOIDS(DelOIDSCNTR) DelOIDS(DelOIDSCNTR) = TempRS!ObjectID ReDim Preserve DelNames(DelOIDSCNTR) DelNames(DelOIDSCNTR) = TempRS!Name End If TempRS.MoveNext If TempRS.EOF Then Exit Do If TempRS!Type <> "AppDBGadget" Then Exit Do Loop ' find all the rs gadgets and delete them TempRS.Seek "=", "AppRSGadget" CurrDBName = ReadProperty(CurrDBGadget, "DB Name") Do While TempRS.NoMatch = False t = ReadGadgetByID(TempRS!ObjectID) Msg = ReadProperty(ReadObjectBuffer, "DB Name") ' Msg = ucase(App.EXEName) & "-" & CurrDBGadget.Name If (Msg = ThisDBName) And (ThisDBName <> VGBDatabaseName) Then DelOIDSCNTR = DelOIDSCNTR + 1 ReDim Preserve DelOIDS(DelOIDSCNTR) DelOIDS(DelOIDSCNTR) = TempRS!ObjectID ReDim Preserve DelNames(DelOIDSCNTR) DelNames(DelOIDSCNTR) = TempRS!Name End If TempRS.MoveNext If TempRS.EOF Then Exit Do If TempRS!Type <> "AppRSGadget" Then Exit Do Loop End If If Msg = "Add" Then DBGadgetsCNTR = DBGadgetsCNTR + 1 DBGadgetsPTR = DBGadgetsCNTR ReDim Preserve DBGadgets(DBGadgetsCNTR) t = ReadGadgetByID(ObjectsRS!ObjectID) DBGadgets(DBGadgetsPTR) = ReadObjectBuffer SetProperty Trace, NextID("trace") & "DBGadgetsLoad Loaded", "DB Name: " & ReadObjectBuffer.Name End If End If 'msg="Add" ObjectsRS.Bookmark = TBookmark ObjectsRS.MoveNext If ObjectsRS.EOF Then Exit Do If ObjectsRS!Type <> "DBGadget" Then Exit Do Loop ' MsgBox "stop" If DBGadgetsCNTR = 10 ^ 4 Then ' need system set up ' rws not here t = ReadProperty(DBGadgetDef, "Last DBGadget Name Index") t = Val(t) + 1 Msg = SetProperty(DBGadgetDef, "Last DBGadget Name Index", CStr(t)) DBGadgetsCNTR = DBGadgetsCNTR + 1 DBGadgetsPTR = DBGadgetsCNTR ReDim Preserve DBGadgets(DBGadgetsCNTR) DBGadgets(DBGadgetsCNTR) = BlankObject DBGadgets(DBGadgetsCNTR).ObjectID = 0 DBGadgets(DBGadgetsCNTR).Name = "RWS.RWS-" & t DBGadgets(DBGadgetsCNTR).Type = "DBGadget" DBGadgets(DBGadgetsCNTR).Container = "AppGadget" DBGadgets(DBGadgetsCNTR).GAppName = "GDS" DBGadgets(DBGadgetsCNTR).Tag = "DBGadgetsLoad/DBGadgetsCNTR=0: " & CStr(Now()) t = SetProperty(DBGadgets(DBGadgetsCNTR), "DB Name", "RWS.RWS") t = SetProperty(DBGadgets(DBGadgetsCNTR), "System", "RWSSYS.RWS") t = SetProperty(DBGadgets(DBGadgetsCNTR), "AutoOpen", "True") t = SetProperty(DBGadgets(DBGadgetsCNTR), "Type", "Jet") t = SetProperty(DBGadgets(DBGadgetsCNTR), "Version", "2.0") t = SetProperty(DBGadgets(DBGadgetsCNTR), "DU", "VBasic") t = SetProperty(DBGadgets(DBGadgetsCNTR), "DP", "TLHicky") ' t = WriteMemGadget(DBGadgets(DBGadgetsCNTR).ObjectID, DBGadgets(DBGadgetsCNTR)) If FileExists(App.Path & "\RWS.RWS") Then t = SetProperty(DBGadgets(DBGadgetsCNTR), "Path", App.Path) End If t = WriteMemGadget(DBGadgets(DBGadgetsCNTR).ObjectID, DBGadgets(DBGadgetsCNTR)) t = WriteMemGadget(DBGadgetDef.ObjectID, DBGadgetDef) Msg = UCase(App.EXEName) & "-" & DBGadgets(DBGadgetsCNTR).Name t = ReadGadgetByName(Msg, CurrentObject) ' MsgBox t If t <> OK Then AppDBGadgetsCNTR = AppDBGadgetsCNTR + 1 ReDim Preserve AppDBGadgets(AppDBGadgetsCNTR) AppDBGadgets(AppDBGadgetsCNTR) = BlankObject AppDBGadgets(AppDBGadgetsCNTR).Name = Msg AppDBGadgets(AppDBGadgetsCNTR).ObjectID = 0 AppDBGadgets(AppDBGadgetsCNTR).Type = "AppDBGadget" AppDBGadgets(AppDBGadgetsCNTR).Container = UCase(App.EXEName) AppDBGadgets(AppDBGadgetsCNTR).Tag = "DBGadgetsLoad: " & Msg & " / " & CStr(Now()) t = SetProperty(AppDBGadgets(AppDBGadgetsCNTR), "DB Name", "RWS.RWS") t = SetProperty(AppDBGadgets(AppDBGadgetsCNTR), "DBGadgets ID", CStr(DBGadgets(DBGadgetsCNTR).ObjectID)) t = SetProperty(AppDBGadgets(AppDBGadgetsCNTR), "Enabled", "True") t = SetProperty(AppDBGadgets(AppDBGadgetsCNTR), "Open in this App?", "True") t = SetProperty(AppDBGadgets(AppDBGadgetsCNTR), "Show DB to User", "False") t = WriteMemGadget(AppDBGadgets(AppDBGadgetsCNTR).ObjectID, AppDBGadgets(AppDBGadgetsCNTR)) End If End If ' delete all the dbgasdget objects without valid files For Cntr1 = 1 To DelOIDSCNTR t = DeleteGadget(DelOIDS(Cntr1)) Next ' load the appdbgadgets ObjectsRS.Index = "Type" ObjectsRS.Seek "=", "AppDBGadget" ' Msg = ucase(App.EXEName) & "-" & CurrDBGadget.Name If ObjectsRS.NoMatch Then ' there are no appdbgadgets, need to create some DBGadgetsPTR = 0 For Cntr1 = 0 To DBGadgetsCNTR ' load all appdbgadgets if none are defined Msg = UCase(App.EXEName) & "-" & DBGadgets(Cntr1).Name AppDBGadgetsCNTR = AppDBGadgetsCNTR + 1 ReDim Preserve AppDBGadgets(AppDBGadgetsCNTR) AppDBGadgets(AppDBGadgetsCNTR) = BlankObject AppDBGadgets(AppDBGadgetsCNTR).Name = Msg AppDBGadgets(AppDBGadgetsCNTR).ObjectID = 0 AppDBGadgets(AppDBGadgetsCNTR).Type = "AppGadget" AppDBGadgets(AppDBGadgetsCNTR).Container = UCase(App.EXEName) AppDBGadgets(AppDBGadgetsCNTR).Tag = "DBGadgetsLoad: No AppdbGadgets" & Now t = SetProperty(AppDBGadgets(AppDBGadgetsCNTR), "DB Name", ReadProperty(DBGadgets(Cntr1), "DB Name")) t = SetProperty(AppDBGadgets(AppDBGadgetsCNTR), "DBGadgets ID", CStr(DBGadgets(Cntr1).ObjectID)) t = SetProperty(AppDBGadgets(AppDBGadgetsCNTR), "Enabled", "True") If Not ExecutingSchedule Then FloatMsgBox "Added: " & Msg, "DB Load" End If Next End If DBGadgetsPTR = 0 For Cntr1 = 0 To DBGadgetsCNTR ' fix up the appdbgadgets ' DoEvents Msg = UCase(App.EXEName) & "-" & DBGadgets(Cntr1).Name t = ReadGadgetByName(Msg, CurrentObject) If t <> OK Then ' need a disk appdbgadget for this guy AppDBGadgetsCNTR = AppDBGadgetsCNTR + 1 AppDBGadgetsPTR = AppDBGadgetsCNTR ReDim Preserve AppDBGadgets(AppDBGadgetsPTR) AppDBGadgets(AppDBGadgetsPTR).Name = UCase(App.EXEName) & "-" & DBGadgets(Cntr1).Name AppDBGadgets(AppDBGadgetsPTR).ObjectID = 0 AppDBGadgets(AppDBGadgetsPTR).Type = "AppDBGadget" AppDBGadgets(AppDBGadgetsPTR).Container = UCase(App.EXEName) AppDBGadgets(AppDBGadgetsPTR).Tag = "DBGadgets Load/Failed to find: " & Msg ThisDBName = ReadProperty(DBGadgets(Cntr1), "DB Name") t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "DB Name", ThisDBName) t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "DBGadgets ID", CStr(DBGadgets(Cntr1).ObjectID)) t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "Enabled", "True") t = WriteMemGadget(AppDBGadgets(AppDBGadgetsPTR).ObjectID, AppDBGadgets(AppDBGadgetsPTR)) ' MsgBox t Else ' load it if not already For CNTR2 = 0 To AppDBGadgetsCNTR If AppDBGadgets(CNTR2).Name = UCase(App.EXEName) & "-" & DBGadgets(Cntr1).Name Then Exit For End If Next If CNTR2 > AppDBGadgetsCNTR Then AppDBGadgetsCNTR = AppDBGadgetsCNTR + 1 AppDBGadgetsPTR = AppDBGadgetsCNTR CNTR2 = AppDBGadgetsCNTR ReDim Preserve AppDBGadgets(AppDBGadgetsPTR) AppDBGadgets(AppDBGadgetsPTR) = CurrentObject End If ' this is a fix for the dbgadgets property t = ReadProperty(AppDBGadgets(CNTR2), "DBGadgets ID") If t = NotFound And CNTR2 > 0 Then ' t = SetProperty(AppDBGadgets(Cntr2), "DBGadgets ID", CStr(DBGadgets(Cntr1).ObjectID)) t = SetProperty(AppDBGadgets(AppDBGadgetsPTR), "DB Name", DBGadgets(Cntr1).Name) t = WriteMemGadget(AppDBGadgets(CNTR2).ObjectID, AppDBGadgets(CNTR2)) ' MsgBox t End If End If Next Cntr1 For Cntr1 = 0 To AppDBGadgetsCNTR ' DoEvents ' now load the apprs gadgets ' the recordsets for the dbgadgets this app opens ' Msg = AppDBGadgets(Cntr1).Name For CNTR2 = 1 To 3 Select Case True Case CNTR2 = 1 Msg = "Objects" Case CNTR2 = 2 Msg = "Props" Case CNTR2 = 3 Msg = "Methods" End Select AppRSName = AppDBGadgets(Cntr1).Name & "-" & Msg For Cntr3 = 0 To AppRSGadgetsCNTR If AppRSGadgets(Cntr3).Name = AppRSName Then Exit For End If Next If Cntr3 > AppRSGadgetsCNTR Then ' Msg = ucase(App.EXEName) & "-" & CurrDBName & "-" & Msg AppRSGadgetsCNTR = AppRSGadgetsCNTR + 1 AppRSGadgetsPTR = AppRSGadgetsCNTR ReDim Preserve AppRSGadgets(AppRSGadgetsCNTR) AppRSGadgets(AppRSGadgetsCNTR) = BlankObject AppRSGadgets(AppRSGadgetsCNTR).ObjectID = 0 AppRSGadgets(AppRSGadgetsCNTR).Name = AppRSName AppRSGadgets(AppRSGadgetsCNTR).Type = "AppRSGadget" AppRSGadgets(AppRSGadgetsCNTR).Container = UCase(App.EXEName) AppRSGadgets(AppRSGadgetsCNTR).Tag = Now t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "DB Name", ReadProperty(AppDBGadgets(Cntr1), "DB Name")) t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "RS Source", Msg) t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "RS Name", Msg & "RS") t = ReadProperty(AppRSGadgets(AppRSGadgetsCNTR), "RS Index") t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "RS Index", "?") ' ShowObject Dematerialize(AppRSGadgets(AppRSGadgetsCNTR)), "mem" ' let's see if this one exists, shouldn't ReadObjectBuffer = BlankObject t = ReadGadgetByName(AppRSGadgets(AppRSGadgetsCNTR).Name, ReadObjectBuffer) If t = OK Then AppRSGadgets(AppRSGadgetsCNTR).ObjectID = ReadObjectBuffer.ObjectID End If t = WriteMemGadget(AppRSGadgets(AppRSGadgetsCNTR).ObjectID, AppRSGadgets(AppRSGadgetsCNTR)) End If Next CNTR2 Next Cntr1 ' load the appdbgadgets ObjectsRS.Index = "Type" ObjectsRS.Seek "=", "AppDBGadget" Msg = UCase(App.EXEName) & "-" & CurrDBGadget.Name Do While ObjectsRS.NoMatch = False If ObjectsRS!Container = UCase(App.EXEName) Then Msg = "Add" For Cntr1 = 0 To AppDBGadgetsCNTR If AppDBGadgets(Cntr1).Name = ObjectsRS!Name Then Msg = "No" Exit For End If Next If Msg = "Add" Then AppDBGadgetsCNTR = AppDBGadgetsCNTR + 1 ReDim Preserve AppDBGadgets(AppDBGadgetsCNTR) t = ReadGadgetByID(ObjectsRS!ObjectID) AppDBGadgets(AppDBGadgetsCNTR) = ReadObjectBuffer End If End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Exit Do If ObjectsRS!Type <> "AppDBGadget" Then Exit Do Loop ObjectsRS.Index = "Type" ObjectsRS.Seek "=", "AppRSGadget" Do While ObjectsRS.NoMatch = False If ObjectsRS!Container = UCase(App.EXEName) Then Msg = "Load AppRS" t = ReadGadgetByID(ObjectsRS!ObjectID) CurrAppRSGadget = ReadObjectBuffer For Cntr1 = 0 To AppRSGadgetsCNTR If UCase(AppRSGadgets(Cntr1).Name) = UCase(ObjectsRS!Name) Then Msg = "No Load" Exit For End If Next Cntr1 If Msg = "Load AppRS" Then ' get name from apprsgadgets ' t = ReadGadgetByName(ObjectsRS!Name, CurrentObject) AppRSGadgetsCNTR = AppRSGadgetsCNTR + 1 ReDim Preserve AppRSGadgets(AppRSGadgetsCNTR) AppRSGadgets(AppRSGadgetsCNTR) = ReadObjectBuffer t = SetProperty(AppRSGadgets(AppRSGadgetsCNTR), "RS Index", "?") End If End If ' DoEvents ObjectsRS.MoveNext If ObjectsRS.EOF Then Exit Do If ObjectsRS!Type <> "AppRSGadget" Then Exit Do Loop GoTo EndSub LocalError: LocalError = Error ' MsgBox "DB Load Error: " & Error, , UCase(App.EXEName) & " Debug Message" SetProperty Trace, NextID("trace") & "Trapped DBGadgetsLoad Error", Param.Name & " / " & LocalError SetProperty VGBErrors, NextID("error") & "Trapped DBGadgetsLoad Error", Param.Name & " / " & LocalError Resume Next EndSub: If StartDBPTR > 0 Then DBSwitch StartDBPTR Else DBGadgetsPTR = StartDBPTR End If SetProperty Trace, NextID("trace") & "DBGadgetsLoaded", CStr(DBGadgetsCNTR) SetProperty Trace, NextID("trace") & "DBGadgetsLoad Time", CStr(Timer - starttime) ' MsgBox Timer - starttime End Function 'Public Function OpenDB(Param As Gadget) Friend Function DBEnable(Param As Gadget) ' this enables a db for a given app Dim t, Msg As String, Cntr1 As Integer Dim RREsults As Gadget, MResults As Gadget Dim ThisDBName As String ThisDBName = UCase(ReadProperty(Param, "DB Name")) For Cntr1 = 0 To AppDBGadgetsCNTR Msg = ReadProperty(AppDBGadgets(Cntr1), "DB Name") If Msg = ThisDBName Then t = SetProperty(AppDBGadgets(Cntr1), "Enabled", "True") MResults = Memorize(AppDBGadgets(Cntr1), "in " & VGBDatabaseNameAndPath) 't = WriteGDSGadget(AppDBGadgets(Cntr1).ObjectID, AppDBGadgets(Cntr1)) Exit For End If Next EndSub: End Function Friend Function DBDisable(Param As Gadget) Dim t, Msg As String, Cntr1 As Integer Dim RREsults As Gadget, MResults As Gadget Dim ThisDBName As String ThisDBName = UCase(ReadProperty(Param, "DB Name")) If ThisDBName = "RWS.RWS" Then If Not ExecutingSchedule Then MsgBox "You can't Disable the System Database", vbExclamation, "System Database Selected" End If GoTo EndSub End If For Cntr1 = 0 To AppDBGadgetsCNTR Msg = ReadProperty(AppDBGadgets(Cntr1), "DB Name") If Msg = ThisDBName Then t = SetProperty(AppDBGadgets(Cntr1), "Enabled", "False") MResults = Memorize(AppDBGadgets(Cntr1), "in " & VGBDatabaseNameAndPath) 't = WriteGDSGadget(AppDBGadgets(Cntr1).ObjectID, AppDBGadgets(Cntr1)) Exit For End If Next If Cntr1 > AppDBGadgetsCNTR Then ' this appdbgadget not registered yet t = ReadGDSGadget(Msg, CurrentObject) If t <> OK Then If Not ExecutingSchedule Then MsgBox "Adding Application Database: " & ThisDBName End If End If End If EndSub: On Error GoTo 0 End Function Friend Function DBSwitch(DBGadgetPTRToUse As Integer) As String ' sets current database to the one pointed to by DBGadgetPTRToUse ' all subsequent object i/o is to the one last set ' if the passed pointer is not valid, add the current application's appdbgadget Dim starttime As Single, stoptime As Single starttime = Timer Dim RREsults As Gadget, MResults As Gadget Dim t, Msg As String, Msg2 As String Dim Cntr1 As Integer, CNTR2 As Integer Dim ObjectRSFound As Boolean Dim PropRSFound As Boolean Dim MethodRSFound As Boolean Dim TotDbs As Integer Dim ThisDBPath As String, ThisDBName As String, ThisDBPathAndName As String Dim AppDBGadgetName As String Dim LocalError As String Dim Result As String Dim FloatMsg As String Result = OK LocalError = "" On Error GoTo LocalError SetProperty Trace, NextID("trace") & "DBSwitch Start *********************************", "***" If DBGadgetPTRToUse = DBGadgetsPTR Then SetProperty Trace, NextID("trace") & "DB Switch", "Already on " & DBGadgets(DBGadgetPTRToUse).Name Result = OK GoTo EndSub End If SetProperty Trace, NextID("trace") & "DB Switch", "To: " & DBGadgets(DBGadgetPTRToUse).Name If DBGadgetsPTR = DBGadgetPTRToUse Then ' no need to waste any time doing something that's already done GoTo EndSub End If ' is the cntr valid? If DBGadgetPTRToUse > DBGadgetsCNTR Then ' error! SetProperty Trace, NextID("trace"), "[" & "DB Pointer wrong" & " DBPTR: " & CStr(DBGadgetsPTR) & "DB To Use: " & CStr(DBGadgetPTRToUse) & "] " FloatMsg = FloatMsg & " [" & "DB Pointer wrong" & " DBPTR: " & CStr(DBGadgetsPTR) & "DB To Use: " & CStr(DBGadgetPTRToUse) & "] " Result = "Error" GoTo EndSub End If ObjectRSFound = False PropRSFound = False MethodRSFound = False ' check to see if this database actually exists. ' if not, we re-initialize to unregister it ThisDBName = UCase(ReadProperty(DBGadgets(DBGadgetPTRToUse), "DB Name")) ThisDBPath = UCase(AddBackSlash(ReadProperty(DBGadgets(DBGadgetPTRToUse), "Path"))) ThisDBPathAndName = ThisDBPath & ThisDBName AppDBGadgetName = UCase(App.EXEName) & "-" & DBGadgets(DBGadgetPTRToUse).Name If Not FileExists(ThisDBPathAndName) Then Result = "File Not Found: " & ThisDBPathAndName SetProperty Trace, NextID("trace") & "DBSwitch Error ", "File not found: " & ThisDBPathAndName If GDSMsg.CommandClose.Visible = False Then GDSMsg.Caption = ThisDBPathAndName & " Database Not Found" GDSMsg.CommandClose.Visible = False GDSMsg.Show GDSMsg.WindowState = NORMAL GDSMsg.MsgText.Visible = True GDSMsg.MsgText = "" GDSMsg.MsgText = GDSMsg.MsgText & "Please wait while I delete the Database and Reinitialize the System. This will take a few seconds" & CrLf GDSMsg.MsgText = GDSMsg.MsgText & "" End If ' InitVGB Unload GDSMsg GoTo EndSub End If ' here we know the db exists ' let's see if this appdbgadget exists ' dbgadget name is filename-index# like VGBDatabaseName-0 ' the appdbgadget's name is: appname-dbgadget name ' like Virtual Cortex-VGBDatabaseName-0 ' Msg = UCase(App.EXEName) & "-" & ThisDBName ' this is the name of the appdbgadget we need Msg = UCase(App.EXEName) & "-" & DBGadgets(DBGadgetPTRToUse).Name For Cntr1 = 0 To AppDBGadgetsCNTR If AppDBGadgets(Cntr1).Name = AppDBGadgetName Then t = ReadProperty(AppDBGadgets(Cntr1), "Enabled") If t = NotFound Then If Not ExecutingSchedule Then FloatMsg = FloatMsg & " [" & " Adding: " & ThisDBName & "] " ' MsgBox "Adding: " & ThisDBName End If t = SetProperty(AppDBGadgets(Cntr1), "Enabled", "True") t = SetProperty(AppDBGadgets(Cntr1), "Open in this App?", "True") MResults = Memorize(AppDBGadgets(Cntr1), "in " & VGBDatabaseNameAndPath) 't = WriteGDSGadget(AppDBGadgets(Cntr1).ObjectID, AppDBGadgets(Cntr1)) End If If ReadProperty(AppDBGadgets(Cntr1), "Enabled") = "False" Then Result = "Disabled" GoTo EndSub End If Exit For End If Next ' was this appdb found? If Cntr1 > AppDBGadgetsCNTR Then ' no, add the appdbgadget ' Msg = UCase(App.EXEName) & "-" & DBGadgets(DBGadgetPTRToUse).Name If (ThisDBName <> VGBDatabaseName) Then AppDBGadgetsCNTR = AppDBGadgetsCNTR + 1 ReDim Preserve AppDBGadgets(AppDBGadgetsCNTR) AppDBGadgets(AppDBGadgetsCNTR) = BlankObject AppDBGadgets(AppDBGadgetsCNTR).Name = AppDBGadgetName AppDBGadgets(AppDBGadgetsCNTR).Type = "AppDBGadget" AppDBGadgets(AppDBGadgetsCNTR).Container = UCase(App.EXEName) AppDBGadgets(AppDBGadgetsCNTR).Tag = "DBSwitch/Cntr1 > AppDBGadgetsCNTR: " & ThisDBName & Now() SetProperty AppDBGadgets(AppDBGadgetsCNTR), "DB Name", ThisDBName SetProperty AppDBGadgets(AppDBGadgetsCNTR), "DBGadgets ID", CStr(DBGadgets(DBGadgetPTRToUse).ObjectID) SetProperty AppDBGadgets(AppDBGadgetsCNTR), "Enabled", "True" MResults = Memorize(AppDBGadgets(AppDBGadgetsCNTR), "in " & VGBDatabaseNameAndPath) 't = WriteGDSGadget(AppDBGadgets(AppDBGadgetsCNTR).ObjectID, AppDBGadgets(AppDBGadgetsCNTR)) End If End If ' this makes the switch to db the current one DBGadgetsPTR = DBGadgetPTRToUse ' ThisDBName = DBGadgets(DBGadgetPTRToUse).Name ' we need to select the correct recordsets for this database For Cntr1 = 0 To AppRSGadgetsCNTR If DBGadgetsPTR <> DBGadgetPTRToUse Then FloatMsg = FloatMsg & " [" & "DB Pointer wrong" & " DBPTR: " & CStr(DBGadgetsPTR) & "DB To Use: " & CStr(DBGadgetPTRToUse) & "] " ' MsgBox "DB Pointer wrong" End If If AppRSGadgets(Cntr1).Name = AppDBGadgetName & "-Objects" Then CNTR2 = Val(ReadProperty(AppRSGadgets(Cntr1), "RS Index")) Set ObjectsRS = OpenRS(CNTR2) ObjectRSFound = True End If If AppRSGadgets(Cntr1).Name = AppDBGadgetName & "-Props" Then CNTR2 = Val(ReadProperty(AppRSGadgets(Cntr1), "RS Index")) Set PropsRS = OpenRS(CNTR2) PropRSFound = True End If If AppRSGadgets(Cntr1).Name = AppDBGadgetName & "-Methods" Then CNTR2 = Val(ReadProperty(AppRSGadgets(Cntr1), "RS Index")) Set MethodsRS = OpenRS(CNTR2) MethodRSFound = True End If Next Cntr1 If ObjectRSFound = False Or PropRSFound = False Or MethodRSFound = False Then FloatMsg = FloatMsg & " [" & "DB Switch failed ObjectsRSFound: " & "ObjectsRSFound: " & CStr(ObjectRSFound) & " PropsRSFound: " & CStr(PropRSFound) & " MethodsRSFound: " & CStr(MethodRSFound) & "] " ' MsgBox "DB Switch failed" End If If DBGadgetsPTR = 0 Then ' must be gdsregister Set JetDatabase = OpenDB(0) JetDatabaseName = OpenDB(0).Name Set ObjectsRS = OpenRS(0) Set PropsRS = OpenRS(1) Set MethodsRS = OpenRS(2) DBGadgetsPTR = 0 OpenDBPTR = 0 Result = OK GoTo EndSub End If ' switch the master recordsets to the given dbgadget ' this is the opendb() array For OpenDBPTR = 1 To OpenDBCNTR Msg2 = "Don't Skip" For Cntr1 = 1 To AppDBGadgetsCNTR If UCase(ReadProperty(AppDBGadgets(Cntr1), "DB Name")) = _ UCase(ReadProperty(DBGadgets(OpenDBPTR), "DB Name")) Then If ReadProperty(AppDBGadgets(Cntr1), "Open in this App?") = "False" Then Msg2 = "Skip" Exit For End If End If Next LocalError = "" If Msg2 <> "Skip" Then If UCase(OpenDB(OpenDBPTR).Name) = ThisDBPathAndName Then If LocalError = "" Then Result = OK Exit For End If End If Else If Cntr1 = DBGadgetPTRToUse Then ' this db is closed Result = "DB Not Open" Exit For End If End If Next OpenDBPTR If OpenDBPTR > OpenDBCNTR And LocalError <> "Object variable or With block variable not set" Then FloatMsg = FloatMsg & " [" & "DB Pointer > DB Counter" & " DBPTR: " & CStr(OpenDBPTR) & " Open DBCNTR: " & CStr(OpenDBCNTR) & " Error was " & LocalError & "] " ' MsgBox "DB Pointer greater than Counter", , UCase(App.EXEName) & " Debug Message" Result = "Switch Error " & " [" & "DB Pointer > DB Counter" & " DBPTR: " & CStr(OpenDBPTR) & " Open DBCNTR: " & CStr(OpenDBCNTR) & " Error was [" & LocalError & "] " GoTo EndSub End If If LocalError = "Object variable or With block variable not set" Then Result = "Database Not Open" End If If Result = OK Then Set JetDatabase = OpenDB(OpenDBPTR) JetDatabaseName = OpenDB(OpenDBPTR).Name End If GoTo EndSub LocalError: LocalError = Error SetProperty Trace, NextID("trace") & "DBSwitch Trapped Error ", "PTR=" & DBGadgetPTRToUse & "/Error=" & LocalError SetProperty VGBErrors, NextID("error") & "DBSwitch Trapped Error ", "PTR=" & DBGadgetPTRToUse & "/Error=" & LocalError If Not (ExecutingSchedule And (LocalError <> "Object variable or With block variable not set")) Then If LocalError <> "Object is invalid or not Set." Then FloatMsg = FloatMsg & " [" & "Trapped DBSwitch Error: " & CStr(Error) & "] " ' MsgBox "Error: " & Error, , "DBSwitch Error" End If End If Resume Next EndSub: GDSFreelocks If FloatMsg <> "" Then ' FloatMsgBox FloatMsg, "DBSwitch Errors Encountered: Debug Message" End If SetProperty Trace, NextID("trace") & "DBSwitch End *********************************", "***" On Error GoTo 0 DBSwitch = Result ' stoptime = Timer ' MsgBox stoptime - starttime End Function Friend Function APPFindIndex(Param As Gadget) As Integer ' this returns the index of the APPgadgets with the APPname passed ' use the return value to set APP with APPswitch function Dim t, Msg As String, Msg2 As String, Cntr1 As Integer Dim TGadget As Gadget Dim APPPathToUse As String, APPNameToUse As String Dim Result As Integer APPPathToUse = AddBackSlash(ReadProperty(Param, "AppPath")) APPNameToUse = UCase(Param.Name) Result = 0 ' zero is a nofind For Cntr1 = 1 To AppGadgetsCNTR ' get app name Msg = UCase(AppGadgets(Cntr1).Name) 'UCase(ReadProperty(AppGadgets(Cntr1), "APPName")) If Msg = APPNameToUse Then ' this is the name, how about path? If APPPathToUse = NotFound Then ' they didn't say, so this is it Result = Cntr1 Exit For End If ' path is provided Msg2 = UCase(ReadProperty(AppGadgets(Cntr1), "AppPath")) End If ' Msg = AddBackSlash(Msg) Msg2 = UCase(ReadProperty(AppGadgets(Cntr1), "AppPath")) Msg2 = AddBackSlash(Msg2) Msg = Msg2 & Msg If Msg = APPPathToUse & APPNameToUse Then Result = Cntr1 Exit For End If Next If Cntr1 > AppGadgetsCNTR Then ' this app was not found in memory ' load from disk? If ReadProperty(Param, "Load From Disk") = "True" Then t = ReadGadgetByName(Param.Name, TGadget) If t = OK Then AppGadgetsCNTR = AppGadgetsCNTR + 1 ReDim Preserve AppGadgets(AppGadgetsCNTR) AppGadgets(AppGadgetsCNTR) = TGadget Result = AppGadgetsCNTR End If End If End If APPFindIndex = Result End Function Friend Function DBFindIndex(DBNameToUse As String) As Integer ' this returns the index of the dbgadgets with the dbname passed ' use the return value to set db with dbswitch function Dim t, Msg As String, Msg2 As String, Cntr1 As Integer Dim Result As Integer DBNameToUse = UCase(DBNameToUse) Result = -1 ' < zero is a nofind SetProperty Trace, NextID("trace") & "DBFindindex", DBNameToUse & " Total DBs: " & CStr(DBGadgetsCNTR) For Cntr1 = 0 To DBGadgetsCNTR Msg = UCase(ReadProperty(DBGadgets(Cntr1), "DB Name")) SetProperty Trace, NextID("trace") & "DBFindindex", "Checking Name: " & Msg If Msg = DBNameToUse Then SetProperty Trace, NextID("trace") & "DBFindindex", "Found (no path): " & DBNameToUse Result = Cntr1 Exit For End If ' Msg = AddBackSlash(Msg) Msg2 = UCase(ReadProperty(DBGadgets(Cntr1), "Path")) Msg2 = AddBackSlash(Msg2) Msg = Msg2 & Msg SetProperty Trace, NextID("trace") & "DBFindindex", "Checking Path: " & Msg If Msg = DBNameToUse Then SetProperty Trace, NextID("trace") & "DBFindindex", "Found (with path): " & DBNameToUse Result = Cntr1 Exit For End If Next DBFindIndex = Result End Function 'Friend Function GDSFirst() ' Dim t ' RunningApplication.Name = UCase(App.EXEName) & "/" & CStr(App.hInstance) ' Randomize ' RunningApplication.ID = Rnd() ' RunningApplication.Name = UCase(App.EXEName) & "/" & CStr(RunningApplication.ID) 'End Function '////////////////// Friend Function WasteTime(SecondsToWaste As Single) As Integer ' waste a give amount of time Dim timerholder As Single, t Dim StartingTime As Single Dim SecsInDay As Double StartingTime = Timer ' see if we're on the cusp of timer rollover ' Total seconds in a day=(24 hrs * 60 min/hr * 60 secs/min) SecsInDay = 86400 If (StartingTime + SecondsToWaste) > SecsInDay Then ' Timer will roll over before we are done, causing a loop that lasts 24 hrs. ' need to do some figuring here t = 0 Do While Timer <= SecsInDay And t <= 10000 If SecondsToWaste > 2 Then ' DoEvents End If t = t + 1 Loop Else timerholder = Timer + SecondsToWaste t = 0 Do While Timer <= timerholder 'And t <= 100000 If SecondsToWaste > 2 Then ' DoEvents End If t = t + 1 Loop End If End Function Friend Function ExtractPathAndFile(Param As Gadget) As Gadget ' this returns a gadget with properties ' "Drive Only" ' "Path Only" ' "File Only" ' "File Name Without Extension" ' "Extension Only" ' plus any properties sent in original parameter gadget ' ' ' Dim t, Msg As String, Cntr1 As Integer, CNTR2 As Integer, TotLen As Integer Dim TotToRemove As Integer Dim TempChar As String Dim PathAndFile As String Dim PathOnly As String Dim FileOnly As String Dim DriveOnly As String Dim FileWithoutExt As String Dim ExtOnly As String Dim PathDone As Boolean, FileDone As Boolean PathAndFile = ReadProperty(Param, "PathFile") TotLen = Len(PathAndFile) ' get file PathDone = False FileDone = False For Cntr1 = TotLen To 0 Step -1 TempChar = Mid(PathAndFile, Cntr1, 1) Select Case True Case TempChar = "\" And Not FileDone ' TotToRemove = TotToRemove + 1 FileDone = True Exit For Case TempChar <> "\" And Not FileDone FileOnly = FileOnly & TempChar TotToRemove = TotToRemove + 1 End Select Next Cntr1 TempChar = "" ' turn it around, it's backwards For Cntr1 = Len(FileOnly) To 1 Step -1 TempChar = TempChar & Mid(FileOnly, Cntr1, 1) Next FileOnly = TempChar TotLen = TotLen - TotToRemove For Cntr1 = 1 To TotLen PathOnly = PathOnly & Mid(PathAndFile, Cntr1, 1) Next Cntr1 If Right(PathOnly, 1) <> "\" Then PathOnly = PathOnly & "\" End If If Mid(PathOnly, 2, 1) = ":" Then DriveOnly = Left(PathOnly, 2) Else DriveOnly = "None Provided" End If ' do the filename without extension FileWithoutExt = "" TotLen = Len(FileOnly) For Cntr1 = 1 To TotLen TempChar = Mid(FileOnly, Cntr1, 1) If TempChar = "." Then Exit For End If FileWithoutExt = FileWithoutExt & TempChar Next Cntr1 ' do the extension only ExtOnly = "" TotLen = Len(FileOnly) For Cntr1 = 1 To TotLen TempChar = Mid(FileOnly, Cntr1, 1) If TempChar = "." Then For CNTR2 = Cntr1 To TotLen TempChar = Mid(FileOnly, CNTR2, 1) ExtOnly = ExtOnly & TempChar Next Exit For End If Next Cntr1 ' set the properties and ship it back t = SetProperty(Param, "Drive Only", DriveOnly) t = SetProperty(Param, "Path Only", PathOnly) t = SetProperty(Param, "File Only", FileOnly) t = SetProperty(Param, "File Name Without Extension", FileWithoutExt) t = SetProperty(Param, "Extension Only", ExtOnly) ExtractPathAndFile = Param End Function Friend Function AddBackSlash(Param As String) As String ' add backslash to passed param if ain't one already If Right(Param, 1) <> "\" Then Param = Param & "\" End If AddBackSlash = Param End Function Friend Sub ShowGadget(Param As Gadget) ' a perfect example of how this stuff is supposed to work Dim t, Msg As String, Cntr As Integer, Cntr1 As Integer ShowGadgetForm.Show ShowGadgetForm.WindowState = NORMAL ShowGadgetForm.Caption = UCase(UCase(App.EXEName)) & " Show Gadget: " & Param.Name ' DoEvents ShowGadgetForm.GadgetOID = Param.ObjectID If Param.ObjectID = 0 Then ShowGadgetForm.GadgetSource = "Memory" Else ShowGadgetForm.GadgetSource = "Disk" End If ShowGadgetForm.GadgetTag = Param.Tag ShowGadgetForm.GadgetName = Param.Name ShowGadgetForm.GadgetType = Param.Type ShowGadgetForm.GadgetContainer = Param.Container ShowGadgetForm.ListOfGadgetProperties.Clear ShowGadgetForm.Graphic = LoadPicture ' convert to load properties ' use Public Sub LoadProps(LObj As Gadget, ListToUse As Control) For Cntr1 = 1 To Param.TotalProperties Msg = Param.Propity(Cntr1) & ": " & Param.ValueAlpha(Cntr1) ShowGadgetForm.ListOfGadgetProperties.AddItem Msg If Param.Propity(Cntr1) = "Picture File" Then If FileExists(Param.ValueAlpha(Cntr1)) Then ShowGadgetForm.Graphic = LoadPicture(Param.ValueAlpha(Cntr1)) End If End If ' Msg = "" Next Cntr1 ShowGadgetForm.LabelGadgetsProps = "Gadget Properties: (" & CStr(Param.TotalProperties) & ")" ShowGadgetForm.SetFocus ShowGadgetForm.GadgetUp = True Do While ShowGadgetForm.GadgetUp = True DoEvents Loop End Sub Friend Function FloatMsgBox(DMsg As String, DTitle As String, Optional ClearFirst As Boolean = False) If DMsg = "" Then GDSMsg.Text1 = "" End If If ClearFirst Then GDSMsg.Text1 = "" End If GDSMsg.Caption = DTitle GDSMsg.CommandClose.Visible = True GDSMsg.WindowState = NORMAL GDSMsg.Text1.Visible = True GDSMsg.Text1 = GDSMsg.Text1 & DMsg ' GDSMsg.Show End Function Friend Function WriteErrorLog() End Function Friend Function FileExists(Checkfile) As Boolean ' CheckFile is the complete path with filename of the file to check Dim HadError As Boolean Dim ThisHandle As Integer ThisHandle = FreeFile On Error GoTo FEError Open Checkfile For Input As #ThisHandle If HadError Then Close #ThisHandle On Error GoTo 0 FileExists = False Exit Function Else Close #ThisHandle On Error GoTo 0 FileExists = True Exit Function End If FEError: FileError = UCase(Error$) HadError = (FileError = UCase("File Not Found")) Or (FileError = UCase("Path Not FOUND")) Resume Next End Function Friend Function DriveExists(DriveToCheck As String) As Boolean ' drive to check is the drive to check, well huh Dim HadError As Boolean Dim StartDrive As String, StartDir As String StartDir = CurDir StartDrive = Left(StartDir, 2) On Error GoTo DEError ChDir DriveToCheck If HadError Then Close #1 On Error GoTo 0 ChDrive StartDrive ChDir StartDir DriveExists = False Exit Function Else Close #1 On Error GoTo 0 ChDrive StartDrive ChDir StartDir DriveExists = True Exit Function End If DEError: HadError = True Resume Next End Function Friend Function AllTrim(TVar As String) As String ' trim all spaces from a string variable AllTrim = RTrim(LTrim(TVar)) End Function Friend Function GetWindowsDir() As String ' yank the windows directory from the win.ini file Dim Temp As String, X As Long Temp$ = String$(145, 0) ' Size Buffer X = GetWindowsDirectory(Temp$, 145) ' Make API Call Temp$ = Left$(Temp$, X) ' Trim Buffer If Right$(Temp$, 1) <> "\" Then ' Add \ if necessary Temp$ = Temp$ + "\" End If WindowsDir = Temp$ GetWindowsDir$ = Temp$ End Function Friend Function DetectOS() As String Dim MsgEnd As String Dim OSName As String, OSVer As String, OSBld As String Load OSDetectAndStatus OSDetectAndStatus.Hide IsAwake = True Select Case OSDetectAndStatus.SysInfo1.OSPlatform Case 0 MsgEnd = "Unidentified" Case 1 OSName = "Windows 95" OSVer = CStr(OSDetectAndStatus.SysInfo1.OSVersion) OSBld = CStr(OSDetectAndStatus.SysInfo1.OSBuild) OSGadget.Name = OSName OSGadget.Type = "Operating System Definition" OSGadget.Container = "System" SetProperty OSGadget, "Name", OSName SetProperty OSGadget, "Version", OSVer SetProperty OSGadget, "Build", OSBld MsgEnd = "Windows 95, ver. " & _ CStr(OSDetectAndStatus.SysInfo1.OSVersion) & "(" & _ CStr(OSDetectAndStatus.SysInfo1.OSBuild) & ")" Case 2 OSName = "Windows NT" OSVer = CStr(OSDetectAndStatus.SysInfo1.OSVersion) OSBld = CStr(OSDetectAndStatus.SysInfo1.OSBuild) OSGadget.Name = OSName OSGadget.Type = "Operating System Definition" OSGadget.Container = "System" SetProperty OSGadget, "Name", OSName SetProperty OSGadget, "Version", OSVer SetProperty OSGadget, "Build", OSBld MsgEnd = "Windows NT, ver. " & _ CStr(OSDetectAndStatus.SysInfo1.OSVersion) & "(" & _ CStr(OSDetectAndStatus.SysInfo1.OSBuild) & ")" End Select If Not StayAwake Then Unload OSDetectAndStatus End If DetectOS = MsgEnd ' MsgBox "System: " & MsgEnd End Function Friend Function GDSAppActive(Param As Gadget) Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Msg As String, Cntr1 As Integer Dim AppToCheck As String Dim Result As Boolean ' Dim mCount As Integer, tCount As Integer, hModule As Integer Dim lpFileName As String ' mCount = 0 AppToCheck = UCase(ReadProperty(Param, "Application")) 'Determine if Application is running Result = False #If Win16 Then Dim mCount As Integer, tCount As Integer, hModule As Integer hModule = GetModuleHandle(AppToCheck) mCount = GetModuleUsage(hModule%) Result = mCount > 0 #Else Dim hSnapShot As Long Dim uProcess As PROCESSENTRY32 Dim TotProcesses As Long Dim r As Long hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&) If hSnapShot = 0 Then GoTo EndSub End If uProcess.dwSize = Len(uProcess) r = ProcessFirst(hSnapShot, uProcess) Do While r If InStr(UCase(uProcess.szExeFile), AppToCheck) > 0 Then Result = True ' Exit Do End If TotProcesses = TotProcesses + 1 r = ProcessNext(hSnapShot, uProcess) Loop Call CloseHandle(hSnapShot) GoTo EndSub #End If EndSub: stoptime = Timer Msg = "" Msg = Msg & "App: " & AppToCheck & CrLf Msg = Msg & "Running: " & CStr(Result) & CrLf Msg = Msg & "Total Processes: " & CStr(TotProcesses) & CrLf Msg = Msg & "" & CrLf Msg = Msg & "Time: " & CStr(stoptime - starttime) & CrLf Msg = Msg & "" & CrLf Msg = Msg & "Continue?" & CrLf ' t = MsgBox(Msg, vbExclamation + vbYesNo, "Debug Message") ' If t = vbNo Then ' End ' End If ' GDSAppActive = True GDSAppActive = Result End Function Friend Sub UnloadMe() Unloading = True Unload Screen.ActiveForm End Sub Friend Function SendStatus() As Gadget Dim t, Msg As String, ErrCntr As Integer Dim Result As Gadget Dim LocalError As String On Error GoTo LocalError Result = DBGadgets(DBGadgetsPTR) Result.Name = App.EXEName & " Status" Result.Type = "Result" SetProperty Result, "Tot Open DB", CStr(DBGadgetsCNTR) SetProperty Result, "Current Open DB PTR", CStr(DBGadgetsPTR) SetProperty Result, "ObjectsRS Recordcount", CStr(ObjectsRS.RecordCount) SendStatus = Result LocalError: LocalError = Error ErrCntr = ErrCntr + 1 SetProperty Result, "Status Error " & CStr(ErrCntr), LocalError Resume Next EndSub: End Function Friend Function PullMethodNames(Task As Gadget, Params As Gadget) As Gadget ' read a class/form/basic file and create a list of the functions in it End Function Friend Function ParseCommand(Param As String) As Gadget ' this function will return a fully qualified command gadget to ' caller. the command processor can then perform the task Dim t, Msg As String, Cntr1 As Long Dim Results As Gadget Dim ParamLen As Long Dim TempChar As String, CharCNTR As Long, CharPTR As Long Dim Words() As String, WordsCNTR As Long, WordsPTR As Long Dim Command As String, CommandDone As Boolean Dim FirstPropWordPTR As Long, LastPropWordPTR As Long Dim Object1 As String, Object1Done As Boolean Dim Object2 As String, Object2Done As Boolean Dim Props() As String, PropValues() As String Dim PropsDone As Boolean ParamLen = Len(Param) ' parse the string into separate words and punctuation For Cntr1 = 1 To ParamLen TempChar = Mid(Param, Cntr1, 1) If TempChar = " " Or TempChar = "," Then WordsCNTR = WordsCNTR + 1 ' this gets punctuation mark in next word Words(WordsCNTR) = TempChar WordsCNTR = WordsCNTR + 1 Else Words(WordsCNTR) = Words(WordsCNTR) & TempChar End If Next Cntr1 ' have sentence in array Command = Words(1) CommandDone = True ' where is the first property definition? For WordsPTR = 2 To WordsCNTR Select Case True Case FirstPropWordPTR = 0 And _ (InStr(UCase(Words(WordsPTR)), "=") > 0 Or _ UCase(Words(WordsPTR)) = "IS") FirstPropWordPTR = WordsPTR Exit For Case FirstPropWordPTR > 0 End Select Next WordsPTR ' the last prop definitions is where? For WordsPTR = WordsCNTR To 2 Step -1 Select Case True Case LastPropWordPTR = 0 And _ (InStr(UCase(Words(WordsPTR)), "=") > 0 Or _ UCase(Words(WordsPTR)) = "IS") LastPropWordPTR = WordsPTR Exit For End Select Next WordsPTR For WordsPTR = 2 To WordsCNTR Select Case True Case Words(WordsPTR) = " " Or Words(WordsPTR) = "," ' these are delimiters Case CommandDone If TempChar = " " Or TempChar = "," Then WordsCNTR = WordsCNTR + 1 Else Words(WordsCNTR) = Words(WordsCNTR) & TempChar End If Case Not Object2Done Case Not PropsDone End Select Next WordsPTR ' here we have all words in sentence ' the first one is the command For WordsPTR = 1 To WordsCNTR Next End Function Friend Function Compare2Gadgets(cGadget1 As Gadget, _ cGadget2 As Gadget) As Gadget ' see if the given objects have the same properties ' returns a list of properties from 2nd gadget that aren't the same as first Dim starttime As Single, stoptime As Single starttime = Timer Dim t, Prop1Name As String, Prop2Name As String Dim Cntr1 As Integer, CNTR2 As Integer Dim TotDiffProps As Integer Dim TotPropsNotFound As Integer Dim ResultGadget As Gadget TotDiffProps = 0 ResultGadget = BlankObject ResultGadget.Name = "Same" t = SetProperty(ResultGadget, "Total Diff Props", CStr(TotDiffProps)) ' skip thru all props in first object For Cntr1 = 1 To cGadget1.TotalProperties ' find corresponding prop in second For CNTR2 = 1 To cGadget2.TotalProperties If cGadget1.Propity(Cntr1) = cGadget2.Propity(CNTR2) Then ' found the same property ' check equivalence If cGadget1.ValueAlpha(Cntr1) <> cGadget2.ValueAlpha(CNTR2) Then ' values not same TotDiffProps = TotDiffProps + 1 ResultGadget.Name = "Different" t = SetProperty(ResultGadget, "Total Diff Props", CStr(TotDiffProps)) t = SetProperty(ResultGadget, "Diff Prop #" & CStr(TotDiffProps), cGadget2.Propity(CNTR2)) End If Exit For End If Next If CNTR2 > cGadget2.TotalProperties Then TotDiffProps = TotDiffProps + 1 ResultGadget.Name = "Different" t = SetProperty(ResultGadget, "Total Diff Props", CStr(TotDiffProps)) t = SetProperty(ResultGadget, cGadget1.Propity(Cntr1), "Not Found in: " & cGadget2.Name) End If Next stoptime = Timer t = SetProperty(ResultGadget, "StartTimer", CStr(starttime)) t = SetProperty(ResultGadget, "StopTimer", CStr(stoptime)) t = SetProperty(ResultGadget, "Total Time", CStr(stoptime - starttime)) Compare2Gadgets = ResultGadget ' MsgBox stoptime - starttime End Function Friend Function TestFXN(DBName As String) As Gadget End Function Friend Function ConvertLegacy(DBName As String) As Gadget Dim starttime As Single, stoptime As Single starttime = Timer Dim OCntr As Long, TotToConvert As Long Dim CheckedCellCntr As Long Dim ChangedCellCntr As Long Dim LegacyCNTR As Long Dim CResults As Gadget Dim DBsDoneCNTR As Long Dim RREsults As Gadget Dim MResults As Gadget Dim CurrentOID As Long Dim ThisOID As Long Dim ObjectRSBookmark As String Dim LType As String, LContainer As String Dim AddTypeProperty As Boolean, AddContainerProperty As Boolean Dim CurrRep As Gadget, CurrCell As Gadget Dim AddCellName As Boolean, OldCellName As String Dim AddCellReportGroup As Boolean Dim DBPointer As Integer Dim LocalError As String Dim TotalErrors As Long Dim TotalBytesAdded As Long Dim DoAll As Boolean Dim TotGaugeFulls As Single, TotGaugeFullsCntr As Integer Dim PropsBookmark As String On Error GoTo LocalError SetProperty Trace, NextID("trace") & "Convert Legacy Start *********************************", "************************" SetProperty Trace, NextID("trace") & "Legacy Converter", "Instruction: " & DBName Load OSDetectAndStatus OSDetectAndStatus.Top = 100 OSDetectAndStatus.Left = 100 OSDetectAndStatus.Caption = "Data Conversion Progress" OSDetectAndStatus.ProgressLabel = "Converting Data Pool" OSDetectAndStatus.GageLabel.Caption = "0 %" OSDetectAndStatus.CmdCancel.Visible = False OSDetectAndStatus.Show DBPointer = DBGadgetsPTR DoAll = (UCase(DBName) = "ALL") DBPointer = -1 StartNewDatabase: If DoAll Then If DBPointer < DBGadgetsCNTR Then DBPointer = DBPointer + 1 DBSwitch DBPointer DBName = ReadProperty(DBGadgets(DBPointer), "DB Name") SetProperty Trace, NextID("trace") & "Legacy Converter", "Switched DB: " & DBName SetProperty CResults, "Legacy Converter", "Switched DB: " & DBName Else SetProperty Trace, NextID("trace") & "Legacy Converter", "Last DB Done: " & DBName ' SetProperty CResults, "Bytes added to Pool " & CStr(DBGadgetsPTR), CStr(TotalBytesAdded) GoTo EndSub End If SetProperty Trace, NextID("trace") & "Legacy Converter", "DB: " & DBName SetProperty CResults, "Legacy Converter", "Switched DB: " & DBName Else SetProperty Trace, NextID("trace") & "Legacy Converter", "DB: " & DBName DBSwitch DBFindIndex(DBName) End If DBsDoneCNTR = DBsDoneCNTR + 1 ObjectsRS.Index = "Name" PropsRS.Index = "ObjectID" ObjectsRS.MoveLast TotToConvert = ObjectsRS.RecordCount TotGaugeFulls = TotToConvert / 32000 If LocalError <> "" Then SetProperty Trace, NextID("trace") & "Legacy Converter Got New Tot To Convert", CStr(TotToConvert) End If LocalError = "" If LocalError <> "" Then SetProperty Trace, NextID("trace") & "set gage value 1", "0" & "/ Error" & LocalError End If LocalError = "" OSDetectAndStatus.GageLabel.Caption = "0 %" If LocalError <> "" Then SetProperty Trace, NextID("trace") & "set gage caption 1", "0 %" & "/ Error" & LocalError End If LocalError = "" If TotToConvert < 32000 Then ' OSDetectAndStatus.ProgressGauge.Max = CInt(TotToConvert + 100) Else TotGaugeFullsCntr = TotGaugeFullsCntr + 1 ' OSDetectAndStatus.ProgressGauge.Max = CInt(32000) End If OSDetectAndStatus.ProgressLabel = "Converting " & CStr(TotToConvert) & " Data Elements" If LocalError <> "" Then SetProperty CResults, "Converter Set Gage 1", "Error: " & LocalError End If ' start skipping thru the data and set the new properties LocalError = "" ObjectsRS.MoveFirst PropsRS.Index = "ObjectID" Do While ObjectsRS.EOF = False If UserCancel = True Then UserCancel = False GoTo EndSub End If OCntr = OCntr + 1 LocalError = "" DoEvents If LocalError <> "" Then SetProperty Trace, NextID("trace") & "set gage value 2", CStr(OCntr) & "/ Error" & LocalError End If LocalError = "" If OCntr Mod 100 = 0 Then OSDetectAndStatus.GageLabel.Caption = CStr(((Round(((OCntr / TotToConvert) * 100))))) & " %" & " (" & CStr(OCntr) & ")" End If If LocalError <> "" Then SetProperty Trace, NextID("trace") & "Gage caption set", CInt(OCntr) & " / Error: " & LocalError End If LocalError = "" AddCellName = False DoEvents If ObjectsRS!Type = "Cell" Then OldCellName = ObjectsRS!Name If LocalError <> "" Then SetProperty Trace, NextID("trace") & "Type=Cell", CInt(OCntr) & " / Error: " & LocalError End If CheckedCellCntr = CheckedCellCntr + 1 AddCellName = True End If LType = ObjectsRS!Type LContainer = ObjectsRS!Container ' find the properties of this object PropsRS.Seek "=", ObjectsRS!ObjectID AddTypeProperty = True AddContainerProperty = True Do While PropsRS.NoMatch = False ' this checks to see if the object already has any property and disables ' the add if it does If PropsRS!Property = "Cell Name" Then AddCellName = False End If If PropsRS!Property = "Type" Then AddTypeProperty = False End If If PropsRS!Property = "Container" Then AddContainerProperty = False End If If PropsRS!Property = "" Then AddContainerProperty = False End If PropsRS.MoveNext If PropsRS.EOF Then Exit Do End If If PropsRS!ObjectID <> ObjectsRS!ObjectID Then Exit Do End If ' OSDetectAndStatus.GageLabel.Caption = CStr(((Round(((OCntr / TotToConvert) * 100))))) & " %" & " (" & CStr(OCntr) & ")" 'OSDetectAndStatus.SetFocus DoEvents Loop If ObjectsRS!Name = VGBDatabaseName Then AddCellName = False AddTypeProperty = False AddContainerProperty = False End If If AddCellName = True Then PropsRS.AddNew PropsRS![ObjectID] = ObjectsRS!ObjectID PropsRS!Property = "Cell Name" PropsRS!ValueAlpha = OldCellName PropsRS!PropSource = "GB" PropsRS!PropType = 0 PropsRS.Update End If If AddTypeProperty = True Then LegacyCNTR = LegacyCNTR + 1 PropsRS.AddNew PropsRS![ObjectID] = ObjectsRS!ObjectID PropsRS!Property = "Type" PropsRS!ValueAlpha = LType PropsRS!PropSource = "GB" PropsRS!PropType = 0 PropsRS.Update End If If AddContainerProperty = True Then PropsRS.AddNew PropsRS![ObjectID] = ObjectsRS!ObjectID PropsRS!Property = "Container" PropsRS!ValueAlpha = LContainer PropsRS!PropSource = "GB" PropsRS!PropType = 0 PropsRS.Update End If ObjectsRS.MoveNext If ObjectsRS.EOF Then Exit Do End If DoEvents Loop If DoAll Then GoTo StartNewDatabase End If GoTo EndSub LocalError: LocalError = Error TotalErrors = TotalErrors + 1 SetProperty VGBErrors, NextID("error") & "Convert Error " & CStr(TotalErrors), "Error: " & LocalError SetProperty Trace, NextID("error") & "Convert Error " & CStr(TotalErrors), "Error: " & LocalError SetProperty CResults, "Error " & CStr(TotalErrors), LocalError SetProperty CResults, "Error", LocalError If TotalErrors > 5 Then SetProperty CResults, "Terminated", "Terminated because of Totalerrors > 5" SetProperty CResults, "Error", "Terminated because of Totalerrors > 5" GoTo EndSub End If Resume Next EndSub: CResults.Name = "Conversion Status" CResults.Type = "System" CResults.Container = "System" SetProperty CResults, "Date of Convert", Now SetProperty CResults, "Total Memories Pools Done", CStr(DBsDoneCNTR) SetProperty CResults, "Total Cells Done", CStr(CheckedCellCntr) SetProperty CResults, "Total Legacies Done", CStr(LegacyCNTR) stoptime = Timer SetProperty CResults, "Total Time", CStr(stoptime - starttime) & " seconds" OSDetectAndStatus.Hide UserCancel = False DBSwitch DBGadgetsPTR DoEvents ConvertLegacy = CResults End Function Friend Function CheckTrace() Dim LocalError As String On Error GoTo LocalError GoTo EndSub If Trace.TotalProperties >= 64 Then Trace.Name = "Saved: " & CStr(Now()) Trace.Type = "Trace Record" Memorize Trace, "in " & AddBackSlash(App.Path) & "Trace.VGB" Trace = BlankObject Trace.Name = "Trace Cleared " & Now End If GoTo EndSub LocalError: LocalError = Error SetProperty VGBErrors, NextID("error") & "CheckTrace Trapped Error", "Error: " & LocalError FloatMsgBox LocalError, "Brain Clear Trace Error" Resume Next EndSub: End Function Public Function ASCIIFileRead(FileToUse As String, ArrayToUse(), Optional ForceUCase As Boolean = False) As String ' reads the file into the passed array (variant) Dim ArrayToUseNDX As Long Dim ThisHandle As Integer, HandleNDX As Integer Dim LocalError As String, Result As String On Error GoTo RAFError LocalError = "" ' get us a good file handle ThisHandle = FreeFile 'Binary Access Read Open FileToUse For Input As #ThisHandle 'Open FileToUse For Binary Access Read As #ThisHandle If LocalError <> "" Then ' MsgBox "Couldn't find ASCII File: " & FileToUse, vbOKOnly + MB_ICONEXCLAMATION, "File Locate Error" Result = "ERROR: Couldn't find ASCII File: " & FileToUse GoTo EndRAF End If Result = "OK" ArrayToUseNDX = 0 Do Until EOF(ThisHandle) ArrayToUseNDX = ArrayToUseNDX + 1 ReDim Preserve ArrayToUse(ArrayToUseNDX) Line Input #ThisHandle, ArrayToUse(ArrayToUseNDX) If ForceUCase Then ArrayToUse(ArrayToUseNDX) = UCase(ArrayToUse(ArrayToUseNDX)) End If If ArrayToUseNDX Mod 9 = 0 Then DoEvents End If Loop Close #ThisHandle GoTo EndRAF RAFError: LocalError = Error$ Result = Error Resume Next EndRAF: ASCIIFileRead = Result End Function Public Function ASCIIFileWrite(FileToUse As String, ArrayToUse(), Optional StringVar As String = "", Optional OverWrite As Boolean = True) As String ' writes the array or string into the file Static FileHandles() Dim ArrayToUseNDX As Long, ArrayLen As Long Dim ThisHandle As Integer Dim LocalError As String, Result As String On Error GoTo RAFError LocalError = "" ' get us a good file handle ThisHandle = FreeFile If OverWrite Then Open FileToUse For Output As #ThisHandle Else Open FileToUse For Append As #ThisHandle End If If LocalError <> "" Then ' MsgBox "Couldn't find ASCII File: " & FileToUse, vbOKOnly + MB_ICONEXCLAMATION, "File Locate Error" If LocalError = "File not found" Then Open FileToUse For Output As #ThisHandle Else Result = "ERROR: Couldn't open ASCII File: " & FileToUse GoTo EndSub End If End If Result = "OK" Select Case True Case StringVar <> "" Print #ThisHandle, StringVar Case Else ArrayLen = UBound(ArrayToUse()) ArrayToUseNDX = 1 Do Until ArrayToUseNDX >= ArrayLen Print #ThisHandle, ArrayToUse(ArrayToUseNDX) ArrayToUseNDX = ArrayToUseNDX + 1 If ArrayToUseNDX Mod 9 = 0 Then DoEvents End If Loop End Select Close #ThisHandle GoTo EndSub RAFError: LocalError = Error$ Result = LocalError Resume Next EndSub: ASCIIFileWrite = Result End Function Private Sub Class_Initialize() ' when it first fires up ' frmSplash.Show Dim t, Msg As String If DoneDone Then GoTo EndSub End If DoneDone = True SetCoreVariables SetVariables SetProperty VGBStatus, "Class Init", Now() Msg = "Instance of BrainGadget Init" & CrLf ' Msg = Msg & InitVGB & CrLf ' FloatMsgBox Msg, "Status Message" EndSub: End Sub Private Sub Class_Terminate() ' Debug.Print "Shutdown: " & Now Unload OSDetectAndStatus Suicide = True End Sub