Option Explicit Public Sub MAILLAGE_RECTANGULAIRE() Dim XD As Long, XF As Long, PX As Double, NBX As Long Dim YD As Long, YF As Long, PY As Double, NBY As Long Dim CX As Double, CY As Double Dim i As Long, j As Long, q As Double, n As Double On Error GoTo 0 'Enlève le gestionnaire d'erreur s'il était mis en place Application.ScreenUpdating = False 'Désactive l'affichage Application.DisplayAlerts = False 'Désactive les alertes For i = Sheets.Count To 1 Step -1 'On rend visible toutes les feuilles temporairement Sheets(i).Visible = 1 Next On Error Resume Next Sheets.Add.Name = "MAILLAGE" 'Créé toujours un onglet de départ On Error GoTo 0 Sheets("MAILLAGE").Cells.Clear Sheets("MAILLAGE").Tab.Color = RGB(0, 176, 240) 'Met l'onglet en Bleu For i = Sheets.Count To 1 Step -1 'On supprime tous les onglets sauf un If Sheets(i).Name <> "MAILLAGE" And Sheets.Count <> 1 Then Sheets(i).Delete End If Next XD = 0 XF = 260 PX = 2 NBX = ((XF - XD) / PX) + 1 YD = 0 YF = 260 PY = 2 NBY = ((YF - YD) / PY) + 1 CX = (XF - XD) / 2 CY = (YF - YD) / 2 Range("B2") = "MAILLAGE DE LA SURFACE" Range("B3") = "Paramètres" Range("B4") = "Largeur initiale" Range("B5") = "Largeur finale" Range("B6") = "Pas en largeur" Range("B7") = "Nombre de points par ligne" Range("B8") = "Nombre de points maximal par fenêtre" Range("B9") = "COORDONNÉES" Range("B10") = "Coordonnées des points en X" Range("C3") = "Unités" Range("C4") = "Pixel" Range("C5") = "Pixel" Range("C6") = "Pixel" Range("D3") = "Application" Range("D4") = XD Range("D5") = XF Range("D6") = PX Range("D7") = NBX Range("D8") = 32000 Range("E3") = "Paramètres" Range("E4") = "Hauteur initiale" Range("E5") = "Hauteur finale" Range("E6") = "Pas en hauteur" Range("E7") = "Nombre de points en colonne" Range("E8") = "Nombre de points dans cette fenêtre" Range("E10") = "Coordonnées des points en Y" Range("F3") = "Unités" Range("F4") = "Pixel" Range("F5") = "Pixel" Range("F6") = "Pixel" Range("G3") = "Application" Range("G4") = YD Range("G5") = YF Range("G6") = PY Range("G7") = NBY Range("G8") = Range("D7") * Range("G7") Range("B11") = XD 'Axe des X For i = 11 To Range("G8") Step NBY For j = i To (i + NBY) + (NBY - 2) Range("B" & i + NBY) = Range("B" & i) + PX Range("B" & j + 1) = Range("B" & j) Next Next For i = 11 To Range("G8") + NBX Step NBY 'Axe des y Range("E" & i) = YD For j = i To i + NBY - 2 Range("E" & j + 1) = Range("E" & j) + PY Next Next q = Sheets("MAILLAGE").UsedRange.Rows.Count 'Compte le nombre de lignes dynamiques For i = q + 1 To 11 Step -1 'Suppression des rayons trop grands If ((Range("B" & i) - CX) ^ 2 + (Range("E" & i) - CY) ^ 2) ^ (1 / 2) > CX Then Cells(i, 1).EntireRow.Delete End If Next n = Sheets("MAILLAGE").UsedRange.Rows.Count 'Compte le nombre de lignes dynamiques Call MISE_EN_FORME(Range("B2:G" & n + 1), Range("B2:G2,B9:G9,B10:D10,E10:G10"), Range("B2,B3,B9,B10,E10,C3,D3,E3,F3,G3"), Range("B2,B3,B9,B10,E10,C3,D3,E3,F3,G3"), Range("B2,B9"), Range("C7:C8,F7:F8"), Range("D4:D6,G4:G6")) For i = 11 To n + 1 Range("B" & i & ":D" & i).MergeCells = True Range("E" & i & ":G" & i).MergeCells = True Next Range("A1:A1").Select 'GRAPHIQUE NUMERO 1 ActiveSheet.Shapes.AddChart.Select 'Créer un graph batard pour le supprimer ensuite ActiveChart.SetSourceData Source:=Range("A1:B1") 'Ne rien changer ActiveSheet.ChartObjects(1).Left = Range("A1").Left 'Positionnement de l'accroche ActiveSheet.ChartObjects(1).Top = Range("A1").Top 'Positionnement de l'accroche ActiveSheet.ChartObjects(1).Width = Range("A1:B2").Width 'Dimensionnement de la largeur ActiveSheet.ChartObjects(1).Height = Range("A1:B2").Height 'Dimensionnement de la hauteur ActiveChart.ChartType = xlXYScatter 'Type de Graph ActiveChart.SeriesCollection(1).Delete 'Supprime la série inutile ActiveChart.ChartArea.Format.ThreeD.Visible = msoTrue 'Permet l'affichage du biseau ActiveChart.ChartArea.Format.ThreeD.BevelTopType = msoBevelCircle 'Sélectionne le type de biseau ActiveChart.ChartArea.Format.ThreeD.BevelTopDepth = 12 'Réglage du biseau ActiveChart.ChartArea.Format.ThreeD.BevelTopInset = 29 'Réglage du biseau ActiveChart.SeriesCollection.NewSeries 'Créer une nouvelle série correcte ActiveChart.SeriesCollection(1).Name = "=""Y VS X""" 'Nom de la série ActiveChart.SeriesCollection(1).XValues = Range("B11:B" & n) 'Valeurs en abscisse ActiveChart.SeriesCollection(1).Values = Range("E11:E" & n) 'Valeurs en ordonnée ActiveChart.SeriesCollection(1).MarkerStyle = -4168 'Permet de mettre le point de coordonnée en forme de croix ActiveChart.SeriesCollection(1).MarkerSize = 6 'Taille des points de coordonnées ActiveChart.ChartTitle.Text = "COORODONNÉES Y EN FONCTION DE X" 'Nom du Graphique ActiveChart.ApplyLayout (1) 'Créer la légende pour X, pour Y et un titre de graph ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "X (Pixels)" 'Nom de l'axe X ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "Y (Pixels)" 'Nom de l'axe Y ActiveChart.SetElement (msoElementPrimaryValueGridLinesMinorMajor) 'Quadriallage horizontal primaire et secondaire ActiveChart.SetElement (msoElementPrimaryCategoryGridLinesMinorMajor) 'Quadriallage vertical primaire et secondaire ActiveChart.Axes(xlCategory).MaximumScaleIsAuto = True 'Abscisse Maximum ActiveChart.Axes(xlCategory).MajorUnitIsAuto = True 'Unité principale des abcsisses ActiveChart.Axes(xlCategory).MinorUnitIsAuto = True 'Unité secondaire des abscisses ActiveChart.Axes(xlValue).MaximumScaleIsAuto = True 'Ordonnée Maximum ActiveChart.Axes(xlValue).MajorUnitIsAuto = True 'Unité principale des ordonnées ActiveChart.Axes(xlValue).MinorUnitIsAuto = True 'Unité secondaire des ordonnées ActiveChart.Axes(xlCategory).ScaleType = xlLinear 'Mettre l'échelle des abcisses en Linéaire (Ou logarytmique) ActiveChart.Axes(xlValue).ScaleType = xlLinear 'Mettre l'échelle des ordonées en Linéaire ActiveChart.Axes(xlCategory).MajorTickMark = xlOutside 'Graduation principale à l'extérieur ActiveChart.Axes(xlCategory).MinorTickMark = xlCross 'Graduation secondaire sur l'axe ActiveChart.Axes(xlValue).MajorTickMark = xlOutside 'Graduation principale à l'extérieur ActiveChart.Axes(xlValue).MinorTickMark = xlCross 'Graduation secondaire sur l'axe ActiveChart.Axes(xlCategory).TickLabelPosition = xlLow 'Forcer l'axe X en bas ActiveChart.Axes(xlValue).TickLabelPosition = xlLow 'Forcer l'axe Y à gauche ActiveChart.ChartType = xlXYScatter 'Type de Graph ActiveChart.ChartArea.Font.Name = "Cambria" 'Mettre tout le graph en cambria ActiveChart.ChartArea.Font.Size = 12 'Mettre tout le graph en taille 12 ActiveChart.ChartArea.Font.Bold = True 'Mettre tout le graph en gras ActiveChart.ChartTitle.Font.Size = 14.5 'Mettre le titre du graph en taille 14.5 ActiveChart.Legend.Font.Size = 10 'Mettre la légende du graph en taille 10 ActiveChart.Legend.Position = xlRight 'Réglage de la légende ActiveChart.Axes(xlCategory).TickLabels.NumberFormat = "0" 'Détermine le nombre de décimales de l'axe X ActiveChart.Axes(xlValue).TickLabels.NumberFormat = "0" 'Détermine le nombre de décimales de l'axe Y ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="GRAPH (1)" 'Permet de déplacer le Graph dans une nouvelle feuille Sheets("GRAPH (1)").Tab.Color = RGB(0, 176, 80) 'Met l'onglet en vert Sheets("GRAPH (1)").Move After:=Sheets("MAILLAGE") 'Permet de déplacer de manière relative des onglets (After/Before) Application.ScreenUpdating = True 'Rétablit l'affichage Application.DisplayAlerts = True 'Rétablit les alertes On Error GoTo 0 'Enlève le gestionnaire d'erreur s'il était mis en place End Sub Private Sub MISE_EN_FORME(Optional Tableau As Variant, Optional Fusion As Variant, Optional Bordure As Variant, Optional Gras As Variant, Optional Violet As Variant, Optional Gris As Variant, Optional Vert As Variant, Optional Orange As Variant) Dim colonne As Long '---------------- Cells.Select With Selection.Font .Name = "Cambria" .Size = 12 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 .ThemeFont = xlThemeFontMajor End With With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext End With '----------------- '----------------- If IsMissing(Tableau) Then GoTo Tableau End If Tableau.Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With Tableau: '------------- '------------- If IsMissing(Fusion) Then GoTo Fusion End If Fusion.Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With Fusion: '------------ '------------ If IsMissing(Bordure) Then GoTo Bordure End If Bordure.Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone Bordure: '------------ '----------- If IsMissing(Gras) Then GoTo Gras End If Gras.Font.Bold = True Gras: '---------- '---------- If IsMissing(Violet) Then GoTo Violet End If Violet.Select With Selection.Interior .Pattern = xlPatternRectangularGradient .Gradient.RectangleLeft = 0.5 .Gradient.RectangleRight = 0.5 .Gradient.RectangleTop = 0.5 .Gradient.RectangleBottom = 0.5 .Gradient.ColorStops.Clear End With With Selection.Interior.Gradient.ColorStops.Add(0) .Color = RGB(204, 0, 255) End With With Selection.Interior.Gradient.ColorStops.Add(1) .Color = RGB(204, 192, 218) End With Violet: '--------- '---------- If IsMissing(Gris) Then GoTo Gris End If Gris.Select With Selection.Interior .Pattern = xlPatternRectangularGradient .Gradient.RectangleLeft = 0.5 .Gradient.RectangleRight = 0.5 .Gradient.RectangleTop = 0.5 .Gradient.RectangleBottom = 0.5 .Gradient.ColorStops.Clear End With With Selection.Interior.Gradient.ColorStops.Add(0) .Color = RGB(165, 165, 165) End With With Selection.Interior.Gradient.ColorStops.Add(1) .Color = RGB(216, 216, 216) End With Gris: '--------- '---------- If IsMissing(Vert) Then GoTo Vert End If Vert.Select With Selection.Interior .Pattern = xlPatternRectangularGradient .Gradient.RectangleLeft = 0.5 .Gradient.RectangleRight = 0.5 .Gradient.RectangleTop = 0.5 .Gradient.RectangleBottom = 0.5 .Gradient.ColorStops.Clear End With With Selection.Interior.Gradient.ColorStops.Add(0) .Color = RGB(0, 176, 80) End With With Selection.Interior.Gradient.ColorStops.Add(1) .Color = RGB(146, 208, 80) End With Vert: '--------- '---------- If IsMissing(Orange) Then GoTo Orange End If Orange.Select With Selection.Interior .Pattern = xlPatternRectangularGradient .Gradient.RectangleLeft = 0.5 .Gradient.RectangleRight = 0.5 .Gradient.RectangleTop = 0.5 .Gradient.RectangleBottom = 0.5 .Gradient.ColorStops.Clear End With With Selection.Interior.Gradient.ColorStops.Add(0) .Color = RGB(255, 192, 0) End With With Selection.Interior.Gradient.ColorStops.Add(1) .Color = RGB(252, 213, 180) End With Orange: '--------- '--------- Rows("1:1").Select 'Réglage de la hauteur Range(Selection, Selection.End(xlDown)).RowHeight = 16 colonne = Cells.Find("*", , , , xlByColumns, xlPrevious).Column 'Compte le nombre de colonnes dynamiques Range("A:A," & Nombre_en_Lettre(colonne + 1) & ":" & Nombre_en_Lettre(colonne + 1)).ColumnWidth = 2 'Réglage de la largeur Columns("A:" & Nombre_en_Lettre(colonne)).EntireColumn.AutoFit 'Ajuste la largeur au contenu Range("A1:" & Nombre_en_Lettre(colonne + 1) & "1").Select 'Pour régler le zoom de la page pour que sa rentre complètement ActiveWindow.Zoom = True Range("A1:A1").Select 'Pour se replacer de manière propre sur la feuille '------------- End Sub Function Nombre_en_Lettre(Nombre As Long) As String If Nombre > 0 And Nombre < 257 Then Nombre_en_Lettre = Split(Cells(Nombre).Address, "$")(1) Else Nombre_en_Lettre = Error(9) End If End Function
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionEst il possible de charger une image sur Excel ?
Une fois l'image chargée et affichée, est il possible de placer des points sur l'image en fonction des coordonnées de pixels