colorized_text_module.f90

Fortran Console 彩色文本屏幕输出的方法

Module Colorized_Text_Mod
!彩色 Console 字体输出模块。依赖 API 函数库 Kernel32
  Use Kernel32 , Only : GetStdHandle , STD_OUTPUT_HANDLE , T_CONSOLE_SCREEN_BUFFER_INFO , &
                         INVALID_HANDLE_VALUE , GetConsoleScreenBufferInfo , SetConsoleTextAttribute
  Implicit None
  Public
  Integer(kind=2) , Parameter :: ctmKIND_COLOR = 2
  Integer(kind=2) , Parameter :: ctmKIND_LOGICAL = 2
  Integer(kind=2) , Parameter :: ctmKIND_FLAG = 2

  Logical(kind=ctmKIND_LOGICAL) , Parameter :: ctmEXECUTE_SUCCESS = .True.
  Logical(kind=ctmKIND_LOGICAL) , Parameter :: ctmEXECUTE_ERROR = .False.

  Integer(kind=ctmKIND_FLAG) , Parameter :: ctmSET_TEXT  = 0
  Integer(kind=ctmKIND_FLAG) , Parameter :: ctmSET_BG    = 1
  Integer(kind=ctmKIND_FLAG) , Parameter :: ctmSET_BOTH   = 2

  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_BLACK        = 0  !//黑色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_BLUE         = 1  !//蓝色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_GREEN        = 2  !//绿色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_CYAN         = 3  !//青色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_RED          = 4  !//红色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_MAGENTA      = 5  !//紫色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_BROWN        = 6  !//棕色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_LIGHTGRAY    = 7  !//浅灰色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_DARKGRAY     = 8  !//深灰色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_LIGHTBLUE    = 9  !//亮蓝色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_LIGHTGREEN   = 10 !//亮绿色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_LIGHTCYAN    = 11 !//亮青色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_LIGHTRED     = 12 !//亮红色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_LIGHTMAGENTA = 13 !//亮紫色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_YELLOW       = 14 !//黄色
  Integer(kind=ctmKIND_COLOR) , Parameter :: ctmCOLOR_WHITE        = 15 !//白色

  Integer , Parameter , Private :: iLENOFCOLORBITS = 4 , iLOWBITPOS = 0 , iHIGHBITPOS = 4

  Integer(kind=4) , Private , Save :: iHandleConsole = 0
  Integer(kind=ctmKIND_COLOR) , Private , Save :: iCurrentColor = 0 , iOriginColor = 0
  Logical(kind=ctmKIND_LOGICAL) , Private , Save :: bIsInit = .False.
  Type( T_CONSOLE_SCREEN_BUFFER_INFO ) , Private :: stConsole_Info
  Integer(kind=4) , Private :: iRes = 0

Contains

  Logical(kind=ctmKIND_LOGICAL) Function ctm_Init()
    Implicit None
    If ( bIsInit ) then
      goto 9998
    End If
    iHandleConsole = GetStdHandle( STD_OUTPUT_HANDLE )
    If ( iHandleConsole == INVALID_HANDLE_VALUE ) then
      goto 9999
    End If
    iRes = GetConsoleScreenBufferInfo( iHandleConsole , stConsole_Info )
    If ( iRes == 0 ) then
      goto 9999
    End If
    iCurrentColor = stConsole_Info%wAttributes
    iOriginColor = iCurrentColor
9998  ctm_Init = ctmEXECUTE_SUCCESS
      bIsInit = .TRUE.
      Return
9999  ctm_Init = ctmEXECUTE_ERROR
      bIsInit = .False.
      Return
  End Function ctm_Init

  Logical(kind=ctmKIND_LOGICAL) Function ctm_SetColor( iColorValue , wFlag )
    Implicit None
    Integer(kind=ctmKIND_COLOR) , Intent( IN ) :: iColorValue
    Integer(kind=ctmKIND_FLAG) , Intent( IN ) :: wFlag
    Integer :: iCopyPos = 0
    If ( .Not.bIsInit ) then
      goto 9999
    End If
    If ( wFlag == ctmSET_TEXT ) then
      iCopyPos = iLOWBITPOS
    Else !If wFlag == ctmSET_BG
      iCopyPos = iHIGHBITPOS
    End If
    Call MvBits( iColorValue , iLOWBITPOS , iLENOFCOLORBITS , iCurrentColor , iCopyPos )
    iRes = SetConsoleTextAttribute( iHandleConsole , iCurrentColor )
    If ( iRes == 0 ) then
      goto 9999
    End If
9998  ctm_SetColor = ctmEXECUTE_SUCCESS
      Return
9999  ctm_SetColor = ctmEXECUTE_ERROR
      Return
  End Function ctm_SetColor

  Logical(kind=ctmKIND_LOGICAL) Function ctm_ResetColor( wFlag )
    Implicit None
    Integer(kind=ctmKIND_FLAG) , Intent( IN ) :: wFlag
    Integer :: iCopyPos = 0 , iLenCopy = iLENOFCOLORBITS
    If ( .Not.bIsInit ) then
      goto 9999
    End If
    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( iOriginColor , iCopyPos , iLenCopy , iCurrentColor , iCopyPos )
    iRes = SetConsoleTextAttribute( iHandleConsole , iCurrentColor )
    If ( iRes == 0 ) then
      goto 9999
    End If
9998  ctm_ResetColor = ctmEXECUTE_SUCCESS
      Return
9999  ctm_ResetColor = ctmEXECUTE_ERROR
      Return
  End Function ctm_ResetColor

  Logical(kind=ctmKIND_LOGICAL) Function ctm_UnInit()
    Implicit None
    Logical(kind=ctmKIND_LOGICAL) :: bRes
    If ( .Not.bIsInit ) then
      goto 9998
    End If
    bRes = ctm_ResetColor( ctmSET_BOTH )
    If ( .Not.bRes ) then
      goto 9999
    End If
9998  ctm_UnInit = ctmEXECUTE_SUCCESS
      bIsInit = .False.
      Return
9999  ctm_UnInit = ctmEXECUTE_ERROR
      bIsInit = .True.
      Return
  End Function ctm_UnInit

End Module Colorized_Text_Mod