Sub Remove_Lines()
'Dim iNumber% 'Integer
'Dim lAverage& 'Long
'Dim sngTotal! 'Single
'Dim dbTotal# 'Double
'Dim cProfit@ 'Currency
'Dim sFirstName$ 'String
'Dim llDiscount^ 'LongLong on 64 bit
'declare variables
Dim lines&, i& '& is the shortcut for Long type. see above for other shortcuts.
'count lines of the "WaterFall_Graph" module
lines = ThisWorkbook.VBProject.VBComponents.Item("WaterFall_Graph").CodeModule.CountOfLines
On Error Resume Next
'loop through each line
For i = 1 To lines
'delete line one by one from the module
ThisWorkbook.VBProject.VBComponents.Item("WaterFall_Graph").CodeModule.DeleteLines 1
Next i
End Sub
Add month to dictionary
Sub AddtoDic()
Dim dict As Scripting.Dictionary
Dim mnth As String
Set dict = New Scripting.Dictionary
'Add items
dict.Add "1", "Jan"
dict.Add "2", "Feb"
dict.Add "3", "Mar"
dict.Add "4", "Apr"
dict.Add "5", "May"
dict.Add "6", "Jun"
dict.Add "7", "Jul"
dict.Add "8", "Aug"
dict.Add "9", "Sep"
dict.Add "10", "Oct"
dict.Add "11", "Nov"
dict.Add "12", "Dec"
mnth = dict(MonthNum)
Set dict = Nothing
End Sub
VBA Free
Option Explicit
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr)
Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (lpAddress As LongPtr, _
ByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr
Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, _
ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As LongPtr, _
ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
Dim HookBytes(0 To 11) As Byte
Dim OriginBytes(0 To 11) As Byte
Dim pFunc As LongPtr
Dim Flag As Boolean
Sub unprotected()
If Hook Then
MsgBox "VBA Project is unprotected!", vbInformation, "*****"
End If
End Sub
Private Function GetPtr(ByVal Value As LongPtr) As LongPtr
GetPtr = Value
End Function
Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 12
End Sub
Public Function Hook() As Boolean
Dim TmpBytes(0 To 11) As Byte
Dim p As LongPtr, osi As Byte
Dim OriginProtect As LongPtr
Hook = False
#If Win64 Then
osi = 1
#Else
osi = 0
#End If
pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
If VirtualProtect(ByVal pFunc, 12, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, osi + 1
If TmpBytes(osi) <> &HB8 Then
MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 12
p = GetPtr(AddressOf MyDialogBoxParam)
If osi Then HookBytes(0) = &H48
HookBytes(osi) = &HB8
osi = osi + 1
MoveMemory ByVal VarPtr(HookBytes(osi)), ByVal VarPtr(p), 4 * osi
HookBytes(osi + 4 * osi) = &HFF
HookBytes(osi + 4 * osi + 1) = &HE0
MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 12
Flag = True
Hook = True
End If
End If
End Function
Private Function MyDialogBoxParam(ByVal hInstance As LongPtr, _
ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
If pTemplateName = 4070 Then
MyDialogBoxParam = 1
Else
RecoverBytes
MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
hWndParent, lpDialogFunc, dwInitParam)
Hook
End If
End Function
Insert Code/Sub Procedure at runtime
Function AddNewSub()
Dim cModuleObj As Variant
Dim curModule As String
Dim a&, b&, c&, d&
Dim xline As Long
Dim z&
'On Error GoTo addnewsubeRR
'curModule = Application.VBE.activecodepane.codeModule
For z = 1 To 13
If Application.VBE.CodePanes.Item(z).CodeModule = "Module3" Then
curModule = Application.VBE.CodePanes.Item(z).CodeModule
Exit For
End If
Next z
Set cModuleObj = ActiveWorkbook.VBProject.vbcomponents(curModule).CodeModule
Application.VBE.activecodepane.GetSelection a, b, c, d
a = 1
c = 1
xline = a + 1
Dim codesnippets(1 To 3), i&
codesnippets(1) = "Sub InsertNewProcedure()"
codesnippets(2) = " exit sub"
codesnippets(3) = "end sub"
With cModuleObj
For i = LBound(codesnippets) To UBound(codesnippets)
.insertlines xline, codesnippets(i)
xline = xline + 1
Next i
End With
Set cModuleObj = Nothing
'addnewsubeRR:
'MsgBox "error:" & Err.Description
End Function
Delete VBA Procedure
Sub DeleteVBComponent(ByVal wb As Workbook, ByVal CompName As String)
'Disabling the alert message
Application.DisplayAlerts = False
'Ignore errors
On Error Resume Next
'Delete the component
wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(CompName)
On Error GoTo 0
'Enabling the alert message
Application.DisplayAlerts = True
End Sub
Sub Delete_procedure()
'Calling DeleteVBComponent macro
DeleteVBComponent ThisWorkbook, "Numberformat" 'change procedure name
End Sub