Option Explicit
Private Const SC_MODULE_NAME As String = "mdlSubcatFuncs"
Private Const SC_FRM_PREFIX As String = "scF_"
Private Const SC_CHK_PREFIX As String = "scC_"
Private Const SC_WKS_SRC_NAME As String = "Lists"
Private Const SC_WKS_SRC_1ST_CELLADDRESS As String = "D3"
Private Const SC_WKS_DST_NAME As String = "Checklist Structure"
Private Const SC_WKS_DATATABLE_NAME As String = "Risk Category Checklist"
Private Const SC_FRM_ANCHOR_LEFT As Single = 211.5
Private Const SC_FRM_ANCHOR_TOP As Single = 276.4688
Private Const SC_FRM_MARGIN_TOP As Single = 29.2243
Private Const SC_FRM_WIDTH As Single = 160.5
Private Const SC_FRM_HEIGHT As Single = 19.5
Private Const SC_CHK_WIDTH As Single = 13.2
Private Const SC_CHK_HEIGHT As Single = 13.8
Private Const SC_FRM_RGB_STATE1 As Long = &HFFFFFF
Private Const SC_FRM_RGB_STATE2 As Long = &H99FFFF
Public Type TSubcategory
Frame As Excel.Shape
CheckBox As Object
End Type
Public Sub RemoveSubcategories()
Dim shp As Excel.Shape
With ThisWorkbook.Worksheets(SC_WKS_DST_NAME)
Application.ScreenUpdating = False
For Each shp In .Shapes
If Left$(shp.Name, Len(SC_FRM_PREFIX)) = SC_FRM_PREFIX Then
Call shp.Delete
ElseIf Left$(shp.Name, Len(SC_CHK_PREFIX)) = SC_CHK_PREFIX Then
Call shp.Delete
End If
Next
Application.ScreenUpdating = True
End With
End Sub
Public Sub MakeSureSubcategoriesExists()
Dim rngSubcats As Excel.Range
Dim rngSubcatCol As Excel.Range
Dim rngSubcatCell As Excel.Range
Dim blnSuccess As Boolean
Dim blnSU As Boolean
blnSU = Application.ScreenUpdating
Application.ScreenUpdating = False
On Error GoTo ErrHandler
With ThisWorkbook.Worksheets(SC_WKS_SRC_NAME)
Set rngSubcats = .Range(SC_WKS_SRC_1ST_CELLADDRESS).CurrentRegion
Set rngSubcats = .Range(.Range(SC_WKS_SRC_1ST_CELLADDRESS), rngSubcats.Cells(rngSubcats.Cells.Count))
End With
blnSuccess = True
For Each rngSubcatCol In rngSubcats.Columns
For Each rngSubcatCell In rngSubcatCol.Cells
Select Case Trim$(rngSubcatCell.Text)
Case "", "not sorted yet"
Exit For
Case Else
If Not SubcategoryExists(rngSubcatCell) Then
If Not CreateSubcategory(rngSubcatCell) Then
blnSuccess = False
End If
End If
End Select
Next
Next
If blnSuccess Then
Call MsgBox("Alle Unterkategorieren sind vorhanden bzw. wurden erstellt.", _
vbInformation, _
"Vorgang abgeschlossen")
Else
Call MsgBox("Einige Unterkategorien konnten nicht erstellt werden.", _
vbExclamation, _
"Vorgang abgeschlossen")
End If
SafeExit:
Application.ScreenUpdating = blnSU
Exit Sub
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
GoTo SafeExit
End Sub
Private Sub RefreshSubcategoryCheckBoxAll()
Dim shp As Excel.Shape
With ThisWorkbook.Worksheets(SC_WKS_DST_NAME)
Application.ScreenUpdating = False
For Each shp In .Shapes
If Left$(shp.Name, Len(SC_CHK_PREFIX)) = SC_CHK_PREFIX Then
Call RefreshSubcategoryCheckBox(shp.OLEFormat.Object)
End If
Next
Application.ScreenUpdating = True
End With
End Sub
Public Sub SubcategoryCheckBox_Click()
Dim shpCheckBox As Excel.Shape
Dim strChkCaption As String
Dim blnSU As Boolean
blnSU = Application.ScreenUpdating
Application.ScreenUpdating = False
On Error GoTo ErrHandler
Select Case TypeName(Application.Caller)
Case "String": Set shpCheckBox = ActiveSheet.Shapes(Application.Caller)
Case Else: GoTo SafeExit
End Select
If Not shpCheckBox.Type = msoFormControl Then Exit Sub
If Not shpCheckBox.FormControlType = xlCheckBox Then Exit Sub
Call RefreshSubcategoryCheckBox(shpCheckBox.OLEFormat.Object)
SafeExit:
Application.ScreenUpdating = blnSU
Exit Sub
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
GoTo SafeExit
End Sub
Public Sub SubcategoryFrame_Click()
Dim rngAutoFilter As Excel.Range
Dim shpSubcat As Excel.Shape
Dim strShapeText As String
Dim blnSU As Boolean
blnSU = Application.ScreenUpdating
Application.ScreenUpdating = False
On Error GoTo ErrHandler
Select Case TypeName(Application.Caller)
Case "String": Set shpSubcat = ActiveSheet.Shapes(Application.Caller)
Case Else: GoTo SafeExit
End Select
strShapeText = Trim$(shpSubcat.TextFrame2.TextRange.Text)
With ThisWorkbook.Worksheets(SC_WKS_DATATABLE_NAME)
If .AutoFilterMode Then
Set rngAutoFilter = .AutoFilter.Range
Else
Call .Range(.Cells(5, "B"), .Cells(5, .Columns.Count).End(xlToLeft)).AutoFilter
Set rngAutoFilter = .AutoFilter.Range
End If
End With
If ToggleShapeColor(shpSubcat) = SC_FRM_RGB_STATE2 Then
Call ModifyFilter(rngAutoFilter, 6, strShapeText)
Else
Call ModifyFilter(rngAutoFilter, 6, strShapeText, mdaRemove)
End If
SafeExit:
Application.ScreenUpdating = blnSU
Exit Sub
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Fehler " & Err.Number)
GoTo SafeExit
End Sub
Private Function SubcategoryExists(SubcategoryCell As Excel.Range) As Boolean
Dim shp As Excel.Shape
On Error GoTo ErrHandler
With ThisWorkbook.Worksheets(SC_WKS_DST_NAME)
Set shp = .Shapes(SC_FRM_PREFIX & SubcategoryCell.Address(False, False))
Set shp = .Shapes(SC_CHK_PREFIX & SubcategoryCell.Address(False, False))
End With
SubcategoryExists = True
Exit Function
ErrHandler:
End Function
Private Sub RefreshSubcategoryCheckBox(CheckBox As Object)
Dim rngSubcategoryCol As Excel.Range
Dim rngResult As Excel.Range
Set rngSubcategoryCol = ThisWorkbook.Worksheets(SC_WKS_DATATABLE_NAME).Columns("G")
Set rngResult = rngSubcategoryCol.Find(Trim$(CheckBox.Caption), LookIn:=xlValues, LookAt:=xlWhole)
CheckBox.Value = Not (rngResult Is Nothing)
End Sub
Private Function CreateSubcategory(SubcategoryCell As Excel.Range) As Boolean
Dim rngFirstSubCatCell As Excel.Range
Dim shpFrame As Excel.Shape
Dim shpChk As Excel.Shape
Set rngFirstSubCatCell = ThisWorkbook.Worksheets(SC_WKS_SRC_NAME).Range(SC_WKS_SRC_1ST_CELLADDRESS)
With ThisWorkbook.Worksheets(SC_WKS_DST_NAME).Shapes
Set shpFrame = .AddShape(MsoAutoShapeType.msoShapeRoundedRectangle, _
Left:=SC_FRM_ANCHOR_LEFT * (1! + (SubcategoryCell.Column - rngFirstSubCatCell.Column)), _
Top:=SC_FRM_ANCHOR_TOP + SC_FRM_MARGIN_TOP * (SubcategoryCell.Row - rngFirstSubCatCell.Row), _
Width:=SC_FRM_WIDTH, _
Height:=SC_FRM_HEIGHT)
With shpFrame
.Name = SC_FRM_PREFIX & Replace$(.Name, " ", "")
.Fill.ForeColor.RGB = rgbWhite
With .TextFrame2
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
.TextRange.Font.Fill.ForeColor.RGB = rgbBlack
.TextRange.Text = Trim$(SubcategoryCell.Text)
End With
.OnAction = SC_MODULE_NAME & ".SubcategoryFrame_Click"
End With
Set shpChk = .AddFormControl(XlFormControl.xlCheckBox, _
Left:=0, _
Top:=0, _
Width:=0, _
Height:=0)
With shpChk
.Name = SC_CHK_PREFIX & Replace$(.Name, " ", "")
With .OLEFormat.Object
.Caption = Trim$(SubcategoryCell.Text)
.Left = shpFrame.Left + 2!
.Top = shpFrame.Top + (shpFrame.Height - SC_CHK_WIDTH) / 2!
.Width = SC_CHK_WIDTH
.Height = SC_CHK_HEIGHT
End With
.OnAction = SC_MODULE_NAME & ".SubcategoryCheckBox_Click"
End With
Call RefreshSubcategoryCheckBox(shpChk.OLEFormat.Object)
End With
CreateSubcategory = True
End Function
Private Function ToggleShapeColor(Shape As Excel.Shape) As Long
With Shape.Fill.ForeColor
If .RGB = SC_FRM_RGB_STATE1 Then
.RGB = SC_FRM_RGB_STATE2
Else
.RGB = SC_FRM_RGB_STATE1
End If
ToggleShapeColor = .RGB
End With
End Function