Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim s As Shape
Dim lwidth As Integer
Dim lcolor As Long
Dim ltrans As Single
Dim rl(4) As Single, rt(4) As Single, rw(4) As Single, rh(4) As Single
lwidth = 2
lcolor = rgb(255, 0, 0)
ltrans = 0.8
For Each s In ActiveSheet.Shapes
If Left(s.Name, Len("selection-rect")) = "selection-rect" Then s.Delete
Next
rl(1) = 1
rt(1) = ActiveCell.Top
rw(1) = (Cells(ActiveCell.Row, Columns.Count).Left + Cells(ActiveCell.Row, Columns.Count).width) - 2
rh(1) = lwidth
rl(2) = rl(1)
rt(2) = rt(1) + ActiveCell.Height - lwidth
rw(2) = rw(1)
rh(2) = rh(1)
rl(3) = ActiveCell.Left
rt(3) = ActiveCell.Top - 2000: If rt(3) < 1 Then rt(3) = 1
rw(3) = lwidth
rh(3) = 4000: If (rt(3) + rh(3)) >= (Cells(Rows.Count, ActiveCell.Column).Top + Cells(Rows.Count, ActiveCell.Column).Height) Then rh(3) = Cells(Rows.Count, ActiveCell.Column).Top + Cells(Rows.Count, ActiveCell.Column).Height - rt(3) - 1
rl(4) = rl(3) + ActiveCell.width - lwidth
rt(4) = rt(3)
rw(4) = rw(3)
rh(4) = rh(3)
For i = 1 To 4
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, rl(i), rt(i), rw(i), rh(i))
.Fill.ForeColor.rgb = lcolor
.Fill.Transparency = ltrans
.Line.Visible = False
.Name = "selection-rect" + Trim$(Str$(i))
End With
Next
End Sub
|
