Excel VBA

Lệnh MiniMIS

Xem ở menu cho file riêng lẻ https://minimis.vn/xml

MsgBox(prompt, buttons, title)

Code tự bỏ phần sau dấu chấm phẩy

Function IsString2(val As Variant) As Boolean
  IsString2 = VarType(val) = vbString
End Function

Function Range2(ParamArray Rngs() As Variant) As String
    Dim r As Variant, s As String
    For Each r In Rngs
        s = s & "," & Split(r.Address(0, 0, xlA1, True), "!")(1)
    Next r
    Range2 = Mid$(s, 2)
End Function

Function Range2(ParamArray Range_() As Variant) As String
  Application.Volatile
  SplitChar = ","
  Dim r As Variant, t As String, strarray() As String, addressPart As String
  t = "" ' Initialize t as an empty string
  For Each r In Range_()
    addressPart = r.Address(0, 0, xlA1, True) ' Get the full address of the range
    strarray = Split(addressPart, "!")  ' Split the address by "!" and get the second part (if exists)
    If UBound(strarray) >= 1 Then
      addressPart = strarray(1) ' Get the second part
    End If
    t = t & IIf(Len(t) > 0, SplitChar, "") & addressPart ' Concatenate the results, adding splitchar only if t is not empty
  Next
  Range2 = t ' Return the final result
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
  Dim cell As Range
  If Not Intersect(Target, Me.Range([A1])) Is Nothing Then
  Application.EnableEvents = False
    For Each cell In Target
      If IsString2(cell.Value) Then
        pos = InStr(cell.Value, ";")
        If pos > 0 Then
          cell.Value = Left(cell.Value, pos - 1)
        End If
      End If
    Next cell
  Application.EnableEvents = True
  End If
End Sub

Code Pop-Up mã theo Validation

(đặt trong module ThisWorkbook)

Option Explicit
Private Const AUTO_TAG As String = "OBJECT NAME"
Private mLastCell As Range
Private mCache As Object        'Formula1 -> Dictionary(Key -> Comment)

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error GoTo ExitHere
    Dim cmt As Comment
    If Not mLastCell Is Nothing Then
        If mLastCell.parent Is Sh Then
            Set cmt = mLastCell.Comment
            If Not cmt Is Nothing Then
                If Left$(cmt.Text, Len(AUTO_TAG)) = AUTO_TAG Then cmt.Delete
            End If
        End If
    End If
    Set mLastCell = Target
    If Not Me.Sheets(ChrW(9989)).Range("A1").Value2 Then Exit Sub
    If Target.CountLarge <> 1 Then Exit Sub
    ShowComment Target
ExitHere:
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    'Refresh cache khi du liêu thay dôi
    Set mCache = Nothing
End Sub

Private Sub ShowComment(ByVal Target As Range)
    On Error GoTo ExitHere
    Dim v As Validation
    Dim dict As Object
    Dim key As String
    Dim txt As String
    Dim cmt As Comment
    key = LCase$(Trim$(CStr(Target.Value2)))
    If Len(key) = 0 Then Exit Sub
    On Error Resume Next
    Set v = Target.Validation
    On Error GoTo ExitHere
    If v Is Nothing Then Exit Sub
    If v.Type <> xlValidateList Then Exit Sub
    Set dict = GetValidationDict(v.Formula1)
    If dict Is Nothing Then Exit Sub
    If Not dict.Exists(key) Then Exit Sub
    txt = dict(key)
    If Len(txt) = 0 Then Exit Sub
    Set cmt = Target.Comment
    If Not cmt Is Nothing Then
        If Left$(cmt.Text, Len(AUTO_TAG)) = AUTO_TAG Then
            cmt.Delete
        Else
            Exit Sub
        End If
    End If
    Target.AddComment AUTO_TAG & vbCrLf & txt
    With Target.Comment
        .Visible = False
        .Shape.TextFrame.AutoSize = True
    End With
ExitHere:
End Sub

Private Function GetValidationDict(ByVal Formula1 As String) As Object
    If mCache Is Nothing Then
        Set mCache = CreateObject("Scripting.Dictionary")
    End If
    If Not mCache.Exists(Formula1) Then
        mCache.Add Formula1, BuildDictionary(Formula1)
    End If
    Set GetValidationDict = mCache(Formula1)
End Function

