|
Option Explicit
Option Private Module
Public gn_SelIndex As Long
Public ga_UndoSelRng() As Range
Public XLS As New cls_ChangeSelection
Private Const ms_CMDB_SELECTION As String = _
"ChangeCurrentSelection"
Public Sub Create_MenuChangeSelection()
Dim objCmdBar As CommandBar
Dim objCmdPopup As CommandBarPopup
Call Delete_MenuChangeSelection
'Laufzeitfehler unterdrücken.
On Error Resume Next
Set objCmdBar = Application.CommandBars("Worksheet Menu Bar")
Set objCmdPopup = _
objCmdBar.Controls.Add(msoControlPopup, , , , True)
With objCmdPopup
.BeginGroup = True
.Caption = "Change Selection"
.Tag = ms_CMDB_SELECTION
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Undo cell selection"
.FaceId = 128
.OnAction = "Get_LastSelection"
.ShortcutText = "Ctrl+Shift+Z"
.Style = msoButtonIconAndCaption
End With
With .Controls.Add(msoControlButton, , , , True)
.BeginGroup = True
.Caption = "Expand to rows"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 1
End With
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Expand to columns"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 2
End With
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Invert selection on selected area"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 3
End With
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Invert selection on used range"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 4
End With
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Invert selection on worksheet"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 5
End With
With .Controls.Add(msoControlButton, , , , True)
.BeginGroup = True
.Caption = "Customized changes..."
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 6
End With
End With
Application.OnKey "^+{z}", "Get_LastSelection"
On Error GoTo 0
End Sub
Public Sub Delete_MenuChangeSelection()
Dim objCmdPopup As CommandBarPopup
Set objCmdPopup = _
Application.CommandBars.FindControl(msoControlPopup, , _
ms_CMDB_SELECTION)
If Not objCmdPopup Is Nothing Then
objCmdPopup.Delete
End If
Application.OnKey "^+{z}"
End Sub
Private Sub Get_LastSelection()
Application.EnableEvents = False
On Error Resume Next
Do
Err.Clear
If gn_SelIndex >= 0 Then
ga_UndoSelRng(gn_SelIndex).Parent.Parent.Activate
ga_UndoSelRng(gn_SelIndex).Parent.Activate
ga_UndoSelRng(gn_SelIndex).Select
ReDim Preserve ga_UndoSelRng(gn_SelIndex) As Range
gn_SelIndex = gn_SelIndex - 1
End If
Loop Until Err.Number = 0 Or gn_SelIndex <= 1
On Error GoTo 0
Application.EnableEvents = True
End Sub
Private Sub Change_CurrentSelection()
If Application.Workbooks.Count > 0 Then
If TypeOf Selection Is Range Then
Select Case CLng(Application.CommandBars.ActionControl.Tag)
Case 1: Selection.Rows.EntireRow.Select
Case 2: Selection.Columns.EntireColumn.Select
Case 3: Call Get_BaseRange(Selection.Cells, 3)
Case 4: Call Get_BaseRange(Selection.Cells, 4)
Case 5: Call Get_BaseRange(Selection.Cells, 5)
Case 6: frm_ChangeSelection.Show
End Select
End If
End If
End Sub
Private Sub Get_BaseRange(ByRef rSelection As Range, ByVal vType _
As Integer)
Dim LB(1) As Long 'Erste Zeile und erste Spalte
Dim UB(1) As Long 'Letzte Zeile und letzte Spalte
Dim objArea As Range 'Einzelne Area Objekte der aktuellen ...
Dim objRng As Range 'Gesamter Zellbereich für die Umkehrung ...
Select Case vType
Case 5: Set objRng = Cells
Case 4: Set objRng = ActiveSheet.UsedRange
Case 3
LB(0) = Rows.Count
LB(1) = Columns.Count
For Each objArea In rSelection.Areas
With objArea
If LB(0) > .Rows(1).Row Then LB(0) = .Rows(1).Row
If LB(1) > .Columns(1).Column Then LB(1) = _
.Columns(1).Column
If UB(0) < .Rows(.Rows.Count).Row Then UB(0) = _
.Rows(.Rows.Count).Row
If UB(1) < .Columns(1).Column Then UB(1) = _
.Columns(.Columns.Count).Column
End With
Next objArea
Set objRng = Range(Cells(LB(0), LB(1)), Cells(UB(0), UB(1)))
End Select
Call Invert_Selection(objRng, rSelection)
objRng.Select
End Sub
Public Sub Invert_Selection(ByRef rRngBase As Range, ByRef _
rRngOld As Range)
Dim objArea As Range 'Einzelnes Area Objekt der ...
Dim objRngUnSel As Range 'Nicht selektierter Zellbereich ...
Dim objRng(1 To 4) As Range 'Erste und letzte Zellen der ...
If Not rRngOld Is Nothing Then
'Erste und letzte Zelle der Tabelle in Variable schreiben.
Set objRng(1) = Cells(1, 1)
Set objRng(2) = Cells(Cells.Rows.Count, Cells.Columns.Count)
For Each objArea In rRngOld.Areas
Set objRng(3) = objArea.Cells(1, objArea.Columns.Count)
Set objRng(4) = objArea.Cells(objArea.Rows.Count, 1)
If objRng(1).Row <> objRng(3).Row Then
Call Join_Rng(objRngUnSel, Range(objRng(1), _
objRng(3).Rows(0)).EntireRow)
End If
If objRng(2).Row <> objRng(4).Row Then
Call Join_Rng(objRngUnSel, Range(objRng(2), _
objRng(4).Rows(2)).EntireRow)
End If
'Spalten linkes neben dem Area Objekt
If objRng(1).Column <> objRng(4).Column Then
Call Join_Rng(objRngUnSel, Range(objRng(1), _
objRng(4).Columns(0)).EntireColumn)
End If
'Spalten rechts neben dem Area Objekt
If objRng(2).Column <> objRng(3).Column Then
Call Join_Rng(objRngUnSel, Range(objRng(2),
objRng(3).Columns(2)).EntireColumn)
End If
On Error Resume Next
Set rRngBase = Application.Intersect(rRngBase, _
Application.Intersect(objRngUnSel, rRngBase))
If Err.Number <> 0 Then
Set rRngBase = ActiveCell
End If
On Error GoTo 0
Set objRngUnSel = Nothing
Next
End If
End Sub
Public Sub Join_Rng(ByRef rRngUnSel As Range, _
ByRef rRngAdd As Range)
If Not rRngAdd Is Nothing Then
If Not rRngUnSel Is Nothing Then
Set rRngUnSel = Union(rRngUnSel, rRngAdd)
Else
Set rRngUnSel = rRngAdd
End If
End If
End SubOption Explicit
Option Private Module
Public gn_SelIndex As Long
Public ga_UndoSelRng() As Range
Public XLS As New cls_ChangeSelection
Private Const ms_CMDB_SELECTION As String = _
"ChangeCurrentSelection"
Public Sub Create_MenuChangeSelection()
Dim objCmdBar As CommandBar
Dim objCmdPopup As CommandBarPopup
Call Delete_MenuChangeSelection
On Error Resume Next
Set objCmdBar = Application.CommandBars("Worksheet Menu Bar")
Set objCmdPopup = _
objCmdBar.Controls.Add(msoControlPopup, , , , True)
With objCmdPopup
.BeginGroup = True
.Caption = "Change Selection"
.Tag = ms_CMDB_SELECTION
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Undo cell selection"
.FaceId = 128
.OnAction = "Get_LastSelection"
.ShortcutText = "Ctrl+Shift+Z"
.Style = msoButtonIconAndCaption
End With
With .Controls.Add(msoControlButton, , , , True)
.BeginGroup = True
.Caption = "Expand to rows"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 1
End With
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Expand to columns"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 2
End With
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Invert selection on selected area"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 3
End With
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Invert selection on used range"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 4
End With
With .Controls.Add(msoControlButton, , , , True)
.Caption = "Invert selection on worksheet"
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 5
End With
With .Controls.Add(msoControlButton, , , , True)
.BeginGroup = True
.Caption = "Customized changes..."
.OnAction = "Change_CurrentSelection"
.Style = msoButtonIconAndCaption
.Tag = 6
End With
End With
Application.OnKey "^+{z}", "Get_LastSelection"
On Error GoTo 0
End Sub
Public Sub Delete_MenuChangeSelection()
Dim objCmdPopup As CommandBarPopup
Set objCmdPopup = _
Application.CommandBars.FindControl(msoControlPopup, , _
ms_CMDB_SELECTION)
If Not objCmdPopup Is Nothing Then
objCmdPopup.Delete
End If
Application.OnKey "^+{z}"
End Sub
Private Sub Get_LastSelection()
Application.EnableEvents = False
On Error Resume Next
Do
Err.Clear
If gn_SelIndex >= 0 Then
'Arbeitsmappe der Zell-Selektion aktivieren.
ga_UndoSelRng(gn_SelIndex).Parent.Parent.Activate
'Tabelle der Zell-Selektion aktivieren.
ga_UndoSelRng(gn_SelIndex).Parent.Activate
'Zellen selektieren.
ga_UndoSelRng(gn_SelIndex).Select
ReDim Preserve ga_UndoSelRng(gn_SelIndex) As Range
'Globaler Index für Selektions-Historie anpassen.
gn_SelIndex = gn_SelIndex - 1
End If
Loop Until Err.Number = 0 Or gn_SelIndex <= 1
On Error GoTo 0
Application.EnableEvents = True
End Sub
Private Sub Change_CurrentSelection()
If Application.Workbooks.Count > 0 Then
If TypeOf Selection Is Range Then
Select Case CLng(Application.CommandBars.ActionControl.Tag)
Case 1: Selection.Rows.EntireRow.Select
Case 2: Selection.Columns.EntireColumn.Select
Case 3: Call Get_BaseRange(Selection.Cells, 3)
Case 4: Call Get_BaseRange(Selection.Cells, 4)
Case 5: Call Get_BaseRange(Selection.Cells, 5)
Case 6: frm_ChangeSelection.Show
End Select
End If
End If
End Sub
Private Sub Get_BaseRange(ByRef rSelection As Range, _
ByVal vType As Integer)
Dim LB(1) As Long 'Erste Zeile und erste Spalte
Dim UB(1) As Long 'Letzte Zeile und letzte Spalte
Dim objArea As Range 'Einzelne Area Objekte der aktuellen ...
Dim objRng As Range 'Gesamter Zellbereich für die Umkehrung ...
Select Case vType
Case 5: Set objRng = Cells
Case 4: Set objRng = ActiveSheet.UsedRange
Case 3
LB(0) = Rows.Count
LB(1) = Columns.Count
For Each objArea In rSelection.Areas
With objArea
If LB(0) > .Rows(1).Row Then LB(0) = .Rows(1).Row
If LB(1) > .Columns(1).Column Then LB(1) = _
.Columns(1).Column
If UB(0) < .Rows(.Rows.Count).Row Then UB(0) = _
.Rows(.Rows.Count).Row
If UB(1) < .Columns(1).Column Then UB(1) = _
.Columns(.Columns.Count).Column
End With
Next objArea
Set objRng = Range(Cells(LB(0), LB(1)), Cells(UB(0), UB(1)))
End Select
Call Invert_Selection(objRng, rSelection)
objRng.Select
End Sub
Public Sub Invert_Selection(ByRef rRngBase As Range, _
ByRef rRngOld As Range)
Dim objArea As Range 'Einzelnes Area Objekt der ...
Dim objRngUnSel As Range 'Nicht selektierter Zellbereich ...
Dim objRng(1 To 4) As Range 'Erste und letzte Zellen der ...
If Not rRngOld Is Nothing Then
Set objRng(1) = Cells(1, 1)
Set objRng(2) = Cells(Cells.Rows.Count, Cells.Columns.Count)
For Each objArea In rRngOld.Areas
Set objRng(3) = objArea.Cells(1, objArea.Columns.Count)
Set objRng(4) = objArea.Cells(objArea.Rows.Count, 1)
If objRng(1).Row <> objRng(3).Row Then
Call Join_Rng(objRngUnSel, Range(objRng(1), _
objRng(3).Rows(0)).EntireRow)
End If
If objRng(2).Row <> objRng(4).Row Then
Call Join_Rng(objRngUnSel, Range(objRng(2), _
objRng(4).Rows(2)).EntireRow)
End If
If objRng(1).Column <> objRng(4).Column Then
Call Join_Rng(objRngUnSel, Range(objRng(1), _
objRng(4).Columns(0)).EntireColumn)
End If
If objRng(2).Column <> objRng(3).Column Then
Call Join_Rng(objRngUnSel, Range(objRng(2), _
objRng(3).Columns(2)).EntireColumn)
End If
On Error Resume Next
Set rRngBase = Application.Intersect(rRngBase, _
Application.Intersect(objRngUnSel, rRngBase))
If Err.Number <> 0 Then
Set rRngBase = ActiveCell
End If
On Error GoTo 0
Set objRngUnSel = Nothing
Next
End If
End Sub
Public Sub Join_Rng(ByRef rRngUnSel As Range, _
ByRef rRngAdd As Range)
If Not rRngAdd Is Nothing Then
If Not rRngUnSel Is Nothing Then
Set rRngUnSel = Union(rRngUnSel, rRngAdd)
Else
Set rRngUnSel = rRngAdd
End If
End If
End Sub
|
|