by Mahaveer Lodha Bangalore (4 Submissions)
Category: Graphics
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 29th July 2005
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
DO YOU WANT TO GIVE NICE EFFECT TO TEXT OF LABEL OR TEXTBOX OR GRAPHICS OF YOUR FORM
VBcoders
'
' Place six command buttons on Your form
'
' Also, Place two more command buttons - give name - cmdExit, cmdClear
'
' And paste the codes the following codes into the form
' To demonstrate some text effects: Rotated Text, Shaded Text, Embossed Text,
' Engraved Text and Gradient Text.
'
Option Explicit
Private Declare Function CreateFontIndirect Lib "gdi32" Alias _
"CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Type LOGFONT
lfHeight As Long ' In logical units
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 33 ' L_FACESIZE
End Type
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
' In order for Windows NT to work
Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
Const GM_ADVANCED = 2
Private Sub Form_Load()
Me.Move 0, 0, 6300, 6700
End Sub
Private Sub cmdExit_Click()
End
End Sub
Private Sub CmdClear_Click()
Me.Cls
End Sub
Private Sub command1_click()
Dim x As Single, y As Single
' Text shaded, vertical, from bottom left
' 90 is 90 degree. &H808080 is gray. -1 is to skip this color. Use default option.
x = Me.ScaleLeft + 35
y = Me.ScaleHeight - 310
RotateText Me, "By Mahaveer Lodha", "Arial", True, False, 8, _
90, 3, vbWhite, &H808080, vbBlack, x, y
x = Me.ScaleLeft + 100
y = Me.ScaleHeight - 305
RotateText Me, "Rotated & Shaded", "Sans Serif", True, False, 14, _
45, 0, &H808080, -1, vbYellow, x, y
End Sub
Private Sub command2_click()
Dim x As Single, y As Single
' Embossed, horizontal
x = Me.ScaleLeft + 35
y = Me.ScaleTop + 160
RotateText Me, "EMBOSSED EFFECT", "Times New Roman", True, False, 18, _
0, 1, vbWhite, &H808080, vbBlack, x, y
End Sub
Private Sub command3_click()
Dim x As Single, y As Single
' Engraved, horizontal. &H808080 is gray
x = Me.ScaleLeft + 35
y = Me.ScaleTop + 215
RotateText Me, "ENGRAVED EFFECT", "Times New Roman", True, False, 18, _
0, 2, vbWhite, &H808080, vbBlack, x, y
End Sub
Private Sub command4_click()
Dim x As Single, y As Single
x = Me.ScaleLeft + 35
y = Me.ScaleTop + 270
GradientText Me, "GRADIENT TEXT R-L", "Times New Roman", True, True, _
18, 4, x, y, 1
End Sub
Private Sub command5_click()
Dim x As Single, y As Single
x = Me.ScaleLeft + 35
y = Me.ScaleTop + 325
GradientText Me, "GRADIENT TEXT L-R", "Times New Roman", True, True, _
18, 1, x, y
End Sub
Private Sub command6_click()
Dim x As Single, y As Single
x = Me.ScaleLeft + 35
y = Me.ScaleTop + 375
GradientText Me, "GRADIENT TEXT B-T", "Times New Roman", True, True, _
18, 1, x, y, 3
End Sub
' Parameters: Object, String, FontName, Bold, Italic, FontSize,
' Angle, Style(0=ordinary shade, 1=emboss text horiz,
' 2=engrave text horiz, 3=emboss text vertical, 4=engrave text vertical)
' Color1, Color2, Color3 (-1 to indicate to skip a color)
' X, Y (& optional Depth)
'
' Example: RotateText Me, "Example 1", "Arial", True, False, 8, _
' 90, 0, &H808080, -1, vbYellow, X, y
' RotateText Me, "Example 2", "Arial", True, False, 8, _
' 90, 3, vbWhite, &H808080, vbBlack, X, y
Function RotateText(inObj As Object, inText As String, inFontName As String, _
inBold As Boolean, inItalic As Boolean, inFontSize As Integer, _
inAngle As Long, inStyle As Integer, _
firstClr As Long, secondClr As Long, mainClr As Long, _
x As Single, y As Single, _
Optional inDepth As Integer = 1) As Boolean
On Error GoTo errHandler
RotateText = False
Dim L As LOGFONT
Dim mFont, mPrevFont As Long
Dim i, origMode As Integer
Dim tmpX As Single, tmpY As Single
Dim mresult
' For Windows NT to work
mresult = SetGraphicsMode(inObj.hdc, GM_ADVANCED)
origMode = inObj.ScaleMode
inObj.ScaleMode = vbPixels
If inBold = True And inItalic = True Then
L.lfFaceName = inFontName & Space(1) & "Bold" & Space(1) & "Italic" & Chr(0) ' Must be null terminated
ElseIf inBold = True And inItalic = False Then
L.lfFaceName = inFontName & Space(1) & "Bold" + Chr$(0)
ElseIf inBold = False And inItalic = True Then
L.lfFaceName = inFontName & Space(1) & "Italic" + Chr$(0)
Else
L.lfFaceName = inFontName & Chr$(0)
End If
L.lfEscapement = inAngle * 10
L.lfHeight = inFontSize * -20 / Screen.TwipsPerPixelY
mFont = CreateFontIndirect(L)
mPrevFont = SelectObject(inObj.hdc, mFont)
inObj.CurrentX = x
inObj.CurrentY = y
tmpX = x
tmpY = y
Select Case inStyle
Case 0 ' Ordinary shade
If firstClr <> -1 Then ' Minus 1 indicate N/A
inObj.ForeColor = firstClr
For i = 1 To inDepth
tmpX = tmpX + 1: tmpY = tmpY + 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If secondClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
tmpX = x
tmpY = y
inObj.ForeColor = secondClr
For i = 1 To inDepth
tmpX = tmpX - 1: tmpY = tmpY - 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If mainClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
inObj.ForeColor = mainClr
inObj.Print inText
End If
Case 1 'Embossed effect - text horizontal
If firstClr <> -1 Then
inObj.ForeColor = firstClr
For i = 1 To inDepth
tmpX = tmpX - 1: tmpY = tmpY - 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If secondClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
tmpX = x
tmpY = y
inObj.ForeColor = secondClr
For i = 1 To inDepth
tmpX = tmpX + 1: tmpY = tmpY + 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If mainClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
inObj.ForeColor = mainClr
inObj.Print inText
End If
Case 2 ' Engroved effect - text horizontal
If firstClr <> -1 Then
inObj.ForeColor = firstClr
For i = 1 To inDepth
tmpX = tmpX + 1: tmpY = tmpY + 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If secondClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
tmpX = x
tmpY = y
inObj.ForeColor = secondClr
For i = 1 To inDepth
tmpX = tmpX - 1: tmpY = tmpY - 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If mainClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
inObj.ForeColor = mainClr
inObj.Print inText
End If
Case 3 ' Embossed effect - text vertical
If firstClr <> -1 Then
inObj.ForeColor = secondClr
For i = 1 To inDepth
tmpX = tmpX + 1: tmpY = tmpY + 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If secondClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
tmpX = x
tmpY = y
inObj.ForeColor = firstClr
For i = 1 To inDepth
tmpX = tmpX - 1: tmpY = tmpY - 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If mainClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
inObj.ForeColor = mainClr
inObj.Print inText
End If
Case 4 'Engraved effect - text vertical
If firstClr <> -1 Then
inObj.ForeColor = secondClr
For i = 1 To inDepth
tmpX = tmpX - 1: tmpY = tmpY - 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If secondClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
tmpX = x
tmpY = y
inObj.ForeColor = firstClr
For i = 1 To inDepth
tmpX = tmpX + 1: tmpY = tmpY + 1
inObj.CurrentX = tmpX
inObj.CurrentY = tmpY
inObj.Print inText
Next i
End If
If mainClr <> -1 Then
inObj.CurrentX = x
inObj.CurrentY = y
inObj.ForeColor = mainClr
inObj.Print inText
End If
End Select
mresult = SelectObject(inObj.hdc, mPrevFont)
mresult = DeleteObject(mFont)
inObj.ScaleMode = origMode
RotateText = True
Exit Function
errHandler:
inObj.ScaleMode = origMode
MsgBox "RotateText"
End Function
' Parameters: Object, String, FontName, Bold, Italic, FontSize,
' SolidColor(1=red, 2=green, 3=blue, 4=black), X, Y,
' (& optional Direction 1=left to right, 2=right to left
' 3=top down, 4=bottom up)
'
' Example: GradientText Me, "Example 3", "Times New Roman", True, False, 18, _
' 3, X, y (0)
' GradientText Me, "Example 3", "Times New Roman", True, False, 18, _
' 3, X, y, 1
Sub GradientText(inObj As Object, inText As String, inFontName As String, _
inBold As Boolean, inItalic As Boolean, inFontSize As Integer, _
SolidClr As Integer, x As Single, y As Single, Optional inDirection As Integer = 0)
On Error GoTo errHandler
Dim L As LOGFONT
Dim mFont, mPrevFont As Long
Dim i, j, k, t, origMode As Integer
Dim interval, mColor, w, h, x2, y2, mresult
origMode = inObj.ScaleMode
inObj.ScaleMode = vbPixels
If inBold = True And inItalic = True Then
L.lfFaceName = inFontName & Space(1) & "Bold" & Space(1) & "Italic" & Chr(0) ' Must be null terminated
ElseIf inBold = True And inItalic = False Then
L.lfFaceName = inFontName & Space(1) & "Bold" + Chr$(0)
ElseIf inBold = False And inItalic = True Then
L.lfFaceName = inFontName & Space(1) & "Italic" + Chr$(0)
Else
L.lfFaceName = inFontName & Chr$(0)
End If
L.lfEscapement = 0
L.lfHeight = inFontSize * -20 / Screen.TwipsPerPixelY
mFont = CreateFontIndirect(L)
mPrevFont = SelectObject(inObj.hdc, mFont)
inObj.CurrentX = x
inObj.CurrentY = y
Select Case SolidClr
Case 1: mColor = vbRed
Case 2: mColor = vbGreen
Case 3: mColor = vbBlue
Case 4: mColor = vbBlack
End Select
inObj.ForeColor = mColor
inObj.Print inText
Screen.MousePointer = vbHourglass
x2 = x: y2 = y
For w = x To inObj.ScaleWidth - 1
' Assume a height which will not intrude into text of next line
For h = y To (y + 50)
If inObj.Point(w, h) = mColor Then
If w > x2 Then
x2 = w
End If
If h > y2 Then
y2 = h
End If
End If
Next h
Next w
interval = Int((x2 - x) \ 255)
If interval = 0 Then interval = 1
Select Case inDirection
Case 0 ' Left to right
For i = x To x2
k = 255 - (i - x) * interval
If k < 0 Then
k = 0
End If
For j = y To y2
If inObj.Point(i, j) = mColor Then
Select Case SolidClr
Case 1
inObj.PSet (i + t, j), RGB(k, 0, 0)
Case 2
inObj.PSet (i + t, j), RGB(0, k, 0)
Case 3
inObj.PSet (i + t, j), RGB(0, 0, k)
Case 4
inObj.PSet (i + t, j), RGB(255 - k, 255 - k, 255 - k)
End Select
End If
Next j
Next i
Case 1 ' Right to left
For i = x2 To x Step -1
k = (i - x) * interval
If k > 255 Then
k = 255
End If
For j = y To y2 + 10
If inObj.Point(i, j) = mColor Then
Select Case SolidClr
Case 1
inObj.PSet (i + t, j), RGB(k, 0, 0)
Case 2
inObj.PSet (i + t, j), RGB(0, k, 0)
Case 3
inObj.PSet (i + t, j), RGB(0, 0, k)
Case 4
inObj.PSet (i + t, j), RGB(255 - k, 255 - k, 255 - k)
End Select
End If
Next j
Next i
Case 2 ' Top down
For i = y To y2
k = 255 - ((i - y) * 8) ' 8 is arbitrarily set,.e.g. can be 6 or 10
If k < 0 Then
k = 0
End If
For j = x To x2
If inObj.Point(j, i) = mColor Then
Select Case SolidClr
Case 1
inObj.PSet (j, i + t), RGB(k, 0, 0)
Case 2
inObj.PSet (j, i + t), RGB(0, k, 0)
Case 3
inObj.PSet (j, i + t), RGB(0, 0, k)
Case 4
inObj.PSet (j, i + t), RGB(255 - k, 255 - k, 255 - k)
End Select
End If
Next j
Next i
Case 3 ' Bottom up
For i = y2 To y Step -1
k = (i - y) * 10
If k > 255 Then
k = 255
End If
For j = x To x2
If inObj.Point(j, i) = mColor Then
Select Case SolidClr
Case 1
inObj.PSet (j, i + t), RGB(k, 0, 0)
Case 2
inObj.PSet (j, i + t), RGB(0, k, 0)
Case 3
inObj.PSet (j, i + t), RGB(0, 0, k)
Case 4
inObj.PSet (j, i + t), RGB(255 - k, 255 - k, 255 - k)
End Select
End If
Next j
Next i
End Select
mresult = SelectObject(inObj.hdc, mPrevFont)
mresult = DeleteObject(mFont)
inObj.ScaleMode = origMode
Screen.MousePointer = vbDefault
Exit Sub
errHandler:
inObj.ScaleMode = origMode
Screen.MousePointer = vbDefault
MsgBox "GradientText"
End Sub
No comments have been posted about DO YOU WANT TO GIVE NICE EFFECT TO TEXT OF LABEL OR TEXTBOX OR GRAPHICS OF YOUR FORM. Why not be the first to post a comment about DO YOU WANT TO GIVE NICE EFFECT TO TEXT OF LABEL OR TEXTBOX OR GRAPHICS OF YOUR FORM.