Planilha Excel VBA Shapes 32 fotos organograma

Planilha Excel VBA Shapes 32 fotos organograma
Com estes Macros do Aplicativo Microsoft Excel VBA(Visual Basic Application), criaremos um organograma hierárquico com imagens(fotos) dos Gerentes e Subgerentes, observe que as fotos serão dispostas em nível e uma linha(shapes)
será criada e os ligará diretamente aos seus gerentes(diretos).

Dim bdt, n, vColuna
Sub vFotoPessoal(Parentes, nivel) ‘ procedimento recursivo
vColuna = vColuna + 1
Range(“B16”).Offset(nivel, vColuna) = Parentes
‘Range(“B16”).Offset(nivel, vColuna).BorderAround Weight:=xlThin
Range(“B16”).Offset(nivel, vColuna).RowHeight = 50
Err = 0
On Error Resume Next
ActiveSheet.Shapes(Parentes).Select
If Err = 0 Then
Selection.ShapeRange.Top = Range(“B16”).Offset(nivel, vColuna).Top + 2
Selection.ShapeRange.Left = Range(“B16”).Offset(nivel, vColuna).Left + 6
Selection.ShapeRange.Width = 20
Selection.ShapeRange.Height = 32
End If
On Error GoTo 0
For i = 1 To n
If UCase(bdt(i, 2)) = UCase(Parentes) Then
vFotoPessoal bdt(i, 1), nivel + 1
End If
Next i
End Sub

Sub OrganogramaFoto()
Range(“C16:M25”).ClearContents
vColuna = 0
n = Application.CountA(Range(“a:a”)) – 1
bdt = Range(“BD”)
vFotoPessoal Range(“D2”), 1
Limpar_Tratamento
Apresentacao
End Sub

Sub Apresentacao()
Application.ScreenUpdating = False
Limpar_Tratamento
For Linha = 0 To 4
Range(“b18”).Offset(Linha, 0).Select
pp = 0
For vCol = 1 To 20
ActiveCell.Offset(0, 1).Select
If ActiveCell <> “” And ActiveCell.Offset(-1, -1) <> “” Then
Inicio = ActiveCell.Left – 3
vfim = Inicio + 20
y = ActiveCell.Top – 5
ActiveSheet.Shapes.AddLine(Inicio, y, vfim, y).Select
ActiveSheet.Shapes.AddLine(vfim, y, vfim, y + 8).Select
pp = vfim
Else
If pp > 0 And ActiveCell <> “” Then
Inicio = pp
vfim = ActiveCell.Left + 20
y = ActiveCell.Top – 5
ActiveSheet.Shapes.AddLine(Inicio, y, vfim, y).Select
ActiveSheet.Shapes.AddLine(vfim, y, vfim, y + 8).Select
End If
End If
Next vCol
Next Linha
Range(“A1”).Select
Saber1.Shapes(“btincre”).Visible = True
End Sub

Sub Limpar_Tratamento()
‘MsgBox ActiveSheet.Shapes.Count
For Each i In ActiveSheet.Shapes
If Left(i.Name, 8) = “Straight” Then
ActiveSheet.Shapes(i.Name).Delete
End If
Next i
End Sub

Sub Importar_imagens_dir_ativo()
ChDir ActiveWorkbook.Path
Foto = Dir(“*.jpg”)     ‘primeiro arquivo
Range(“b2”).Select
Do While Foto <> “”
Set NomeImagem = ActiveSheet.Pictures.Insert(Foto)
NomeImagem.Name = Left(Foto, Len(Foto) – 4)    ‘ dê um nome a suas imagens
ActiveCell.Offset(0, -1) = Application.Proper(Left(Foto, Len(Foto) – 4))
ActiveCell.EntireRow.RowHeight = NomeImagem.Height + 0
Foto = Dir          ‘ proxima
ActiveCell.Offset(1, 0).Select
Loop
End Sub

‘//============’ DESFAZER FORMAÇÃO PARA REALIZAÇÃO DO TESTE:
Sub sby_limpar_formacao()
Limpar_Tratamento
ActiveSheet.Shapes.Range(Array(“Bene”)).Select
Selection.ShapeRange.IncrementLeft 2.25
Selection.ShapeRange.IncrementTop -40.5
ActiveSheet.Shapes.Range(Array(“Linda”)).Select
Selection.ShapeRange.IncrementLeft -1.5
Selection.ShapeRange.IncrementTop -90
ActiveSheet.Shapes.Range(Array(“Flavia”)).Select
Selection.ShapeRange.IncrementLeft -2.25
Selection.ShapeRange.IncrementTop -90
ActiveSheet.Shapes.Range(Array(“Will”)).Select
Selection.ShapeRange.IncrementLeft -15
Selection.ShapeRange.IncrementTop -42
ActiveSheet.Shapes.Range(Array(“Bure”)).Select
Selection.ShapeRange.IncrementLeft -3
Selection.ShapeRange.IncrementTop -88.5
ActiveSheet.Shapes.Range(Array(“Waleska”)).Select
Selection.ShapeRange.IncrementLeft -0.75
Selection.ShapeRange.IncrementTop -88.5
ActiveSheet.Shapes.Range(Array(“Jones”)).Select
Selection.ShapeRange.IncrementLeft -18.75
Selection.ShapeRange.IncrementTop -138.75
ActiveSheet.Shapes.Range(Array(“Joaquina”)).Select
Selection.ShapeRange.IncrementLeft -28.5
Selection.ShapeRange.IncrementTop -90.75
Saber1.Shapes(“btincre”).Visible = False
Saber1.[c17:K22].ClearContents
Range(“G14”).Select
End Sub