VBA 输出到CMD控制台显示暨更新当前行显示

参考资料： 在VB控制台中更新当前行 |

应用于：用 chrome + excel + VBA + XMLHTTP 爬视频网站 video 标签中的 blob:http m3u8 视频资源，ffmpeg 拼接资源_jessezappy的博客-CSDN博客

 之前的文章：两 API 三步最简实现 VB6 输出到CMD控制台显示 (含获取输入)，真输出至 CMD 窗口，非 AllocConsole 模式_jessezappy的博客-CSDN博客_vbs输出内容到cmd窗口

中，已实现输出控制台显示，但想在 VBA 中使用时就不行，查了下，发现需要加上：AllocConsole 用伪控制台方式就行，但注意 VB6 不能加这个。

下面放上 VBA 可用的模块定义：

'--------所用API定义
Public Declare Function AllocConsole Lib "kernel32" () As Long
Public Declare Function FreeConsole Lib "kernel32" () As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Public Declare Function LstrLen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
'Public Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long
'Public Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal dwMode As Long) As Long
Public Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long
Public Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" (ByVal lpConsoleTitle As String) As Long
Public Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, ByVal lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
 
'-------------常量定义
'控制台输入输出句柄获取用常量
Public Const STD_INPUT_HANDLE = -10&
Public Const STD_OUTPUT_HANDLE = -11&
Public Const STD_ERROR_HANDLE = -12&
'部分前背景颜色代码，详见： 控制台色卡.png
Public Const FOREGROUND_BLUE = 9
Public Const FOREGROUND_GREEN = 10
Public Const FOREGROUND_RED = 12
Public Const FOREGROUND_INTENSITY = &H8
Public Const BACKGROUND_BLUE = &H10
Public Const BACKGROUND_GREEN = &H20
Public Const BACKGROUND_RED = &H40
Public Const BACKGROUND_INTENSITY = &H80
'设置输入模式常量 SetConsoleMode (input)
Public Const ENABLE_LINE_INPUT = &H2
Public Const ENABLE_ECHO_INPUT = &H4
Public Const ENABLE_MOUSE_INPUT = &H10
Public Const ENABLE_PROCESSED_INPUT = &H1
Public Const ENABLE_WINDOW_INPUT = &H8
'设置输出模式常量 SetConsoleMode (output)
Public Const ENABLE_PROCESSED_OUTPUT = &H1
Public Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2
'-----------所需全局变量
Public hConsoleIn As Long ' 控制台输入句柄
Public hConsoleOut As Long ' 控制台输出句柄
'Public hConsoleErr As Long ' 控制台错误句柄
 
'==========================使用例子=========
'    Call Initialize
''----------此处程序代码开始-------------
'    Call setTitle(App.Title)
'    Call setCONColor(FOREGROUND_GREEN, 0)
''    Call COut("VB6 控制台：Hello World ！" & vbCrLf)
'    Call COut(App.Title & "，启动数据接收工作：" & vbCrLf)
'    'szUserInput = LIn
'    'Call COut(szUserInput)
'
'
'
'    If 1 = 1 Then '--调整此句决定有无窗口显示
'        Load Form1
'        Form1.Show
'        Exit Sub
'    End If
''----------程序代码到此结束-------------
'    Call Terminate
'==================================================
'---------定义函数
Public Sub Initialize() '---初始化获取句柄
    Call AllocConsole   'VBA 中使用。
    '获得控制窗口的句柄
    'hConsoleIn = GetStdHandle(STD_INPUT_HANDLE)
    hConsoleOut = GetStdHandle(STD_OUTPUT_HANDLE)
    'hConsoleErr = GetStdHandle(STD_ERROR_HANDLE)
End Sub
 
Public Sub Terminate() '-----销毁句柄
    Call FreeConsole ' Destroy the console
    'Call CloseHandle(hConsoleIn)
    Call CloseHandle(hConsoleOut)
End Sub
 
Public Sub COut(szOut As String)   '------文字输出到控制台函数
    WriteConsole hConsoleOut, szOut, LstrLen(szOut), vbNull, vbNull
End Sub
 
Public Sub setTitle(s As String)
    SetConsoleTitle s '设置窗口标题 '获得控制窗口的句柄
End Sub
 
Public Sub setCONColor(ByVal f As Long, ByVal b As Long) '---设置文字和背景显示颜色
    If b >= 0 And b <= 15 Then
        If f >= 0 And f <= 15 Then
            b = b * &H10
            SetConsoleTextAttribute hConsoleOut, f Or b
        Else
            'MsgBox "输入的文字颜色代码错误！颜色代码详见：控制台色卡.png", vbCritical, "错误"
        End If
    Else
        'MsgBox "输入的背景颜色代码错误！颜色代码详见：控制台色卡.png", vbCritical, "错误"
    End If
End Sub
 
'Public Function LIn() As String
'    Dim sUserInput As String * 256
'    Call ReadConsole(hConsoleIn, sUserInput, Len(sUserInput), vbNull, vbNull)
'    '--去除空字符和回车字符
'    LIn = Left$(sUserInput, InStr(sUserInput, Chr$(0)) - 3)
'End Function

注意这个是 VBA 环境使用的。注意，若中途调用 shell 执行 bat 文件的话，执行结果会跑到上面创建的控制台窗口去显示。

今天用这个显示下载 m3u8 资源文件进程时，总觉得刷屏稀里哗啦的不美观，想跟 ffmpeg 那样，执行进度只显示在一行，查了下，没找到直接说明资料，但是有个类似的：在VB控制台中更新当前行 | ，说是用  vbCr 结尾就行，用上面的代码试了下，果然可以：

将原来的换行  vbCrLf   ：

Call COut("第 " & x & " 组：第" & i & "/" & d & "行：......下载完成，用时：" & Format((Timer - timerX) * 1000, "#0.00") & " 毫秒。        " & vbCrLf)

换成 vbCr ：

Call COut("第 " & x & " 组：第" & i & "/" & d & "行：......下载完成，用时：" & Format((Timer - timerX) * 1000, "#0.00") & " 毫秒。        " & vbCr)

即可，如下图：

 要正常换行时，使用 vbCrLf 结尾即可。

此记！