Kiểm tra tên các workbook đang mở để xác định 1 file đã mở hay chưa.

Ai có code lấy tên các workbook đang mở không cho mình tham khảo với. Thanks!

Bạn làm như thế này nè:
– Double click vào các file (file nào bạn muốn mở)
– Đứng ở 1 file nào đó, bấm Ctrl + N, xong hãy chèn code và chạy thử
Bạn làm không ra kết quả là vì bạn khởi động 2 lần Excel khác nhau (2 session khác nhau) nên Workbook này không "nhìn thấy" Workbbok kia
Kiểm tra đơn giản nhất là: Ở tại 1 Workbook nào đó, vào menu Window xem có thấy tên các Workbook khác được liệt kê tại đây không?
Nhớ nha: Double Click vài file, xong Ctrl + N và chèn code
hình như không dùng được (trong trường hợp mở Excel giống như tác giả topic này)
Một ngày nào đó ta mở 2 file Excel (mở bằng 2 session) rồi dùng code trên kiểm tra workbook có đang mở hay không… nó lại cho kết quả = False thì … thật buồn cười
Chẳng lẽ không có code nào làm việc được với MutiSession hay sao ta? —> Phải xem lại kiến thức mà ta đã học thôi vì rắc rối này đã kéo theo thêm mấy rắc rối khác —> Hic…
Trên mạng cũng đã có người quan tâm đến vấn đề này… xem tại đây:
https://www.mrexcel.com/forum/showthread.php?t=72743
Tuy nhiên các câu trả lời cũng chưa giải quyết triệt để được vấn đề

Tình huống như bạn vừa nói tôi vẫn chưa nghĩ ra cách khắc phục

Hihi, mới google được: https://www.xtremevbtalk.com/showthread.php?t=298539
Chép code sau vào module

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetRunningObjectTable Lib "ole32.dll" (ByVal dwReserved As Long, pROT As Long) As Long
Private Declare Function CreateBindCtx Lib "ole32.dll" (ByVal dwReserved As Long, pBindCtx As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Sub OleInitialize Lib "ole32.dll" (pvReserved As Any)
Private Declare Sub OleUninitialize Lib "ole32.dll" ()
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
  ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)
