How to get multi-colors ?

[WSinc]

Of course we can get that with GRAPHICS routines, but what about regular text from Write or Print

statements?

Is there a trick that will allow other colors besides the regular white on black stuff?

I am assuming that a regular console output window is used, 

Naturally if the BACKGROUND is white, one would want to use some other color for the letters.

[JVanB]

I had high hopes for this:

program P
   use IFWIN
   implicit none
   integer(HANDLE) hConsoleOutput
   integer(WORD) wAttribute
   character(*), parameter :: mess = 'Hello, world'
   integer(DWORD) nLength
   type(T_CONSOLE_SCREEN_BUFFER_INFO) ScreenBufferInfo
   integer(BOOL) result4
   integer(DWORD) lpNumberOfAttrsWritten

   hConsoleOutput = GetStdHandle(STD_OUTPUT_HANDLE)
   if(hCOnsoleOutput == INVALID_HANDLE_VALUE) then
      write(*,'(a,i0)') 'GetStdHandle failed with error code ',GetLastError()
      stop
   end if
   wAttribute = iany([FOREGROUND_RED,FOREGROUND_GREEN,FOREGROUND_INTENSITY, &
      BACKGROUND_BLUE])
   nLength = len(mess)+1
   result4 = GetConsoleScreenBufferInfo(hConsoleOutput,ScreenBufferInfo)
   if(result4 == 0) then
      write(*,'(a,i0)') 'GetConsoleScreenBufferInfo failed with error code ' &
         ,GetLastError()
      stop
   end if
   result4 = FillConsoleOutputAttribute(hConsoleOutput,wAttribute, &
      nLength,ScreenBufferInfo%dwCursorPosition,%LOC(lpNumberOfAttrsWritten))
   if(result4 == 0) then
      write(*,'(a,i0)') 'FillConsoleOutputAttribute failed with error code ' &
         ,GetLastError()
      stop
   end if
   write(*,'(a)') mess
end program P

But the only character that picks up our attributes is the one after 'Hello, world'. Evidently ifort sidesteps console attributes when it outputs to the screen. Probably you can write your output to a NUL-terminated string and use a Windows Console function to do the output, but this seems to be outside the parameters of the problem statement.

[JVanB]

OK, what you can do is write the stuff out in Fortran and then set the attributes retroactively. You have to be careful because if the console buffer has been scrolled, the coordinates of the stuff you have written have changed. This program takes that possibility into account:

program P
   use IFWIN
   implicit none
   integer(HANDLE) hConsoleOutput
   integer(WORD) wAttribute
   character(*), parameter :: mess = 'Hello, world'
   integer(DWORD) nLength
   type(T_CONSOLE_SCREEN_BUFFER_INFO) ScreenBufferInfo
   type(T_COORD) dwWriteCoord
   integer(BOOL) result4
   integer(DWORD) lpNumberOfAttrsWritten

   hConsoleOutput = GetStdHandle(STD_OUTPUT_HANDLE)
   if(hCOnsoleOutput == INVALID_HANDLE_VALUE) then
      write(*,'(a,i0)') 'GetStdHandle failed with error code ',GetLastError()
      stop
   end if
   wAttribute = iany([FOREGROUND_RED,FOREGROUND_GREEN,FOREGROUND_INTENSITY, &
      BACKGROUND_BLUE])
   nLength = len(mess)
   result4 = GetConsoleScreenBufferInfo(hConsoleOutput,ScreenBufferInfo)
   if(result4 == 0) then
      write(*,'(a,i0)') 'GetConsoleScreenBufferInfo failed with error code ' &
         ,GetLastError()
      stop
   end if
   dwWriteCoord = ScreenBufferInfo%dwCursorPosition
   write(*,'(a)') mess
   result4 = GetConsoleScreenBufferInfo(hConsoleOutput,ScreenBufferInfo)
   if(result4 == 0) then
      write(*,'(a,i0)') 'GetConsoleScreenBufferInfo failed with error code ' &
         ,GetLastError()
      stop
   end if
   if(dwWriteCoord%Y == ScreenBufferInfo%dwCursorPosition%Y)then
      dwWriteCoord%Y = dwWriteCoord%Y - 1
   end if
   result4 = FillConsoleOutputAttribute(hConsoleOutput,wAttribute, &
      nLength,dwWriteCoord,%LOC(lpNumberOfAttrsWritten))
   if(result4 == 0) then
      write(*,'(a,i0)') 'FillConsoleOutputAttribute failed with error code ' &
         ,GetLastError()
      stop
   end if
end program P

