• Welcome to #1 Roulette Forum & Message Board | www.RouletteForum.cc.

News:

Odds and payouts are different things. If either the odds or payouts don't change, then the result is the same - eventual loss.

Main Menu
Popular pages:

Roulette System

The Roulette Systems That Really Work

Roulette Computers

Hidden Electronics That Predict Spins

Roulette Strategy

Why Roulette Betting Strategies Lose

Roulette System

The Honest Live Online Roulette Casinos

Cool extention for excel

Started by iggiv, Jul 13, 04:52 PM 2011

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.


iggiv

link:://:.mrexcel.com/forum/showthread.php?t=158031



In the workbook module:

Private Sub Workbook_Deactivate()
Application.CommandBars("Cell").ReSet
End Sub

Private Sub Workbook_Activate()
Run "ModifyRightClick"
End Sub



In a standard module:

Private Sub ModifyRightClick()
Dim O1 As Object, O2 As Object
On Error Resume Next
With CommandBars("Cell")
.Controls("Deselect ActiveCell").Delete
.Controls("Deselect ActiveArea").Delete
End With
On Error GoTo 0
Set O1 = CommandBars("Cell").Controls.Add
With O1
.Caption = "Deselect ActiveCell"
.OnAction = "DeselectActiveCell"
End With
Set O2 = CommandBars("Cell").Controls.Add
With O2
.Caption = "Deselect ActiveArea"
.OnAction = "DeselectActiveArea"
End With
End Sub

Private Sub DeselectActiveCell()
Dim x As Range, why As Range
If Selection.Cells.Count > 1 Then
For Each why In Selection.Cells
If y.Address <> ActiveCell.Address Then
If x Is Nothing Then
Set x = y
Else
Set x = Application.Union(x, y)
End If
End If
Next y
If x.Cells.Count > 0 Then
x.Select
End If
End If
End Sub

Private Sub DeselectActiveArea()
Dim x As Range, why As Range
If Selection.Areas.Count > 1 Then
For Each why In Selection.Areas
If Application.Intersect(ActiveCell, y) Is Nothing

Then
If x Is Nothing Then
Set x = y
Else
Set x = Application.Union(x, y)
End If
End If
Next y
x.Select
End If
End Sub

-