MacroFacili: Disegno di frecce

Un esempio che mostra come sia possibile aggiungere delle frecce ai fogli di calcolo per evidenziare una sequenza di valori.

Nell'esempio puramente ipotetico viene evidenziato il percorso di prelievo in un magazzino: è solo una schematizzazione che non tiene conto dei percorsi reali ed è creata solo per mostrare come sia possibile lavorare con le frecce.

L'immagine a destra mostra il risultato finale della macro applicata alla sequenza di valori:

Inizio --> 20 --> 24 --> 60 --> 29 --> 65 --> 70 --> 72 --> Fine

In questo caso è stata anche utilizzata la conversione di colori dal formato HSL a RGB per dare un colore diverso ad ogni freccia/nodo.

La freccia fa parte dell'insieme di forme che è possibile aggiungere ad un foglio.

Volendo diegnare una semplice freccia fra due celle la versione semplificata della procedure utilizzata nell'esempio (quella qui sotto) permette di disegnare una freccia che parte dal centro di un cella ed arriva al centro di una seconda cella:

Il dettaglio del codice utilizzato nell'esempio commentato

Il corpo centrale della procedura:

Public Sub DisegnaFrecce()
  Dim CellaDa As Range
  Dim CellaA As Range
  Dim Colore As Long

  Set Ambiente = Range("Ambiente")
  Set Percorso = Range("Percorso")
  Set Fa = ActiveSheet

  'cancella le frecce e ovali disegnati in precedenza
  For Each shp In Fa.Shapes
    If (Not Application.Intersect(shp.TopLeftCell, Ambiente) Is Nothing Or _
        Not Application.Intersect(shp.BottomRightCell, Ambiente) Is Nothing) Then
      If (shp.AutoShapeType = msoShapeOval Or _
          shp.AutoShapeType = msoConnectorStraight Or _
          shp.AutoShapeType = msoShapeMixed) Then
        shp.Delete
      End If
    End If
  Next shp

  ' disegna il primo ovale di evidenziazione del testo
  ColoreH = 0
  Set CellaDa = Ambiente.Find(Percorso.Cells(1, 1).Value, , xlValues, xlWhole)
  EvidenziaCella Cella:=CellaDa, Colore:=HSL_To_Color(ColoreH, 100, 40)

  ' disegna le frecce e i successivi ovali di evidenziazione del testo
  For Each Passo In Percorso
    If (Passo.Value <> "" And Passo.Offset(1, 0).Value <> "") Then
      Set CellaDa = Ambiente.Find(Passo.Value, , xlValues, xlWhole)
      Set CellaA = Ambiente.Find(Passo.Offset(1, 0).Value, , xlValues, xlWhole)

      EvidenziaCella Cella:=CellaA, Colore:=HSL_To_Color(ColoreH, 100, 40)
      CreaFreccia CellaDa:=CellaDa, CellaA:=CellaA, Colore:=HSL_To_Color(ColoreH, 100, 40)
      ColoreH = ColoreH + 30
    End If
  Next Passo
End Sub

Il disegno dell'ovale per evidenziare il testo delle celle collegate:

Sub EvidenziaCella(Cella As Range, Colore As Long)
  If (Not Cella Is Nothing) Then
    'le coordinate del centro delle cella
    xi = Cella.Left + Cella.Width / 2
    yi = Cella.Top + Cella.Height / 2

    'calcolo delle dimensioni dell'ovale
    DimOvaleTesto Cella:=Cella, DimX:=Dx, DimY:=Dy

    'disegna l'ovale
    Dim Ovale As Shape
    Set Ovale = ActiveSheet.Shapes.AddShape(msoShapeOval, xi - Dx, yi - Dy, Dx * 2, Dy * 2)
    Ovale.Line.Weight = 0.1
    Ovale.Line.ForeColor.RGB = Colore
    Ovale.Fill.ForeColor.RGB = Colore
    Ovale.Fill.Transparency = 0.8
  End If
End Sub

Il disegno della freccia: è stata utilizzata una procedura leggermente più complessa per evitare che la freccia arrivi al centro della cella nascondendo il testo e si fermi al bordo dell'ovale disengato attorno al testo.

Sub CreaFreccia(CellaDa As Range, CellaA As Range, Colore As Long)
  If (Not CellaDa Is Nothing And Not CellaA Is Nothing) Then
    ' coordinate iniziale e finale della freccia partendo dal centro delle celle
    yi = CellaDa.Top + CellaDa.Height / 2
    xi = CellaDa.Left + CellaDa.Width / 2
    yf = CellaA.Top + CellaA.Height / 2
    xf = CellaA.Left + CellaA.Width / 2

    ' lunghezza della freccia e della componente X e Y
    lx = xf - xi
    ly = yf - yi
    lf = Sqr(lx * lx + ly * ly)

    ' distanza dal centro da cui far partire/arrivare la freccia
    DimOvaleTesto Cella:=CellaDa, DimX:=dxi, DimY:=dyi
    DimOvaleTesto Cella:=CellaA, DimX:=dxf, DimY:=dyf

    ' calcola le nuove coordinate tenendo conto della distanza dal centro
    xi = xi + dxi * lx / lf
    yi = yi + dyi * ly / lf
    xf = xf - dxf * lx / lf
    yf = yf - dyf * ly / lf

    'disegna la freccia
    Dim Freccia As Shape
    Set Freccia = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, xi, yi, xf, yf)
    Freccia.Line.EndArrowheadStyle = msoArrowheadTriangle
    Freccia.Line.Weight = 1
    Freccia.Line.ForeColor.RGB = Colore
  End If
End Sub

Per il calcolo della dimensione dell'ovale che contiene il testo:

Private Sub DimOvaleTesto(Cella As Range, ByRef DimX, ByRef DimY)
  Testo = Cella.Value
  ChSize = Cella.Font.Size

  DimY = ChSize * 1.3
  DimX = DimY + ChSize * (Len(Testo) - 1) * 0.6
  If (DimX > Cella.Width) Then DimX = Cella.Width
  If (DimY > Cella.Height) Then DimY = Cella.Height

  DimX = DimX / 2
  DimY = DimY / 2
End Sub

Questa funzione da un calcolo approssimativo, il calcolo corretto della dimensione di un testo su schermo non è fra le funzioni disponibili in VBA e avrebbe richiesto una procedura molto più complessa e non significativa per questo esempio.

L'esempio completo é scaricabile da questo link: Es363.xlsm (a questo link le info per attivare le macro se risultano bloccate)

Gli esempi contenuti nel sito sono per uso personale, non é consentito l'uso professionale, commerciale o la riproduzione senza autorizzazione.

Per dubbi o domande potete scriverci a domande@macrofacili.it, sulla nostra pagina FB MacroFacili.it o sul gruppo FB Excel, macro e formule.