Đóng toàn bộ ứng dụng và tắt máy tính bằng VBA!

[HeSanbi]

Share mọi người code đóng toàn bộ ứng dụng , save file excel rồi tắt PC sau vài giây trong một cú click

Chạy: Call remote_pc_LRS (3, True, 15)
Để Hủy Shutdown:
Cách 1. Call remote_pc_LRS (code vào Workbook_AfterOpen, mở lại Workbook tự động hủy shutdown)
Cách 2. mở hộp thoại Run (Phím Window + R) gõ: shutdown -a

Chương trình gồm có:
1. Sub remote_pc_LRS gồm 3 biến:
- state: giá trị 1 là logout, 2 là restart, 3 là shutdown, giá trị khác là hủy tắc PC
- actionYes: True - Thực hiện ngay / False - hỏi xem có muốn tắt không
- num: số giây hẹn thực hiện

2. Function arrayAppSYS: là một mảng chứa các chương trình sẽ không đóng các ứng dụng này
Nếu muốn không đóng một chương trình nào đó, hãy thêm vào array

3. Function quit_app_running : dùng để dóng chương trình
True: đóng không cần hỏi/ False: hỏi trước khi đóng

4. Function close_excel gồm 2 biến:
- saveAll: True - save tất cả các workbook / False - Save file đang chỉnh sữa
- closeOK: True - đóng ứng dụng không hỏi/ False - hỏi trước khi đóng ứng dụng

Lưu Ý: Nhớ sao lưu file của các ứng dụng khác. Nhỡ Run tay thì hãy thử nó khi PC vừa mở, vào Excel và ấn Thử.
Đã quen tay cứ ấn thõa thích.

#If VBA7 Then
  Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
  Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
  Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
  Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Sub close_FileEXPLORER()
    Dim lExplhwnd As Long
    lExplhwnd = FindWindow("CabinetWClass", vbNullString) ' "ExploreWClass"'
    If lExplhwnd Then
        SendMessage lExplhwnd, &H112, &HF060&, ByVal 0&
    End If
End Sub

Sub CloseAllWorkbooks()
    Dim wb As Workbook
    For Each wb In Workbooks
        wb.Close False 'True -> Save
    Next wb
End Sub

Sub test_close_excel()
    close_excel  , True
End Sub
 
Function close_excel(Optional save As Boolean = True, _
                       Optional closeOK As Boolean = False)
    ThisWorkbook.save
    Call close_FileEXPLORER
    Call quit_app_running(closeOK)
    Application.DisplayAlerts = False
      Application.Quit
      ActiveWorkbook.Close SaveChanges:=False
    Application.DisplayAlerts = True
  End Function

    Function arrayAppSYS(Optional toArray2D As Boolean) As Variant
        Dim m, dArr() As Variant, k: k = 0
        arrayAppSYS = Array("ApplicationFrameHost.exe", "audiodg.exe", "backgroundTaskHost.exe", "CCleaner64.exe", "CocCocCrashHandler.exe", "CocCocUpdate.exe", "conhost.exe", "csrss.exe", "ctfmon.exe", "dllhost.exe", "dwm.exe", "explorer.exe", _
                            "fontdrvhost.exe", "fsnotifier64.exe", "GoogleCrashHandler.exe", "GoogleCrashHandler64.exe", "googledrivesync.exe", "gxxsvc.exe", "jusched.exe", "LockApp.exe", "lsass.exe", "Microsoft.Mashup.Container.NetFX40.exe", "MSASCuiL.exe", _
                            "nvcontainer.exe", "NVDisplay.Container.exe", "NVIDIA Web Helper.exe", "NvTelemetryContainer.exe", "obs-browser-page.exe", "OpenWith.exe", _
                            "RemindersServer.exe", "RemoteServerWin.exe", "RtkNGUI64.exe", "RuntimeBroker.exe", "SearchFilterHost.exe", "SearchIndexer.exe", _
                            "SearchProtocolHost.exe", "SearchUI.exe", "SecurityHealthService.exe", "services.exe", "SettingSyncHost.exe", "SgrmBroker.exe", "ShellExperienceHost.exe", "sihost.exe", "smss.exe", "SMSvcHost.exe", _
                            "spoolsv.exe", "sqlwriter.exe", "SteamService.exe", "steamwebhelper.exe", "svchost.exe", "SystemSettingsBroker.exe", "taskhostw.exe", "TeamViewer_Service.exe", "TiltWheelMouse.exe", "tv_w32.exe", _
                            "tv_x64.exe", "UniKeyNT.exe", "UnrealCEFSubProcess.exe", "update_notifier.exe", "wininit.exe", "winlogon.exe", "WmiPrvSE.exe", "WsxService.exe")
        If toArray2D Then
            ReDim dArr(1 To UBound(arrayAppSYS) + 1, 1 To 1)
            For Each m In arrayAppSYS
                k = k + 1
                dArr(k, 1) = m
            Next
            arrayAppSYS = dArr
        End If
    End Function
Sub test_quit_app_running()
    If quit_app_running Then Debug.Print 2
End Sub
    Function quit_app_running(Optional ByVal bool As Boolean) As Boolean
        Dim question
        If Not bool Then question = MsgBox("Close Application Running?", 3): If question <> vbYes Then Exit Function
        Dim objWMIcimv2 As Object, objProcess As Object, objList As Object, intError As Integer
        Dim  dArr
        With MyPC

            Set objWMIcimv2 = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
            Set objList = objWMIcimv2.ExecQuery("select * from win32_process")
            For Each objProcess In objList
                On Error Resume Next
                If objProcess.Name Like "*" & ".exe" Then
                    dArr = Application.Match(objProcess.Name, arrayAppSYS, False)
                    If dArr Is Nothing Then
                        On Error Resume Next
                        intError = objProcess.Terminate
                        If intError <> 0 Then Debug.Print objProcess.Name
                    End If
                End If
            Next
        End With
        quit_app_running = True
        Set objWMIcimv2 = Nothing
        Set objList = Nothing
        Set sArr = Nothing
        Set dArr = Nothing
    End Function
    Sub remote_pc_LRS(Optional ByVal state As Integer, _
                                Optional ByVal actionYes As Boolean = False, _
                                Optional num As Integer = 10)
        Dim Result
        Shell "shutdown -a", vbHide
        If state <> 0 And Not actionYes Then
             Result = MsgBox("Shutdown PC?", 3)
        End If
        If Result = vbYes Or actionYes Then
            If state = 1 Then
    Dim xWb As Workbook
    For Each xWb In Application.Workbooks
        If Not xWb.ReadOnly And Windows(xWb.Name).Visible Then
            xWb.Save
        End If
    Next
ThisWorkbook.save
Shell "shutdown -l", vbHide
end if
            If state = 2 Then Shell "shutdown -r -t " & num, vbHide
            If state = 3 Then Shell "shutdown -s -t " & num, vbHide
            close_excel , True
        End If
    End Sub

 

[Thangvmbdl]

Laptop của tôi chạy windows 10, chỉ cần đóng nắp cái là xong hết, không cần code nào cả

Anh ơi cho e hỏi có code nào tắt được file share khi file đang mở trên 3 máy tính khác nhau không ạ. Yêu cầu khi chạy code vba thì file này đang mở ở tất cả các máy đều đóng hết ạ. E cảm ơn