! ! Excel to tab separated value file ! ! fileDir: The file directory ! fileNames: The multiple file name parts separated by '|' ! subroutine svExcelToTSV(fileDir,fileNames) use svKinds character(*), intent(in) :: fileDir character(*), intent(in) :: fileNames !Multiple file names in gino format, separated by | character with supplemental | character appended character(1024) :: macroName character(1024) :: filePath character(128) :: fileList(200) !Maximum of 200 files allowed presently integer(b32) :: fileCount integer(b32) :: fileMax integer(b32) :: cStart integer(b32) :: cEnd integer(b32) :: lfn = 71 integer(b32) :: ios !IO status ! ! Initialize and identify the list of files (file names separated by "|" character) ! fileList = " " fileCount = 0 cStart = 1 cEnd = 1 do i = 1,len_trim(filenames) if (fileNames(i:i) == "|") then cEnd = i-1 fileCount = fileCount + 1 fileList(fileCount) = fileNames(cStart:cEnd) cStart = i+1 if (fileCount > size(fileList)) exit end if end do fileMax = fileCount fileCount = 1 if (fileMax < 1) then call guierr('Error','No files selected') return end if ! ! First create the VB Script macro in the target directory ! macroName = trim(fileDir) // '\' // 'svExcel2TSV.vbs' open(lfn,file=trim(macroName),status='unknown',iostat=ios) if (ios /= 0) then call guierr('Error','Unable to create conversion macro, check write access to folder') return end if ! ! Write the macro content ! write(lfn,'(a)')'Const xlText = -4158' write(lfn,'(a)')'Set objArgs = WScript.Arguments' write(lfn,'(a)')'For I = 0 to objArgs.Count - 1' write(lfn,'(a)')'FullName = objArgs(I)' write(lfn,'(a)')'FileName = Left(objArgs(I), InstrRev(objArgs(I), ".") )' write(lfn,'(a)')'Set objExcel = CreateObject("Excel.application")' write(lfn,'(a)')'Set objExcelBook = objExcel.Workbooks.Open(FullName)' write(lfn,'(a)')'objExcel.application.visible=false' write(lfn,'(a)')'objExcel.application.displayalerts=false' write(lfn,'(a)')'objExcelBook.SaveAs FileName & "tsv", xlText' write(lfn,'(a)')'objExcel.Application.Quit' write(lfn,'(a)')'objExcel.Quit' write(lfn,'(a)')'Set objExcel = Nothing' write(lfn,'(a)')'Set objExcelBook = Nothing' write(lfn,'(a)')'Next' close(lfn) do i = 1,fileMax filePath = trim(fileDir) // '\' // trim(fileList(i)) open(lfn,file=filePath,status='unknown',iostat=ios) if (ios /= 0) then call svMessage('Error, Unable to assign file: ' // filePath) call sleepqq(2000) !Wait long enough to read it cycle end if call svMessage('Converting: ' // trim(filePath)) call svOSCall(-1,'cScript ' // '"' // trim(macroName) // '" "' // trim(filePath) // '"',ios) !Execute the vb macro if (ios == -1) call guierr('Error','Executing vbs macro returned non-zero return code') end do ! ! Remove macro ! open(lfn,file=trim(macroName),status='unknown',iostat=ios) if (ios == 0) close(lfn,status='delete') return end subroutine ! ! Execute a system command (this version allows a wait decision; command string should be fully formed, including quoting, externally) ! ! iWait: 0 = do not wait for completion ! >0 = Number of milliseconds to wait for completion of initiated process ! -1 = Infinite wait (wait for process completion) ! Command: character command string ! retCode: the return code ! -1 = Unable to initiate process ! 0 = Successful process initiate (if iWait = 0) ! 1 = Successful process initiate (Process terminated normally prior to wait period) ! 2 = Successful process initiate (Wait timeout occurred prior to process termination) ! 3 = Successful process initiate (Wait abandoned (unreleased mutex object)) ! 4 = Successful process initiate (Wait failed) ! 5 = executable file not found ! subroutine svOSCall(iWait,Command,retCode) use svKinds use dfwin use dfwinty implicit none character(*), intent(in) :: Command !Command portion of the command line (i.e. the program name) character(32767) :: CmdLine !Work area for the command line integer, intent(in) :: iWait !Process completion wait value in milliseconds integer, intent(inout) :: retCode !Main return code integer(b32) :: iWRC !Return code for WaitForSingleObject integer(b32) :: iCRC !Return code for CreateProcess type (T_StartupInfo) :: StartInfo !CreatProcess parms type (T_Process_Information) :: ProcInfo !CreatProcess parms (created process info) ! ! Initialize return code ! retCode = 0 ! ! Ensure console window is suppressed ! StartInfo%cb = 68 StartInfo%lpReserved = 0 StartInfo%lpDesktop = NULL StartInfo%lpTitle = NULL StartInfo%dwX = 0 StartInfo%dwY = 0 StartInfo%dwXSize = 0 StartInfo%dwYSize = 0 StartInfo%dwXCountChars = 0 StartInfo%dwYCountChars = 0 StartInfo%dwFillAttribute = 0 StartInfo%dwFlags = StartF_UseShowWindow StartInfo%wShowWindow = SW_HIDE StartInfo%cbReserved2 = 0 StartInfo%lpReserved2 = NULL ! ! Prepare the command line string and arguments ! cmdLine = trim(command) // char(0) ! ! Initiate process ! iCRC = CreateProcess(null_character, & cmdLine, & null_Security_Attributes, & null_Security_Attributes, & .false., & Null, & Null, & Null_Character, & StartInfo, & ProcInfo) if (getLasterror() == 2) then retCode = 5 return end if ! ! Check return code from Createprocess ! if (iCRC == 0) then !Nonzero means success (i.e. the process id) retCode = -1 return end if ! ! If user specified to wait ! if (iWait /= 0) then iWRC = WaitForSingleObject(ProcInfo%hProcess,iWait) !Wait for completion if (iWRC == Wait_Failed) retCode = 4 !Wait failed if (iWRC == Wait_Abandoned) retCode = 3 !Timeout abandoned if (iWRC == Wait_Timeout) retCode = 2 !Timeout occurred if (iWRC == Wait_Object_0) retCode = 1 !Normal termination (signaled) end if return end subroutine module svKinds use ISO_C_Binding implicit none ! ! Base types, all signed ! integer, parameter :: b08 = 1 !Compiler dependent 8-bit integer kind value integer, parameter :: b16 = 2 !Compiler dependent 16-bit integer kind value integer, parameter :: b32 = 4 !Compiler dependent 32-bit integer kind value integer, parameter :: b64 = 8 !Compiler dependent 64-bit integer kind value ! ! Additional C Types (ISO_C_Binding excludes unsigned types and assumes you will use the signed item where it is interoperable) ! integer, parameter :: c_byte = c_char !Compiler dependent 8-bit integer kind value integer, parameter :: c_uchar = c_char !Compiler dependent 8-bit integer kind value integer, parameter :: c_ushort = c_short !Compiler dependent 16-bit integer kind value integer, parameter :: c_ulong = c_long !Compiler dependent 32-bit integer kind value integer, parameter :: c_slong = c_long !Compiler dependent 32-bit integer kind value integer, parameter :: c_int64 = b64 !Compiler dependent 64-bit integer kind value integer, parameter :: c_dword = c_long !Compiler dependent 64-bit integer kind value (redundancies to match some c prototypes) end module