COMPILE FUNCTION Comm_Exports(Instruction, Parm1, Parm2, Parm3) #pragma precomp SRP_PreCompiler /* Commuter module for Exports 12/14/2007 - John C. Henry, J.C. Henry & Co., Inc. */ DECLARE SUBROUTINE Set_Property, End_Dialog, Send_Event, Set_Status,RList, ErrMsg, Make.List DECLARE SUBROUTINE ErrMsg, Send_Message, Set_Property, Send_Event, Btree.Extract, obj_AppWindow DECLARE SUBROUTINE Update_Index, SetInitDirOptions, Yield, Security_Err_Msg, Utility, Database_Services DECLARE FUNCTION Get_Property, Get_Status, Dialog_Box, Utility, Center_Window, Popup, Collect.Ixvals, SRP_DateTime DECLARE FUNCTION Send_Message, Security_Check, Message_Box, obj_ICAR, obj_Export, MemberOf, Environment_Services DECLARE FUNCTION Datetime, Database_Services $INSERT EXPORTS_EQU $INSERT RLIST_EQUATES $INSERT MSG_EQUATES $INSERT DICT_EQUATES $INSERT MESSAGE_BOX_EQUATES $INSERT APPCOLORS $INSERT SECURITY_RIGHTS_EQU $INSERT POPUP_EQUATES $INSERT LOGICAL $INSERT EXCEL_EQU EQU CRLF$ TO \0D0A\ EQU COL$QUERY_COL TO 1 EQU COL$QUERY_FILTER TO 2 ErrTitle = 'Error in Comm_Exports' ErrorMsg = '' Result = '' BEGIN CASE CASE Instruction = 'Create' ; GOSUB Create CASE Instruction = 'Read' ; GOSUB Read CASE Instruction = 'LUExportName' ; GOSUB LUExportName CASE Instruction = 'Refresh' ; GOSUB Refresh CASE Instruction = 'LUTable' ; GOSUB LUTable CASE Instruction = 'LUColumns' ; GOSUB LUColumns CASE Instruction = 'ColumnMove' ; GOSUB ColumnMove CASE Instruction = 'ClearColumns' ; GOSUB ClearColumns CASE Instruction = 'IdxDC' ; GOSUB IdxDC CASE Instruction = 'NIdxDC' ; GOSUB NIdxDC CASE Instruction = 'PathChange' ; GOSUB PathChange CASE Instruction = 'Export' ; GOSUB Export CASE 1 ErrorMsg = 'Unknown Instruction passed to routine.' ErrMsg(ErrorMsg) END CASE RETURN Result * * * * * * * Create: * * * * * * * obj_Appwindow('Create') TemplatePassed = FIELD( Parm1, '*', 1 ) SystemGenerated = FALSE$ IF INDEX( Parm1, 'NOEXCEL', 1 ) THEN Set_Property( @WINDOW, '@NoExcel', 1 ) END ELSE Set_Property( @WINDOW, '@NoExcel', 0 ) END IF INDEX( Parm1, 'SYSTEM_GENERATED', 1 ) THEN SystemGenerated = TRUE$ END * This system generated stuff will move to obj_Export as a method JCH * These hide the window from the user and just run a predefined export IF SystemGenerated THEN Set_Property( @WINDOW, '@SystemGenerated', TRUE$ ) Set_Property( @WINDOW, '@CurCustomer', FIELD( Parm1, '*', 3 ) ) TemplateToUse = FIELD( Parm1, '*', 2 ) Set_Property(@WINDOW:'.EXPORT_NAME','TEXT', TemplateToUse) Send_event( @WINDOW:'.EXPORT_NAME', 'LOSTFOCUS' ) Send_event( @WINDOW:'.EXPORT_BUTTON', 'CLICK' ) END IF TemplatePassed THEN Set_Property(@WINDOW:'.EXPORT_NAME','TEXT',TemplatePassed) Send_event( @WINDOW:'.EXPORT_NAME', 'LOSTFOCUS' ) END GOSUB Refresh RETURN * * * * * * * LUExportName: * * * * * * * IF NOT(ASSIGNED(Parm1)) THEN FocusControl = '' ELSE FocusControl = Parm1 IF NOT(ASSIGNED(Parm2)) THEN FocusPos = '' ELSE FocusPos = Parm2 RList('SELECT EXPORTS BY NAME WITH SHARABLE = 1 OR WITH ENTRY_ID = ':QUOTE(@USER4), TARGET_ACTIVELIST$, '', '', '' ) Result = PopUp(@WINDOW,'','SHOW_EXPORTS') IF Result NE '' THEN obj_Appwindow('LoadFormKeys',@WINDOW:@RM:Result) END RETURN * * * * * * * Read: * * * * * * * ExportID = Get_Property(@WINDOW:'.EXPORT_NAME','TEXT') IF ROWEXISTS( 'EXPORTS', ExportID ) THEN IF Get_Property(@WINDOW:'.SHARABLE','CHECK') NE 1 THEN IF @USER4 NE XLATE('EXPORTS',ExportID,EXPORTS_ENTRY_ID$,'X') THEN Message = 'You are only allowed to view sharable or your own Export Templates...' Message = 'H' Msg( '', Message ) Set_Property(@WINDOW,'SAVEWARN',0) Send_Event(@WINDOW,'CLEAR') RETURN END END ExportTableName = Get_Property(@WINDOW:'.TABLE','TEXT') ExportTableName = OCONV( ExportTableName, '[TABLENAME_CONV]' ) IF NOT(Security_Check(ExportTableName,READ$)) THEN ErrMsg('You do not have Read rights to the Table used in this export.') Set_Property(@WINDOW,'SAVEWARN',0) Send_Event(@WINDOW,'CLEAR') RETURN END END ELSE IF Get_Property(@WINDOW:'.ENTRY_ID','TEXT') = '' THEN Set_Property(@WINDOW:'.ENTRY_ID','TEXT', OCONV( @USER4, '[XLATE_CONV,LSL_USERS*FIRST_LAST]' )) Set_Property(@WINDOW:'.ENTRY_DATE','TEXT',OCONV(Date(),'D4/')) END END ;* End of check for existing record RETURN * * * * * * * LUTable: * * * * * * * FocusCtrl = Parm1 IF FocusCtrl = '' THEN FocusCtrl = Get_Property(@WINDOW,'@FOCUS') END ELSE IF NOT(INDEX(FocusCtrl,'.',1)) THEN FocusCtrl = @WINDOW:'.':FocusCtrl END END ExportTableNamesInt = XLATE( 'LISTBOX_CONFIG', 'EXPORTTABLENAMES', 1, 'X' ) ExportTableNamesExt = OCONV( ExportTableNamesInt, '[TABLENAME_CONV]' ) AuthorizedTables = '' TableCnt = COUNT(ExportTableNamesInt,@VM) + (ExportTableNamesInt NE '') LoadCnt = 0 FOR I = 1 TO TableCnt Table = ExportTableNamesInt<1,I> IF Table EQ 'PM_SCHED' AND MemberOf(@USER4, 'OI_SUPERUSER') THEN Null ;//DEBUG IF Table EQ 'ICAR' AND NOT(obj_ICAR('RespSup') ) THEN Null IF Security_Check( ExportTableNamesExt<1,I>, Read$ ) THEN LoadCnt += 1 AuthorizedTables<1,LoadCnt,1> = ExportTableNamesExt<1,I> AuthorizedTables<1,LoadCnt,2> = ExportTableNamesInt<1,I> END NEXT I IF AuthorizedTables NE '' THEN IF MemberOf(@USER4, 'OI_SUPERUSER') THEN LoadCnt += 1 AuthorizedTables<1,LoadCnt,2> = 'NOTES' AuthorizedTables<1,LoadCnt+1,2> = 'MODS' END END TypeOver = '' Typeover = AuthorizedTables Table = Popup(@WINDOW,TypeOver,'EXPORT_TABLES') errCode = '' IF Get_Status(errCode) THEN ErrMsg(errCode) RETURN END IF Table NE '' THEN obj_AppWindow('LUValReturn',Table:@RM:FocusCtrl) END GOSUB Refresh RETURN * * * * * * * LUColumns: * * * * * * * SelPos = Get_Property(@WINDOW:'.COLUMNS','SELPOS') CurrRow = SelPos<2> CurrTable = Get_Property(@WINDOW:'.TABLE','TEXT') CurrTableColumns = Get_Property(@WINDOW,'@COLUMNS') PopupData = '' FOR I = 1 TO COUNT(CurrTableColumns,@VM) + (CurrTableColumns NE '') CurrColumn = CurrTableColumns<1,I> PopupData<1,I,1> = CurrColumn PopupData<1,I,2> = XLATE('DICT.':CurrTable,CurrColumn,DICT_DESC$,'X') NEXT I TypeOver = '' TypeOver = PopupData SelectedColumns = Popup(@WINDOW,TypeOver,'DICT_COLUMNS') IF SelectedColumns NE '' THEN CONVERT @FM TO @VM IN SelectedColumns CurrArray = Get_Property(@WINDOW:'.COLUMNS','ARRAY') CurrArray = Delete( CurrArray, 1, CurrRow, 0 ) CurrArray = Insert( CurrArray, 1, CurrRow, 0, SelectedColumns ) Set_Property(@WINDOW:'.COLUMNS','ARRAY', CurrArray) END RETURN * * * * * * * Refresh: * * * * * * * Ctrls = @WINDOW:'.UTIL_START':@RM ; Props = 'VISIBLE':@RM Ctrls := @WINDOW:'.UTIL_END':@RM ; Props := 'VISIBLE':@RM Ctrls := @WINDOW:'.UTIL_START_LABEL':@RM ; Props := 'VISIBLE':@RM Ctrls := @WINDOW:'.UTIL_END_LABEL' ; Props := 'VISIBLE' ExportTableName = Get_Property(@WINDOW:'.TABLE','TEXT') IF ExportTableName = 'REACT_UTIL' THEN Vals = '1':@RM:'1':@RM:'1':@RM:'1' END ELSE Vals = '0':@RM:'0':@RM:'0':@RM:'0' END Set_Property(Ctrls,Props,Vals) AllCols = '' BtreeCols = '' QueryCols = '' IF ExportTableName NE '' THEN DictFields = XLATE('DICT.':ExportTableName,'%FIELDS%','','X') FOR I = 1 TO COUNT(DictFields,@VM) + (DictFields NE '') FieldType = DictFields FieldName = DictFields IF FieldType = 'F' OR FieldType = 'S' THEN AllCols<1,-1> = FieldName IF DictFields = 1 THEN BtreeCols<1,-1> = FieldName END ELSE QueryCols<1,-1> = FieldName END END NEXT I END Set_Property(@WINDOW,'@COLUMNS',AllCols) Set_Property(@WINDOW,'@BTREECOLUMNS',BtreeCols) Set_Property(@WINDOW,'@QCOLUMNS',QueryCols) RETURN * * * * * * * ColumnMove: * * * * * * * Direction = Parm1 IF Direction = '' THEN RETURN CtrlEntID = @WINDOW:'.COLUMNS' ExpColumns = Get_Property(CtrlEntID,'ARRAY') CurrPos = Get_Property(CtrlEntID,'SELPOS') CurrRow = CurrPos<2> SWAP @VM:@VM WITH '' IN ExpColumns IF ExpColumns[-1,1] = @VM THEN ExpColumns[-1,1] = '' ;* Trims trailing blank lines BEGIN CASE CASE Direction = 'UP' NewRow = CurrRow - 1 CASE Direction = 'DOWN' NewRow = CurrRow + 1 CASE Direction = 'TOP' NewRow = 1 CASE Direction = 'BOTTOM' NewRow = COUNT(ExpColumns<1>,@VM) + (ExpColumns<1> NE '') END CASE RowData = ExpColumns<1,CurrRow> IF RowData <> '' THEN ExpColumns = DELETE( ExpColumns, 1, CurrRow, 0 ) ExpColumns = INSERT( ExpColumns, 1, NewRow, 0, RowData ) Set_Property(CtrlEntID,'ARRAY',ExpColumns) Set_Property(CtrlEntID,'SELPOS',1:@FM:NewRow) END RETURN * * * * * * * ClearColumns: * * * * * * * CurrArray = Get_Property(@WINDOW:'.COLUMNS','ARRAY') FOR I = 1 TO COUNT(CurrArray,@VM) + (CurrArray NE '') CurrArray<1,I> = '' NEXT I Set_Property(@WINDOW:'.COLUMNS','ARRAY', CurrArray) RETURN * * * * * * * IdxDC: * * * * * * * CtrlEntID = @WINDOW:'.QUERY_INFO' CurrPos = Get_Property(CtrlEntID,'SELPOS') CurrCol = CurrPos<1> CurrRow = CurrPos<2> IF CurrCol = COL$QUERY_COL THEN CurrTable = Get_Property(@WINDOW:'.TABLE','TEXT') CurrTableColumns = Get_Property(@WINDOW,'@BTREECOLUMNS') PopupData = '' FOR I = 1 TO COUNT(CurrTableColumns,@VM) + (CurrTableColumns NE '') CurrColumn = CurrTableColumns<1,I> PopupData<1,I,1> = CurrColumn PopupData<1,I,2> = XLATE('DICT.':CurrTable,CurrColumn,DICT_DESC$,'X') NEXT I TypeOver = '' TypeOver = PopupData SelectedColumns = Popup(@WINDOW,TypeOver,'DICT_COLUMNS') IF SelectedColumns NE '' THEN SelColDelimCnt = COUNT(SelectedColumns,@VM) CurrArray = Get_Property(CtrlEntID,'ARRAY') CurrArray = INSERT(CurrArray,COL$QUERY_COL, CurrRow, 0, SelectedColumns ) CurrArray = INSERT(CurrArray,COL$QUERY_FILTER,CurrRow,0,STR(@VM,SelColDelimCnt)) Set_Property(CtrlEntID,'ARRAY', CurrArray) END END IF CurrCol = COL$QUERY_FILTER THEN CurrArray = Get_Property(CtrlEntID,'ARRAY') Column = CurrArray Filter = CurrArray NewFilter = Dialog_Box( 'EXPORTS2', @WINDOW, Column:'*':Filter ) IF NewFilter NE Filter And NewFilter NE 'CANCEL' THEN CurrArray = NewFilter Set_Property(CtrlEntID,'ARRAY', CurrArray) END END RETURN * * * * * * * NIdxDC: * * * * * * * CtrlEntID = @WINDOW:'.NQUERY_INFO' CurrPos = Get_Property(CtrlEntID,'SELPOS') CurrCol = CurrPos<1> CurrRow = CurrPos<2> IF CurrCol = COL$QUERY_COL THEN CurrTable = Get_Property(@WINDOW:'.TABLE','TEXT') CurrTableColumns = Get_Property(@WINDOW,'@QCOLUMNS') PopupData = '' FOR I = 1 TO COUNT(CurrTableColumns,@VM) + (CurrTableColumns NE '') CurrColumn = CurrTableColumns<1,I> PopupData<1,I,1> = CurrColumn PopupData<1,I,2> = XLATE('DICT.':CurrTable,CurrColumn,DICT_DESC$,'X') NEXT I TypeOver = '' TypeOver = PopupData SelectedColumns = Popup(@WINDOW,TypeOver,'DICT_COLUMNS') IF SelectedColumns NE '' THEN SelColDelimCnt = COUNT(SelectedColumns,@VM) CurrArray = Get_Property(CtrlEntID,'ARRAY') CurrArray = INSERT(CurrArray,COL$QUERY_COL, CurrRow, 0, SelectedColumns ) CurrArray = INSERT(CurrArray,COL$QUERY_FILTER,CurrRow,0,STR(@VM,SelColDelimCnt)) Set_Property(CtrlEntID,'ARRAY', CurrArray) END END IF CurrCol = COL$QUERY_FILTER THEN CurrArray = Get_Property(CtrlEntID,'ARRAY') Column = CurrArray Filter = CurrArray NewFilter = Dialog_Box( 'EXPORTS2', @WINDOW, Column:'*':Filter ) IF NewFilter NE Filter And NewFilter NE 'CANCEL' THEN CurrArray = NewFilter Set_Property(CtrlEntID,'ARRAY', CurrArray) END END * * * * * * * PathChange: * * * * * * * CtrlEntID = @WINDOW:'.PATH' Path = Get_Property(CtrlEntID,'DEFPROP') IF INDEX(Path,'/',1) THEN Call ErrMsg('"/" characters are invalid in paths. Use "\" instead.') END RETURN * * * * * * * HadError: * * * * * * * status = OleStatus() IF Status THEN ErrMsg('OLE Error Code ':Status) END xlChart = '' Charts = '' range = '' xlSht = '' xlWkb='' xlWorkBooks = '' x = OleCallMethod(xlApp, 'Quit') RETURN * * * * * * * CheckError: ErrorCodes = '' Status = get_Status( ErrorCodes ) Parent = '' ErrorCode = Get_Property( Parent, 'DDEERROR' ) return * * * * * * * * * * * * * * Export: * * * * * * * * New Version places export data onto the users CLIPBOARD and attempts to start Excel * Good Start -> data is pasted into Excel and formatted. * Bad Start -> user is told that the data is on the CLIPBOARD of their local machine // Record when it was last run, so we can audit and get the old stuff out of here exportRec = Database_Services('ReadDataRow', 'EXPORTS', @ID) exportKey = @ID exportRec = SRP_DateTime("Combine", DateTime()) exportRec = @USER4 Database_Services('WriteDataRow', 'EXPORTS', exportKey, exportRec, True$, False$, True$) UtilStartDt = Get_Property(@WINDOW:'.UTIL_START','INVALUE') UtilEndDt = Get_Property(@WINDOW:'.UTIL_END','INVALUE') SystemGenerated = Get_Property(@WINDOW,'@SystemGenerated') NoExcel = Get_Property(@WINDOW,'@NoExcel') ExpandMV = Get_Property(@WINDOW:'.EXPAND_MV','CHECK') Table = Get_Property(@WINDOW:'.TABLE','TEXT') DictTable = 'DICT.':Table OPEN Table TO TableVar ELSE Msg( '', 'Unable to open ':Table:'...' ) RETURN END OPEN DictTable TO @dict ELSE Msg( '', 'Unable to open ':DictTable:'...' ) RETURN END CLEARSELECT Statement = 'SELECT ':Table ExportCols = Get_Property(@WINDOW:'.COLUMNS','ARRAY')<1> ;* Export columns SWAP @VM:@VM WITH '' IN ExportCols IF ExportCols[-1,1] = @VM THEN ExportCols[-1,1] = '' IdxQuery = Get_Property(@WINDOW:'.QUERY_INFO','ARRAY') IdxFilters = IdxQuery IdxColumns = IdxQuery SWAP @VM:@VM WITH '' IN IdxColumns ; IF IdxColumns[-1,1] = @VM THEN IdxColumns[-1,1] = '' ;* Trim Trailing blanks SWAP @VM:@VM WITH '' IN IdxFilters ; IF IdxFilters[-1,1] = @VM THEN IdxFilters[-1,1] = '' IdxColCnt = FieldCount( IdxColumns, @VM ) ExportColCnt = FieldCount( ExportCols, @VM ) * * * Indexed Query * * * ValNo = 1 FOR I = 1 TO IdxColCnt IdxColumn = IdxColumns<1,I> IdxFilter = IdxFilters<1,I> Operator = FIELD(IdxFilter, ' ', 1 ) IF Operator = '<>' THEN Operator = '#' IF Operator = 'NE' THEN Operator = '#' Values = FIELD(IdxFilter,' ',2,99 ) ValNo = 1 IF TRIM(Operator) = 'FROM' THEN SWAP ' TO ' WITH '" TO "' IN Values IF I = 1 THEN Statement := ' WITH ':IdxColumn:' ':Operator:' ':QUOTE(Values) END ELSE Statement := ' AND WITH ':IdxColumn:' ':Operator:' ':QUOTE(Values) END END ELSE SWAP '~' WITH 'NOT ' IN Operator SWAP ' ' WITH '" "' IN Values Values = QUOTE(Values) IF I = 1 THEN Statement := ' WITH ':IdxColumn:' ':Operator:' ':Values END ELSE Statement := ' AND WITH ':IdxColumn:' ':Operator:' ':Values END END ;* End of check for 'FROM' (Date Range) in filter NEXT I IF Statement NE 'SELECT ':Table THEN DoneSelect = TRUE$ Utility( 'CURSOR', 'H' ) RList( Statement, TARGET_ACTIVELIST$, '', '', '' ) IF Get_Status(errCode) THEN CALL ErrMsg(errCode) RETURN END END ELSE DoneSelect = FALSE$ END * * * Non Indexed query * * * Statement = 'SELECT ':Table NIdxQuery = Get_Property(@WINDOW:'.NQUERY_INFO','ARRAY') NIdxColumns = NIdxQuery NIdxFilters = NIdxQuery * Trim Trailing blanks SWAP @VM:@VM WITH '' IN NIdxColumns ; IF NIdxColumns[-1,1] = @VM THEN NIdxColumns[-1,1] = '' SWAP @VM:@VM WITH '' IN NIdxFilters ; IF NIdxFilters[-1,1] = @VM THEN NIdxFilters[-1,1] = '' NIdxColCnt =COUNT(NIdxColumns, @VM ) + (NIdxColumns NE '') ValNo = 1 FOR I = 1 TO NIdxColCnt NIdxColumn = NIdxColumns<1,I> NIdxFilter = NIdxFilters<1,I> Operator = FIELD(NIdxFilter, ' ', 1 ) Values = FIELD(NIdxFilter,' ',2,99 ) IF TRIM(Operator) = 'FROM' THEN SWAP ' TO ' WITH '" TO "' IN Values IF ValNo = 1 THEN Statement := ' WITH ':NIdxColumn:' ':Operator:' ':QUOTE(Values) END ELSE Statement := ' AND WITH ':NIdxColumn:' ':Operator:' ':QUOTE(Values) END END ELSE SWAP '~' WITH 'NOT ' IN Operator 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 END Values[1,COL2()] = '' IF ValNo = 1 THEN Statement := ' WITH ':NIdxColumn:' ':Operator:' ':Value END ELSE Statement := ' AND WITH ':NIdxColumn:' ':Operator:' ':Value END ValNo += 1 REPEAT END NEXT I IF Statement <> 'SELECT ':Table THEN Utility( 'CURSOR', 'H' ) RList( Statement, target_activelist$, '', '', '' ) END ELSE IF DoneSelect = FALSE$ THEN MsgInfo = '' MsgInfo = 'You have not defined any query information...Do you wish TO export the whole table?' MsgInfo = '?' MsgInfo = 'BNYC' IF SystemGenerated THEN Resp = 1 END ELSE Resp = Msg( '', MsgInfo ) END IF Resp = 1 THEN Utility( 'CURSOR', 'H' ) RList( Statement, TARGET_ACTIVELIST$, '', '', '' ) IF Get_Status(errCode) THEN CALL ErrMsg(errCode) RETURN END END ELSE RETURN END END END ExportColCnt = COUNT(ExportCols,@VM ) + (ExportCols NE '') BytePos = 0 * Build Qty and List of columns without output conversions TextColCnt = 0 TextColNos = '' FOR I = 1 TO ExportColCnt OutConversion = XLATE( DictTable, ExportCols<1,I>, DICT_CONV$, 'X' ) IF OutConversion = '' OR OutConversion[1,2] = 'DT' THEN TextColCnt +=1 TextColNos<1,TextColCnt> = I END NEXT I PasteOut = '' PasteBlob = '' TextCols = '' ColNames = ExportCols CONVERT @VM TO @FM IN ColNames ColHeads = XLATE( DictTable, ColNames, DICT_DISPLAY$, 'X' ) ;* Get column headings CONVERT @VM TO ' ' IN ColHeads ;* Convert multi-lined headings to single line ExportData = '' ;* Used when writing export data to DOS FOR I = 1 TO ExportColCnt PasteOut<1,I> = ColHeads ExportData := QUOTE(ColHeads):',' NEXT I PasteOut := @FM PasteBlob<-1> = PasteOut ExportData := CRLF$ FieldsRec = XLATE( DictTable, '%FIELDS%', '', 'X' ) * setup positions or tag as null FMCs = '' KeyParts = '' OutConvs = '' MVFlags = '' FOR I = 1 TO ExportColCnt LOCATE ExportCols<1,I> IN FieldsRec<3> USING @VM SETTING FPos THEN FMCs = FieldsRec KeyParts = FieldsRec OutConvs = FieldsRec MVFlags = FieldsRec END ELSE MsgInfo = '' MsgInfo = 'Unable TO locate ':ExportCols<1,I>:' in %FIELDS%...Get Bryce for Help.' MsgInfo = '!' Void = msg( '', MsgInfo ) RETURN END NEXT I IF ExpandMV THEN LOCATE 0 IN FMCs USING @FM SETTING IDPos ELSE MsgText = 'You have chosen to expand multi-values, you must select the ID to the table as one ' MsgText := 'of your export colums, so you know which record each value corresponds to. ' MsgText := 'Typically this is SEQ.' MsgInfo = '' MsgInfo = MsgText MsgInfo = 'H' Void = msg( '', MsgInfo ) RETURN END END Def = "" Def = "Building Export..." Def = "GC" Def = @RECCOUNT Def = 400 MsgUp = Msg(@WINDOW, Def) ;* Put up the gas gauge @RN.COUNTER = 0 RecCnt = 0 Done = 0 RowCnt = 0 LOOP READNEXT @ID ELSE Done = 1 UNTIL Done READ @RECORD FROM TableVar, @ID ELSE GOTO SkipRecord END BlobOut = '' PasteOut = '' Continue = TRUE$ FOR MVLine = 1 TO 999 WHILE Continue Continue = FALSE$ FOR ExpColNo = 1 TO ExportColCnt ThisFmc = FMCs IsMV = MVFlags IF ThisFmc <> '' THEN IF ThisFmc = 0 THEN IF KeyParts NE '' THEN ExDataVal = FIELD(@ID,'*',KeyParts) END ELSE ExDataVal = @ID END CONVERT '"' TO '' in ExDataVal ThisOutput = OutConvs END ELSE ExDataVal = @RECORD CONVERT '"' TO '' in ExDataVal ThisOutput = OutConvs END END ELSE ExDataVal = CALCULATE( ExportCols<1,ExpColNo> ) CONVERT '"' TO '' IN ExDataVal ThisOutput = OutConvs END IF ThisOutput THEN IF ExpandMV AND ExDataVal<1,MVLine> = '' AND not(IsMV) THEN BlobOut := QUOTE( OCONV(ExDataVal<1,1>, ThisOutput ) ):',' PasteOut := OCONV(ExDataVal<1,1>,ThisOutput):@VM END ELSE BlobOut := QUOTE( OCONV(ExDataVal<1,MVLine>, ThisOutput ) ):',' PasteOut := OCONV(ExDataVal<1,MVLine>,ThisOutput):@VM END END ELSE IF ExpandMV AND ExDataVal<1,MVLine> = '' AND not(IsMV) THEN BlobOut := QUOTE(ExDataVal<1,1> ):',' PasteOut := ExDataVal<1,1>:@VM END ELSE BlobOut := QUOTE(ExDataVal<1,MVLine> ):',' PasteOut := ExDataVal<1,MVLine>:@VM END END IF LEN(ExDataVal<1,MVLine + 1> ) THEN Continue = TRUE$ END NEXT ExportColNo IF PasteOut[-1,1] = @VM THEN PasteOut[-1,1] = '' PasteOut := @FM BlobOut := CRLF$ RowCnt += 1 NEXT MVLine ExportData := BlobOut PasteBlob := PasteOut WHILE Msg(@window, MsgUp, @RN.COUNTER, MSGINSTUPDATE$) SkipRecord: REPEAT Msg(@WINDOW, MsgUp) ;* take down the gauge * If text file required -> write BLOB out to the specified DOS filename. DosTable = Get_Property(@WINDOW:'.PATH','TEXT') IF DosTable NE '' THEN IF DosTable[1,1] = 'C' or DosTable[1,1] = 'V' or DosTable[1,1] EQ 'D' ELSE MsgText = 'You must export only to your C: drive, or IF you are using terminal server use the ' MsgText := 'V: drive...Please change the export path to reflect this.' MsgInfo = '' MsgInfo = MsgText MsgInfo = '!' Msg( '', MsgInfo ) RETURN END DosTable[1,1] = 'C' Status() = 0 OSWRITE '' ON DosTable Tstat = Status() IF Tstat THEN Err = 'Bad operating system filename (e1431)' Err<-1> = 'Access Denied' Err<-1> = 'Disk or Directory full' Err<-1> = 'Operating system error not defined elsewhere' Err<-1> = 'Attempt to write a read only file' Void = msg( '', Err ) END ELSE Status() = 0 OSWrite ExportData TO DosTable MsgStruct = '' MsgStruct = 'T2' MsgStruct = 'Export Data Written' MsgStruct = 'Export Data Successfully Written To ':DosTable MsgStruct = '*' OK = Msg(@WINDOW,MsgStruct,'') END END * * * * * * SWAP @VM WITH CHAR(9) IN PasteBlob SWAP @FM WITH CRLF$ IN PasteBlob CALL Set_Property('CLIPBOARD', 'TEXT', PasteBlob) * * * Paste it into a blank Excel Sheet xlApp = OleCreateInstance("excel.Application") IF OleStatus() THEN ErrorMsg = 'Excel failed to start.':CRLF$:CRLF$ ErrorMsg := 'The data from this export is on your clipboard and can be pasted into Excel on your local machine using .' ErrMsg(ErrorMsg) END xlWorkBooks = OleGetProperty(xlApp, "Workbooks") xlWorkBook = OleCallMethod(xlWorkBooks,'Add') * * * wait a second Now = Time() LOOP CALL Yield() WHILE Time() EQ Now REPEAT OlePutProperty(XlApp, 'Visible', xlSheetVisible) void = OleCallMethod(xlWorkBook,'Activate') xlActiveSheet = OleGetProperty(xlWorkBook,'ActiveSheet') void = OleCallMethod(xlActiveSheet,'Paste') eXcelCols = obj_Export('ExcelCol',TextColNos) ;* Returns alpha Excel columns from numeric columns FirstLastCols = obj_Export('ExcelCol',1:@VM:ExportColCnt) FirstColumn = FirstLastCols[1,@VM] LastColumn = FirstLastCols[COL2()+1,@VM] range = OleGetProperty(xlActiveSheet,'Range',FirstColumn:'1:':LastColumn:'1') font = OleGetProperty(range,'Font') OlePutProperty(font,'FontStyle','Bold') OlePutProperty(font,'UnderLine',xlUnderlineStyleSingle) column = OleGetProperty(xlActiveSheet,'Columns',FirstColumn:':':LastColumn) void = OleCallMethod(column,'AutoFit') RETURN