Now, if your write has scrolled the console buffer by more than one line you will need more complex logic to detect and handle it.

[IanH]

PROGRAM ICanCodeARainbow
  USE IFWIN
  IMPLICIT NONE
  INTEGER(BOOL) :: brc
  INTEGER(HANDLE) :: console_handle
  
  console_handle = GetStdHandle(STD_OUTPUT_HANDLE)
  brc = SetConsoleTextAttribute(  &
      console_handle,  &
      INT(IANY([FOREGROUND_RED, FOREGROUND_INTENSITY]), WORD) )
  PRINT "(A)", 'Red and'
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_RED]), WORD) )
  PRINT "(A)", 'yellow and'
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_RED, FOREGROUND_BLUE]), WORD) )
  PRINT "(A)", 'pink-ish and '
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_GREEN]), WORD) )
  PRINT "(A)", 'green,'
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_BLUE, FOREGROUND_RED]), WORD) )
  PRINT "(A)", 'purple (sort of) and '
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_RED]), WORD) )
  PRINT "(A)", 'a bit orange and'
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_BLUE, FOREGROUND_INTENSITY]), WORD) )
  PRINT "(A)", 'blue'
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_BLUE, FOREGROUND_RED, FOREGROUND_GREEN]), WORD) )
  PRINT "(A)", 'I can code a rainbow '
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([BACKGROUND_BLUE, FOREGROUND_GREEN, FOREGROUND_INTENSITY]), WORD) )
  PRINT "(A)", 'and stuff your prompt up too...'
END PROGRAM ICanCodeARainbow

[WSinc]

OK, I ran this and it worked -

However, should i assume that all the characters on a given line have to be the SAME color?

Or is there some way to get mixed colors on the same line?

[IanH]

Try using non-advancing output and FLUSH.

PROGRAM ICanCodeARainbow
  USE IFWIN
  USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT
  IMPLICIT NONE
  INTEGER(BOOL) :: brc
  INTEGER(HANDLE) :: console_handle
  CHARACTER(*), PARAMETER :: fmt = "(A)"  
  
  console_handle = GetStdHandle(STD_OUTPUT_HANDLE)
  brc = SetConsoleTextAttribute(  &
      console_handle,  &
      INT(IANY([FOREGROUND_RED, FOREGROUND_INTENSITY]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='NO') 'Red and '
  FLUSH (OUTPUT_UNIT)
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_RED, FOREGROUND_GREEN, FOREGROUND_INTENSITY]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='NO') 'yellow and '
  FLUSH (OUTPUT_UNIT)
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_RED, FOREGROUND_BLUE, FOREGROUND_INTENSITY]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='NO') 'pink-ish and '
  FLUSH (OUTPUT_UNIT)
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_GREEN]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='YES') 'green,'
  
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_BLUE, FOREGROUND_RED]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='NO') 'purple (sort of) and '
  FLUSH (OUTPUT_UNIT)
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_RED]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='NO') 'a bit orange and '
  FLUSH (OUTPUT_UNIT)
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_BLUE, FOREGROUND_INTENSITY]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='YES') 'blue'
  
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([FOREGROUND_BLUE, FOREGROUND_RED, FOREGROUND_GREEN]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='NO') 'I can code a rainbow '
  FLUSH (OUTPUT_UNIT)
  brc = SetConsoleTextAttribute(  &
      console_handle,   &
      INT(IANY([BACKGROUND_BLUE, FOREGROUND_GREEN, FOREGROUND_INTENSITY]), WORD) )
  WRITE (OUTPUT_UNIT, fmt, ADVANCE='YES') 'and stuff your prompt up too...'
END PROGRAM ICanCodeARainbow

I'm not happy with my orange.  Perhaps it is fortunate that I'm spending today just oiling the deck, and not painting the house proper.

[jimdempseyatthecove]

What's a house proper? I don't know if my house has one?

Jim ;)

[IanH]

It is the bright blue stick that is holding up the wall of my house in the attached secret plans (encoded in an ancient language so that only readers of this forum can decipher them).
 

[andrew_4619]

+1 Ian :-)

[Steven_L_Intel1]

Other than the daft syntax error, I like it!

[jimdempseyatthecove]

Great! The stick props the house up, thus house proper.

Jim

[mecej4]

jimdempseyatthecove wrote:
Great! The stick props the house up, thus house proper.

And, in the name of interproppability, we shall not quibble about the un-doubled p in Ian's "propper".

[WSinc]

If its at a house of ill repute, would it still be proper?

Maybe we should let it fall down?

Hmm- what was this about originally ? - I forgot ............