Add files via upload

FL.bas

@@ -0,0 +1,518 @@
+Option Explicit
+
+Public x As New TheBigOne
+
+Sub Determine_Active_Range()
+
+    Dim r As range
+    Dim s As String
+    
+    Set r = Selection
+
+    MsgBox (r.Address)
+    
+    For Each cell In r
+        s = s & cell.value
+    Next cell
+    
+    MsgBox (s)
+
+End Sub
+
+
+Sub BackupPersonal()
+
+
+  Application.DisplayAlerts = False
+  With Workbooks("Personal.xlsb")
+    .SaveCopyAs Workbooks("Personal.xlsb").Sheets("CONST").Cells(1, 2)
+    .Save
+  End With
+  Application.DisplayAlerts = True
+End Sub
+
+Sub ExtractPNC_CSV()
+
+    
+    Dim x As New TheBigOne
+    Dim f() As String
+    Dim col() As String
+    Dim coli As Long
+    Dim bal() As String
+    Dim bali As Long
+    Dim sched_loan As String
+    Dim p As FileDialog
+    Dim i As Long
+    Dim j As Long
+    Dim m As Long
+    Dim k As Long
+    Dim row() As String
+    Dim commit As Integer
+    Dim oblig As Integer
+    Dim sched As Integer
+    Dim loan As Integer
+    Dim wb As Workbook
+    Dim sh1 As Worksheet
+    Dim sh2 As Worksheet
+    
+    
+    '--------Open file-------------
+    Set p = Application.FileDialog(msoFileDialogOpen)
+    p.Show
+    '--------Extract text----------
+    f = x.FILEp_GetTXT(p.SelectedItems(1), 2000)
+    
+    '--------resize arrays---------
+    ReDim col(11, UBound(f, 2))
+    ReDim bal(8, UBound(f, 2))
+    coli = 1
+    bali = 1
+    j = 1
+    m = 1
+    
+    '--------main interation-------
+    For i = 0 To UBound(f, 2)
+        sched = InStr(f(0, i), "Schedule")
+        loan = InStr(f(0, i), "Loan")
+        If sched <> 0 Then
+            row = x.TXTp_ParseCSVrow(f, i + 2, 0)
+            col(0, 0) = "Schedule#"
+            For k = 0 To 10
+                col(k + 1, 0) = row(k)
+            Next k
+            sched_loan = x.TXTp_ParseCSVrow(f, i + 1, 0)(0)
+            i = i + 3
+            commit = 0
+            oblig = 0
+            Do Until commit <> 0 Or oblig <> 0
+                row = x.TXTp_ParseCSVrow(f, i, 0)
+                col(0, j) = sched_loan
+                For k = 0 To 10
+                    col(k + 1, j) = row(k)
+                Next k
+                j = j + 1
+                i = i + 1
+                commit = InStr(f(0, i), "Commitment")
+                oblig = InStr(f(0, i), "Oblig")
+                '---or end of file-----
+            Loop
+            sched = 0
+        ElseIf loan <> 0 Then
+        
+            row = x.TXTp_ParseCSVrow(f, i + 2, 0)
+            bal(0, 0) = "Loan#"
+            For k = 0 To 7
+                bal(k + 1, 0) = row(k)
+            Next k
+            
+            sched_loan = x.TXTp_ParseCSVrow(f, i + 1, 0)(0)
+            i = i + 3
+            commit = 0
+            oblig = 0
+            Do Until commit <> 0 Or oblig <> 0
+                row = x.TXTp_ParseCSVrow(f, i, 0)
+                bal(0, m) = sched_loan
+                For k = 0 To 7
+                    bal(k + 1, m) = row(k)
+                Next k
+                m = m + 1
+                i = i + 1
+                If i > UBound(f, 2) Then Exit Do
+                If f(0, i) = "" Then Exit Do
+                commit = InStr(f(0, i), "Commitment")
+                oblig = InStr(f(0, i), "Oblig")
+                '---or end of file-----
+            Loop
+            sched = 0
+            loan = 0
+        End If
+    Next i
+    
+    Set wb = Workbooks.Add
+    wb.Sheets.Add
+    Set sh1 = wb.Sheets("Sheet1")
+    Set sh2 = wb.Sheets("Sheet2")
+    sh1.Name = "Collateral"
+    sh2.Name = "Balance"
+    
+    Call x.SHTp_Dump(col, sh1.Name, 1, 1, True, True, 1, 4, 5, 6, 7, 8, 9, 10, 11)
+    Call x.SHTp_Dump(bal, sh2.Name, 1, 1, True, True, 1, 2, 5, 6, 7, 8)
+    
+    sh1.range("A1").CurrentRegion.Columns.AutoFit
+    sh2.range("A2").CurrentRegion.Columns.AutoFit
+    
+    
+End Sub
+
+
+Sub GrabBorrowHist()
+    
+    Dim sh As Worksheet
+    Dim x As New TheBigOne
+    Dim i As Long
+    Dim b() As String
+    Set sh = Application.ActiveSheet
+    
+    b = x.SHTp_Get(sh.Name, 3, 1, True)
+    Call x.TBLp_FilterSingle(b, 14, "", False)
+    Call x.TBLp_DeleteCols(b, x.ARRAYp_MakeInteger(6, 7, 8, 9, 10, 11, 12, 13))
+    Call x.TBLp_AddEmptyCol(b)
+    Call x.TBLp_AddEmptyCol(b)
+    For i = 1 To UBound(b, 2)
+        b(9, i) = ActiveSheet.Name
+        b(10, i) = ActiveWorkbook.Name
+    Next i
+    b(9, 0) = "Tab"
+    b(10, 0) = "File"
+    
+    Application.Workbooks("PERSONAL.XLSB").Activate
+    Set sh = Application.Workbooks("PERSONAL.XLSB").Sheets("BORROW")
+    i = 1
+    Do Until sh.Cells(i, 1) = ""
+        i = i + 1
+    Loop
+    Call x.SHTp_Dump(b, "BORROW", i, 1, False, True)
+
+End Sub
+
+Function fn_coln_colchar(colnum As Long) As String
+    
+    fn_coln_colchar = colnum / 26
+    
+End Function
+
+Sub add_quote_front()
+
+    Dim r As range
+    Set r = Selection
+    Dim c As Object
+    
+    For Each c In r.Cells
+        If c.value <> "" Then c.value = "'" & c.value
+    Next c
+    
+
+End Sub
+
+Function json_from_list(keys As range, values As range) As String
+
+    Dim json As String
+    Dim i As Integer
+    Dim first_comma As Boolean
+    Dim needs_braces As Integer
+    
+    needs_comma = False
+    needs_braces = 0
+    
+    For i = 1 To keys.Cells.Count
+        If values.Cells(i).value <> "" Then
+            needs_braces = needs_braces + 1
+            If needs_comma Then json = json & ","
+            needs_comma = True
+            If IsNumeric(values.Cells(i).value) Then
+                json = json & Chr(34) & keys.Cells(i).value & Chr(34) & ":" & values.Cells(i).value
+            Else
+                json = json & Chr(34) & keys.Cells(i).value & Chr(34) & ":" & Chr(34) & values.Cells(i).value & Chr(34)
+            End If
+        End If
+    Next i
+    
+    If needs_braces > 0 Then json = "{" & json & "}"
+    
+    json_from_list = json
+
+End Function
+
+Function json_concat(list As range) As String
+    
+        Dim json As String
+        Dim i As Integer
+        
+        i = 0
+
+        For Each cell In list
+            If cell.value <> "" Then
+                i = i + 1
+                If i = 1 Then
+                    json = cell.value
+                Else
+                    json = json & "," & cell.value
+                End If
+            End If
+        Next cell
+        
+        If i > 1 Then json = "[" & json & "]"
+        json_concat = json
+
+End Function
+
+
+Sub json_from_table_pretty()
+    
+    Dim wapi As New Windows_API
+    
+    Dim tbl() As Variant
+    
+    tbl = Selection
+    
+    Dim ajson As String
+    Dim json As String
+    Dim r As Integer
+    Dim c As Integer
+    Dim needs_comma As Boolean
+    Dim needs_braces As Integer
+    
+    needs_comma = False
+    needs_braces = 0
+    ajson = ""
+    
+    For r = 2 To UBound(tbl, 1)
+        For c = 1 To UBound(tbl, 2)
+            If tbl(r, c) <> "" Then
+                needs_braces = needs_braces + 1
+                If needs_comma Then json = json & "," & vbCrLf
+                needs_comma = True
+                If IsNumeric(tbl(r, c)) Then
+                    json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & tbl(r, c)
+                Else
+                    json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
+                End If
+            End If
+        Next c
+        If needs_braces > 0 Then json = "{" & vbCrLf & json & vbCrLf & "}"
+        needs_comma = False
+        needs_braces = 0
+        If r > 2 Then
+            ajson = ajson & vbCrLf & "," & vbCrLf & json
+        Else
+            ajson = json
+        End If
+        json = ""
+    Next r
+    
+    If r > 2 Then ajson = "[" & ajson & "]"
+    
+      
+    Call wapi.ClipBoard_SetData(ajson)
+
+End Sub
+
+Sub json_from_table()
+    
+    Dim wapi As New Windows_API
+    
+    Dim tbl() As Variant
+    
+    tbl = Selection
+    
+    Dim ajson As String
+    Dim json As String
+    Dim r As Integer
+    Dim c As Integer
+    Dim needs_comma As Boolean
+    Dim needs_braces As Integer
+    
+    needs_comma = False
+    needs_braces = 0
+    ajson = ""
+    
+    For r = 2 To UBound(tbl, 1)
+        For c = 1 To UBound(tbl, 2)
+            If tbl(r, c) <> "" Then
+                needs_braces = needs_braces + 1
+                If needs_comma Then json = json & ","
+                needs_comma = True
+                If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
+                    json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & tbl(r, c)
+                Else
+                    json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
+                End If
+            End If
+        Next c
+        If needs_braces > 0 Then json = "{" & json & "}"
+        needs_comma = False
+        needs_braces = 0
+        If r > 2 Then
+            ajson = ajson & "," & json
+        Else
+            ajson = json
+        End If
+        json = ""
+    Next r
+    
+    If r > 2 Then ajson = "[" & ajson & "]"
+    
+      
+    Call wapi.ClipBoard_SetData(ajson)
+
+End Sub
+
+Sub PastValues()
+
+On Error GoTo errh
+
+    Call Selection.PasteSpecial(xlPasteValues, xlNone, False, False)
+    
+errh:
+
+    
+End Sub
+Sub CollapsePvtItem()
+
+On Error GoTo show_det
+    ActiveCell.PivotItem.DrilledDown = False
+    
+On Error GoTo drill_down
+    ActiveCell.PivotItem.ShowDetail = False
+
+
+
+show_det:
+
+    If Err.Number <> 0 Then
+        On Error GoTo errh
+        ActiveCell.PivotItem.ShowDetail = False
+        Err.Number = 0
+    End If
+drill_down:
+    If Err.Number <> 0 Then
+        On Error GoTo errh
+        ActiveCell.PivotItem.DrilledDown = False
+    End If
+errh:
+
+
+End Sub
+
+Sub ExpandPvtItem()
+
+On Error GoTo show_det
+    ActiveCell.PivotItem.DrilledDown = True
+    
+On Error GoTo drill_down
+    ActiveCell.PivotItem.ShowDetail = True
+
+
+show_det:
+
+    If Err.Number <> 0 Then
+        On Error GoTo errh
+        ActiveCell.PivotItem.ShowDetail = True
+        Err.Number = 0
+    End If
+drill_down:
+On Error GoTo errh
+    If Err.Number <> 0 Then
+        On Error GoTo errh
+        ActiveCell.PivotItem.DrilledDown = True
+    End If
+
+errh:
+
+End Sub
+
+Sub CollapsePvtFld()
+
+On Error GoTo show_det
+    ActiveCell.PivotField.DrilledDown = False
+    
+On Error GoTo drill_down
+    ActiveCell.PivotField.ShowDetail = False
+
+
+
+show_det:
+
+    If Err.Number <> 0 Then
+        On Error GoTo errh
+        ActiveCell.PivotField.ShowDetail = False
+        Err.Number = 0
+    End If
+drill_down:
+On Error GoTo errh
+    If Err.Number <> 0 Then
+        On Error GoTo errh
+        ActiveCell.PivotField.DrilledDown = False
+    End If
+
+errh:
+
+End Sub
+
+Sub ExpandPvtFld()
+
+On Error GoTo show_det
+    ActiveCell.PivotField.DrilledDown = True
+    
+On Error GoTo drill_down
+    ActiveCell.PivotField.ShowDetail = True
+
+
+show_det:
+
+    If Err.Number <> 0 Then
+        On Error GoTo errh
+        ActiveCell.PivotField.ShowDetail = True
+        Err.Number = 0
+    End If
+drill_down:
+    If Err.Number <> 0 Then
+        On Error GoTo errh
+        ActiveCell.PivotField.DrilledDown = True
+    End If
+    
+errh:
+
+End Sub
+                        
+Sub ColorMatrixExtract()
+
+    Dim s() As String
+    Dim t() As String
+    
+    Dim i As Long
+    Dim j As Long
+    Dim k As Long
+    Dim m As Long
+    Dim sh As Worksheet
+    Dim found As Boolean
+    
+    ReDim s(1, 10000)
+    For Each sh In Sheets
+        If sh.Name = "Color Matrix" Then found = True
+    Next sh
+    If Not found Then Exit Sub
+    Set sh = Sheets("Color Matrix")
+    If sh.Cells(5, 1) <> "BASE WHITE" Then Exit Sub
+    m = 1
+    i = 1
+    s(0, 0) = "COLOR ID"
+    s(1, 0) = "DESCRIPTION"
+    
+    
+    
+    Do
+        If sh.Cells(6, i) = "COLOR ID" Then
+            j = 1
+            Do Until sh.Cells(6, i + j) = "DESCRIPTION"
+                j = j + 1
+            Loop
+            k = 7
+            Do Until sh.Cells(k, i) = ""
+                s(0, m) = sh.Cells(k, i)
+                s(1, m) = sh.Cells(k, i + j)
+                k = k + 1
+                m = m + 1
+            Loop
+        End If
+        i = i + 1
+        If i = 500 Then Exit Do
+    Loop
+    
+    ReDim Preserve s(1, m - 1)
+    
+    Call x.SHTp_Dump(s, "Extract", 1, 1, True, True)
+
+End Sub
+
+