Private Function BuildDictionary(ByVal src As String) As Object
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim rng As Range
    Dim arr As Variant
    Dim s As String
    Dim p As Long
    Dim i As Long
    If Left$(src, 1) = "=" Then
        Set rng = Evaluate(src)
        If rng Is Nothing Then
            Set BuildDictionary = dict
            Exit Function
        End If
        arr = rng.Value2
        If IsArray(arr) Then
            For i = 1 To UBound(arr, 1)
                s = Trim$(CStr(arr(i, 1)))
                p = InStr(s, ";")
                If p > 0 Then
                    dict(LCase$(Trim$(Left$(s, p - 1)))) = Trim$(Mid$(s, p + 1))
                End If
            Next
        Else
            s = Trim$(CStr(arr))
            p = InStr(s, ";")
            If p > 0 Then
                dict(LCase$(Trim$(Left$(s, p - 1)))) = Trim$(Mid$(s, p + 1))
            End If
        End If
    Else
        arr = Split(src, ",")
        For i = LBound(arr) To UBound(arr)
            s = Trim$(arr(i))
            p = InStr(s, ";")
            If p > 0 Then
                dict(LCase$(Trim$(Left$(s, p - 1)))) = Trim$(Mid$(s, p + 1))
            End If
        Next
    End If
    Set BuildDictionary = dict
End Function

Code PublishExcel

Private Sub HashCell(ws)
   Dim r As Range, c As Range
   Dim t As String
   Set r = ws.UsedRange
   For Each c In r
       t = c.Text
       If IsNumeric(c.Value) And (t = "#" Or t = "##" Or t = "###" Or t = "####" Or t = "#####" Or t = "#####" Or t = "######" Or t = "#######" Or t = "########" Or t = "#########" Or t = "##########" Or t = "###########" Or t = "############" Or t = "#############" Or t = "##############" Or t = "###############") Then c.ShrinkToFit = True
    Next c
End Sub

Private Sub HashCells()
    Dim ws As Worksheet, selectedSheet As Worksheet
    For Each selectedSheet In ActiveWindow.SelectedSheets
        Call HashCell(selectedSheet)
    Next selectedSheet
End Sub

Private Sub FitPrint()
    With ActiveSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 100
    End With
End Sub

Sub xml_PublishAsExcel(control As IRibbonControl)
    Call PublishAsExcel
End Sub