Private Declare Function PutMem2 Lib "msvbvm60" (ByVal pWORDDst As Long, ByVal NewValue As Long) As Long
Private Declare Function PutMem4 Lib "msvbvm60" (ByVal pDWORDDst As Long, ByVal NewValue As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (ByVal pDWORDSrc As Long, ByVal pDWORDDst As Long) As Long
Private Declare Function VarPtr Lib "msvbvm60" (var As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function CopyStringA Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, _
  lpWideCharStr As Any, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, _
  ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long

Private Const GMEM_FIXED As Long = &H0
Private Const asmPUSH_imm32 As Byte = &H68
Private Const asmRET_imm16 As Byte = &HC2
Private Const asmRET_16 As Long = &H10C2&
Private Const asmCALL_rel32 As Byte = &HE8

'IUnknown vTable ordinals
Private Const unk_QueryInterface As Long = 0
Private Const unk_AddRef As Long = 1
Private Const unk_Release As Long = 2
Private Const vtbl_ROT_EnumRunning = 9
Private Const vtbl_EnumMoniker_Next = 3
Private Const vtbl_Moniker_GetDisplayName = 20

'Function to call Interface members by ordinal in VTable
Private Function CallInterface(ByVal pInterface As Long, ByVal FuncOrdinal As Long, _
  ByVal ParamsCount As Long, Optional ByVal p1 As Long = 0, Optional ByVal p2 As Long = 0, _
  Optional ByVal p3 As Long = 0, Optional ByVal p4 As Long = 0, Optional ByVal p5 As Long = 0, _
  Optional ByVal p6 As Long = 0, Optional ByVal p7 As Long = 0, Optional ByVal p8 As Long = 0, _
  Optional ByVal p9 As Long = 0, Optional ByVal p10 As Long = 0) As Long
    Dim i As Long, t As Long
    Dim hGlobal As Long, hGlobalOffset As Long

If ParamsCount < 0 Then Err.Raise 5 'invalid call
    If pInterface = 0 Then Err.Raise 5

'5 bytes for each parameter
    '5 bytes - PUSH this
    '5 bytes - call member function
    '3 bytes - ret 0x0010, pop CallWindowProc
    '1 byte - dword align.

hGlobal = GlobalAlloc(GMEM_FIXED, 5 * ParamsCount + 5 + 5 + 3 + 1)
    If hGlobal = 0 Then Err.Raise 7 'insuff. memory
        hGlobalOffset = hGlobal

If ParamsCount > 0 Then
        t = VarPtr(p1)
        For i = ParamsCount - 1 To 0 Step -1
            PutMem2 hGlobalOffset, asmPUSH_imm32
            hGlobalOffset = hGlobalOffset + 1
            GetMem4 t + i * 4, hGlobalOffset
            hGlobalOffset = hGlobalOffset + 4
        Next
    End If

'First member of any interface - this. Assign...
    PutMem2 hGlobalOffset, asmPUSH_imm32
    hGlobalOffset = hGlobalOffset + 1
    PutMem4 hGlobalOffset, pInterface
    hGlobalOffset = hGlobalOffset + 4

'Call IFace Function by its ordinal
    PutMem2 hGlobalOffset, asmCALL_rel32
    hGlobalOffset = hGlobalOffset + 1

GetMem4 pInterface, VarPtr(t) 'dereference: find vTable
    GetMem4 t + FuncOrdinal * 4, VarPtr(t) 'Function offset in vTable, dereference
    PutMem4 hGlobalOffset, t - hGlobalOffset - 4
    hGlobalOffset = hGlobalOffset + 4

'all interfaces are stdcall, so forget about stack clearing
    PutMem4 hGlobalOffset, asmRET_16 'ret 0x0010

CallInterface = CallWindowProc(hGlobal, 0, 0, 0, 0)

GlobalFree hGlobal

End Function

Private Function StrFromPtrA(ByVal lpszA As Long, Optional nSize As Long = 0) As String
    Dim s As String, bTrim As Boolean
    If nSize = 0 Then
        nSize = lstrlenA(lpszA)
        bTrim = True
    End If
    s = String(nSize, Chr$(0))
    CopyStringA s, ByVal lpszA
    If bTrim Then s = TrimNULL(s)
    StrFromPtrA = s
End Function

Private Function StrFromPtrW(ByVal lpszW As Long, Optional nSize As Long = 0) As String
    Dim s As String, bTrim As Boolean
    If nSize = 0 Then
        nSize = lstrlenW(lpszW) * 2
        bTrim = True
    End If
    s = String(nSize, Chr$(0))
    ' CopyMemory ByVal StrPtr(s), ByVal lpszW, nSize ' VBA doesn't support StrPtr
    WideCharToMultiByte 0, &H0, ByVal lpszW, -1, ByVal s, Len(s), &H0, &H0
    If bTrim Then s = TrimNULL(s)
    StrFromPtrW = s
End Function

Private Function TrimNULL(ByVal str As String) As String
    If InStr(str, Chr$(0)) > 0& Then
        TrimNULL = Left$(str, InStr(str, Chr$(0)) - 1&)
    Else
        TrimNULL = str
    End If
End Function

Public Function GetAllInstances() As Collection
    Dim pROT As Long, pEnumMoniker As Long, pMoniker As Long, pBindCtx As Long
    Dim ret As Long, nCount As Long, CheckForInstance As Boolean, Key As String
    Dim pName As Long, RegisteredName As String, ExcelApp As Application

ret = GetRunningObjectTable(0, pROT)
    ret = CreateBindCtx(0, pBindCtx)
    CallInterface pROT, vtbl_ROT_EnumRunning, 1, VarPtr(pEnumMoniker)
    While CallInterface(pEnumMoniker, vtbl_EnumMoniker_Next, 3, 1, VarPtr(pMoniker), VarPtr(nCount)) = 0
        CallInterface pMoniker, vtbl_Moniker_GetDisplayName, 3, pBindCtx, 0, VarPtr(pName)
        'For win9x you'll need StrFromPtrA

RegisteredName = StrFromPtrW(pName)
        If InStr(LCase(RegisteredName), "book") Then
                CheckForInstance = True
            Else
                Select Case Right(RegisteredName, 3)
                    Case "xla", "slk", "dif", "csv", "txt", "prn", "dbf", "wq1", "wks", "wk1", "wk3", "wk4", "xlw", "xls", "xlt", "htm", "mht", "xml"
                        CheckForInstance = True
                    End Select
                        Select Case Right(RegisteredName, 5)
                    Case ".html", "mhtml"
                        CheckForInstance = True
                End Select
        End If

If CheckForInstance Then
                CheckForInstance = False
                If ParentIsExcel(RegisteredName, ExcelApp) Then
                    If GetAllInstances Is Nothing Then Set GetAllInstances = New Collection
                    Key = CStr(ObjPtr(ExcelApp))
                    If Not InstanceAlreadyCollected(GetAllInstances, Key) Then
                    GetAllInstances.Add ExcelApp, Key
                End If
            End If
        End If

CallInterface pMoniker, unk_Release, 0
        CoTaskMemFree pName
    Wend
    CallInterface pEnumMoniker, unk_Release, 0
    CallInterface pBindCtx, unk_Release, 0
    CallInterface pROT, unk_Release, 0
    Exit Function

End Function

Private Function ParentIsExcel(ByVal RegisteredName As String, ExcelApp As Application) As Boolean
    On Error Resume Next

Set ExcelApp = GetObject(RegisteredName).Parent
    If ExcelApp.Name = "Microsoft Excel" Then
        ParentIsExcel = True
    End If

End Function

Private Function InstanceAlreadyCollected(GetAllInstances As Collection, Key As String) As Boolean
    On Error GoTo Err_InstanceAlreadyCollected
    Dim o As Application
    Set o = GetAllInstances(Key)
    InstanceAlreadyCollected = True
Err_InstanceAlreadyCollected:
End Function

[/GPECODE]

Rồi tiếp tục chép code sau vào bên dưới module, xong chạy code này:

[GPECODE=vb]Sub Example()
     Dim AllExcelApps As Collection, ExcelApp As Application, wb As Workbook, Pid As Long

Set AllExcelApps = GetAllInstances
     If Not AllExcelApps Is Nothing Then
        For Each ExcelApp In AllExcelApps
            GetWindowThreadProcessId ExcelApp.hwnd, Pid
            Debug.Print ExcelApp.Caption & ",  Process ID = " & Pid
            For Each wb In ExcelApp.Workbooks
                Debug.Print "    " & wb.Name
            Next
        Next
     End If
End Sub

Bạn có thể sửa code trên để đóng file.

Dài thấy ớn, cao thủ nào test và rút gọn bớt dùm

Mình test, nó không hiện thị được file có dấu tiếng Việt, ngoài ra nếu code nằm trong file có dấu tiếng Việt, nó bị lỗi tại dòng màu đỏ: GetWindowThreadProcessId ExcelApp.hwnd, Pid.

————————————————————-

Vọc từ sáng giờ rốt cuộc cũng hoàn thiện được, không quá dài, gởi tặng mọi người.
Liệt kê được tất cả các File Excel đang mở trên tất cả các session, kể cả có dấu tiếng Việt.

P/s: Dạo này (từ khi diễn đàn có chức năng hiển thị STT các dòng code) trang nào có code thì rất khó mở, chỉ hiển thị được một ít ở phần đầu trang.Càng dài càng khó mở, phải mở nhiều lần mới được. Các bạn có ai bị vậy không?

Bài này có liên quan đến CÁC CỬA SỔ nên chợt nghĩ đến hàm EnumWindows và AddressOf Operator
Thử làm bài này theo phương án ấy xem:
1> Trong Module:

Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextW" (ByVal hWnd As Long, ByVal lpString As Long, ByVal cch As Long) As Long
Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthW" (ByVal hWnd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Dic As Object

Public Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Boolean
Dim sSave As String, Ret As Long, wClass As String
Ret = GetWindowTextLength(hWnd)
sSave = Space(Ret)
GetWindowText hWnd, StrPtr(sSave), Ret + 1
wClass = WinClassName(hWnd)
If (wClass = "MS-SDIb") Or (wClass = "XLMAIN") Then
If sSave Like "Microsoft Excel – *" Then sSave = Mid(sSave, 19)
sSave = Trim(Replace(sSave, "", ""))
If Not Dic.Exists(sSave) Then Dic.Add sSave, ""
End If
EnumWindowsProc = True
End Function

Function WinClassName(ByVal hWnd As Long) As String
Dim RetVal As Long, lpClassName As String
If hWnd <> 0 Then
lpClassName = Space(256)
RetVal = GetClassName(hWnd, lpClassName, 256)
WinClassName = Left$(lpClassName, RetVal)
End If
End Function

Sub Main()
Set Dic = CreateObject("Scripting.Dictionary")
UserForm1.Show
End Sub
2> Trong UserForm (với 1 CommandButton và 1 ListBox)

Private Sub CommandButton1_Click()
On Error Resume Next
EnumWindows AddressOf EnumWindowsProc, ByVal 0&
Me.ListBox1.List() = Dic.Keys
End Sub
Hoàn toàn không có tí vòng lập nào hen
Giải thuật là:
– Cứ cửa số nào có ClassName = "XLMAIN" hoặc "MS-SDIb" thì lấy
– Lấy xong, xử lý các phần thừa để chỉ còn lại TÊN
Giải thuật là như vậy nhưng vì chưa rành API lắm, lại thông qua quá trình thí nghiệm mà suy luận nên phần triển khai có chút luộm thuộm
Rất mong các cao thủ góp ý, nhất là code trong hàm EnumWindowsProc (chưa hài lòng lắm)
Mình rất khoái thằng em "AddressOf" —> Có vẽ như là 1 sự "tương tác 2 chiều gì đó" mà mình không mấy hiểu

www.giaiphapexcel.com/diendan/threads/ki%E1%BB%83m-tra-t%C3%AAn-c%C3%A1c-workbook-%C4%91ang-m%E1%BB%9F-%C4%91%E1%BB%83-x%C3%A1c-%C4%91%E1%BB%8Bnh-1-file-%C4%91%C3%A3-m%E1%BB%9F-hay-ch%C6%B0a.34357/

Khóa học SprinGO phù hợp

Học Nhân sự Tổng hợp – Trở thành chiến binh nhân sự vững nghiệp vụ

Con người là một trong những yếu tố quan trọng của công ty, là tài sản quý giá của doanh nghiệp. Chính vì thế,...

Xem khóa học