Sub organig()

Sub organig()
'bloquer le usedrange sur A1
If Cells(1) = "" Then Cells(1) = " "
Set Source = Sheets("feuil1").UsedRange
Source.Cells(Source.Cells.Count + 1).Select
échelle = 550 / Source.Width
'créer une feuille graphique contenant une copie de la plage utile
Set gr = Charts.Add
Source.CopyPicture Appearance:=xlScreen, Format:=xlPicture
gr.Paste
'choix de l'échelle
If Selection.ShapeRange.Height / gr.ChartArea.Height >= Selection.ShapeRange.Width / gr.ChartArea.Width Then
Selection.ShapeRange.Height = gr.ChartArea.Height
Else
Selection.ShapeRange.Width = gr.ChartArea.Width
End If
'exporter la feuille graphique au format .gif
gr.Export ThisWorkbook.Path & "\rien.gif", "GIF"
Application.DisplayAlerts = False
gr.Delete
Application.DisplayAlerts = True
'créer la page html
fich = ThisWorkbook.Path & "\test_map.html"
Open fich For Output As 1
'creation Code html
Print #1, "<HTML>" & Chr$(13)
Print #1, "<BODY BGCOLOR='WHITE'><CENTER>" & Chr$(13)
Print #1, "<MAP NAME='carte'>"
'chercher les coordonn des cases
For Each cel In Source
If cel.Interior.ColorIndex <> xlNone Then
'recherche du lien hypertexte
lien = ""
On Error Resume Next
lien = cel.Hyperlinks(1).Address
On Error GoTo 0
'cellule avec lien
Print #1, "<AREA SHAPE='rectangle' COORDS='" & échelle * cel.Left & "," & échelle * cel.Top & "," & échelle * cel.Left + échelle * cel.Width & "," & échelle * cel.Top + échelle * cel.Height & "' HREF='" & lien & "'>"
End If
Next cel
Print #1, "</MAP>"
Print #1, "<IMG SRC='" & "rien.gif" & "' width=" & échelle * Source.Width & " usemap='#carte' border='0'>"
Print #1, "</CENTER></BODY></HTML>"
Close #1
'ouvrir la page html
ThisWorkbook.FollowHyperlink ThisWorkbook.Path & "\test_map.html", , True
End Sub