Add files via upload
This commit is contained in:
fleetside72
GitHub
parent
d1de671066
commit
51164251a5
518
FL.bas
Normal file
518
FL.bas
Normal file
@ -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
|
||||
|
||||
|
||||
1900
TheBigOne.cls
Normal file
1900
TheBigOne.cls
Normal file
File diff suppressed because it is too large
Load Diff
236
Windows_API.cls
Normal file
236
Windows_API.cls
Normal file
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user