Lập trình VBA: Phương pháp chống thực thi chồng chất

[HeSanbi]

Xin chào các bạn, hôm nay tôi lại giới thiệu với các bạn một phương pháp lập trình tạo ứng dụng chống thực thi chồng chất.
Khi các ứng dụng được nhân bản chạy song song với nhau, thì các mã chắc chắn sẽ được thực thi song song, nếu hai mã tương đồng chắc chắn sẽ chạy nạp chồng lên nhau.
Chẳng hạn như khi ta sao chép ứng dụng và mở ứng dụng đó chạy song song. Nhờ phương pháp này chúng ta có thể sao chép mã vào ứng dụng mới, và mở chạy song song, mà không gặp một khó khăn nào.
Phương pháp mới này giúp ứng dụng hoạt động trơn tru mà không bị hỏng khi hoạt động, ngăn chặn nhiều nguy cơ làm kết thúc tiến trình Excel của bạn.
Phương pháp này hoạt động tốt kể cả bạn có cài song song hai phiên bản Excel trên cùng máy tính và chạy ứng dụng song song.

Để thực hiện được phương pháp này ta sẽ sử dụng Thiết lập Settings trong registry của ứng dụng Excel.


Phương pháp chống thực thi chồng chất:

Phương pháp 1: Đặt ứng dụng ưu tiên vào registry

Nếu ứng dụng nhân bản nào chạy trước thì ưu tiên lưu vào registry trước, ứng dụng chạy sau sẽ kiểm tra trong registry đã tồn tại tiến trình nào chưa, chưa thì sẽ lưu vào ưu tiên.

Dưới đây là các mã để làm theo mục đích đã nói ở trên:

• Thủ tục AddGlobalRun: nếu tìm trong registry, nếu không tìm thấy thì đặt ưu tiên, hàm này được đặt vào sự kiện Workbook_Open.
• Hàm checkGlobalRunning: tìm kiếm quyền ưu tiên đã tồn tại chưa, nếu chưa hoặc là chính nó thì được phép chạy.
• Thủ tục removeGlobalRun: để xóa quyền ưu tiên để nhường quyền cho tiến trình khác.

Const ROOTNAME = "ROOTNAME"

Function checkGlobalRunning(ByVal bookName$) As Boolean
  On Error Resume Next
  Dim s$: s = GlobalSetting()
  checkGlobalRunning = s <> Empty And s <> ThisWorkbook.Name
  If s = Empty Then Call GlobalSetting(1, bookName)
End Function

Sub AddGlobalRun()
  Dim s$: s = GlobalSetting()
  If s = Empty And s <> ThisWorkbook.Name Then
    Call GlobalSetting(1, ThisWorkbook.Name)
  End If
End Sub

Sub removeGlobalRun()
  On Error Resume Next
  Dim s$: s = GlobalSetting()
  If s = ThisWorkbook.Name Then
    Call GlobalSetting(2)
  End If
End Sub

Private Function GlobalSetting(Optional style%, Optional value$) As String
  Const t = "Ready"
  Dim s$: s = "Global_" & CStr(Val(Application.Version))
  On Error Resume Next
  Select Case VBA.Abs(style) Mod 3
  Case 0: GlobalSetting = VBA.GetSetting(ROOTNAME, s, t, "")
  Case 1: Call VBA.SaveSetting(ROOTNAME, s, t, value)
  Case 2: Call VBA.DeleteSetting(ROOTNAME, s, t)
  End Select
End Function

Sub projectExit()
  removeGlobalRun
End Sub

Ví dụ cho sự kiện SheetBeforeDoubleClick như sau:

Private WithEvents app As Application
Private Sub App_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal t As Range, Cancel As Boolean)
  If checkGlobalRunning(Sh.Parent.Name) Then Exit Sub
  ' Sẽ thực thi nếu đủ điều kiện'
End Sub
Private Sub Class_Initialize()
  Set app = Application
End Sub

Sau khi thoát ứng dụng thì quyền ưu tiên cần xóa đi để nhường lại cho tiến trình khác:
Thủ tục projectExit sẽ được đặt vào sự kiện Workbook_Close


Phương pháp 2: Đặt tiến trình ưu tiên vào registry

Đặt tiến trình ưu tiên có ưu thế là Ứng dụng chính vẫn chạy, nhưng sẽ nhường quyền thực thi cho mã trong tiến trình ưu tiên ở ứng dụng khác. Ví dụ bạn có ứng dụng tận dụng sự kiện Application, nay bạn muốn tận dụng ứng dụng đấy nhưng chỉ chạy ở mức độ sự kiện Workbook, thì phương pháp 2 này sẽ phù hợp với mục đích này.

• Thủ tục AddSingleProcess: nếu tìm trong registry, nếu không tìm thấy thì đặt ưu tiên, thủ tục này được đặt vào sự kiện Workbook_Open.
• Hàm checkProcessRunning: tìm kiếm quyền ưu tiên đã tồn tại chưa, nếu chưa hoặc là chính nó thì được phép chạy.
• Thủ tục removeSingleProcess: để xóa quyền tiến trình ưu tiên.

Function checkProcessRunning(Optional ByVal bookName$) As Boolean
  On Error Resume Next
  If bookName = ThisWorkbook.Name Then Exit Function
  Dim s$: s = ProcessSetting(0, bookName)
  checkProcessRunning = s = bookName
End Function

Sub removeSingleProcess()
  On Error Resume Next
  Dim s$: s = ProcessSetting()
  If s = ThisWorkbook.Name Then
    Call ProcessSetting(2)
  End If
End Sub

Sub AddSingleProcess()
  Dim s$: s = ProcessSetting()
  If s = Empty And s <> ThisWorkbook.Name Then
    Call ProcessSetting(1, ThisWorkbook.Name)
  End If
End Sub

Private Function ProcessSetting(Optional style%, Optional value$) As String
  Dim s$, t: s = "Process_" & CStr(Val(Application.Version)): t = value
  On Error Resume Next
  Select Case VBA.Abs(style) Mod 3
  Case 0: ProcessSetting = VBA.GetSetting(ROOTNAME, s, t, "")
  Case 1: Call VBA.SaveSetting(ROOTNAME, s, t, t)
  Case 2: Call VBA.DeleteSetting(ROOTNAME, s, t)
  End Select
End Function

Ví dụ cho sự kiện SheetBeforeDoubleClick như sau:

Private WithEvents app As Application
Private Sub App_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal t As Range, Cancel As Boolean)
  If checkProcessRunning(Sh.Parent.Name) Then Exit Sub
  If checkGlobalRunning(Sh.Parent.Name) Then Exit Sub
  ' Sẽ thực thi nếu đủ điều kiện'
End Sub
Private Sub Class_Initialize()
  Set app = Application
End Sub

LƯU Ý: Các khóa Registry trong các ứng dụng nhân bản phải giống y nhau, thì mới ứng dụng được phương pháp này.


Ứng dụng tham khảo Phương pháp chống thực thi chồng chất:
https://www.giaiphapexcel.com/diendan/resources/17/


Trên đây đó là hướng dẫn của tôi về Phương pháp chống thực thi chồng chất, nếu các bạn có thắc mắc hãy đặt câu hỏi, và tôi sẽ sẵn lòng trả lời các bạn. Phương pháp sẽ có nhiều cải tiến trong tương lai các bạn theo dõi chủ đề để cập nhật.
Chúc các bạn thành công.


Tải ứng dụng tương đồng nhau bên dưới và chạy song song để thử: