de qualquer forma está aí a macro
não sei se alguem vai estar disposto a mexer nisso e ajudar
Sub SelecFORMA()
Dim Nn As Long, Cj As Long, dsL As Long, dsC As Long, V As Long
Dim Sh As Shape 'Object
Dim ConfigB() As String ' matriz de configuração
Dim CfB(1 To 20) As Long ' define possição das configurações
CfB(1) = 0 'Tipo= 0 controle, 1 chekcbox ,2 option, 3 rotativo
CfB(2) = 1 'Estado= 0 desativado, 1 ativado, possição no rotativo
CfB(3) = 2 'valor se desaAtivado
CfB(4) = 3 'valor se ativado
CfB(5) = 4
CfB(6) = 5 'Linha inicial ( 0 PARA POSSIÇÃO TopLeftCell)*
CfB(7) = 6 'deslocamento LINHA
CfB(8) = 7 'deslocamento LINHA DE GRUPO
CfB(9) = 8 'coluna inicial ( 0 PARA POSSIÇÃO TopLeftCell)*
CfB(10) = 9 'deslocamento COLUNA
CfB(11) = 10 'deslocamento COLUNA DE GRUPO
CfB(12) = 11 '
CfB(13) = 12 '
CfB(14) = 13 '
CfB(15) = 14 'cor fundo se desativado
CfB(16) = 15 'cor fundo se ativado
CfB(17) = 16 'cor texto se desativado
CfB(18) = 17 'cor texto se ativado
CfB(19) = 18 'possição de sequencia acionamento
CfB(20) = 19 'Nome botão
'ActiveSheet.Shapes.SelectAll
Set Sh = ActiveSheet.Shapes(Application.Caller)
'Sh.Fill.BackColor.RGB = RGB(0, 128, 64)
ccs = Sh.TopLeftCell.Column
cs = Cells(1, ccs).Value2
NWP = Sh.OnAction & cs
Gn = Sh.Title ' nome grupo
pre = Sh.OLEFormat.Object.Caption & ccs
ConfigB = Split(Sh.AlternativeText, ",")
If UBound(ConfigB) < 1 Then Exit Sub
If ConfigB(CfB(1)) = "0" Then
V = ConfigB(CfB(2))
If V = 1 Then
ConfigB(CfB(2)) = 0
Sh.BackgroundStyle = 3
Sh.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground2
Else
ConfigB(CfB(2)) = 1
Sh.BackgroundStyle = 1:
Sh.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorText2
End If
Sh.AlternativeText = Join(ConfigB, ",")
For Each Sh2 In ActiveSheet.Shapes
ccs = Sh2.TopLeftCell.Column
gcs = Cells(1, ccs).Value2
BBN = Sh2.OnAction & gcs
If BBN = NWP Then
If Gn = Sh2.Title Then
ConfigB2 = Split(Sh2.AlternativeText, ",")
If UBound(ConfigB2) < 19 Then Exit Sub
If ConfigB2(CfB(1)) <> "0" Then
ConfigB2(CfB(1)) = Val(ConfigB(CfB(2))) + 1
End If
Sh2.AlternativeText = Join(ConfigB2, ",")
End If
End If
Next Sh2
Else
'==========================================================
With ActiveSheet
For Each Sh In .Shapes
adf = Sh.TopLeftCell.Address 'Local
ccs = Range(adf).Column
lls = Range(adf).Row
gcs = Cells(1, ccs).Value2
BBN = Sh.OnAction & gcs
If BBN = NWP Then
If Gn = Sh.Title Then ' nome grupo
ConfigB = Split(Sh.AlternativeText, ",")
If UBound(ConfigB) < 10 Then Exit Sub
If ConfigB(CfB(1)) <> "0" Then 'verifica se não é botão de controle
If ConfigB(CfB(6)) = "0" Then dsL = gcs + ConfigB(CfB(7)) + Val(ConfigB(CfB(8))) Else dsL = Val(ConfigB(CfB(6))) + ConfigB(CfB(7)) + Val(ConfigB(CfB(8))) 'LINHA DE SAIDA
If ConfigB(CfB(9)) = "0" Then dsC = gcs + ConfigB(CfB(10)) + Val(ConfigB(CfB(11))) Else dsC = Val(ConfigB(CfB(9))) + ConfigB(CfB(10)) + Val(ConfigB(CfB(11))) 'COLUNA DE SAIDA
If pre = Sh.OLEFormat.Object.Caption & ccs Then
If ConfigB(CfB(2)) = "0" Then
ConfigB(CfB(2)) = 1
Cells(dsL, dsC).Value2 = ConfigB(CfB(4))
Sh.BackgroundStyle = 3
Sh.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground2
Else
If ConfigB(CfB(1)) = "1" Then
ConfigB(CfB(2)) = 0:
Cells(dsL, dsC).Value2 = ConfigB(CfB(3))
Sh.BackgroundStyle = 1:
Sh.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorText2
End If
End If
Else
If ConfigB(CfB(1)) = "2" Then
ConfigB(CfB(2)) = "0":
Cells(dsL, dsC).Value2 = ConfigB(CfB(3))
Sh.BackgroundStyle = 1:
Sh.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorText2
End If
End If
End If
Sh.AlternativeText = Join(ConfigB, ",")
End If
End If
Next Sh
End With
End If
End Sub
está tudo junto pq ainda estou redefinindo as características
acho que o certo seria ter uns padrões de cor "temas" para escolher
ainda tenho que descobrir como fazer funcionar em objetos agrupados
Postado : 22/08/2017 5:50 pm