WinAPI 操作win控制台cmd相关

lss001

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetSystemMenu Lib "user32" ( _
    ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare PtrSafe Function GetSubMenu Lib "user32" ( _
    ByVal hMenu As Long, ByVal nPos As Long) As Long
'Private Declare ptrsafe Function GetMenuItemCount Lib "user32" ( _
    ByVal hMenu As Long) As Long
Private Declare PtrSafe Function GetMenuItemID Lib "user32" ( _
    ByVal hMenu As Long, ByVal nPos As Long) As Long
'Private Declare ptrsafe Function GetMenuString Lib "user32" Alias "GetMenuStringA" _
   (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, _
   ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SYSCOMMAND = &H112, WM_CLOSE = &H10, WM_SETTEXT = &HC


Sub cmdfs() 'winapi操作CMD
     Dim hwnd&, hMenu&, hSubMenu&, SelectAllID&, CopyID&, PasteID&, closeMenu&

     Shell "cmd.exe", vbMinimizedFocus                      '打开CMD程序
     Application.Wait Now + TimeSerial(0, 0, 2)             '延时响应打开CMD程序
     hwnd = FindWindow("ConsoleWindowClass", vbNullString)  '获取cmd窗口句柄
     hMenu = GetSystemMenu(hwnd, False)                     '获取cmd窗口系统菜单的句柄
     hSubMenu = GetSubMenu(hMenu, 7)                        '获取"编辑"控件的句柄

     Set hf = CreateObject("htmlfile")                      '或xmlfile
     Set clip = hf.parentwindow.clipboarddata               'htmlfile剪贴板
     sText = "cd C:\Users\Administrator\Documents"          '设置cmd命令
     clip.Setdata "Text", CStr(sText)                       '设置剪贴板数据

     PasteID = GetMenuItemID(hSubMenu, 2)                   '获取"粘贴"项的ID
     SendMessage hwnd, WM_SYSCOMMAND, PasteID, ByVal 0      '向cmd窗口发送粘贴命令
     PostMessage hwnd, &H101, &HD, ByVal 0&                               '向cmd窗口发送回车键<Enter>
     Application.Wait Now + TimeSerial(0, 0, 2)

     SelectAllID = GetMenuItemID(hSubMenu, 3)               '获取"全选"项的ID
     SendMessage hwnd, WM_SYSCOMMAND, SelectAllID, ByVal 0  '向cmd窗口发送全选命令

     CopyID = GetMenuItemID(hSubMenu, 1)                    '获取"复制"项的ID
     SendMessage hwnd, WM_SYSCOMMAND, CopyID, ByVal 0       '向cmd窗口发送复制命令

     closeMenu = GetSubMenu(hMenu, 6)                       '获取"关闭" 控件的句柄
     SendMessage hwnd, WM_CLOSE, closeMenu, ByVal 0         '向cmd窗口发送关闭命令

     Sheet1.Range("a1").Select
     Sheet1.Paste                                           '粘贴到A1单元格
     Set hf = Nothing                                       '释放剪贴板对象
     Set clip = Nothing
End Sub

伶俐的毛豆

太漂亮了，完美；老师，能不能加一句，防止过早关闭了控制台窗口，导致回显不完整

lss001

伶俐的毛豆 发表于 2024-7-29 21:37
太漂亮了，完美；老师，能不能加一句，防止过早关闭了控制台窗口，导致回显不完整

以下是代码是关闭，把以下代都删除即可
closeMenu = GetSubMenu(hMenu, 6)                       '获取"关闭" 控件的句柄
     SendMessage hwnd, WM_CLOSE, closeMenu, ByVal 0         '向cmd窗口发送关闭命令

伶俐的毛豆

lss001 发表于 2024-7-29 21:39
以下是代码是关闭，把以下代都删除即可
closeMenu = GetSubMenu(hMenu, 6)                       '获取 ...

比如我dir 一个2000多个文件的目录，可能要1分多钟才能执行完，这时候，即使不执行关闭控制台的命令，由于过早的copy，回显也是不完整的...

有不有办法，检测最后一个命令（比如最后我运行exit）被执行了，才开始全选，copy，再close窗口呢

lss001

伶俐的毛豆 发表于 2024-7-29 21:51
比如我dir 一个2000多个文件的目录，可能要1分多钟才能执行完，这时候，即使不执行关闭控制台的命令，由 ...

把最后的延时2秒→
Application.Wait Now + TimeSerial(0, 0, 2)
加大些改为2分钟→
t = Timer
Do While Timer < t + 120
     vba.DoEvents
Loop