COMPILE FUNCTION obj_Export(Method, Parms, AutoFlag) #pragma precomp SRP_PreCompiler /* Methods for Export table 09/26/2006 JCH - Initial Coding Properties: Methods: ExportDelimited ;* Create new record ExportExcel ExportTemplate */ DECLARE FUNCTION Get_Status, Msg, Utility, obj_Tables, NextKey, Logging_Services, Environment_Services DECLARE SUBROUTINE Set_Status, Msg, obj_Tables, ErrMsg, Yield, RList, Msg, Logging_Services $INSERT EXPORTS_EQU $INSERT MSG_EQUATES $INSERT DICT_EQUATES $INSERT RLIST_EQUATES EQU CRLF$ TO \0D0A\ EQU CR$ TO \0D\ EQU TAB$ TO \09\ EQU TRUE$ TO 1 EQU FALSE$ TO 0 equ xlTrue to -1 equ xlFalse to 0 equ xlSheetVisible to -1 equ xlRangeAutoFormatSimple to -4154 equ xlRangeAutoFormatClassic1 to 1 equ xlCSV to 6 equ xlWorkbookNormal to -4143 equ xlTextMSDOS to 21 equ xlCSVWindows to 23 eXcelCols = 'A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,AA,BB,CC,DD,EE,FF,GG,HH,II,JJ,KK,LL' SWAP "','" WITH ',' IN eXcelCols CONVERT ',' TO @VM IN eXcelCols ErrTitle = 'Error in Stored Procedure "obj_Export"' ErrorMsg = '' LogPath = Environment_Services('GetApplicationRootPath') : '\LogFiles\Export' LogDate = Oconv(Date(), 'D4/') LogTime = Oconv(Time(), 'MTS') LogFileName = LogDate[7, 4] : '-' : LogDate[1, 2] : '-' : LogDate[4, 2] : ' Export Log.csv' Headers = 'Logging DTM' : @FM : 'AutoFlag' objLog = Logging_Services('NewLog', LogPath, LogFileName, CRLF$, Comma$, Headers, '', False$, False$) IF NOT(ASSIGNED(Method)) THEN ErrorMsg = 'Unassigned parameter "Method" passed to subroutine' IF NOT(ASSIGNED(Parms)) THEN Parms = '' If Not(Assigned(AutoFlag)) then AutoFlag = False$ LoggingDTM = LogDate : ' ' : LogTime ; // Logging DTM LogData = '' LogData<1> = LoggingDTM LogData<2> = AutoFlag Logging_Services('AppendLog', objLog, LogData, @RM, @FM) IF ErrorMsg NE '' THEN Set_Status(-1,ErrTitle:@SVM:ErrorMsg) RETURN '' END Result = '' BEGIN CASE CASE Method = 'ExportDelimited' ; GOSUB ExportDelimited CASE Method = 'ExportExcel' ; GOSUB ExportExcel CASE Method = 'ExportTemplate' ; GOSUB ExportTemplate CASE Method = 'ExcelCol' ; GOSUB ExcelCol CASE 1 END CASE IF ErrorMsg NE '' THEN Set_Status(-1,ErrTitle:@SVM:ErrorMsg) RETURN '' END RETURN Result * * * * * * * ExcelCol: * * * * * * * ColNos = Parms[1,@RM] ColCnt = COUNT(ColNos,@VM) + (ColNos NE '') eXcelCols = '' FOR I = 1 TO ColCnt ColNo = ColNos<1,I> IF NUM(ColNo) THEN MSig = INT(ColNo/26) LSig = MOD(ColNo,26) IF MSig > 0 AND LSig = 0 THEN MSig -= 1 LSig = 26 END IF MSig > 0 THEN eXcelCols<1,I> = CHAR(MSig + 64):CHAR(LSig + 64) END ELSE eXcelCols<1,I> = CHAR(LSig + 64) END END ELSE eXCelCols<1,I> = '' END NEXT I Result = eXcelCols RETURN * * * * * * * ExportDelimited: * * * * * * * Delimiter = Parms[1,@RM] KeyList = Parms[COL2()+1,@RM] ExportID = Parms[COL2()+1,@RM] DosTable = Parms[COL2()+1,@RM] TableName = Parms[COL2()+1,@RM] FieldNames = Parms[COL2()+1,@RM] NoHeader = Parms[COL2()+1,@RM] Automated = Parms[COL2()+1,@RM] IF ExportID NE '' THEN ExportRec = XLATE('EXPORTS',ExportID,'','X') IF DosTable = '' THEN DosTable = ExportRec IF Tablename = '' THEN TableName = ExportRec IF FieldNames = '' THEN FieldNames = ExportRec END IF Delimiter = '' THEN Delimiter = 'Comma' IF TableName = '' THEN ErrorMsg = 'Null Parameter "TableName" passed to routine. (':Method:')' IF FieldNames = '' THEN ErrorMsg = 'Null Parameter "FieldNames" passed to routine. (':Method:')' IF KeyList = '' THEN ErrorMsg = 'Null Parameter "KeyList" passed to routine. (':Method:')' IF DosTable = '' THEN ErrorMsg = 'Null Parameter "DosTable" passed to routine. (':Method:')' IF NoHeader = '' THEN NoHeader = 0 Delimiters = 'COMMA':@VM:'TAB' TestDelimiter = Delimiter CONVERT @LOWER_CASE TO @UPPER_CASE IN TestDelimiter LOCATE TestDelimiter IN Delimiters USING @VM SETTING Pos THEN BEGIN CASE CASE TestDelimiter = 'TAB' DelimChar = CHAR(9) FileExt = 'tsv' CASE TestDelimiter = 'COMMA' DelimChar = "," FileExt = 'csv' END CASE END ELSE ErrorMsg = 'Invalid Delimiter Parameter ':QUOTE(Delimiter):' passed to routine. (':Method:')' RETURN END if Automated EQ 1 then DosTableName = DosTable DosTable = DosTableName end else DosTableName = DosTable[1,'.'] DosTable = DosTableName:'.':FileExt end OPEN TableName TO TableVar ELSE ErrorMsg = 'Unable to open ':TableName:' table in Export_Delimited routine' RETURN END OPEN 'DICT.':TableName TO @DICT ELSE ErrorMsg = 'Unable to open DICT.':TableName:' table in Export_Delimited routine.' RETURN END DataOut = '' OSOPEN DosTable TO DOSFile THEN OSWrite DataOut ON DosTable ;* Clear file it was already there END ELSE OSWrite DataOut ON DosTable ;* Create the file if it wasn't OSOPEN DosTable TO DOSFile ELSE ErrorMsg = "Unable to open ":QUOTE(DosTable):" in Export_TSV routine." RETURN END END READ Fields FROM @DICT,'%FIELDS%' ELSE ErrorMsg = 'Unable to read %FIELDS% from DICT.':TableName:' in ExportDelimited routine.' RETURN END FilePointer = 0 KeylistCnt = COUNT(KeyList,@VM) + (KeyList NE '') Def = "" Def = 'Exporting ':TableName:' Data...' Def = "GC" Def = KeyListCnt Def = 400 HeaderOut = '' FOR I = 1 TO COUNT(FieldNames,@VM) + (FieldNames NE '') FieldName = FieldNames<1,I> READV FieldHeader FROM @DICT,FieldName,DICT_DISPLAY$ THEN HeaderOut := QUOTE(FieldHeader):DelimChar END NEXT I DataOut = '' HeaderOut[-1,1] = '' HeaderOut := CRLF$ IF NoHeader ELSE * OSBWrite HeaderOut ON DOSFile AT FilePointer FilePointer += LEN(HeaderOut) DataOut := HeaderOut END fnCnt = COUNT(FieldNames,@VM) + (FieldNames NE '') FOR I = 1 TO COUNT(KeyList,@VM) + (KeyList NE '') @ID = KeyList<1,I> rv = 1 WHILE rv READ @RECORD FROM TableVar,@ID THEN FOR N = 1 TO fnCnt FieldName = FieldNames<1,N> LOCATE FieldName IN Fields USING @VM SETTING Pos THEN FType = Fields FNo = Fields FMV = Fields FPart = Fields FJust = Fields FConv = Fields IF FNo[1,1] = 0 THEN DataVal = FIELD(@ID,'*',FPart,1) ;* Part or all of key END ELSE IF FType = 'F' THEN DataVal = @RECORD ;* Real field IF FType = 'S' THEN DataVal = Calculate(FieldName) ;* Symbolic field END IF FConv NE '' THEN DataVal = OCONV(DataVal,FConv) ;* Conversion if required If Index(DataVal, '"', 1) then Swap '"' with '""' in DataVal end DataOut := QUOTE(DataVal):DelimChar END NEXT N DataOut[-1,1] = '' DataOut := CRLF$ END YIELD() NEXT I OSWrite DataOut to DOSFile Def = '' Def = 'File ':DosTable:' written.' Def = 'TA3' OSClose DOSFile RETURN * * * * * * * ExportExcel: * * * * * * * KeyList = Parms[1,@RM] ExportID = Parms[COL2()+1,@RM] ExcelFileName = Parms[COL2()+1,@RM] TableName = Parms[COL2()+1,@RM] FieldNames = Parms[COL2()+1,@RM] IF ExportID NE '' THEN ExportRec = XLATE('EXPORTS',ExportID,'','X') IF ExcelFileName = '' THEN ExcelFileName = ExportRec IF Tablename = '' THEN TableName = ExportRec IF FieldNames = '' THEN FieldNames = ExportRec END IF TableName = '' THEN ErrorMsg = 'Null Parameter "TableName" passed to routine. (':Method:')' IF FieldNames = '' THEN ErrorMsg = 'Null Parameter "FieldNames" passed to routine. (':Method:')' IF KeyList = '' THEN ErrorMsg = 'Null Parameter "KeyList" passed to routine. (':Method:')' IF ExcelFileName = '' THEN ErrorMsg = 'Null Parameter "ExcelFileName" passed to routine. (':Method:')' ExcelFileName = FIELD(ExcelFileName,'.',1) ExcelFileName = ExcelFileName:'.xls' ;* Standardize the file extension if there is one OPEN TableName TO TableVar ELSE ErrorMsg = 'Unable to open ':TableName:' table in for Read. (':Method:')' RETURN END OPEN 'DICT.':TableName TO @DICT ELSE ErrorMsg = 'Unable to open DICT.':TableName:' table for Read. (':Method:')' RETURN END DataOut = '' READ Fields FROM @DICT,'%FIELDS%' ELSE ErrorMsg = 'Unable to read %FIELDS% from DICT.':TableName:' in Export_TSV routine.' RETURN END FilePointer = 0 Def = '' Def = 'Exporting ':TableName:' Data...' Def = 'U' DataArray = '' FOR I = 1 TO COUNT(FieldNames,@VM) + (FieldNames NE '') FieldName = FieldNames<1,I> READV FieldHeader FROM @DICT,FieldName,DICT_DISPLAY$ THEN DataArray = FieldHeader END NEXT I fnCnt = COUNT(FieldNames,@VM) + (FieldNames NE '') FOR I = 1 TO COUNT(KeyList,@VM) + (KeyList NE '') @ID = KeyList<1,I> READ @RECORD FROM TableVar,@ID THEN FOR N = 1 TO fnCnt FieldName = FieldNames<1,N> LOCATE FieldName IN Fields USING @VM SETTING Pos THEN FType = Fields FNo = Fields FMV = Fields FPart = Fields FJust = Fields FConv = Fields IF FNo[1,1] = 0 THEN DataVal = FIELD(@ID,'*',FPart,1) ;* Part or all of record key END ELSE IF FType = 'F' THEN DataVal = @RECORD ;* Real field IF FType = 'S' THEN DataVal = Calculate(FieldName) ;* Symbolic field END IF FConv NE '' THEN DataVal = OCONV(DataVal,FConv) ;* Conversion if required DataArray = DataVal END NEXT N END NEXT I xlApp = OleCreateInstance("excel.Application") OlePutProperty(XlApp, 'Visible', xlSheetVisible) if OleStatus() then Goto HadError xlWorkBooks =OleGetProperty(xlApp, "Workbooks") xlWkb = OleCallMethod(xlWorkbooks,"Add") if OleStatus() then Goto HadError xlSht = OleGetProperty(xlWkb, "Worksheets",1) if OleStatus() then Goto HadError xlPageSetup = OleGetProperty(xlSht,"PageSetup") if OleStatus() then GOTO HadError OlePutProperty( xlPageSetup, 'PrintGridLines', xlTrue ) if OleStatus() then GOTO HadError ColCnt = COUNT(DataArray,@FM) + (DataArray NE '') LineCnt = COUNT(DataArray<1>,@VM) + (DataArray<1> NE '') FOR LineNo = 1 TO LineCnt FOR Column = 1 to ColCnt RangeColumn = eXcelCols<1,Column> range = OleGetProperty( xlSht, 'Range',RangeColumn:LineNo) OlePutProperty(range, 'Value', DataArray) IF OleStatus() THEN GOTO HadError NEXT Column NEXT LineCnt LastColumn = eXcelCols<1,ColCnt> IF OleStatus() THEN GOTO HadError RangeColumn = eXcelCols<1,ColCnt> range = OleGetProperty( xlSht, 'Range','A1:':RangeColumn:LineCnt) Void = OleCallMethod( range, 'AutoFormat', xlRangeAutoFormatClassic1 ) IF OleStatus() THEN GOTO HadError Void = OleCallMethod( xlWkb, 'SaveAs',ExcelFileName, xlWorkbookNormal ) * No error checking -> xl closes if you don't save otherwise. RETURN * * * * * * * ExportTemplate: * * * * * * * ExportID = Parms[1,@RM] TypeOver = Parms[COL2()+1,@RM] IF ExportID = '' THEN ErrorMsg = 'Null Parameter "ExportID" passed to routine. (':Method:')' RETURN END ExportRec = XLATE('EXPORTS',ExportID,'','X') IF ExportRec = '' THEN ErrorMsg = 'Template ':QUOTE(ExportID):' not on file in Exports table. (':Method:')' RETURN END IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver IF TypeOver NE '' THEN ExportRec = TypeOver ExcelFileName = ExportRec TableName = ExportRec ExcelFileName = FIELD(ExcelFileName,'.',1) ExcelFileName = ExcelFileName:'.csv' ;* Standardize the file extension if there is one OPEN TableName TO TableVar ELSE ErrorMsg = 'Unable to open ':TableName:' table in for Read. (':Method:')' OPEN 'DICT.':TableName TO @DICT ELSE ErrorMsg = 'Unable to open DICT.':TableName:' table for Read. (':Method:')' READ DictFields FROM @DICT,'%FIELDS%' ELSE ErrorMsg = 'Unable to read %FIELDS% from DICT.':TableName:' in Export_TSV routine.' IF ErrorMsg NE '' THEN RETURN DataOut = '' FilePointer = 0 Def = '' Def = 'Exporting ':TableName:' Data...' Def = 'U' CLEARSELECT IdxQueryColumns = ExportRec IdxQueryFilters = ExportRec IdxColCnt = COUNT(IdxQueryColumns,@VM) + (IdxQueryColumns NE '') IdxStatement = 'SELECT ':TableName ValNo = 1 FOR I = 1 TO IdxColCnt IdxColumn = IdxQueryColumns<1,I> IdxFilter = IdxQueryFilters<1,I> Operator = FIELD(IdxFilter, ' ', 1 ) Values = FIELD(IdxFilter,' ',2,99 ) SWAP '~' WITH 'NOT ' IN Operator IF TRIM(Operator) = 'FROM' THEN SWAP ' TO ' WITH '" TO "' IN Values IF ValNo = 1 THEN IdxStatement := ' WITH ':IdxColumn:' ':Operator:' ':QUOTE(Values) END ELSE IdxStatement := ' AND WITH ':IdxColumn:' ':Operator:' ':QUOTE(Values) END END ELSE LOOP Value = Values[1,' '] UNTIL Value = '' CONVERT "'" TO '"' IN Value IF NOT(Value[1,1] = '"' AND Value[-1,1] = '"') THEN Value = Quote(Value) ;* Put quotes around values not already quoted Values[1,COL2()] = '' IF ValNo = 1 THEN IdxStatement := ' WITH ':IdxColumn:' ':Operator:' ':Value END ELSE IdxStatement := ' AND WITH ':IdxColumn:' ':Operator:' ':Value END ValNo += 1 REPEAT END ;* End of check for 'FROM' (Date Range) in filter NEXT I * Non Indexed query NIdxQueryColumns = ExportRec NIdxStatement = 'SELECT ':TableName NIdxColCnt = COUNT(NIdxQueryColumns, @VM ) + (NIdxQueryColumns NE '') ValNo = 1 FOR I = 1 TO NIdxColCnt NIdxColumn = NIdxQueryColumns<1,I> NIdxFilter = NIdxQueryFilters<1,I> Operator = FIELD(NIdxFilter, ' ', 1 ) Values = FIELD(NIdxFilter,' ',2,99 ) SWAP '~' WITH 'NOT ' IN Operator IF TRIM(Operator) = 'FROM' THEN SWAP ' TO ' WITH '" TO "' IN Values IF ValNo = 1 THEN NIdxStatement := ' WITH ':NIdxColumn:' ':Operator:' ':QUOTE(Values) END ELSE NIdxStatement := ' AND WITH ':NIdxColumn:' ':Operator:' ':QUOTE(Values) END END ELSE LOOP Value = Values[1,' '] UNTIL Value = '' CONVERT "'" TO '"' IN Value IF NOT(Value[1,1] = '"' AND Value[-1,1] = '"') THEN Value = Quote(Value) ;* Put quotes around values not already quoted Values[1,COL2()] = '' IF ValNo = 1 THEN NIdxStatement := ' WITH ':NIdxColumn:' ':Operator:' ':Value END ELSE NIdxStatement := ' AND WITH ':NIdxColumn:' ':Operator:' ':Value END ValNo += 1 REPEAT END NEXT I RList(IdxStatement, TARGET_ACTIVELIST$, '', '', '' ) ;* This select always runs IF Get_Status(errCode) THEN ErrMsg(errCode) RETURN END IF ExportRec NE '' THEN RList(NIdxStatement, TARGET_ACTIVELIST$, '', '', '' ) ;* This one only runs if there is a non-indexed filter present IF Get_Status(errCode) THEN RETURN END END IF NOT(@RECCOUNT) THEN MsgInfo = '' MsgInfo = 'No records meeting your search criteria...' MsgInfo = '!' RETURN END ExpColumns = ExportRec ExpColCnt = COUNT(ExpColumns,@VM) + (ExpColumns NE '') ExpandMV = ExportRec IF ExpandMV THEN KeyFields = '' FieldNames = DictFields FOR I = 1 TO COUNT(FieldNames,@VM) + (FieldNames NE '') IF DictFields = '0' THEN IF DictFields NE '' THEN KeyFields<1,DictFields> = FieldNames<1,I> ;* Build MV's list of key field names END ELSE Keyfields<1,1> = FieldNames<1,I> ;* Or just the single value END END NEXT I KFCount = COUNT(KeyFields,@VM) + (Keyfields NE '') FOR N = KFCount TO 1 Step -1 KeyField = Keyfields<1,N> LOCATE KeyField IN ExpColumns USING @VM SETTING Pos ELSE ExpColumns = INSERT(ExpColumns,1,1,0,KeyField) ;* Insert key column not already in the columns list at the front END NEXT N ExpColCnt = COUNT(ExpColumns,@VM) + (ExpColumns NE '') END DataOut = '' FOR I = 1 TO ExpColCnt ExpColumn = ExpColumns<1,I> READV ExpColHeader FROM @DICT,ExpColumn,DICT_DISPLAY$ THEN CONVERT @VM TO ' ' IN ExpColHeader ;* Multi-Line headings - convert to flat DataOut := QUOTE(ExpColHeader):',' END NEXT I DataOut := CRLF$ Def = "" Def = "Building Export..." Def = "GC" Def = @RECCOUNT Def = 400 RecCnt = 0 LineCnt = 1 ;* Headings are on line 1 already Done = 0 LOOP READNEXT @ID Else Done = 1 UNTIL Done READ @RECORD FROM TableVar,@ID THEN RecCnt += 1 MaxMVCnt = 0 LineCnt += 1 LineOut = '' Continue = TRUE$ FOR MV = 1 TO 999 WHILE Continue Continue = FALSE$ FOR N = 1 TO ExpColCnt ExpColumn = ExpColumns<1,N> LOCATE ExpColumn IN DictFields USING @VM SETTING Pos THEN FType = DictFields FNo = DictFields FMV = DictFields FPart = DictFields FJust = DictFields FConv = DictFields IF FNo[1,1] = 0 THEN * @ID field DataVal = FIELD(@ID,'*',FPart,1) END ELSE IF FType = 'F' THEN DataVal = @RECORD IF FType = 'S' THEN DataVal = Calculate(ExpColumn) END END IF FConv NE '' THEN DataVal = OCONV(DataVal,FConv) CONVERT '"' TO ' ' IN DataVal IF ExpandMV AND DataVal<1,MV> = '' AND NOT(FMV) THEN DataVal = QUOTE( DataVal<1,1> ) END ELSE DataVal = QUOTE( DataVal<1,MV> ) END DataOut := DataVal:',' IF LEN( DataVal<1,MV+1> ) THEN Continue = TRUE$ END END NEXT N DataOut := CRLF$ NEXT MV END rv = 1 WHILE rv REPEAT OSWrite DataOut To ExcelFileName xlApp = OleCreateInstance("excel.Application") OlePutProperty(XlApp, 'Visible', xlSheetVisible) if OleStatus() then Goto HadError xlWorkBooks = OleGetProperty(xlApp, "Workbooks") if OleStatus() then Goto HadError x = OleCallMethod(xlWorkbooks,"OpenText",ExcelFileName) if OleStatus() then Goto HadError xlWorkBook = OleGetProperty(xlApp,"ActiveWorkbook") if OleStatus() then Goto HadError xlSht = OleGetProperty(xlWorkBook,"ActiveSheet") if OleStatus() then Goto HadError xlPageSetup = OleGetProperty(xlSht,"PageSetup") if OleStatus() then GOTO HadError OlePutProperty( xlPageSetup, 'PrintGridLines', xlTrue ) if OleStatus() then GOTO HadError RangeColumn = eXcelCols<1,ExpColCnt> range = OleGetProperty( xlSht, 'Range','A1:':RangeColumn:LineCnt) Void = OleCallMethod( range, 'AutoFormat', xlRangeAutoFormatClassic1 ) IF OleStatus() THEN GOTO HadError TextFileName = ExcelFileName SWAP '.csv' WITH '.txt' IN TextFileName Void = OleCallMethod( xlWkb, 'SaveAs',TextFileName, xlWorkbookNormal ) * No error checking -> xl closes if you don't save otherwise. RETURN * * * * * * * HadError: * * * * * * * a = OleStatus() xlChart = '' Charts = '' range = '' xlSht = '' xlWkb='' xlWorkBooks = '' x = OleCallMethod(xlApp, 'Quit') IF NOT(ASSIGNED(DosTable)) THEN DosTable = ExcelFileName Def = '' Def = 'File ':DosTable:' written.' Def = 'TA3' RETURN