Sub PublishAsExcel()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim filePath As String, fileName As String
    Dim lastRow As Long, i As Long
    Dim visibleArray() As Boolean

    Set wb1 = ActiveWorkbook
    filePath = wb1.Path & "\"
    
    fileName = wb1.Name
    fileName = Left(fileName, InStrRev(fileName, ".") - 1) ' Loai bo phan mo rong
    fileName = fileName & "_" & Format(Now, "yymmdd-hhmm") & ".xlsx"
    
    Set wb2 = Workbooks.Add
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    wb2.SaveAs fileName:=filePath & fileName, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    ' Duyet qua tung sheet trong workbook hien tai
    For Each ws1 In wb1.Sheets
        If Left(ws1.Name, 1) = ChrW(10022) Or Left(ws1.Name, 1) = ChrW(10023) Then
        Application.StatusBar = "Publishing sheet " & ws1.Name
            
            ' Tao sheet moi trong workbook moi
            Set ws2 = wb2.Sheets.Add(After:=wb2.Sheets(wb2.Sheets.count))
            
            ws2.Name = ws1.Name
            If Err.Number <> 0 Then ws2.Name = "Copy_" & ws1.Name
            On Error GoTo 0
            ws2.Tab.color = ws1.Tab.color
            
            ' Sao chep du lieu va dinh dang
            ws1.UsedRange.Copy
            ws2.Cells(1, 1).PasteSpecial xlPasteValues
            ws2.Cells(1, 1).PasteSpecial xlPasteFormats
            ws2.Cells(1, 1).PasteSpecial xlPasteColumnWidths
            Application.CutCopyMode = False ' Dung che do sao chep

            ' Sao chep cai dat trang
            With ws2.PageSetup
                .Orientation = ws1.PageSetup.Orientation
                .PaperSize = ws1.PageSetup.PaperSize
                .Zoom = ws1.PageSetup.Zoom
                .FitToPagesWide = ws1.PageSetup.FitToPagesWide
                .FitToPagesTall = ws1.PageSetup.FitToPagesTall

                ' Cai dat layout in
                .LeftMargin = ws1.PageSetup.LeftMargin
                .RightMargin = ws1.PageSetup.RightMargin
                .TopMargin = ws1.PageSetup.TopMargin
                .BottomMargin = ws1.PageSetup.BottomMargin
                .HeaderMargin = ws1.PageSetup.HeaderMargin
                .FooterMargin = ws1.PageSetup.FooterMargin
                .CenterHorizontally = ws1.PageSetup.CenterHorizontally
                .CenterVertically = ws1.PageSetup.CenterVertically

                ' Tieu de va chan trang
                .CenterHeader = ws1.PageSetup.CenterHeader
                .LeftHeader = ws1.PageSetup.LeftHeader
                .RightHeader = ws1.PageSetup.RightHeader
                .CenterFooter = ws1.PageSetup.CenterFooter
                .LeftFooter = ws1.PageSetup.LeftFooter
                .RightFooter = ws1.PageSetup.RightFooter
                .DifferentFirstPageHeaderFooter = ws1.PageSetup.DifferentFirstPageHeaderFooter
                .OddAndEvenPagesHeaderFooter = ws1.PageSetup.OddAndEvenPagesHeaderFooter

                ' In duong luoi va tieu de
                .PrintGridlines = ws1.PageSetup.PrintGridlines
                .PrintHeadings = ws1.PageSetup.PrintHeadings
                .PrintComments = ws1.PageSetup.PrintComments

                ' Cai dat trang in
                .PrintArea = ws1.PageSetup.PrintArea
                .Order = ws1.PageSetup.Order
                .AlignMarginsHeaderFooter = ws1.PageSetup.AlignMarginsHeaderFooter
            End With
            
            lastRow = ws1.Cells(ws1.Rows.count, 1).End(xlUp).Row
            ReDim visibleArray(1 To lastRow)
            For i = 1 To lastRow
                visibleArray(i) = ws1.Rows(i).Hidden
            Next i
            For i = 1 To lastRow
                ws2.Rows(i).Hidden = visibleArray(i)
            Next i
            
            Call FitPrint
            wb2.Activate
            ActiveWindow.View = xlPageBreakPreview
        End If
    Next ws1
    
    wb2.Activate
    Application.DisplayAlerts = False
    Sheets(1).Delete
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationSemiautomatic
    
    For Each ws2 In wb2.Worksheets
        ws2.Select
        Call HashCell(ws2)
        Range("A1").Select
    Next ws2
    Sheets(1).Select
    wb2.Save
    Application.Assistant.DoAlert title, "Ða xuât các sheet báo cáo ra file Excel mói", 0, 5, 0, 0, 0
    
End Sub

Sub PublishAsExcel2()
    Application.Run ("'C:\miniMis\miniSql.xlam'!CopySheet1")
End Sub

Sub PublishAsPDF()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim arrSheets() As String
    Dim i As Long
    Dim filePath As String, fileName As String
    Dim useSelectedSheets As Boolean

    Set wb = ActiveWorkbook
    filePath = wb.Path & "\"

    fileName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
    fileName = fileName & "_" & Format(Now, "yymmdd-hhmm") & ".pdf"

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' ===== 1. Kiem tra có dang chon nhieu sheet không =====
    If TypeName(ActiveWindow.SelectedSheets) = "Sheets" _
        And ActiveWindow.SelectedSheets.count >= 2 Then
        useSelectedSheets = True
    End If

    ' ===== 2. Lay danh sách sheet =====
    If useSelectedSheets Then
        ' ? Dùng sheet dang chon
        For Each ws In ActiveWindow.SelectedSheets
            i = i + 1
            ReDim Preserve arrSheets(1 To i)
            arrSheets(i) = ws.Name
        Next ws
    Else
        ' ? Dùng logic cu theo ký tu dac biet
        For Each ws In wb.Worksheets
            If Left(ws.Name, 1) = ChrW(10022) Or Left(ws.Name, 1) = ChrW(10023) Then
                i = i + 1
                ReDim Preserve arrSheets(1 To i)
                arrSheets(i) = ws.Name
            End If
        Next ws
    End If

    If i = 0 Then
        MsgBox "Không có sheet nào dê xuât PDF", vbExclamation
        GoTo ExitSub
    End If

    ' ===== 3. Xuat PDF =====
    wb.Worksheets(arrSheets).Select

    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        fileName:=filePath & fileName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    MsgBox "Ðã xuât PDF thành công", vbInformation

ExitSub:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    wb.Worksheets(arrSheets(1)).Select

End Sub

Mã gán vào sự kiện DoubleClick để chọn địa chỉ range và gán lại vào textbox

