Do You Know by GURUS: Excel

Showing posts with label Excel. Show all posts

Getting the Last Position of a Character using Excel Formula

=RIGHT(A2,LEN(A2)-FIND("@",SUBSTITUTE(A2,"/","@",LEN(A2)-LEN(SUBSTITUTE(A2,"/",""))),1))

Capturing keypress in Excel Worksheet with VBA

'
' by http://www.experts-exchange.com
'

Option Explicit
Declare Function SetWindowsHookEx Lib _
Declare Function CallNextHookEx Lib "user32" _
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" _
Const HC_ACTION = 0
Type KBDLLHOOKSTRUCT
Enum AllowedValues

Function LowLevelKeyboardProc _
'\hook keyboard only if XL is the active window
End Function
Public Sub Unhook_KeyBoard()
If hhkLowLevelKybd <> 0 Then UnhookWindowsHookEx hhkLowLevelKybd
End Sub
Sub ValidateRange(r As Range, ByVal v As AllowedValues)
'\store these in global variables for they will be
End Sub
Sub test()
'\ignore any mishandling of the following
End Sub

"user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long

(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long

(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

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

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

alpha
numeric
End Enum

(ByVal nCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long

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)

blnHookEnabled = False
Cells.Clear

'\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

'\input boxes by the user
On Error Resume Next
Cells.Clear
Set objValidationRange = Application.InputBox _
("Selet one or more Cells ", "Custom Data Validation...", Type:=8)
If objValidationRange Is Nothing Then GoTo errHdlr
objValidationRange.Interior.Color = vbGreen
vAns = InputBox("To allow only alpha values in the selected range enter 1 " _
& vbCrLf & vbCrLf & "To allow only numeric values in the selected range enter 2 ")
If vAns = 1 Then
ValidateRange objValidationRange, AllowedValues.alpha
ElseIf vAns = 2 Then
ValidateRange objValidationRange, AllowedValues.numeric
Else
GoTo errHdlr
End If
objValidationRange.Cells(1).Select
Set objValidationRange = Nothing
Exit Sub
errHdlr:
MsgBox "criteria error- Try again !", vbCritical
Unhook_KeyBoard

Cracking Password of VBA Project

You can try this direct VBA approach which doesn't require HEX editing. It will work for any files (*.xls, *.xlsm, *.xlam ...).

Tested and works on

Excel 2007
Excel 2010
Excel 2013 - 32 bit version.
Excel 2016 - 32 bit version.

How it will work

I will try my best to explain how it works - please excuse my english.

Excel will call a system function to create the password dialog box.
If user enters the right password and click OK, this function returns 1. If user enters the wrong password or click Cancel, this function returns 0.
After the dialog box is closed, Excel checks the returned value of the system function
if this value is 1, Excel will "think" that the password is right, hence the locked VBA project will be opened.
The code below swaps the memory of the original function used to display the password dialog with a user defined function that will always return 1 when being called.

using the code

Open the file(s) that contain your locked VBA Projects
Create a new xlsm file and store this code in Module1

'---------------------------------------------

Option Explicit

Private Const PAGE_EXECUTE_READWRITE = &H40

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _

(Destination As Long, Source As Long, ByVal Length As Long)

Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _

ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long

Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _

ByVal lpProcName As String) As Long

Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _

ByVal pTemplateName As Long, ByVal hWndParent As Long, _

ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer

Dim HookBytes(0 To 5) As Byte

Dim OriginBytes(0 To 5) As Byte

Dim pFunc As Long

Dim Flag As Boolean

Private Function GetPtr(ByVal Value As Long) As Long

GetPtr = Value

End Function

Public Sub RecoverBytes()

If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6

End Sub

Public Function Hook() As Boolean

Dim TmpBytes(0 To 5) As Byte

Dim p As Long

Dim OriginProtect As Long

Hook = False

pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")

If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then

MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6

If TmpBytes(0) <> &H68 Then

MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6

p = GetPtr(AddressOf MyDialogBoxParam)

HookBytes(0) = &H68

MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4

HookBytes(5) = &HC3

MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6

Flag = True

Hook = True

End If

End If

End Function

Private Function MyDialogBoxParam(ByVal hInstance As Long, _

ByVal pTemplateName As Long, ByVal hWndParent As Long, _

ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer

If pTemplateName = 4070 Then

MyDialogBoxParam = 1

Else

RecoverBytes

MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _

hWndParent, lpDialogFunc, dwInitParam)

Hook

End If

End Function

'---------------------------------------------

3. Paste this code in Module2 and run it

'---------------------------------------------

Sub unprotected()

If Hook Then

MsgBox "VBA Project is unprotected!", vbInformation, "*****"

End If

End Sub

'---------------------------------------------

4. Come back to your VBA Projects and enjoy

by Siwtom (nick name), a Vietnamese developer

Saving all sheets of single Excel File as multiple files as sheet names

Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Hidden Games in Microsoft Excel 2000

Follow the instructions to launch Trigger the egg game:

Open a new workbook Press F5, type X97:L97 and press Enter.
Press Tab Press Ctrl+Shift and Click on the Chart Wizard button from the toolbar.

You will be greeted with a full-screen animated image. Use the mouse to “fly” over the landscape (the mouse changes direction, left button moves forward and right button moves backwards). Fly around a bit and you will see a grey stone pyramid. Fly to the side of the pyramid that’s black and you’ll see the credits scroll by for the developers.

Now, follow the instructions to launch a car racing/shooting game:

Open a new workbook in Excel 2000
Save as a web-page. Give any file name you wish. In the save as Window, select Selection:Sheet, add Interactivity and Publish as web-page. Click Publish
Now, open your saved web-page.
Reach Row 2000, column WC.
Use “Shift+Space bar” to select whole row.
Press ALT key+ Shift + Ctrl and click on the Microsoft Logo on the top left handed side of the sheet
Enjoy the hidden game. The game is car chase/driving game. It gives you control of a car and you get to shoot other cars. Also has unlimited lives.