Excelabo.net

Embossage de cellules

J'aimerais donner un effet d'embossage à un groupe de cellules...

Sub Embossage()
Dim NBL As Integer, NBC As Integer, PL As Integer, PC As Integer
Dim couleur1 As Double, couleur2 As Double, RELIEF As String
RELIEF = UCase(Trim(InputBox("pour Relief tapez R" _
& Chr(10) & "pour Creux Tapez C" _
& Chr(10) & "pour effacer tapez 0" _
& Chr(10) & "second caractère possible :" _
& Chr(10) & "G pour Gold" _
& Chr(10) & "1 2 3 4 ou V", _
"Geedee Embossage", "Relief")))
Select Case Left(RELIEF, 1)
Case "C"
couleur1 = RGB(64, 64, 64): couleur2 = RGB(255, 255, 255)
Case "R"
couleur1 = RGB(255, 255, 255): couleur2 = RGB(64, 64, 64)
Case Else
Selection.Interior.ColorIndex = xlNone
Selection.Borders.LineStyle = xlNone
Exit Sub
End Select
If Mid(RELIEF, 2, 1) = "G" Then
Selection.Interior.ColorIndex = 6
Selection.Interior.PatternColorIndex = 22
Selection.Interior.Pattern = xlGray25
Else
Selection.Interior.ColorIndex = 15
End If
Selection.Borders.LineStyle = xlNone
'-----------------------------------
NBL = Selection.Rows.Count
NBC = Selection.Columns.Count
PL = Selection.Row
PC = Selection.Column
Set AngleHG = Cells(PL, PC)
Set ANGleHD = Cells(PL, PC + NBC - 1)
Set AngleBG = Cells(PL + NBL - 1, PC)
Set AngleBD = Cells(PL + NBL - 1, PC + NBC - 1)

'----------Bordure Haut
Range(AngleHG, ANGleHD).Select
Selection.Borders(xlTop).Weight = xlThick
Selection.Borders(xlTop).Color = couleur1
'----------Bordure Gauche
Range(AngleHG, AngleBG).Select
Selection.Borders(xlLeft).Weight = xlThick
Selection.Borders(xlLeft).Color = couleur1
'----------Bordure Bas
Range(AngleBG, AngleBD).Select
Selection.Borders(xlBottom).Weight = xlThick
Selection.Borders(xlBottom).Color = couleur2
'----------Bordure Droite
Range(ANGleHD, AngleBD).Select
Selection.Borders(xlRight).Weight = xlThick
Selection.Borders(xlRight).Color = couleur2
'----------------------
With Union(AngleHG, ANGleHD, AngleBG, AngleBD)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Wingdings"
.Font.Size = 16
Select Case Mid(RELIEF, 2, 1)
Case Is = "1"
.Value = "m"
Case Is = "2"
.Value = "l"
Case Is = "3"
.Value = Chr(123)
Case Is = "4"
.Value = "£"
Case Is = "V"
.Font.Name = "Webdings"
.Value = "x"
Case Is = "G"
Case Else
.Value = ""
End Select
End With
End Sub

L'effet produit par cette macro est visible dans le classeur préparé par Modeste
GeeDee pour l' href="http://disciplus.simplex.free.fr/classeursxl/gd-anivdisciplus.zip">anniversaire du
disciplus.

GeeDee, (N°183)

Des cellules carrées

Je voudrais que mes cellules soient exactement carrées. Comment faire ?

Sub FaireCarreEnmm()
Dim WPChar As Double
Dim DInch As Double
Dim Temp As String

Temp = InputBox("Hauteur,largeur en mm?")
DInch = Val(Temp) / 25.4
If DInch > 0 And DInch < 2.5 Then
i = 0
For Each col In ActiveWindow.RangeSelection.Columns
i = i + 1
If i = 1 Then
col.EntireColumn.AutoFit
WPChar = col.Width / col.ColumnWidth
End If
col.ColumnWidth = ((DInch * 72) / WPChar)
Next col
For Each lig In ActiveWindow.RangeSelection.Rows
lig.RowHeight = (DInch * 72)
Next lig
End If
End Sub

le résultat de cette macro de GeeDee est visualisable dans le classeur qu'il a
préparé pour
l'anniversaire du Disciplus
simplex !

GeeDee, (N°182)

Arrondir les angles d'une cellule

Comment donner une apparence arrondie à une cellules?

Sub CelluleArrondie()
Set depart = ActiveCell
r1 = depart.Height
r2 =
depart.Width
r3 = depart.Top
r4 = depart.Left

ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, _
r4, r3, r2, r1).Select
Selection.ShapeRange.Fill.Visible = msoFalse
depart.Select

End Sub

Serge Garneau, (N°181)