Private Sub TextBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim rng As Range
    On Error Resume Next
    Set rng = Application.InputBox( _
        Prompt:="Range:", _
        Title:="Select target", _
        Type:=8)
    On Error GoTo 0
    If Not rng Is Nothing Then
        TextBox.value = rng.Address
    End If
End Sub

Unprotect VBA Project

Summary (English)
Temporarily hooks the Windows DialogBoxParamA API to bypass the VBA Project password dialog and unlock a protected VBA project.

1. Chức năng
Can thiệp vào API DialogBoxParamA của Windows để bỏ qua hộp thoại mật khẩu của VBA Project, từ đó làm cho VBA Project đang được bảo vệ bằng mật khẩu có thể được truy cập/chỉnh sửa.

2. Hướng dẫn

1. Mở workbook có VBA Project đang bị khóa bằng mật khẩu.

2. Mở VBA Editor bằng Alt + F11.

3. Import hoặc đặt đoạn mã vào một Module chuẩn.

4. Chạy Sub UnprotectVBA.

5. Macro thực hiện Hook vào hàm DialogBoxParamA của user32.dll.

6. Khi Excel gọi hộp thoại bảo vệ VBA, mã kiểm tra template ID 4070 và trả về kết quả xác nhận thay vì hiển thị yêu cầu mật khẩu.

7. Nếu Hook thành công, thông báo "VBA Project is unprotected!" được hiển thị.

8. Với các hộp thoại khác, mã tạm thời khôi phục byte gốc, gọi API bình thường rồi cài Hook lại.

3. Minh họa chức năng

🔒 VBA Project dang bi khoa
        ┌──────────────────────────┐
        │ VBAProject Properties     │
        │                           │
        │ Password: ********       │
        │                           │
        │        [ OK ] [Cancel]    │
        └──────────────────────────┘
                    │
                    │ Chay UnprotectVBA
                    ▼
        ⚙️ Hook DialogBoxParamA
                    │
                    ▼
        🔓 Bo qua hop thoai bao ve
                    │
                    ▼
        ┌──────────────────────────┐
        │ VBA Project              │
        │                           │
        │  Modules                  │
        │  Forms                    │
        │  References               │
        └──────────────────────────┘
                    │
                    ▼
        ✅ VBA Project is unprotected!

Khuyến nghị Ribbon:

Label     : Unprotect VBA Project
ImageMso  : LockUnlock

Lưu ý: mã này không đơn thuần là thao tác VBA thông thường mà sử dụng Windows API hooking (VirtualProtect, GetProcAddress, RtlMoveMemory) để can thiệp vào mã thực thi của DialogBoxParamA.

Private Const PAGE_EXECUTE_READWRITE = &H40
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr)
Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (lpAddress As LongPtr, _
    ByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr
Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, _
    ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As LongPtr, _
    ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
    ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
Dim HookBytes(0 To 11) As Byte
Dim OriginBytes(0 To 11) As Byte
Dim pFunc As LongPtr
Dim Flag As Boolean
Private Function GetPtr(ByVal Value As LongPtr) As LongPtr
GetPtr = Value
End Function
Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 12
End Sub
Public Function Hook() As Boolean
Dim TmpBytes(0 To 11) As Byte
Dim p As LongPtr, osi As Byte
Dim OriginProtect As LongPtr
Hook = False

#If Win64 Then
    osi = 1
#Else
    osi = 0
#End If
pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
If VirtualProtect(ByVal pFunc, 12, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
    MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, osi + 1
    If TmpBytes(osi) <> &HB8 Then
        MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 12
        p = GetPtr(AddressOf MyDialogBoxParam)
        If osi Then HookBytes(0) = &H48
        HookBytes(osi) = &HB8
        osi = osi + 1
        MoveMemory ByVal VarPtr(HookBytes(osi)), ByVal VarPtr(p), 4 * osi
        HookBytes(osi + 4 * osi) = &HFF
        HookBytes(osi + 4 * osi + 1) = &HE0
        MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 12
        Flag = True
        Hook = True
    End If
End If
End Function

Private Function MyDialogBoxParam(ByVal hInstance As LongPtr, _
    ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
    ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
If pTemplateName = 4070 Then
    MyDialogBoxParam = 1
Else
    RecoverBytes
    MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
        hWndParent, lpDialogFunc, dwInitParam)
    Hook
End If
End Function

Sub UnprotectVBA()
    If Hook Then
        MsgBox "VBA Project is unprotected!", vbInformation, "VBA Unlocked"
    End If
End Sub