' TextEffect.frm
'
' By Herman Liu
'
' 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 Herman Liu", "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 As Long
    Dim mPrevFont As Long
    Dim i As Integer
    Dim 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 As Long
    Dim mPrevFont As Long
    Dim i As Integer, j As Integer, k As Integer, t As Integer
    Dim origMode As Integer
    Dim interval
    Dim mColor
    Dim w, h, x2, y2
    Dim 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
    End If
    
    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