Question

我正在尝试将我找到的代码调整到我们的一些食谱表中，它只会扫描条目而不是键入。需要输入的单元格为橙色。我希望这些单元格只接受扫描的条目。到目前为止，我已经知道它是否会将代码应用于“I”列并将其全部颜色为橙色。我希望它不要为细胞着色，而是使用已经着色的细胞。继续我到目前为止所拥有的

...

Option Explicit

Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Declare Function GetActiveWindow Lib "user32" () As Long

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Const HC_ACTION = 0
Const WM_KEYDOWN = &H100
Const WH_KEYBOARD_LL = 13
Dim hhkLowLevelKybd As Long
Dim blnHookEnabled As Boolean
Dim enumAllowedValues As AllowedValues
Dim objTargetRange As Range
Dim objValidationRange As Range
Dim vAns As Variant

Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

Enum AllowedValues
    alpha
    numeric
End Enum




Function LowLevelKeyboardProc _
(ByVal nCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long

    '\hook keyboard only if XL is the active window
    If GetActiveWindow = FindWindow("XLMAIN", Application.Caption) Then
        If (nCode = HC_ACTION) Then
            '\check if a key is pushed
            If wParam = WM_KEYDOWN Then
            '\if so, check if the active cell is within the target range
                If Union(ActiveCell, objTargetRange).Address = objTargetRange.Address Then
                '\if only numeric values should be allowed then
                    If enumAllowedValues = 1 Then
                    '\check if the pushed key is a numeric key or a navigation key
                    '\by checking the vkCode stored in the laparm parameter
                        If Chr(lParam.vkCode) Like "#" Or _
                            lParam.vkCode = 37 Or lParam.vkCode = 38 Or lParam.vkCode = 39 Or _
                            lParam.vkCode = 40 Or lParam.vkCode = 9 Or lParam.vkCode = 13 Then
                            '\if so allow the input
                            LowLevelKeyboardProc = 0
                        Else
                            '\else filter out this Key_Down message from message qeue
                            Beep
                            LowLevelKeyboardProc = -1
                            Exit Function
                        End If
                        '\if onle alpha values should be allowed then
                    ElseIf enumAllowedValues = 0 Then
                        '\check the laparam parameter
                        If Chr(lParam.vkCode) Like "#" Then
                            '\if numeric prevent the input
                            Beep
                            LowLevelKeyboardProc = -1
                            Exit Function
                        Else
                            '\otherwise allow the input
                            LowLevelKeyboardProc = 0
                    End If
                    End If
                End If
            End If
        End If
    End If
    '\pass function to next hook if there is one
    LowLevelKeyboardProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)

End Function


Public Sub Unhook_KeyBoard()

    If hhkLowLevelKybd <> 0 Then UnhookWindowsHookEx hhkLowLevelKybd
    blnHookEnabled = False


End Sub


Sub ValidateRange(r As Range, ByVal v As AllowedValues)

    '\store these in global variables for they will be
    '\needed later in the filter function
    enumAllowedValues = v
    Set objTargetRange = r
    '\don't hook the keyboard twice !!
    If blnHookEnabled = False Then
        hhkLowLevelKybd = SetWindowsHookEx _
        (WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, Application.Hinstance, 0)
        blnHookEnabled = True
    End If

End Sub


Sub test()

    '\ignore any mishandling of the following
    '\input boxes by the user
    On Error Resume Next
    Set objValidationRange = Sheets("Sheet1").Range("I:I")
    If objValidationRange Is Nothing Then GoTo errHdlr
        objValidationRange.Interior.ColorIndex = 44
        vAns = 2
        If vAns = 2 Then
            ValidateRange objValidationRange, AllowedValues.numeric + alpha
        Else
        GoTo errHdlr
    End If
    objValidationRange.Cells(1).Select
    Set objValidationRange = Nothing
    Exit Sub
errHdlr:
    MsgBox "criteria error- Try again !", vbCritical
    Unhook_KeyBoard

End Sub

Answer 1

如果您确定要修改的单元格/行确实以

为特征

.Interior.ColorIndex = 44

然后你所要做的就是检查一下，如果它出现积极的话，继续你的逻辑：

If myCell.Interior.ColorIndex = 44 Then
' do your stuff
End If

如果颜色不是简单的ColorIndex = 44，您可以使用

检查立即窗口中的颜色。

?myCell.Interior.Color

您可以将颜色值（它的输出作为数值）复制并粘贴到您的条件中，只需记住区分Color和ColorIndex。

仅在VBA中将代码应用于彩色单元格

1 个答案: