This is the code i found originally. (I can't remember the source)
In worksheet1 add the following code.
Private Sub Worksheet_Activate()
MsgBox "A calculation happened!", vbOKOnly
End Sub
In new module add the following code.
Sub AddCode()
Dim StartLine As Long
With ActiveWorkbook.VBProject.VBComponents("Sheet1").CodeModule
StartLine = .CreateEventProc("Activate", "Worksheet") + 1
.InsertLines StartLine, _
"Msgbox ""A calculation happened!"",vbOkOnly"
End With
End Sub
I have 'added code on the fly' before and this is a real working example of how i used it.
I was using it in an 'addin' which means i could use it in any Workbook, not necessarily the workbook the code was in. My intention was to launch a Command window PINGing the IP Address in the cell i clicked.
I had two variations of the command window that launched.
A standard ping (4 pings and present results) and a continuous ping.
Here is the code i used to get it working. I have tried to comment the code as best i can for clarity.
Place the following code into a Module.
Sub AddPingProcedure()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Dim SheetNumber
'If there is a problem from the outset go to ErrorMessage
On Error GoTo Errormessage
'Set VBProj as the ACTIVE Workbook. Remember this code was stored in an ADDIN
'(which is a workbook in itself technically) I needed the code to work in the Active Workbook (not the addin)
Set VBProj = ActiveWorkbook.VBProject
'I'm going to delete any other code from the Worksheet i want to work from.
'This might not be best practice but my code wont work otherwise.
'If any errors are seen trying to delete any code from the worksheet (there is none) then just add the code.
On Error GoTo AddProcedure
'Set the variable called SheetNumber to the Active Worksheet (with the IP Addresses on) using the
'Active Workbook \ Active Worksheet. We need the name of that worksheet and we can get that by adding .Codename.
'See this link for an explanation. "http://msdn.microsoft.com/en-us/library/office/aa214189(v=office.11).aspx"
SheetNumber = ActiveWorkbook.ActiveSheet.CodeName
'Delete Any Procedure (code) from the worksheet.
With ActiveWorkbook.VBProject.VBComponents(SheetNumber).CodeModule
.DeleteLines 1, .CountOfLines
End With
'Then add this procedure.
AddProcedure:
'If there's a problem, go to the errormessage label.
On Error GoTo Errormessage
With ActiveWorkbook.VBProject.VBComponents(SheetNumber).CodeModule
LineNum = .CountOfLines + 10
.InsertLines LineNum, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
LineNum = LineNum + 1
.InsertLines LineNum, "Dim sPingcmd As String"
LineNum = LineNum + 1
.InsertLines LineNum, "On Error GoTo ErrorTrap"
LineNum = LineNum + 1
.InsertLines LineNum, "If Intersect(Target, UsedRange).Address = Target.Address Then"
LineNum = LineNum + 1
.InsertLines LineNum, "sPingcmd = ""ping -a "" & Target.Value"
LineNum = LineNum + 1
.InsertLines LineNum, "Call Shell(""cmd /K"" & sPingcmd, vbNormalFocus)"
LineNum = LineNum + 1
.InsertLines LineNum, "End If"
LineNum = LineNum + 1
.InsertLines LineNum, "ErrorTrap:"
LineNum = LineNum + 1
.InsertLines LineNum, "End Sub"
End With
'Present the user with information about how it works.
MsgBox "If You Select A Cell With An IP Address In It, It Will Attempt To Ping The IP Address." & _
vbCrLf & "The PINGing Function will remain with this Worksheet unless removed", vbInformation, _
"PING right from your Worksheet!"
Exit Sub
'Inform the user this won't work and tell them what they need to do to get it working.
Errormessage:
MsgBox "Sorry - You need to allow Macros to trust the Visual Basic Project." & _
vbCrLf & vbCrLf & "I will take you to the location where you can enable this feature." & _
vbCrLf & " Tick the box called Trust Access to Visual Basic Project.", vbCritical, _
"You only need to tick the box once...."
'Use Sendkeys to access the box in question. (Usually works but sometimes it's hit and miss)
Application.SendKeys ("%TMS{RIGHT}")
End Sub
To add a continous ping, use the following script.
Sub AddContinuousPingProcedure()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Dim SheetNumber
'If there is a problem from the outset go to ErrorMessage
On Error GoTo Errormessage
'Set VBProj as the ACTIVE Workbook. Remember this code was stored in an ADDIN
'(which is a workbook in itself technically) I needed the code to work in the Active Workbook (not the addin)
Set VBProj = ActiveWorkbook.VBProject
'I'm going to delete any other code from the Worksheet i want to work from.
'This might not be best practice but my code wont work otherwise.
'If any errors are seen trying to delete any code from the worksheet (there is none) then just add the code.
On Error GoTo AddProcedure
'Set the variable called SheetNumber to the Active Worksheet (with the IP Addresses on) using the
'Active Workbook \ Active Worksheet. We need the name of that worksheet and we can get that by adding .Codename.
'See this link for an explanation. "http://msdn.microsoft.com/en-us/library/office/aa214189(v=office.11).aspx"
SheetNumber = ActiveWorkbook.ActiveSheet.CodeName
'Delete Any Procedure (code) from the worksheet.
With ActiveWorkbook.VBProject.VBComponents(SheetNumber).CodeModule
.DeleteLines 1, .CountOfLines
End With
'Then add this procedure.
AddProcedure:
'If there's a problem, go to the errormessage label.
On Error GoTo Errormessage
With ActiveWorkbook.VBProject.VBComponents(SheetNumber).CodeModule
LineNum = .CountOfLines + 10
.InsertLines LineNum, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
LineNum = LineNum + 1
.InsertLines LineNum, "Dim sPingcmd As String"
LineNum = LineNum + 1
.InsertLines LineNum, "On Error GoTo ErrorTrap"
LineNum = LineNum + 1
.InsertLines LineNum, "If Intersect(Target, UsedRange).Address = Target.Address Then"
LineNum = LineNum + 1
.InsertLines LineNum, "sPingcmd = ""ping -a "" & Target.Value"
LineNum = LineNum + 1
.InsertLines LineNum, "Call Shell(""cmd /K"" & sPingcmd, vbNormalFocus)"
LineNum = LineNum + 1
.InsertLines LineNum, "End If"
LineNum = LineNum + 1
.InsertLines LineNum, "ErrorTrap:"
LineNum = LineNum + 1
.InsertLines LineNum, "End Sub"
End With
'Present the user with information about how it works.
MsgBox "If You Select A Cell With An IP Address In It, It Will Attempt To Ping The IP Address." & _
vbCrLf & "The PINGing Function will remain with this Worksheet unless removed", vbInformation, _
"PING right from your Worksheet!"
Exit Sub
'Inform the user this won't work and tell them what they need to do to get it working.
Errormessage:
MsgBox "Sorry - You need to allow Macros to trust the Visual Basic Project." & _
vbCrLf & vbCrLf & "I will take you to the location where you can enable this feature." & _
vbCrLf & " Tick the box called Trust Access to Visual Basic Project.", vbCritical, _
"You only need to tick the box once...."
'Use Sendkeys to access the box in question. (Usually works but sometimes it's hit and miss)
Application.SendKeys ("%TMS{RIGHT}")
End Sub
To delete the VBA Code from the worksheet, you need the following code.
Sub DeletePingModule()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
End If
Next VBComp
Call MenuDelete
End Sub
Now that you have the code, you can add this directly to the worksheet you want to use it on. But, what if you want to swap between standard and continuous pings without constantly cutting and pasting the code into the worksheet. That's what i thought too. So i created a floating toolbar with a couple of buttons on. One for standard ping, one for continuous ping and another to remove the code from the page completely.
Remember, the code itself will attempt to ping ANY cell you click in, that includes cells with text!
Here's my toolbar code.
Option Explicit
Const sCB As String = "PING"
Sub WorkSheetPing()
On Error Resume Next
Application.CommandBars(sCB).Delete
On Error GoTo 0
'Add a new command bar
With Application.CommandBars.Add(sCB, , False, True)
'add the following button controls to the toolbar
With .Controls.Add(msoControlButton)
.BeginGroup = False
End With
With .Controls.Add(msoControlButton)
.TooltipText = "PING IP's from Worksheet"
.FaceId = 9717
.OnAction = "AddPingProcedure"
.BeginGroup = False
End With
With .Controls.Add(msoControlButton)
.TooltipText = "Continuous PING IP's from Worksheet"
.FaceId = 9718
.OnAction = "AddContinuousPingProcedure"
.BeginGroup = True
End With
With .Controls.Add(msoControlButton)
.TooltipText = "Remove PING Functionality from Worksheet"
.FaceId = 9719
.OnAction = "DeletePingModule"
.BeginGroup = True
End With
With .Controls.Add(msoControlButton)
.BeginGroup = False
End With
.Protection = msoBarNoCustomize
.Position = msoBarFloating
.Visible = True
End With
End Sub
'Use this code to delete the toolbar when you're done.
Sub MenuDelete()
On Error Resume Next
Application.CommandBars(sCB).Delete
On Error GoTo 0
End Sub
No comments:
Post a Comment