//Source of this test file: https://github.com/patrickTingen/DataDigger/blob/master/DataDiggerLib.p &ANALYZE-SUSPEND _VERSION-NUMBER AB_v10r12 &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-CODE-BLOCK _CUSTOM _DEFINITIONS Procedure /*------------------------------------------------------------------------ Name: DataDiggerLib.p Desc: Library for DataDigger functions ------------------------------------------------------------------------*/ /* This .W file was created with the Progress AppBuilder. */ /*----------------------------------------------------------------------*/ DEFINE VARIABLE gcSaveDatabaseList AS CHARACTER NO-UNDO. DEFINE VARIABLE giDataserverNr AS INTEGER NO-UNDO. /* [JAG 01-11-2019] */ DEFINE VARIABLE glDirtyCache AS LOGICAL NO-UNDO. /* Buildnr, temp-tables and forward defs */ { DataDigger.i } PROCEDURE GetUserNameA EXTERNAL "ADVAPI32.DLL": DEFINE INPUT PARAMETER mUserId AS MEMPTR NO-UNDO. DEFINE INPUT-OUTPUT PARAMETER intBufferSize AS LONG NO-UNDO. DEFINE RETURN PARAMETER intResult AS SHORT NO-UNDO. END PROCEDURE. /* Detect bitness of running Progress version * See Progress kb #54631 */ &IF PROVERSION <= '8' &THEN /* OE 10+ */ &IF PROVERSION >= '11.3' &THEN /* PROCESS-ARCHITECTURE function is available */ &IF PROCESS-ARCHITECTURE = 32 &THEN /* 32-bit pointers */ &GLOBAL-DEFINE POINTERTYPE LONG &GLOBAL-DEFINE POINTERBYTES 4 &ELSEIF PROCESS-ARCHITECTURE = 64 &THEN /* 64-bit pointers */ &GLOBAL-DEFINE POINTERTYPE INT64 &GLOBAL-DEFINE POINTERBYTES 8 &ENDIF /* PROCESS-ARCHITECTURE */ &ELSE /* Can't check architecture pre-11.3 so default to 32-bit */ &GLOBAL-DEFINE POINTERTYPE LONG &GLOBAL-DEFINE POINTERBYTES 4 &ENDIF /* PROVERSION > 11.3 */ &ELSE /* pre-OE10 always 32-bit on Windows */ &GLOBAL-DEFINE POINTERTYPE LONG &GLOBAL-DEFINE POINTERBYTES 4 &ENDIF /* PROVERSION < 8 */ PROCEDURE GetKeyboardState EXTERNAL "user32.dll": DEFINE INPUT PARAMETER KBState AS {&POINTERTYPE}. /* memptr */ DEFINE RETURN PARAMETER RetVal AS LONG. /* bool */ END PROCEDURE. /* Windows API entry point */ PROCEDURE ShowScrollBar EXTERNAL "user32.dll": DEFINE INPUT PARAMETER hwnd AS LONG. DEFINE INPUT PARAMETER fnBar AS LONG. DEFINE INPUT PARAMETER fShow AS LONG. DEFINE RETURN PARAMETER ReturnValue AS LONG. END PROCEDURE. PROCEDURE SendMessageA EXTERNAL "user32.dll": DEFINE INPUT PARAMETER hwnd AS long NO-UNDO. DEFINE INPUT PARAMETER wmsg AS long NO-UNDO. DEFINE INPUT PARAMETER wparam AS long NO-UNDO. DEFINE INPUT PARAMETER lparam AS long NO-UNDO. DEFINE RETURN PARAMETER rc AS long NO-UNDO. END PROCEDURE. PROCEDURE RedrawWindow EXTERNAL "user32.dll": DEFINE INPUT PARAMETER v-hwnd AS LONG NO-UNDO. DEFINE INPUT PARAMETER v-rect AS LONG NO-UNDO. DEFINE INPUT PARAMETER v-rgn AS LONG NO-UNDO. DEFINE INPUT PARAMETER v-flags AS LONG NO-UNDO. DEFINE RETURN PARAMETER v-ret AS LONG NO-UNDO. END PROCEDURE. PROCEDURE SetWindowTextA EXTERNAL "user32.dll": DEFINE INPUT PARAMETER hwnd AS long. DEFINE INPUT PARAMETER txt AS CHARACTER. END PROCEDURE. PROCEDURE GetWindow EXTERNAL "user32.dll" : DEFINE INPUT PARAMETER hwnd AS LONG. DEFINE INPUT PARAMETER uCmd AS LONG. DEFINE RETURN PARAMETER hwndOther AS LONG. END PROCEDURE. PROCEDURE GetParent EXTERNAL "user32.dll" : DEFINE INPUT PARAMETER hwndChild AS LONG. DEFINE RETURN PARAMETER hwndParent AS LONG. END PROCEDURE. PROCEDURE GetCursorPos EXTERNAL "user32": DEFINE INPUT PARAMETER lpPoint AS {&POINTERTYPE}. /* memptr */ DEFINE RETURN PARAMETER ReturnValue AS LONG. END PROCEDURE. PROCEDURE GetSysColor EXTERNAL "user32.dll": DEFINE INPUT PARAMETER nDspElement AS LONG. DEFINE RETURN PARAMETER COLORREF AS LONG. END PROCEDURE. PROCEDURE ScreenToClient EXTERNAL "user32.dll" : DEFINE INPUT PARAMETER hWnd AS LONG. DEFINE INPUT PARAMETER lpPoint AS MEMPTR. END PROCEDURE. /* Transparency */ PROCEDURE SetWindowLongA EXTERNAL "user32.dll": DEFINE INPUT PARAMETER HWND AS LONG. DEFINE INPUT PARAMETER nIndex AS LONG. DEFINE INPUT PARAMETER dwNewLong AS LONG. DEFINE RETURN PARAMETER stat AS LONG. END PROCEDURE. PROCEDURE SetLayeredWindowAttributes EXTERNAL "user32.dll": DEFINE INPUT PARAMETER HWND AS LONG. DEFINE INPUT PARAMETER crKey AS LONG. DEFINE INPUT PARAMETER bAlpha AS SHORT. DEFINE INPUT PARAMETER dwFlagsas AS LONG. DEFINE RETURN PARAMETER stat AS SHORT. END PROCEDURE. /* Find out if a file is locked */ &GLOBAL-DEFINE GENERIC_WRITE 1073741824 /* &H40000000 */ &GLOBAL-DEFINE OPEN_EXISTING 3 &GLOBAL-DEFINE FILE_SHARE_READ 1 /* = &H1 */ &GLOBAL-DEFINE FILE_ATTRIBUTE_NORMAL 128 /* = &H80 */ PROCEDURE CreateFileA EXTERNAL "kernel32": DEFINE INPUT PARAMETER lpFileName AS CHARACTER. DEFINE INPUT PARAMETER dwDesiredAccess AS LONG. DEFINE INPUT PARAMETER dwShareMode AS LONG. DEFINE INPUT PARAMETER lpSecurityAttributes AS LONG. DEFINE INPUT PARAMETER dwCreationDisposition AS LONG. DEFINE INPUT PARAMETER dwFlagsAndAttributes AS LONG. DEFINE INPUT PARAMETER hTemplateFile AS LONG. DEFINE RETURN PARAMETER ReturnValue AS LONG. END PROCEDURE. PROCEDURE CloseHandle EXTERNAL "kernel32" : DEFINE INPUT PARAMETER hObject AS LONG. DEFINE RETURN PARAMETER ReturnValue AS LONG. END PROCEDURE. /* Used in update check / about window */ PROCEDURE URLDownloadToFileA EXTERNAL "URLMON.DLL" : DEFINE INPUT PARAMETER pCaller AS LONG. DEFINE INPUT PARAMETER szURL AS CHARACTER. DEFINE INPUT PARAMETER szFilename AS CHARACTER. DEFINE INPUT PARAMETER dwReserved AS LONG. DEFINE INPUT PARAMETER lpfnCB AS LONG. DEFINE RETURN PARAMETER ReturnValue AS LONG. END PROCEDURE. /* URLDownloadToFileA */ PROCEDURE DeleteUrlCacheEntry EXTERNAL "WININET.DLL" : DEFINE INPUT PARAMETER lbszUrlName AS CHARACTER. END PROCEDURE. /* DeleteUrlCacheEntry */ DEFINE TEMP-TABLE ttColor NO-UNDO FIELD cName AS CHARACTER FIELD iColor AS INTEGER INDEX iPrim AS PRIMARY cName. DEFINE TEMP-TABLE ttFont NO-UNDO FIELD cName AS CHARACTER FIELD iFont AS INTEGER INDEX iPrim AS PRIMARY cName. /* If you have trouble with the cache, disable it in the settings screen */ DEFINE VARIABLE glCacheTableDefs AS LOGICAL NO-UNDO. DEFINE VARIABLE glCacheFieldDefs AS LOGICAL NO-UNDO. /* Vars for caching dirnames */ DEFINE VARIABLE gcProgramDir AS CHARACTER NO-UNDO. DEFINE VARIABLE gcWorkFolder AS CHARACTER NO-UNDO. /* Locking / unlocking windows */ &GLOBAL-DEFINE WM_SETREDRAW 11 &GLOBAL-DEFINE RDW_ALLCHILDREN 128 &GLOBAL-DEFINE RDW_ERASE 4 &GLOBAL-DEFINE RDW_INVALIDATE 1 /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-PREPROCESSOR-BLOCK /* ******************** Preprocessor Definitions ******************** */ &Scoped-define PROCEDURE-TYPE Procedure &Scoped-define DB-AWARE no /* _UIB-PREPROCESSOR-BLOCK-END */ &ANALYZE-RESUME /* ************************ Function Prototypes ********************** */ &IF DEFINED(EXCLUDE-addConnection) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD addConnection Procedure FUNCTION addConnection RETURNS LOGICAL ( pcDatabase AS CHARACTER , pcSection AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-formatQueryString) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD formatQueryString Procedure FUNCTION formatQueryString RETURNS CHARACTER ( INPUT pcQueryString AS CHARACTER , INPUT plExpanded AS LOGICAL ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getColor) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getColor Procedure FUNCTION getColor RETURNS INTEGER ( pcName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getColorByRGB) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getColorByRGB Procedure FUNCTION getColorByRGB RETURNS INTEGER ( piRed AS INTEGER , piGreen AS INTEGER , piBlue AS INTEGER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getColumnLabel) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getColumnLabel Procedure FUNCTION getColumnLabel RETURNS CHARACTER ( INPUT phFieldBuffer AS HANDLE ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getColumnWidthList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getColumnWidthList Procedure FUNCTION getColumnWidthList RETURNS CHARACTER ( INPUT phBrowse AS HANDLE ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getDatabaseList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getDatabaseList Procedure FUNCTION getDatabaseList RETURNS CHARACTER FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getEscapedData) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getEscapedData Procedure FUNCTION getEscapedData RETURNS CHARACTER ( pcTarget AS CHARACTER , pcString AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getFieldList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getFieldList Procedure FUNCTION getFieldList RETURNS CHARACTER ( pcDatabase AS CHARACTER , pcFile AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getFileCategory) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getFileCategory Procedure FUNCTION getFileCategory RETURNS CHARACTER ( piFileNumber AS INTEGER , pcFileName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getFont) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getFont Procedure FUNCTION getFont RETURNS INTEGER ( pcName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getImagePath) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getImagePath Procedure FUNCTION getImagePath RETURNS CHARACTER ( pcImage AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getIndexFields) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getIndexFields Procedure FUNCTION getIndexFields RETURNS CHARACTER ( INPUT pcDatabaseName AS CHARACTER , INPUT pcTableName AS CHARACTER , INPUT pcFlags AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getKeyList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getKeyList Procedure FUNCTION getKeyList RETURNS CHARACTER ( /* parameter-definitions */ ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getLinkInfo) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getLinkInfo Procedure FUNCTION getLinkInfo RETURNS CHARACTER ( INPUT pcFieldName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getMaxLength) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getMaxLength Procedure FUNCTION getMaxLength RETURNS INTEGER ( cFieldList AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getOsErrorDesc) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getOsErrorDesc Procedure FUNCTION getOsErrorDesc RETURNS CHARACTER (INPUT piOsError AS INTEGER) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getProgramDir) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getProgramDir Procedure FUNCTION getProgramDir RETURNS CHARACTER ( /* parameter-definitions */ ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getQuery) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getQuery Procedure FUNCTION getQuery RETURNS CHARACTER ( INPUT pcDatabase AS CHARACTER , INPUT pcTable AS CHARACTER , INPUT piQuery AS INTEGER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getReadableQuery) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getReadableQuery Procedure FUNCTION getReadableQuery RETURNS CHARACTER ( INPUT pcQuery AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getRegistry) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getRegistry Procedure FUNCTION getRegistry RETURNS CHARACTER ( pcSection AS CHARACTER , pcKey AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getSchemaHolder) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getSchemaHolder Procedure FUNCTION getSchemaHolder RETURNS CHARACTER ( INPUT pcDataSrNameOrDbName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getStackSize) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getStackSize Procedure FUNCTION getStackSize RETURNS INTEGER() FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getTableDesc) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getTableDesc Procedure FUNCTION getTableDesc RETURNS CHARACTER ( INPUT pcDatabase AS CHARACTER , INPUT pcTable AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getTableLabel) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getTableLabel Procedure FUNCTION getTableLabel RETURNS CHARACTER ( INPUT pcDatabase AS CHARACTER , INPUT pcTable AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getTableList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getTableList Procedure FUNCTION getTableList RETURNS CHARACTER ( INPUT pcDatabaseFilter AS CHARACTER , INPUT pcTableFilter AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getUserName) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getUserName Procedure FUNCTION getUserName RETURNS CHARACTER ( /* parameter-definitions */ ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getWidgetUnderMouse) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getWidgetUnderMouse Procedure FUNCTION getWidgetUnderMouse RETURNS HANDLE ( phFrame AS HANDLE ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getWorkFolder) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getWorkFolder Procedure FUNCTION getWorkFolder RETURNS CHARACTER ( /* parameter-definitions */ ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getXmlNodeName) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD getXmlNodeName Procedure FUNCTION getXmlNodeName RETURNS CHARACTER ( pcFieldName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-isDataServer) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isDataServer Procedure FUNCTION isDataServer RETURNS LOGICAL ( INPUT pcDataSrNameOrDbName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-isDefaultFontsChanged) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isDefaultFontsChanged Procedure FUNCTION isDefaultFontsChanged RETURNS LOGICAL ( /* parameter-definitions */ ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-isFileLocked) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isFileLocked Procedure FUNCTION isFileLocked RETURNS LOGICAL ( pcFileName AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-isMouseOver) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isMouseOver Procedure FUNCTION isMouseOver RETURNS LOGICAL ( phWidget AS HANDLE ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-isTableFilterUsed) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isTableFilterUsed Procedure FUNCTION isTableFilterUsed RETURNS LOGICAL ( INPUT TABLE ttTableFilter ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-isValidCodePage) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD isValidCodePage Procedure FUNCTION isValidCodePage RETURNS LOGICAL (pcCodepage AS CHARACTER) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-readFile) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD readFile Procedure FUNCTION readFile RETURNS LONGCHAR (pcFilename AS CHARACTER) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-removeConnection) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD removeConnection Procedure FUNCTION removeConnection RETURNS LOGICAL ( pcDatabase AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-resolveOsVars) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD resolveOsVars Procedure FUNCTION resolveOsVars RETURNS CHARACTER ( pcString AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-resolveSequence) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD resolveSequence Procedure FUNCTION resolveSequence RETURNS CHARACTER ( pcString AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-setColor) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD setColor Procedure FUNCTION setColor RETURNS INTEGER ( pcName AS CHARACTER , piColor AS INTEGER) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-setColumnWidthList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD setColumnWidthList Procedure FUNCTION setColumnWidthList RETURNS LOGICAL ( INPUT phBrowse AS HANDLE , INPUT pcWidthList AS CHARACTER) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-setLinkInfo) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD setLinkInfo Procedure FUNCTION setLinkInfo RETURNS LOGICAL ( INPUT pcFieldName AS CHARACTER , INPUT pcValue AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-setRegistry) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _FUNCTION-FORWARD setRegistry Procedure FUNCTION setRegistry RETURNS CHARACTER ( pcSection AS CHARACTER , pcKey AS CHARACTER , pcValue AS CHARACTER ) FORWARD. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF /* *********************** Procedure Settings ************************ */ &ANALYZE-SUSPEND _PROCEDURE-SETTINGS /* Settings for THIS-PROCEDURE Type: Procedure Allow: Frames: 0 Add Fields to: Neither Other Settings: CODE-ONLY COMPILE */ &ANALYZE-RESUME _END-PROCEDURE-SETTINGS /* ************************* Create Window ************************** */ &ANALYZE-SUSPEND _CREATE-WINDOW /* DESIGN Window definition (used by the UIB) CREATE WINDOW Procedure ASSIGN HEIGHT = 41 WIDTH = 57.4. /* END WINDOW DEFINITION */ */ &ANALYZE-RESUME &ANALYZE-SUSPEND _UIB-CODE-BLOCK _CUSTOM _MAIN-BLOCK Procedure /* *************************** Main Block *************************** */ /* terminate it. */ ON CLOSE OF THIS-PROCEDURE DO: DEFINE VARIABLE cEnvironment AS CHARACTER NO-UNDO. cEnvironment = SUBSTITUTE('DataDigger-&1', getUserName() ). UNLOAD 'DataDiggerHelp' NO-ERROR. UNLOAD 'DataDigger' NO-ERROR. UNLOAD cEnvironment NO-ERROR. END. /* CLOSE OF THIS-PROCEDURE */ /* Caching settings must be set from within UI. * Since the library might be started from DataDigger.p * we cannot rely on the registry being loaded yet */ glCacheTableDefs = TRUE. glCacheFieldDefs = TRUE. /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME /* ********************** Internal Procedures *********************** */ &IF DEFINED(EXCLUDE-applyChoose) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE applyChoose Procedure PROCEDURE applyChoose : /* Apply the choose event to a dynamically created widget */ DEFINE INPUT PARAMETER pihWidget AS HANDLE NO-UNDO. IF VALID-HANDLE(pihWidget) THEN DO: PUBLISH "debugInfo" (3, SUBSTITUTE("Apply CHOOSE to &1 &2", pihWidget:TYPE, pihWidget:NAME)). APPLY 'choose' TO pihWidget. END. END PROCEDURE. /* applyChoose */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-applyEvent) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE applyEvent Procedure PROCEDURE applyEvent : /* Apply an event to a dynamically created widget */ DEFINE INPUT PARAMETER pihWidget AS HANDLE NO-UNDO. DEFINE INPUT PARAMETER pcEvent AS CHARACTER NO-UNDO. IF VALID-HANDLE(pihWidget) THEN DO: PUBLISH "debugInfo" (3, SUBSTITUTE("Apply &1 to &2 &3", CAPS(pcEvent), pihWidget:TYPE, pihWidget:NAME)). APPLY pcEvent TO pihWidget. END. END PROCEDURE. /* applyEvent */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-checkBackupFolder) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE checkBackupFolder Procedure PROCEDURE checkBackupFolder : /* If backup is on, create a folder for it */ DEFINE OUTPUT PARAMETER plFolderOk AS LOGICAL NO-UNDO. DEFINE VARIABLE cFolder AS CHARACTER NO-UNDO. IF LOGICAL(getRegistry("DataDigger:Backup","BackupOnCreate")) OR LOGICAL(getRegistry("DataDigger:Backup","BackupOnDelete")) OR LOGICAL(getRegistry("DataDigger:Backup","BackupOnDelete")) THEN DO: RUN getDumpFileName ( INPUT 'dump' /* action */ , INPUT '' /* database */ , INPUT '' /* table */ , INPUT '' /* extension */ , INPUT getRegistry("DataDigger:Backup", "BackupDir") /* template */ , OUTPUT cFolder ). RUN createFolder(cFolder). /* Now check if folder is actually created */ FILE-INFO:FILE-NAME = cFolder. plFolderOk = (FILE-INFO:FULL-PATHNAME <> ?). IF NOT plFolderOk THEN DO: RUN showHelp('CannotCreateBackupFolder', cFolder). setRegistry("DataDigger:Backup","BackupOnCreate", "NO"). setRegistry("DataDigger:Backup","BackupOnUpdate", "NO"). setRegistry("DataDigger:Backup","BackupOnDelete", "NO"). END. END. ELSE plFolderOk = TRUE. END PROCEDURE. /* checkBackupFolder */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-checkDir) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE checkDir Procedure PROCEDURE checkDir : /* Check if a folder exists, is accessible etc */ DEFINE INPUT PARAMETER pcFileName AS CHARACTER NO-UNDO. DEFINE OUTPUT PARAMETER pcError AS CHARACTER NO-UNDO. DEFINE VARIABLE cDumpDir AS CHARACTER NO-UNDO. DEFINE VARIABLE cDirToCreate AS CHARACTER NO-UNDO. DEFINE VARIABLE iDir AS INTEGER NO-UNDO. PUBLISH "debugInfo" (3, SUBSTITUTE("Check &1", pcFileName)). /* If no path is given, use startup folder */ cDumpDir = SUBSTRING(pcFileName, 1, R-INDEX(pcFileName,"\")). IF cDumpDir = '' THEN cDumpDir = '.'. /* We cannot use the program dir itself */ FILE-INFO:FILE-NAME = cDumpDir. IF TRIM(FILE-INFO:FULL-PATHNAME,'\/') = TRIM(getProgramDir(),"/\") THEN DO: pcError = getRegistry('DataDigger:Help', 'ExportToProgramdir:message'). RETURN. END. PUBLISH "debugInfo" (3, SUBSTITUTE("Dir = &1", cDumpDir)). /* Ask to overwrite if it already exists */ FILE-INFO:FILE-NAME = pcFileName. IF FILE-INFO:FULL-PATHNAME <> ? THEN DO: PUBLISH "debugInfo" (3, SUBSTITUTE("Already exists as &1 (&2)", FILE-INFO:FULL-PATHNAME, FILE-INFO:FILE-TYPE)). IF FILE-INFO:FILE-TYPE MATCHES '*F*' THEN DO: RUN showHelp('OverwriteDumpFile', pcFileName). IF getRegistry('DataDigger:Help', 'OverwriteDumpFile:answer') <> '1' THEN DO: /* Do not remember the answer "No" for this question, otherwise it will be * confusing the next time the user encounters this situation */ setRegistry('DataDigger:Help', 'OverwriteDumpFile:answer',?). pcError = 'Aborted by user.'. RETURN. END. /* Write access to this file? */ IF NOT FILE-INFO:FILE-TYPE MATCHES '*W*' THEN DO: pcError = SUBSTITUTE('Cannot overwrite output file "&1"', pcFileName). RETURN. END. END. /* If a dir already exists with the same name as the output file, we cannot create it */ IF FILE-INFO:FILE-TYPE MATCHES '*D*' THEN DO: pcError = SUBSTITUTE('A directory named "&1" exists; cannot create a file with the same name.', pcFileName). RETURN. END. END. /* Check dir */ FILE-INFO:FILE-NAME = cDumpDir. IF cDumpDir <> "" /* Don't complain about not using a dir */ AND FILE-INFO:FULL-PATHNAME = ? THEN DO: RUN showHelp('CreateDumpDir', cDumpDir). IF getRegistry('DataDigger:Help', 'CreateDumpDir:answer') <> '1' THEN DO: pcError = 'Aborted by user.'. RETURN. END. END. /* Try to create path + file. Progress will not raise an error if it already exists */ cDirToCreate = ENTRY(1,cDumpDir,'\'). DO iDir = 2 TO NUM-ENTRIES(cDumpDir,'\'). /* In which dir do we want to create a subdir? */ IF iDir = 2 THEN FILE-INFO:FILE-NAME = cDirToCreate + '\'. ELSE FILE-INFO:FILE-NAME = cDirToCreate. /* Does it even exist? */ IF FILE-INFO:FULL-PATHNAME = ? THEN DO: pcError = SUBSTITUTE('Directory "&1" does not exist.', cDirToCreate). PUBLISH "debugInfo" (3, SUBSTITUTE("Error: &1", pcError)). RETURN. END. /* Check if the dir is writable */ IF FILE-INFO:FILE-TYPE MATCHES '*X*' /* Happens on CD-ROM drives */ OR ( FILE-INFO:FILE-TYPE MATCHES '*D*' AND NOT FILE-INFO:FILE-TYPE MATCHES '*W*' ) THEN DO: pcError = SUBSTITUTE('No write-access to directory: "&1"', cDirToCreate). PUBLISH "debugInfo" (3, SUBSTITUTE("Error: &1", pcError)). RETURN. END. /* Seems to exist and to be writable. */ cDirToCreate = cDirToCreate + '\' + ENTRY(iDir,cDumpDir,'\'). /* If a file already exists with the same name, we cannot create a dir */ FILE-INFO:FILE-NAME = cDirToCreate. IF FILE-INFO:FILE-TYPE MATCHES '*F*' THEN DO: pcError = SUBSTITUTE('A file named "&1" exists; cannot create a dir with the same name.', cDirToCreate). PUBLISH "debugInfo" (3, SUBSTITUTE("Error: &1", pcError)). RETURN. END. /* Create the dir. Creating an existing dir gives no error */ OS-CREATE-DIR value(cDirToCreate). IF OS-ERROR <> 0 THEN DO: pcError = getOsErrorDesc(OS-ERROR). PUBLISH "debugInfo" (3, SUBSTITUTE("Error: &1", pcError)). RETURN. END. /* error */ END. /* iDir */ END PROCEDURE. /* checkDir */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-clearColorCache) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearColorCache Procedure PROCEDURE clearColorCache : /* Clear the registry cache */ PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing color cache")). EMPTY TEMP-TABLE ttColor. END PROCEDURE. /* clearColorCache */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-clearDiskCache) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearDiskCache Procedure PROCEDURE clearDiskCache : /* Clear the cache files on disk */ DEFINE VARIABLE cFile AS CHARACTER NO-UNDO EXTENT 3. PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing disk cache")). FILE-INFORMATION:FILE-NAME = getWorkFolder() + "cache". IF FILE-INFORMATION:FULL-PATHNAME = ? THEN RETURN. INPUT FROM OS-DIR(FILE-INFORMATION:FULL-PATHNAME). REPEAT: IMPORT cFile. IF cFile[1] MATCHES "*.xml" THEN OS-DELETE VALUE( cFile[2]). END. INPUT CLOSE. END PROCEDURE. /* clearDiskCache */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-clearFontCache) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearFontCache Procedure PROCEDURE clearFontCache : /* Clear the font cache */ PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing font cache")). EMPTY TEMP-TABLE ttFont. END PROCEDURE. /* clearFontCache */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-clearMemoryCache) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearMemoryCache Procedure PROCEDURE clearMemoryCache : /* Clear the memory cache */ PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing memory cache")). EMPTY TEMP-TABLE ttFieldCache. END PROCEDURE. /* clearMemoryCache */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-clearRegistryCache) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE clearRegistryCache Procedure PROCEDURE clearRegistryCache : /* Clear the registry cache */ PUBLISH "debugInfo" (3, SUBSTITUTE("Clearing registry cache")). EMPTY TEMP-TABLE ttConfig. END PROCEDURE. /* clearRegistryCache */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-collectQueryInfo) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE collectQueryInfo Procedure PROCEDURE collectQueryInfo : /* Fill the query temp-table */ DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO. DEFINE INPUT PARAMETER pcTable AS CHARACTER NO-UNDO. DEFINE VARIABLE iMaxQueryHistory AS INTEGER NO-UNDO. DEFINE VARIABLE iQueryNr AS INTEGER NO-UNDO. DEFINE VARIABLE iLoop AS INTEGER NO-UNDO. DEFINE VARIABLE cSetting AS CHARACTER NO-UNDO. DEFINE BUFFER bQuery FOR ttQuery. {&timerStart} /* Delete all known queries in memory of this table */ FOR EACH bQuery WHERE bQuery.cDatabase = pcDatabase AND bQuery.cTable = pcTable: DELETE bQuery. END. iMaxQueryHistory = INTEGER(getRegistry("DataDigger", "MaxQueryHistory" )). IF iMaxQueryHistory = 0 THEN RETURN. /* no query history wanted */ /* If it is not defined use default setting */ IF iMaxQueryHistory = ? THEN iMaxQueryHistory = 10. collectQueries: DO iLoop = 1 TO iMaxQueryHistory: cSetting = getRegistry( SUBSTITUTE("DB:&1", pcDatabase) , SUBSTITUTE('&1:query:&2', pcTable, iLoop )). IF cSetting = '' THEN NEXT collectQueries. IF cSetting <> ? THEN DO: CREATE bQuery. ASSIGN iQueryNr = iQueryNr + 1 bQuery.cDatabase = pcDatabase bQuery.cTable = pcTable bQuery.iQueryNr = iQueryNr bQuery.cQueryTxt = cSetting. END. ELSE LEAVE collectQueries. END. /* 1 .. MaxQueryHistory */ {&timerStop} END PROCEDURE. /* collectQueryInfo */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-correctFilterList) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE correctFilterList Procedure PROCEDURE correctFilterList : /* Move negative entries from positive list to negative */ DEFINE INPUT-OUTPUT PARAMETER pcPositive AS CHARACTER NO-UNDO. DEFINE INPUT-OUTPUT PARAMETER pcNegative AS CHARACTER NO-UNDO. DEFINE VARIABLE iWord AS INTEGER NO-UNDO. /* Strip entries that start with a ! */ IF INDEX(pcPositive,"!") > 0 THEN DO: DO iWord = 1 TO NUM-ENTRIES(pcPositive): IF ENTRY(iWord,pcPositive) BEGINS "!" THEN DO: /* Add this word to the negative-list */ pcNegative = TRIM(pcNegative + ',' + TRIM(ENTRY(iWord,pcPositive),'!'),','). /* And wipe it from the positive-list */ ENTRY(iWord,pcPositive) = ''. END. END. /* Remove empty elements */ pcPositive = TRIM(pcPositive,','). REPEAT WHILE INDEX(pcPositive,',,') > 0: pcPositive = REPLACE(pcPositive,',,',','). END. END. END PROCEDURE. /* correctFilterList */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-createFolder) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE createFolder Procedure PROCEDURE createFolder : /* Create a folder structure */ DEFINE INPUT PARAMETER pcFolder AS CHARACTER NO-UNDO. DEFINE VARIABLE iElement AS INTEGER NO-UNDO. DEFINE VARIABLE cPath AS CHARACTER NO-UNDO. /* c:\temp\somefolder\subfolder\ */ DO iElement = 1 TO NUM-ENTRIES(pcFolder,'\'): cPath = SUBSTITUTE('&1\&2', cPath, ENTRY(iElement,pcFolder,'\')). cPath = LEFT-TRIM(cPath,'\'). IF iElement > 1 THEN OS-CREATE-DIR VALUE(cPath). END. END PROCEDURE. /* createFolder */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-dumpRecord) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE dumpRecord Procedure PROCEDURE dumpRecord : /* Dump the record(s) to disk */ DEFINE INPUT PARAMETER pcAction AS CHARACTER NO-UNDO. DEFINE INPUT PARAMETER phSource AS HANDLE NO-UNDO. DEFINE OUTPUT PARAMETER plContinue AS LOGICAL NO-UNDO. DEFINE VARIABLE hExportTT AS HANDLE NO-UNDO. DEFINE VARIABLE hExportTtBuffer AS HANDLE NO-UNDO. DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO. DEFINE VARIABLE cFileName AS CHARACTER NO-UNDO. DEFINE VARIABLE cError AS CHARACTER NO-UNDO. DEFINE VARIABLE cMessage AS CHARACTER NO-UNDO. DEFINE VARIABLE iRow AS INTEGER NO-UNDO. DEFINE VARIABLE lDefaultDump AS LOGICAL NO-UNDO. IF NOT VALID-HANDLE(phSource) THEN RETURN. /* Protect against wrong input */ IF LOOKUP(pcAction,'Dump,Create,Update,Delete') = 0 THEN DO: MESSAGE 'Unknown action' pcAction VIEW-AS ALERT-BOX INFORMATION BUTTONS OK. RETURN. END. /* Determine appropriate buffer and populate an intermediate tt * with the data to export */ CASE phSource:TYPE: WHEN 'buffer' THEN DO: hBuffer = phSource. /* Create temptable-handle... */ CREATE TEMP-TABLE hExportTt. hExportTt:CREATE-LIKE(SUBSTITUTE("&1.&2", hBuffer:DBNAME, hBuffer:TABLE)). /* Prepare the TempTable... */ hExportTt:TEMP-TABLE-PREPARE(SUBSTITUTE("&1", hBuffer:TABLE)). hExportTtBuffer = hExportTt:DEFAULT-BUFFER-HANDLE. hExportTtBuffer:BUFFER-CREATE(). hExportTtBuffer:BUFFER-COPY(hBuffer). END. WHEN 'browse' THEN DO: hBuffer = phSource:QUERY:GET-BUFFER-HANDLE(1). /* Create temptable-handle... */ CREATE TEMP-TABLE hExportTt. hExportTt:CREATE-LIKE(SUBSTITUTE("&1.&2", hBuffer:DBNAME, hBuffer:TABLE)). /* Prepare the TempTable... */ hExportTt:TEMP-TABLE-PREPARE(SUBSTITUTE("&1", hBuffer:TABLE)). hExportTtBuffer = hExportTt:DEFAULT-BUFFER-HANDLE. /* Copy the records */ DO iRow = 1 TO phSource:NUM-SELECTED-ROWS: phSource:FETCH-SELECTED-ROW(iRow). hExportTtBuffer:BUFFER-CREATE(). hExportTtBuffer:BUFFER-COPY(hBuffer). END. END. OTHERWISE RETURN. END CASE. /* Do we need to dump at all? * If the setting=NO or if no setting at all, then don't do any checks */ IF pcAction <> 'Dump' AND ( getRegistry('DataDigger:Backup','BackupOn' + pcAction) = ? OR logical(getRegistry('DataDigger:Backup','BackupOn' + pcAction)) = NO ) THEN DO: ASSIGN plContinue = YES. RETURN. END. /* Determine the default name to save to */ RUN getDumpFileName ( INPUT pcAction /* Dump | Create | Update | Delete */ , INPUT hBuffer:DBNAME , INPUT hBuffer:TABLE , INPUT "XML" , INPUT "" , OUTPUT cFileName ). RUN checkDir(INPUT cFileName, OUTPUT cError). IF cError <> "" THEN DO: MESSAGE cError VIEW-AS ALERT-BOX INFORMATION BUTTONS OK. RETURN. END. /* Fix XML Node Names for fields in the tt */ RUN setXmlNodeNames(INPUT hExportTt:DEFAULT-BUFFER-HANDLE). /* See if the user has specified his own dump program */ plContinue = ?. /* To see if it ran or not */ PUBLISH "customDump" ( INPUT pcAction , INPUT hBuffer:DBNAME , INPUT hBuffer:TABLE , INPUT hExportTt , INPUT cFileName , OUTPUT cMessage , OUTPUT lDefaultDump , OUTPUT plContinue ). IF plContinue <> ? THEN DO: IF cMessage <> "" THEN MESSAGE cMessage VIEW-AS ALERT-BOX INFORMATION BUTTONS OK. IF NOT lDefaultDump OR NOT plContinue THEN RETURN. END. plContinue = hExportTT:WRITE-XML ( 'file' /* TargetType */ , cFileName /* File */ , YES /* Formatted */ , ? /* Encoding */ , ? /* SchemaLocation */ , NO /* WriteSchema */ , NO /* MinSchema */ ). DELETE OBJECT hExportTt. END PROCEDURE. /* dumpRecord */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-dynamicDump) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE dynamicDump Procedure PROCEDURE dynamicDump : /* Dump the data to a file that is similar to those of Progress self. */ DEFINE INPUT PARAMETER pihBrowse AS HANDLE NO-UNDO. DEFINE INPUT PARAMETER picFile AS CHARACTER NO-UNDO. DEFINE VARIABLE cTimeStamp AS CHARACTER NO-UNDO. DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO EXTENT 5. DEFINE VARIABLE hColumn AS HANDLE NO-UNDO. DEFINE VARIABLE hField AS HANDLE NO-UNDO. DEFINE VARIABLE hQuery AS HANDLE NO-UNDO. DEFINE VARIABLE iBack AS INTEGER NO-UNDO. DEFINE VARIABLE iBuffer AS INTEGER NO-UNDO. DEFINE VARIABLE iColumn AS INTEGER NO-UNDO. DEFINE VARIABLE iExtent AS INTEGER NO-UNDO. DEFINE VARIABLE iRecords AS INTEGER NO-UNDO. DEFINE VARIABLE iTrailer AS INTEGER NO-UNDO. DEFINE VARIABLE lFirst AS LOGICAL NO-UNDO. hQuery = pihBrowse:QUERY. /* Accept max 5 buffers for a query */ DO iBuffer = 1 TO min(5, hQuery:NUM-BUFFERS): hBuffer[iBuffer] = hQuery:GET-BUFFER-HANDLE(iBuffer). END. ASSIGN iRecords = 0 cTimeStamp = STRING(YEAR( TODAY),"9999":u) + "/":u + string(MONTH(TODAY),"99":u ) + "/":u + string(DAY( TODAY),"99":u ) + "-":u + string(TIME,"HH:MM:SS":u). hQuery:GET-FIRST. /* Open outputfile */ OUTPUT to value(picFile) no-echo no-map. EXPORT ?. iBack = seek(output) - 1. SEEK OUTPUT TO 0. REPEAT WHILE NOT hQuery:QUERY-OFF-END ON STOP UNDO, LEAVE: ASSIGN iRecords = iRecords + 1 lFirst = TRUE . PROCESS EVENTS. browseColumn: DO iColumn = 1 TO pihBrowse:NUM-COLUMNS: /* Grab the handle */ hColumn = pihBrowse:GET-BROWSE-COLUMN(iColumn). /* Skip invisible columns */ IF NOT hColumn:VISIBLE THEN NEXT browseColumn. /* Find the buffer the column belongs to */ SearchLoop: DO iBuffer = 1 TO 5: ASSIGN hField = hBuffer[iBuffer]:BUFFER-FIELD(hColumn:NAME) NO-ERROR. IF ERROR-STATUS:ERROR = FALSE AND hField <> ? THEN LEAVE SearchLoop. END. /* If no column found, something weird happened */ IF hField = ? THEN NEXT browseColumn. IF hField:DATA-TYPE = "recid":u THEN NEXT browseColumn. IF lFirst THEN lFirst = FALSE. ELSE DO: SEEK OUTPUT TO seek(output) - iBack. PUT CONTROL ' ':u. END. IF hField:EXTENT > 1 THEN DO iExtent = 1 TO hField:EXTENT: IF iExtent > 1 THEN DO: SEEK OUTPUT TO SEEK(OUTPUT) - iBack. PUT CONTROL ' ':u. END. EXPORT hField:BUFFER-VALUE(iExtent). END. ELSE EXPORT hField:BUFFER-VALUE. END. hQuery:GET-NEXT(). END. /* Add a checksum and nr of records at the end of the file. */ PUT UNFORMATTED ".":u SKIP. iTrailer = SEEK(OUTPUT). PUT UNFORMATTED "PSC":u SKIP "filename=":u hBuffer[1]:TABLE SKIP "records=":u STRING(iRecords,"9999999999999":u) SKIP "ldbname=":u hBuffer[1]:DBNAME SKIP "timestamp=":u cTimeStamp SKIP "numformat=":u ASC(SESSION:NUMERIC-SEPARATOR) ",":u ASC(SESSION:NUMERIC-DECIMAL-POINT) SKIP "dateformat=":u SESSION:DATE-FORMAT "-":u SESSION:YEAR-OFFSET SKIP "map=NO-MAP":u SKIP "cpstream=":u SESSION:CPSTREAM SKIP ".":u SKIP STRING(iTrailer,"9999999999":u) SKIP. OUTPUT CLOSE. END PROCEDURE. /* dynamicDump */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-flushRegistry) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE flushRegistry Procedure PROCEDURE flushRegistry : /* Flush all dirty registry settings to disk */ {&timerStart} IF glDirtyCache THEN RUN saveConfigFileSorted. {&timerStop} END PROCEDURE. /* flushRegistry */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getColumnSort) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getColumnSort Procedure PROCEDURE getColumnSort : /* Return the column nr the browse is sorted on */ DEFINE INPUT PARAMETER phBrowse AS HANDLE NO-UNDO. DEFINE OUTPUT PARAMETER pcColumn AS CHARACTER NO-UNDO. DEFINE OUTPUT PARAMETER plAscending AS LOGICAL NO-UNDO. DEFINE VARIABLE hColumn AS HANDLE NO-UNDO. DEFINE VARIABLE iColumn AS INTEGER NO-UNDO. {&timerStart} #BrowseColumns: DO iColumn = 1 TO phBrowse:NUM-COLUMNS: hColumn = phBrowse:GET-BROWSE-COLUMN(iColumn). IF hColumn:SORT-ASCENDING <> ? THEN DO: ASSIGN pcColumn = hColumn:NAME plAscending = hColumn:SORT-ASCENDING . LEAVE #BrowseColumns. END. END. IF pcColumn = '' THEN ASSIGN pcColumn = phBrowse:GET-BROWSE-COLUMN(1):name plAscending = TRUE. PUBLISH "debugInfo" (3, SUBSTITUTE("Sorting &1 on &2", STRING(plAscending,"up/down"), pcColumn)). {&timerStop} END PROCEDURE. /* getColumnSort */ /* _UIB-CODE-BLOCK-END */ &ANALYZE-RESUME &ENDIF &IF DEFINED(EXCLUDE-getDumpFileName) = 0 &THEN &ANALYZE-SUSPEND _UIB-CODE-BLOCK _PROCEDURE getDumpFileName Procedure PROCEDURE getDumpFileName : /* Return a file name based on a template */ DEFINE INPUT PARAMETER pcAction AS CHARACTER NO-UNDO. DEFINE INPUT PARAMETER pcDatabase AS CHARACTER NO-UNDO. DEFINE INPUT PARAMETER pcTable AS CHARACTER NO-UNDO. DEFINE INPUT PARAMETER pcExtension AS CHARACTER NO-UNDO. DEFINE INPUT PARAMETER pcTemplate AS CHARACTER NO-UNDO. DEFINE OUTPUT PARAMETER pcFileName AS CHARACTER NO-UNDO. DEFINE VARIABLE cLastDir AS CHARACTER NO-UNDO. DEFINE VARIABLE cDayOfWeek AS CHARACTER NO-UNDO EXTENT 7 INITIAL ['Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat']. DEFINE VARIABLE cDumpName AS CHARACTER NO-UNDO. DEFINE VARIABLE cDumpDir AS CHARACTER NO-UNDO. DEFINE VARIABLE cBackupDir AS CHARACTER NO-UNDO. DEFINE VARIABLE hBuffer AS HANDLE NO-UNDO. DEFINE VARIABLE cUserId AS CHARACTER NO-UNDO. /* Checks */ IF LOOKUP(pcAction, "Dump,Create,Update,Delete") = 0 THEN DO: MESSAGE 'Unknown action' pcAction VIEW-AS ALERT-BOX. RETURN. END. /* If not provided, find the template from the settings, * depending on the action we want to perform. */ IF pcTemplate = ? OR pcTemplate = "" THEN DO: IF pcAction = 'Dump' THEN pcFileName = "" + getRegistry("DumpAndLoad", "DumpFileTemplate"). ELSE pcFileName = "" + getRegistry("DataDigger:Backup", "BackupFileTemplate"). END. ELSE pcFileName = pcTemplate. IF pcFileName = ? THEN pcFileName = "". PUBLISH "debugInfo" (3, SUBSTITUTE("Dump to: &1", pcFileName)). /* Dump dir / backup dir / last-used dir from settings */ cDumpDir = RIGHT-TRIM(getRegistry("DumpAndLoad", "DumpDir"),'/\') + '\'. IF cDumpDir = ? OR cDumpDir = '' THEN cDumpDir = "dump\". cBackupDir = RIGHT-TRIM(getRegistry("DataDigger:Backup", "BackupDir"),'/\') + '\'. IF cBackupDir = ? OR cBackupDir = '' THEN cBackupDir = "backup\". cLastDir = RIGHT-TRIM(getRegistry("DumpAndLoad", "DumpLastFileName"),'/\'). cLastDir = SUBSTRING(cLastDir,1,R-INDEX(cLastDir,"\")). IF cLastDir = ? THEN cLastDir = "dump". cLastDir = RIGHT-TRIM(cLastDir,'\'). /* Find _file for the dump-name */ CREATE BUFFER hBuffer FOR TABLE SUBSTITUTE('&1._file', pcDatabase) NO-ERROR. IF VALID-HANDLE(hBuffer) THEN DO: hBuffer:FIND-UNIQUE(SUBSTITUTE('where _file-name = &1 and _File._File-Number < 32768', QUOTER(pcTable)),NO-LOCK). IF hBuffer:AVAILABLE THEN cDumpName = hBuffer::_dump-name. ELSE cDumpName = pcTable. END. ELSE cDumpName = pcTable. IF cDumpName = ? THEN cDumpName = pcTable. /* If you have no db connected, userid gives back unknown value * which misbehaves in a replace statement */ cUserId = USERID(LDBNAME(1)). IF cUserId = ? THEN cUserId = ''. PUBLISH "debugInfo" (3, SUBSTITUTE("DumpDir : &1", cDumpDir)). PUBLISH "debugInfo" (3, SUBSTITUTE("BackupDir: &1", cBackupDir)). PUBLISH "debugInfo" (3, SUBSTITUTE("LastDir : &1", cLastDir)). PUBLISH "debugInfo" (3, SUBSTITUTE("DumpName : &1", cDumpName)). /* Now resolve all tags */ pcFileName = REPLACE(pcFileName,"" , cDumpDir ). pcFileName = REPLACE(pcFileName,"", cBackupDir ). pcFileName = REPLACE(pcFileName,"" , cLastDir ). pcFileName = REPLACE(pcFileName,"" , getWorkFolder() ). pcFileName = REPLACE(pcFileName,"" , getWorkFolder() ). pcFileName = REPLACE(pcFileName,"" , pcAction ). pcFileName = REPLACE(pcFileName,"" , cUserId ). pcFileName = REPLACE(pcFileName,"" , pcDatabase ). pcFileName = REPLACE(pcFileName,"" , pcTable ). pcFileName = REPLACE(pcFileName,"" , cDumpName ). pcFileName = REPLACE(pcFileName,"" , pcExtension ). pcFileName = REPLACE(pcFileName,"", "." ). pcFileName = REPLACE(pcFileName,"" , "--" ). pcFileName = REPLACE(pcFileName,"