有人说 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