FormShape

Option Explicit

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

'API calls


Private Declare Function BeginPath Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" (ByVal hdc As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long

Private Declare Function EndPath Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function PathToRegion Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function GetRgnBox Lib "gdi32" _
(ByVal hRgn As Long, lpRect As RECT) As Long

Private Declare Function CreateRectRgnIndirect Lib "gdi32" _
(lpRect As RECT) As Long

Private Declare Function CombineRgn Lib "gdi32" _
(ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, _
ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) _
As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" _
(ByVal hWnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long

Private Declare Function ReleaseCapture Lib "user32" () _
As Long

Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Const RGN_AND = 1

Dim Color1 As Long
Dim Color2 As Long


Private Function GetTextRgn(Font As String, Size As Integer, _
Text As String) As Long
Me.Font = Font
Me.FontSize = Size
Dim hRgn1 As Long, hRgn2 As Long
Dim rct As RECT
BeginPath hdc
TextOut hdc, 10, 10, Text, Len(Text)
EndPath hdc
hRgn1 = PathToRegion(hdc)
GetRgnBox hRgn1, rct
hRgn2 = CreateRectRgnIndirect(rct)
CombineRgn hRgn2, hRgn2, hRgn1, RGN_AND
DeleteObject hRgn1
GetTextRgn = hRgn2
End Function

Private Sub GradateColors(Colors() As Long, _
ByVal Color1 As Long, ByVal Color2 As Long)
On Error Resume Next
Dim i As Integer
Dim dblR As Double, dblG As Double, dblB As Double
Dim addR As Double, addG As Double, addB As Double
Dim bckR As Double, bckG As Double, bckB As Double
dblR = CDbl(Color1 And &HFF)
dblG = CDbl(Color1 And &HFF00&) / 255
dblB = CDbl(Color1 And &HFF0000) / &HFF00&
bckR = CDbl(Color2 And &HFF&)
bckG = CDbl(Color2 And &HFF00&) / 255
bckB = CDbl(Color2 And &HFF0000) / &HFF00&
addR = (bckR - dblR) / UBound(Colors)
addG = (bckG - dblG) / UBound(Colors)
addB = (bckB - dblB) / UBound(Colors)

For i = 0 To UBound(Colors)
dblR = dblR + addR
dblG = dblG + addG
dblB = dblB + addB
If dblR > 255 Then dblR = 255
If dblG > 255 Then dblG = 255
If dblB > 255 Then dblB = 255
If dblR < 0 Then dblR = 0
If dblG < 0 Then dblG = 0
If dblG < 0 Then dblB = 0
Colors(i) = RGB(dblR, dblG, dblB)
Next
End Sub

Private Sub Form_MouseDown(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
'Questo e' per spostare il form che non ta titleBar

ReleaseCapture
SendMessage hWnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&
End Sub

Private Sub Form_Paint()
Dim Colors() As Long
Dim Iter As Long
Const Banding = 8
ReDim Colors(ScaleHeight \ Banding) As Long
GradateColors Colors(), Color1, Color2
For Iter = 0 To ScaleHeight Step Banding
Line (0, Iter)-(ScaleWidth, Iter + Banding), _
Colors(Iter \ Banding), BF
Next
End Sub

Private Sub Form_Load()
Dim hRgn As Long
'hRgn = GetTextRgn("Wingdings", 100, "M" & "<")

hRgn = GetTextRgn("Courier New", 100, "Mark")
'cambiare il valore: Font, Size (font), Text

SetWindowRgn hWnd, hRgn, 1
Color1 = vbBlack
'setta i colori per l'effetto gradient

Color2 = vbBlue
Me.Refresh
End Sub


Form Shae con effetti gradient
In questo esempio potrete visualizzare un testo gradient
di qualsiasi dimensione e colore, tramite una comoda
funzione a cui passare Font,dimensioni e Testo