有人说 Fortran 这方面不在行，建议用 C 来实现，其实 C 也是使用外部的函数库的。如果单单为了这一点点东西就改用另一门语言，或者改用 QuickWin，似乎有点小题大做了。
仔细想想，其实彩色文字这方面平常我们也经常会需要的。比如程序碰到例外或出错了，我们都希望给出红色的错误提示，或者黄色的警告。于是就有了一个想法，写一个模块来实现彩色文本的窗口输出。（输出到文件当然就失效了）
翻了翻有关的 API 函数，大概能够实现了。拿出来大家共同探讨。
模块取名为 Colorized_Text_Class 。使用了 Kernel32 这个 API 函数库的一些东西。所以，需要你的编译器有 API 的导入库。一般windows 的编译器都是可以的。
先 Use Colorized_Text_Class使用之前必须先定义一个逻辑型变量来接收模块函数的返回值，比如：
Logical(kind=ctmKIND_LOGICAL) :: bRes然后，你需要为类实例化一个对象：
Type( T_Colorized_Text ) :: ctm
调用 Colorized_Text_Class 中的函数以后都可以判断失败或成功。失败时返回值为 ctmEXECUTE_ERROR 成功时则为 ctmEXECUTE_SUCCESS。
定义好以后需要初始化：
bRes = ctm%Init()
通过调用函数 ctm_SetColor 来改变当前的颜色：
bRes = ctm%SetColor( iColorValue , wFlag )
参数定义为：
Integer(kind=ctmKIND_COLOR) , Intent( IN ) :: iColorValue
Integer(kind=ctmKIND_FLAG) , Intent( IN ) :: wFlag
iColorValue 为颜色索引值，一共有 16 种颜色可以选择，建议直接使用定义好的常量，使用其他量的时候应该定义为 Integer(kind=ctmKIND_COLOR)，并且小于等于16，大于等于0。十六个定义好的常量有：
ctmCOLOR_BLACK 0 黑色
ctmCOLOR_BLUE 1 蓝色
ctmCOLOR_GREEN 2 绿色
ctmCOLOR_CYAN 3 青色
ctmCOLOR_RED 4 红色
ctmCOLOR_MAGENTA 5 紫色
ctmCOLOR_BROWN 6 棕色
ctmCOLOR_LIGHTGRAY 7 浅灰色
ctmCOLOR_DARKGRAY 8 深灰色
ctmCOLOR_LIGHTBLUE 9 亮蓝色
ctmCOLOR_LIGHTGREEN 10 亮绿色
ctmCOLOR_LIGHTCYAN 11 亮青色
ctmCOLOR_LIGHTRED 12 亮红色
ctmCOLOR_LIGHTMAGENTA 13 亮紫色
ctmCOLOR_YELLOW 14 黄色
ctmCOLOR_WHITE 15 白色
wFlag 指定需要设定的是文本颜色还是背景颜色。指定为 ctmSET_TEXT 代表要设定文本颜色，指定为 ctmSET_BG 代表要设定背景颜色。
测试发现改变背景颜色很不好看，建议就不要使用了。
通过调用 ctm%ResetColor( wFlag ) 恢复默认的显示方式
wFlag 可以指定为 ctmSET_TEXT 代表要恢复文本颜色，指定为 ctmSET_BG 代表要恢复背景颜色，指定为 ctmSET_BOTH 代表恢复文本和背景颜色。
最后调用 ctm_UnInit 结束 ：
bRes = ctm%UnInit()
ctm_UnInit 内部会调用 ctm%ResetColor( ctm_SET_BOTH ) 恢复文本和背景颜色的显示。
举一个例子：
Program www_fcode_cn Use Colorized_Text_Class Implicit None Type( T_Colorized_Text ) :: ctm Logical(kind=ctmKIND_LOGICAL) :: bRes bRes = ctm%Init() If ( .Not.bRes ) write(*,*) 'Init Error！' bRes = ctm%SetScreenMode( ctmFULLSCREEN ) Write(*,*) 'Full Screen' !bRes = ctm%SetScreenMode( ctmFWINDOWED ) !//Restore to window bRes = ctm%SetColor( ctmCOLOR_BLUE , ctmSET_TEXT ) Write(*,*) 'Blue Text' bRes = ctm%ResetColor( ctmSET_TEXT ) Write(*,*) 'Restore Text Color' bRes = ctm%SetColor( ctmCOLOR_RED , ctmSET_TEXT ) Write(*,*) 'Red Text' bRes = ctm%SetColor( ctmCOLOR_YELLOW , ctmSET_BG ) Write(*,*) 'Yellow BG Color' bRes = ctm%ResetColor( ctmSET_BG ) Write(*,*) 'Restore BG Color , Keep Text Color' bRes = ctm%SetColor( ctmCOLOR_GREEN , ctmSET_BG ) Write(*,*) 'Green BG Color' call ctm%UnInit() Write(*,*) 'Restore All' Read(*,*) End Program www_fcode_cn
源码如下：
Module Colorized_Text_Class
!彩色 Console 字体输出模块。依赖 API 函数库 Kernel32
!// 面向对象修改版 作者： gao@fcode.cn
Use , Intrinsic :: ISO_C_Binding
Use Kernel32 , Only : GetStdHandle , STD_OUTPUT_HANDLE , T_CONSOLE_SCREEN_BUFFER_INFO , &
INVALID_HANDLE_VALUE , GetConsoleScreenBufferInfo , SetConsoleTextAttribute
Implicit None
Private
Interface
Integer(kind=C_INT) Function SetConsoleDisplayMode( hConsoleOutput , dwFlags , lpCoord )
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'SetConsoleDisplayMode' :: SetConsoleDisplayMode
import
Integer(kind=C_INT) , Intent( IN ) :: hConsoleOutput , dwFlags , lpCoord
End Function SetConsoleDisplayMode
End Interface
Integer , public , Parameter :: ctmKIND_COLOR = C_SHORT
Integer , public , Parameter :: ctmKIND_LOGICAL = C_SHORT
Integer , public , Parameter :: ctmKIND_FLAG = C_SHORT
Logical(kind=ctmKIND_LOGICAL) , public , Parameter :: ctmEXECUTE_SUCCESS = .True.
Logical(kind=ctmKIND_LOGICAL) , public , Parameter :: ctmEXECUTE_ERROR = .False.
Integer(kind=ctmKIND_FLAG) , public , Parameter :: ctmFULLSCREEN = 1
Integer(kind=ctmKIND_FLAG) , public , Parameter :: ctmFWINDOWED = 2
Integer(kind=ctmKIND_FLAG) , public , Parameter :: ctmSET_TEXT = 0
Integer(kind=ctmKIND_FLAG) , public , Parameter :: ctmSET_BG = 1
Integer(kind=ctmKIND_FLAG) , public , Parameter :: ctmSET_BOTH = 2
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_BLACK = 0 !//黑色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_BLUE = 1 !//蓝色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_GREEN = 2 !//绿色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_CYAN = 3 !//青色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_RED = 4 !//红色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_MAGENTA = 5 !//紫色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_BROWN = 6 !//棕色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_LIGHTGRAY = 7 !//浅灰色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_DARKGRAY = 8 !//深灰色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_LIGHTBLUE = 9 !//亮蓝色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_LIGHTGREEN = 10 !//亮绿色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_LIGHTCYAN = 11 !//亮青色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_LIGHTRED = 12 !//亮红色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_LIGHTMAGENTA = 13 !//亮紫色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_YELLOW = 14 !//黄色
Integer(kind=ctmKIND_COLOR) , public , Parameter :: ctmCOLOR_WHITE = 15 !//白色
Integer , Parameter :: LenofColorBits = 4 , LowBitPos = 0 , HighBitPos = 4
Type , public :: T_Colorized_Text
Integer(kind=C_INT) , Private :: hConsole = 0
Integer(kind=ctmKIND_COLOR) , Private :: iCurrentColor = 0 , iOriginColor = 0
Logical(kind=ctmKIND_LOGICAL) , Private :: bInited = .False.
Type( T_CONSOLE_SCREEN_BUFFER_INFO ) :: stConsoleInfo
contains
Procedure :: Init
Procedure :: SetColor
Procedure :: ResetColor
Procedure :: SetScreenMode
Procedure :: UnInit
Final :: FinalIt
End Type T_Colorized_Text
Contains
Logical(kind=ctmKIND_LOGICAL) Function Init( this )
class(T_Colorized_Text) :: this
integer :: iRes
Init = ctmEXECUTE_ERROR
If ( this%bInited ) Return
this%hConsole = GetStdHandle( STD_OUTPUT_HANDLE )
If ( this%hConsole == INVALID_HANDLE_VALUE ) Return
iRes = GetConsoleScreenBufferInfo( this%hConsole , this%stConsoleInfo )
If ( iRes == 0 ) return
this%iCurrentColor = this%stConsoleInfo%wAttributes
this%iOriginColor = this%iCurrentColor
Init = ctmEXECUTE_SUCCESS
this%bInited = .TRUE.
End Function Init
Logical(kind=ctmKIND_LOGICAL) Function SetColor( this , iColorValue , wFlag )
class(T_Colorized_Text) :: this
Integer(kind=ctmKIND_COLOR) , Intent( IN ) :: iColorValue
Integer(kind=ctmKIND_FLAG) , Intent( IN ) :: wFlag
Integer :: iCopyPos , iRes
SetColor = ctmEXECUTE_ERROR
If ( .Not. this%bInited ) return
iCopyPos = merge( LowBitPos , HighBitPos , wFlag == ctmSET_TEXT )
Call MvBits( iColorValue , LowBitPos , LenofColorBits , this%iCurrentColor , iCopyPos )
iRes = SetConsoleTextAttribute( this%hConsole , this%iCurrentColor )
If ( iRes /= 0 ) SetColor = ctmEXECUTE_SUCCESS
End Function SetColor
Logical(kind=ctmKIND_LOGICAL) Function ResetColor( this , wFlag )
class(T_Colorized_Text) :: this
Integer(kind=ctmKIND_FLAG) , Intent( IN ) :: wFlag
Integer :: iCopyPos , iLenCopy , iRes
ResetColor = ctmEXECUTE_ERROR
If ( .Not. this%bInited ) Return
iCopyPos = merge( HighBitPos , LowBitPos , wFlag == ctmSET_BG )
iLenCopy = merge( 2 , 1 , wFlag == ctmSET_BOTH ) * LenofColorBits
Call MvBits( this%iOriginColor , iCopyPos , iLenCopy , this%iCurrentColor , iCopyPos )
iRes = SetConsoleTextAttribute( this%hConsole , this%iCurrentColor )
If ( iRes /= 0 ) ResetColor = ctmEXECUTE_SUCCESS
End Function ResetColor
Logical(kind=ctmKIND_LOGICAL) Function SetScreenMode( this , wFlag )
class(T_Colorized_Text) :: this
Integer(kind=ctmKIND_FLAG) , Intent( IN ) :: wFlag
Integer(kind=C_INT) :: iRes
SetScreenMode = ctmEXECUTE_ERROR
If ( .Not. this%bInited ) Return
iRes = SetConsoleDisplayMode( this%hConsole , Int(wFlag) , 0 )
SetScreenMode = ctmEXECUTE_SUCCESS
End Function SetScreenMode
Subroutine UnInit( this )
class(T_Colorized_Text) :: this
Logical(kind=ctmKIND_LOGICAL) :: bRes
If ( .Not. this%bInited ) Return
bRes = this%ResetColor( ctmSET_BOTH )
this%bInited = .False.
End Subroutine UnInit
Subroutine FinalIt( this )
type(T_Colorized_Text) :: this
call this%UnInit()
End Subroutine FinalIt
End Module Colorized_Text_Class
