No declarations

' By Mahaveer Lodha - marumaha@yahoo.com ' ' 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