Quella di oggi serve per visualizzare una shape, più spesso una casella di testo, per un tempo determinato con un effetto dissolvenza in entrata e in uscita, un po' come quello della nova mail in arrivo di outlook.
Per il funzionamento di questa procedura servono alcune funzioni:
- Dichiarare la funzione sleep del kernel, che permetet di definire delle pause in millisecondi senza sprecare cpu.
- Procedura FadeInOut, che applica l'efeftto dissolvenza, i parametri sono:
Oggetto shape al quale applicare l'effetto,
valore Tree/False per indicare rispettivamente FadeIn o FadeOut,
durata dell'effetto in msec. - Funzione rgbLum che applica una luminosità in % ad un colore, i parametri sono:
R,G,B (colore di base), L luminosità compresa tra 0 e 100 - Procedura splitRGB traduce nei 3 componenti rgb un colore, i parametri sono:
l_RGBcolor: colore da trasformare,
r,g,b: valori in output che conterrano le 3 componenti del colore.
I parametri della procedura principale TimeredShape sono:
Oggetto shape da mostrare;
Tempo di visualizzazione in msec (default 5)
Tempo dell'effetto dissolvenza
[english]
Today I begin the publication of some VBA procedure that I currently use.
TimeredShape is useful for displaying a shape with fadein effect, after waiting for a time in milliseconds hide that with fadeout effect.
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub FadeInOut(s As Shape, _
Optional bFadeIN As Boolean = True, _
Optional lDelayMS As Long = 1000)
Dim i As Integer
Dim iBegin As Integer, iEnd As Integer, iStep As Integer
Dim lDelay As Long
Dim l_Trsp As Long ' Final Ttransparency / Trasparenza definitiva
Dim l_ForeColor As Long ' Border final color / Colore definitivo bordo
Dim bTrasp As Boolean ' Trasparenzy are applicable ? / Trasperenza applicabile ?
Const kScala As Integer = 100
lDelay = CLng(lDelayMS / kScala) ' Calculate step delay /Calcola il ritardo per ogni step
Dim r As Integer, g As Integer, b As Integer
l_ForeColor = s.Line.ForeColor ' Store line color / Determino il colore dell'oggetto
splitRGB l_ForeColor, r, g, b ' Retrieve r,g,b components / Scompongo i valori RGB
If s.AutoShapeType <> msoShapeMixed Then ' Aplly only for fillable shape / Applico solo x shape con proprietà Fill
l_Trsp = s.Fill.Transparency * kScala ' Store transparency value / Valore Trasparenza dell'oggetto
bTrasp = True
Else
l_Trsp = 0
bTrasp = False
End If
If bFadeIN Then ' Define Fade paramters / Definisce i parametri per Fade In e Fade Out
iBegin = kScala
iEnd = 0
iStep = -1
Else
iBegin = 0
iEnd = kScala
iStep = 1
End If
lDelay = lDelay * Abs(iStep) '
s.Line.ForeColor.RGB = rgbLum(r, g, b, iBegin) ' Initialize colour / Inizializzo il colore
If bTrasp Then
s.Fill.Transparency = (l_Trsp + (100 - l_Trsp) * iBegin / kScala) / kScala
End If
s.Visible = True ' Show shape / Mostra l'oggetto
For i = iBegin To iEnd Step iStep ' Fade effect / Effetto dissolvenza
s.Line.ForeColor.RGB = rgbLum(r, g, b, i) ' Apply color to border line / Applico il colore alla linea del brodo
If bTrasp Then ' Apply transparency / Applico la trasparenza se esiste fill
s.Fill.Transparency = (l_Trsp + (100 - l_Trsp) * i / kScala) / kScala
End If
DoEvents
Sleep lDelay
Next i
s.Visible = bFadeIN ' Show/Hide shape / Mostra/Nasconde oggetto
If bFadeIN = False Then
s.Line.ForeColor.RGB = l_ForeColor ' Reapply original colour / Riapplico il colore originale
If bTrasp Then '
s.Fill.Transparency = l_Trsp / kScala ' Reapply original transparency / Riapplico la trasparenza iniziale
End If
End If
End Sub
'
' Return color with luminance in % 100=White
' Restituisce il colore corrispondente con una luminosità in % 100%=bianco
'
Function rgbLum(r As Integer, g As Integer, b As Integer, l As Integer) As Long
' Red, Green, Blue, Luminance%
rgbLum = RGB(r + (255 - r) * l / 100, g + (255 - g) * l / 100, b + (255 - b) * l / 100)
End Function
'
' Retrieve RGC colour component from RGB colour
' Scompone un colore RGB nei 3 componenti
'
Sub splitRGB(lRGBcolor As Long, r As Integer, g As Integer, b As Integer)
Dim s As String
s = Right$("000000" & Hex$(lRGBcolor), 6)
r = Val("&h" & Mid$(s, 1, 2))
g = Val("&h" & Mid$(s, 3, 2))
b = Val("&h" & Mid$(s, 5, 2))
End Sub
' ' Display a shape for a time in msec whith fade effect
' Mostra una shape per i millisecondi indicati + il doppio del tempo di dissolvenza indicato
'
Sub TimeredShape(s As Shape, Optional l_DisplayTimeMS As Long = 5000, Optional l_FadeTime As Long = 2000)
FadeIn s, True, l_FadeTime
Sleep l_DisplayTimeMS
FadeInOut s, False, l_FadeTime
End Sub
