首页 > 代码 > 常规代码 > 正文

代码

阅读排行

彩色 Console 字体输出办法【仅适合VF系列编译器】
2014-01-20 11:11:52   来源:Fcode研讨团队   评论:0 点击:

本文介绍了IVF和Ftn95编译器在console界面下使用彩色字体的方法。本文涉及内容可能超出了语法范畴,请确认您的编译器允许。

前几天看到有朋友讨论有关 Console 类型工程使用彩色字体输出的问题。

有人说 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 ) then
      write(*,*) 'Init Error!'
  EndIf
  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'
  bRes = 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 )
      import
      !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'SetConsoleDisplayMode' :: SetConsoleDisplayMode
      Integer(kind=C_INT) , Intent( IN ) :: hConsoleOutput , dwFlags , lpCoord
    End Function SetConsoleDisplayMode
  End Interface
  
  
  Integer(kind=2) , public , Parameter :: ctmKIND_COLOR   = C_SHORT
  Integer(kind=2) , public , Parameter :: ctmKIND_LOGICAL = C_SHORT
  Integer(kind=2) , 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 :: iLENOFCOLORBITS = 4 , iLOWBITPOS = 0 , iHIGHBITPOS = 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
  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 = 0
    If ( wFlag == ctmSET_TEXT ) then
      iCopyPos = iLOWBITPOS
    Else !If wFlag == ctmSET_BG
      iCopyPos = iHIGHBITPOS
    End If
    Call MvBits( iColorValue , iLOWBITPOS , iLENOFCOLORBITS , this%iCurrentColor , iCopyPos )
    iRes = SetConsoleTextAttribute( this%hConsole , this%iCurrentColor )
    If ( iRes == 0 ) return
    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 = 0
    iLenCopy = iLENOFCOLORBITS
    If ( wFlag == ctmSET_TEXT ) then
      iCopyPos = iLOWBITPOS
      iLenCopy = iLENOFCOLORBITS
    ElseIf ( wFlag == ctmSET_BG ) then
      iCopyPos = iHIGHBITPOS
      iLenCopy = iLENOFCOLORBITS
    ElseIf ( wFlag == ctmSET_BOTH ) then
      iCopyPos = iLOWBITPOS
      iLenCopy = 2 * iLENOFCOLORBITS
    End If
    Call MvBits( this%iOriginColor , iCopyPos , iLenCopy , this%iCurrentColor , iCopyPos )
    iRes = SetConsoleTextAttribute( this%hConsole , this%iCurrentColor )
    If ( iRes == 0 ) Return
    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

  Logical(kind=ctmKIND_LOGICAL) Function UnInit( this )
    class(T_Colorized_Text) :: this
    Logical(kind=ctmKIND_LOGICAL) :: bRes
    UnInit = ctmEXECUTE_ERROR
    If ( .Not. this%bInited ) Return
    bRes = this%ResetColor( ctmSET_BOTH )
    If ( .Not.bRes ) Return
    UnInit = ctmEXECUTE_SUCCESS
    this%bInited = .False.
  End Function UnInit

End Module Colorized_Text_Class

相关热词搜索:Console 彩色字体

上一篇:第一页
下一篇:公历转农历日期模块

分享到: 收藏