[VBA] 如何將「核取方塊」變大 ? (方法1)

opa

發佈於Excel & VBA (共同作者)

2024/09/21 更新2023/09/21 發佈閱讀 8 分鐘

前言：

怎麼把表單控制項的核取方塊變大 ? 這是個很久很久以前就遇過的問題，根據查得的資訊顯示，至今約莫 11 年前就有人提過這問題了。

表單控制項的核取方塊

目前 Excel 系統仍然沒有提供調整其大小的方式，但由一些資訊得知，之前還是有很多高手提出一些解決方法。
有字型方法、VBA方法 ( ActiveX 控制項的 TextBox、利用 VBA 控制儲存格內的字型 ) ... 等等。

本篇將介紹如何用 VBA 控制儲存格內的字型，在輸入特定字元，即顯示特定圖案，來達到模擬核取方塊的目的。

操作：

點擊藍色文字框使其文字變為「核取方塊 (已開啟)」，即可在空白儲存格，任意輸入資料，此時左邊的儲存格會立即出現一個核取方塊。
只要在其上方，滑鼠左鍵連點兩下，即可自動變成核取圖案，並在最右方會自動顯示核取的日期時間。
在核取方框上方，再次連點兩下，會出現「是否取消勾選」，點【是】，即變成不核取狀態並刪除最右方的日期時間。
點擊藍色文字框使其文字變為「核取方塊 (已關閉)」，可關閉自動核取方塊功能。

成果：

以下是成果影片，請先欣賞~ 謝謝。

工作表

【Sheet1】內的程式碼

Private Sub Worksheet_Change(ByVal T As Range)

If ActiveSheet.Shapes("REC_CheckBox").TextFrame.Characters.Text = "核取方塊 (已關閉)" Then Exit Sub

If T.Count > 1 Then Exit Sub  ' 單選儲存格

Application.EnableEvents = False

If T.Offset(, -1) = "" And T <> "" Then
    With T.Offset(, -1)
        .Value = ChrW(163)
        .Font.Name = "Wingdings 2"
        .Font.Size = 30  ' 不核取
    End With
    
    With T  ' 核取方塊內容
        .Font.Name = "微軟正黑體"
        .Font.Size = 12
    End With
ElseIf (T.Offset(, -1) = ChrW(163) Or T.Offset(, -1) = ChrW(82)) And T = "" Then
    ' 將 核取方塊位置 和 時間戳記 刪除 !
    With Range(T.Offset(, -1).Address & "," & T.Offset(, 1).Address)
        .Value = ""
        .Font.Name = "微軟正黑體"
    End With
End If

Application.EnableEvents = True

End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)

    If T(1, 2) = "" Then Exit Sub  ' 抓核取方塊右邊的內容 ，為空不執行
    If Not (T(1, 1) = ChrW(163) Or T(1, 1) = ChrW(82)) Then Exit Sub
    
    Application.EnableEvents = False
    
    If T.Value = ChrW(82) Then If MsgBox("是否取消勾選？", vbYesNo) = vbNo Then GoTo Handle_Cancel
    
    With T
        .Value = IIf(.Value = ChrW(163), ChrW(82), ChrW(163))
        .Font.Name = "Wingdings 2"
        .Font.Size = 30
    End With
    
    If T.Value = ChrW(82) And T(1, 3) = "" Then
        With T(1, 3)
            .Value = Now()
            .Font.Name = "微軟正黑體"
            .NumberFormatLocal = "yyyy/mm/dd hh:mm:ss"
        End With
        Columns(Split(T(1, 3).Address, "$")(1) & ":" & Split(T(1, 3).Address, "$")(1)).EntireColumn.AutoFit
    ElseIf T.Value = ChrW(163) Then
        T(1, 3) = ""
        MsgBox "【 時間戳記 】 資料已刪除 !!"
        T(1, 3).Select
    Else
        MsgBox "有資料 !! 【 時間戳記 】 無法記錄 !!"
        T(1.3).Select
    End If
    
Handle_Cancel:

    Application.EnableEvents = True
    Cancel = True
    
End Sub

模組

【Module1】內的程式碼

Sub Turn_OnOff_CheckBox()
    Dim REC_text As String
    REC_text = ActiveSheet.Shapes("REC_CheckBox").TextFrame.Characters.Text
    
    If REC_text = "核取方塊 (已關閉)" Then
        ActiveSheet.Shapes("REC_CheckBox").TextFrame.Characters.Text = "核取方塊 (已開啟)"
    ElseIf REC_text = "核取方塊 (已開啟)" Then
        ActiveSheet.Shapes("REC_CheckBox").TextFrame.Characters.Text = "核取方塊 (已關閉)"
    Else
        ActiveSheet.Shapes("REC_CheckBox").TextFrame.Characters.Text = "核取方塊 (Error)"
    End If
End Sub