Windows_API.cls

@@ -0,0 +1,236 @@
+Option Explicit
+
+Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
+Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
+Private Declare PtrSafe Function GetClipboardOwner Lib "user32" () As LongPtr
+Private Declare PtrSafe Function SetClipboardViewer Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
+Private Declare PtrSafe Function GetClipboardViewer Lib "user32" () As LongPtr
+Private Declare PtrSafe Function ChangeClipboardChain Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndNext As LongPtr) As Long
+Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
+Private Declare PtrSafe Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr
+Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
+Private Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
+Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
+Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" _
+    (ByVal wFormat As Long, _
+    ByVal lpString As String, _
+    ByVal nMaxCount As Long) As Long
+Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
+Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
+Private Declare PtrSafe Function GetPriorityClipboardFormat Lib "user32" (lpPriorityList As Long, ByVal nCount As Long) As Long
+Private Declare PtrSafe Function GetOpenClipboardWindow Lib "user32" () As LongPtr
+Private Declare PtrSafe Function CharToOem Lib "user32" Alias "CharToOemA" _
+    (ByVal lpszSrc As String, _
+     ByVal lpszDst As String) As Long
+Private Declare PtrSafe Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
+Private Declare PtrSafe Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" _
+    (ByVal lpszSrc As String, _
+    ByVal lpszDst As String, _
+    ByVal cchDstLength As Long) As Long
+Private Declare PtrSafe Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" _
+    (ByVal lpszSrc As String, _
+    ByVal lpszDst As String, _
+    ByVal cchDstLength As Long) As Long
+Private Declare PtrSafe Function CharUpper Lib "user32" Alias "CharUpperA" (ByVal lpsz As String) As String
+Private Declare PtrSafe Function CharUpperBuff Lib "user32" Alias "CharUpperBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long
+Private Declare PtrSafe Function CharLower Lib "user32" Alias "CharLowerA" (ByVal lpsz As String) As String
+Private Declare PtrSafe Function CharLowerBuff Lib "user32" Alias "CharLowerBuffA" (ByVal lpsz As String, ByVal cchLength As Long) As Long
+Private Declare PtrSafe Function CharNext Lib "user32" Alias "CharNextA" (ByVal lpsz As String) As String
+Private Declare PtrSafe Function CharPrev Lib "user32" Alias "CharPrevA" (ByVal lpszStart As String, ByVal lpszCurrent As String) As String
+Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
+Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
+Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
+Private Declare PtrSafe Function GlobalHandle Lib "kernel32" (wMem As Any) As LongPtr
+Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
+Private Declare PtrSafe Function GlobalReAlloc Lib "kernel32" (ByVal hMem As LongPtr, ByVal dwBytes As LongPtr, ByVal wFlags As Long) As LongPtr
+Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
+Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
+Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" _
+    (ByRef lpMsg As MSG, ByVal hwnd As Long, _
+     ByVal wMsgFilterMin As Long, _
+     ByVal wMsgFilterMax As Long, _
+     ByVal wRemoveMsg As Long) As Long
+Private Declare PtrSafe Function TranslateMessage Lib "user32" _
+    (ByRef lpMsg As MSG) As Long
+Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
+    (ByVal hwnd As Long, _
+     ByVal wMsg As Long, _
+     ByVal wParam As Long, _
+     lParam As Any) As Long
+Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
+    (ByVal lpClassName As String, _
+     ByVal lpWindowName As String) As Long
+
+
+
+Private Type POINTAPI
+    x As Long
+    y As Long
+End Type
+
+Private Type MSG
+    hwnd As Long
+    Message As Long
+    wParam As Long
+    lParam As Long
+    time As Long
+    pt As POINTAPI
+End Type
+
+Private Const WM_KEYDOWN As Long = &H100
+Private Const PM_REMOVE  As Long = &H1
+Private Const WM_CHAR    As Long = &H102
+Private Const GHND As Long = &H42
+Private Const CF_TEXT = 1
+Private Const MAXSIZE = 40096
+Private bExitLoop As Boolean
+
+
+
+Public Sub SetClipboard(sUniText As String)
+    Dim iStrPtr As LongPtr
+    Dim iLen As LongPtr
+    Dim iLock As LongPtr
+    Const GMEM_MOVEABLE As Long = &H2
+    Const GMEM_ZEROINIT As Long = &H40
+    Const CF_UNICODETEXT As Long = &HD
+    OpenClipboard 0&
+    EmptyClipboard
+    iLen = LenB(sUniText) + 2&
+    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
+    iLock = GlobalLock(iStrPtr)
+    lstrcpy iLock, StrPtr(sUniText)
+    GlobalUnlock iStrPtr
+    SetClipboardData CF_UNICODETEXT, iStrPtr
+    CloseClipboard
+End Sub
+
+Public Sub ClipBoard_SetData(sUniText As String)
+
+    
+    Dim hGlobalMemory As LongPtr
+    Dim lpGlobalMemory As LongPtr
+    Dim hClipMemory As LongPtr
+    Dim x As Long
+    
+    hGlobalMemory = GlobalAlloc(GHND, Len(sUniText) + 1)
+    
+    lpGlobalMemory = GlobalLock(hGlobalMemory)
+    
+    lpGlobalMemory = lstrcpy(lpGlobalMemory, sUniText)
+    
+    If GlobalUnlock(hGlobalMemory) <> 0 Then
+        GoTo OutOfHere2
+    End If
+    
+    If OpenClipboard(0&) = 0 Then
+        Exit Sub
+    End If
+    
+    x = EmptyClipboard()
+    
+    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
+    
+OutOfHere2:
+    
+    If CloseClipboard() = 0 Then
+        MsgBox ("ruh-roh")
+    End If
+
+End Sub
+
+Public Function GetClipboard() As String
+    Dim iStrPtr As Long
+    Dim iLen As Long
+    Dim iLock As Long
+    Dim sUniText As String
+    Const CF_UNICODETEXT As Long = 13&
+    OpenClipboard 0&
+    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
+        iStrPtr = GetClipboardData(CF_UNICODETEXT)
+        If iStrPtr Then
+            iLock = GlobalLock(iStrPtr)
+            iLen = GlobalSize(iStrPtr)
+            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
+            lstrcpy StrPtr(sUniText), iLock
+            GlobalUnlock iStrPtr
+        End If
+        GetClipboard = sUniText
+    End If
+    CloseClipboard
+End Function
+
+
+Sub TrackKeyPressInit()
+
+    Dim msgMessage As MSG
+    Dim bCancel As Boolean
+    Dim iKeyCode As Integer
+    Dim lXLhwnd As Long
+
+    On Error GoTo errHandler:
+        Application.EnableCancelKey = xlErrorHandler
+        'initialize this boolean flag.
+        bExitLoop = False
+        'get the app hwnd.
+        lXLhwnd = FindWindow("XLMAIN", Application.Caption)
+    Do
+        WaitMessage
+        'check for a key press and remove it from the msg queue.
+        If PeekMessage _
+            (msgMessage, lXLhwnd, WM_KEYDOWN, WM_KEYDOWN, PM_REMOVE) Then
+            'strore the virtual key code for later use.
+            iKeyCode = msgMessage.wParam
+           'translate the virtual key code into a char msg.
+            TranslateMessage msgMessage
+            PeekMessage msgMessage, lXLhwnd, WM_CHAR, _
+            WM_CHAR, PM_REMOVE
+           'for some obscure reason, the following
+          'keys are not trapped inside the event handler
+            'so we handle them here.
+            If iKeyCode = vbKeyBack Then SendKeys "{BS}"
+            If iKeyCode = vbKeyReturn Then SendKeys "{ENTER}"
+           'assume the cancel argument is False.
+            bCancel = False
+            'the VBA RaiseEvent statement does not seem to return ByRef arguments
+            'so we call a KeyPress routine rather than a propper event handler.
+            Sheet_KeyPress ByVal msgMessage.wParam, ByVal iKeyCode, ByVal Selection, bCancel
+            'if the key pressed is allowed post it to the application.
+            If bCancel = False Then
+                PostMessage _
+                lXLhwnd, msgMessage.Message, msgMessage.wParam, 0
+            End If
+        End If
+errHandler:
+        'allow the processing of other msgs.
+        DoEvents
+    Loop Until bExitLoop
+
+End Sub
+
+Sub StopKeyWatch()
+
+    'set this boolean flag to exit the above loop.
+    bExitLoop = True
+
+End Sub
+
+
+'\\This example illustrates how to catch worksheet
+'\\Key strokes in order to prevent entering numeric
+'\\characters in the Range "A1:D10" .
+Private Sub Sheet_KeyPress(ByVal KeyAscii As Integer, ByVal KeyCode As Integer, ByVal Target As range, Cancel As Boolean)
+
+    Const MSG As String = "Numeric Characters are not allowed in" & vbNewLine & "the Range:  """
+    Const TITLE As String = "Invalid Entry !"
+
+    If Not Intersect(Target, range("A1:D10")) Is Nothing Then
+        If Chr(KeyAscii) Like "[0-9]" Then
+            MsgBox MSG & range("A1:D10").Address(False, False) _
+            & """ .", vbCritical, TITLE
+            Cancel = True
+        End If
+    End If
+
+End Sub
+