Sub colorer_reg()
Dim Colorimetre
Dim derlig As Integer, lig As Integer
Dim score As Integer, reg As String
Colorimetre = Array(RGB(255, 255, 255), RGB(255, 255, 175), RGB(255, 255, 90), _
RGB(255, 255, 0), RGB(255, 212, 10), RGB(255, 197, 25), _
RGB(255, 183, 16), RGB(255, 165, 50), RGB(255, 149, 40), _
RGB(255, 123, 0), RGB(255, 97, 0), RGB(255, 64, 0), _
RGB(255, 0, 0), RGB(255, 0, 128), RGB(245, 25, 255), _
RGB(220, 65, 255), RGB(204, 102, 255), RGB(191, 128, 255), _
RGB(160, 126, 255), RGB(130, 120, 255), RGB(113, 113, 255), _
RGB(96, 96, 255), RGB(64, 64, 255), RGB(0, 0, 230), _
RGB(0, 0, 128))
derlig = Sheets("Reg").Range("A" & Rows.Count).End(xlUp).Row
For lig = 2 To derlig
reg = Sheets("Reg").Cells(lig, "A").Value
score = Sheets("Dept").Cells(lig, "D").Value
If score > 0 Then
Sheets("Carte").Shapes.Range(Array(reg)).Fill.ForeColor.RGB = Colorimetre(def_color(score))
End If
Next lig
End Sub
Sub dessin_reg()
Dim longitude() As Double, latitude() As Double
Dim i As Integer, j As Long
Dim fin As Byte, virgule As Byte, nbpoint As Integer
Dim ville As String, dept() As String, S As String, reg() As String
Dim Sepa As String
Dim tablo() As String
Dim couleur, indexcouleur As Single
Dim Colorimetre
Dim derlig As Integer, lig As Integer
Dim score As Double
Colorimetre = Array(RGB(255, 255, 255), RGB(255, 255, 175), RGB(255, 255, 90), _
RGB(255, 255, 0), RGB(255, 212, 10), RGB(255, 197, 25), _
RGB(255, 183, 16), RGB(255, 165, 50), RGB(255, 149, 40), _
RGB(255, 123, 0), RGB(255, 97, 0), RGB(255, 64, 0), _
RGB(255, 0, 0), RGB(255, 0, 128), RGB(245, 25, 255), _
RGB(220, 65, 255), RGB(204, 102, 255), RGB(191, 128, 255), _
RGB(160, 126, 255), RGB(130, 120, 255), RGB(113, 113, 255), _
RGB(96, 96, 255), RGB(64, 64, 255), RGB(0, 0, 230), _
RGB(0, 0, 128))
indexcouleur = 0
Sepa = Application.International(xlDecimalSeparator)
ReDim dept(Sheets("Data").Range("A65000").End(xlUp).Row)
For j = 2 To Sheets("Data").Range("A65000").End(xlUp).Row
ville = Sheets("Data").Cells(j, 3).Value
dept(j) = Sheets("Data").Cells(j, 4).Value
score = Sheets("Data").Cells(j, 10).Value
If dept(j) <> dept(j - 1) Then
indexcouleur = def_color(score)
End If
S = Sheets("Data").Cells(j, 7).Value & Sheets("Data").Cells(j, 8).Value
tablo = Split(S, "[")
ReDim longitude(UBound(tablo))
ReDim latitude(UBound(tablo))
nbpoint = 0
For i = 0 To UBound(tablo)
fin = InStr(1, tablo(i), "]")
If fin > 0 Then
nbpoint = nbpoint + 1
virgule = InStr(1, tablo(i), ",")
longitude(nbpoint) = (longitude0 + CDbl(Replace(Mid(tablo(i), 1, virgule - 1), ".", Sepa))) * 46.2 '710
latitude(nbpoint) = (latitude0 - CDbl(Replace(Mid(tablo(i), virgule + 1, fin - virgule - 1), ".", Sepa))) * 66 '1000
End If
Next i
With Sheets("Carte").Shapes.BuildFreeform(msoEditingAuto, longitude(1), latitude(1))
For i = 2 To nbpoint
.AddNodes msoSegmentLine, msoEditingAuto, longitude(i), latitude(i)
Next i
.AddNodes msoSegmentLine, msoEditingAuto, longitude(1), latitude(1)
.ConvertToShape.Select
Selection.Name = dept(j)
Selection.ShapeRange.Fill.ForeColor.RGB = Colorimetre(indexcouleur)
Selection.OnAction = "USF"
End With
Next j
Sheets("Carte").Range("A1").Select
End Sub
Sub dessin_pref()
Dim Colorimetre, indexcouleur As Byte, sh As Shape, shTxt As Shape
Dim derlig As Integer, lig As Integer, coef As Single
Dim longitude As Double, latitude As Double
Dim Sepa As String, tablo() As String, txt As Integer, textper As String
Colorimetre = Array(RGB(255, 255, 255), RGB(255, 255, 175), RGB(255, 255, 90), _
RGB(255, 255, 0), RGB(255, 212, 10), RGB(255, 197, 25), _
RGB(255, 183, 16), RGB(255, 165, 50), RGB(255, 149, 40), _
RGB(255, 123, 0), RGB(255, 97, 0), RGB(255, 64, 0), _
RGB(255, 0, 0), RGB(255, 0, 128), RGB(245, 25, 255), _
RGB(220, 65, 255), RGB(204, 102, 255), RGB(191, 128, 255), _
RGB(160, 126, 255), RGB(130, 120, 255), RGB(113, 113, 255), _
RGB(96, 96, 255), RGB(64, 64, 255), RGB(0, 0, 230), _
RGB(0, 0, 128))
For Each sh In Sheets("Carte").Shapes
If (Left(sh.Name, 1) = "_") Then sh.Delete
Next sh
Sepa = Application.International(xlDecimalSeparator)
derlig = Sheets("Reg").Range("A" & Rows.Count).End(xlUp).Row
For lig = 2 To derlig
txt = Sheets("Reg").Cells(lig, "D").Value
textper = Round(Sheets("Reg").Cells(lig, "D").Value, 0) & "%"
If Not txt = 0 Then
coef = Sheets("Reg").Cells(lig, "E").Value
indexcouleur = def_color(txt)
tablo = Split(Sheets("Reg").Cells(lig, 3).Value, ",")
latitude = (latitude0 - CDbl(Replace(tablo(0), ".", Sepa))) * 66 ' 1000
longitude = (longitude0 + CDbl(Replace(tablo(1), ".", Sepa))) * 46.2 ' 710
Set sh = Sheets("Carte").Shapes.AddShape(msoShapeOval, longitude - 5, latitude - 5, 10, 10)
With sh
.Name = "_" & Sheets("Reg").Cells(lig, "B").Value
.Fill.ForeColor.RGB = Colorimetre(indexcouleur)
.Line.Weight = 1
.Height = coef * 50
.Width = coef * 50
.OnAction = "USF"
End With
Set shTxt = Sheets("Carte").Shapes.AddTextbox(1, longitude - 5, latitude - 5, 40, 25)
With shTxt
.Name = "__" & Sheets("Reg").Cells(lig, "B").Value
With .TextFrame2.TextRange.Characters
.Text = textper
.Font.Size = 12
.Font.Bold = True
End With
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.OnAction = "USF"
End With
End If
Next lig
'For lig = 10 To 34
' Sheets("Carte").Cells(lig , "B").Interior.color = Colorimetre(lig - 9)
'Next lig
Sheets("Carte").Range("A1").Select
End Sub