module1.bas

vb源码大全

Attribute VB_Name = "Module1"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Program: Gradient text                                                                   '
' Author : Osama Abdel-Karim                                                               '
' e-mail : [e-mail]                                                            '
' My vb site  : www.homestead.com/programming_links/vb.html                                '
' Discription : A program for drawing horizontal,                                          '
'               rectangular or spherical gradient texts.                                   '
' To use the code in your app, follow these steps                                          '
'       1) create a label named txtlen with 3dappearnce property set to true,visible=false '
'       2) create a picturebox named pictmp with visible=false,autoredraw=true             '
'       2) place the module in your app.                                                   '
'       3) simply call drawtxt function.                                                   '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'You will have to change PicTmp font if u want to change the font
'Change Picresult background as you wish.
Public Enum RGBColor
    gcRed = 1
    gcblue = 2
    gcgreen = 3
End Enum

Public Sub DrawTxt(blAutoSize As Boolean, strTxt As String, FirstColor As Long, LastColor As Long, intGradType As Integer)
Dim PicMask, PicReverseMask, PicReverseForeground, PicForeground As Picture
With Form1
    'Clear result picture
    .picResult.Cls
    .PicTmp.Cls
    .PicTmp.Picture = LoadPicture("")
    .PicTmp.BackColor = vbWhite
    .PicTmp.Picture = .PicTmp.Image
    
    'Change label's font
    .txtLen.FontBold = .PicTmp.FontBold
    .txtLen.FontItalic = .PicTmp.FontItalic
    .txtLen.FontSize = .PicTmp.FontSize
    .txtLen.FontUnderline = .PicTmp.FontUnderline
    .txtLen.FontName = .PicTmp.FontName
    
    'Small trick for getting text width for pictures boxes
    .txtLen.Caption = strTxt
    .PicTmp.Width = .txtLen.Width
    .PicTmp.Height = .txtLen.Height
    .PicTmp.Picture = .PicTmp.Image
    If blAutoSize Then
        .picResult.Width = .txtLen.Width
        .picResult.Height = .txtLen.Height
        .picResult.Picture = .picResult.Image
    End If
    
    'Print text
    .PicTmp.Print strTxt
    Set PicMask = .PicTmp.Image
    
    'Draw gradient
    .PicTmp.Cls
    GradientPlus .PicTmp, FirstColor, LastColor, intGradType
    Set PicForeground = .PicTmp.Image
    
    ' Copy the mask onto the result picture
    .picResult.PaintPicture PicMask, _
        0, 0, , , , , , , vbMergePaint
    
    ' Make a reversed mask.
    .PicTmp.Cls
    .PicTmp.PaintPicture PicMask, _
        0, 0, , , , , , , vbNotSrcCopy
    Set PicReverseMask = .PicTmp.Image

    ' Copy the reversed mask onto the foreground
    .PicTmp.Cls
    .PicTmp.Picture = PicForeground
    .PicTmp.PaintPicture PicReverseMask, 0, 0, , , , , , , vbMergePaint
    .PicTmp.Picture = .PicTmp.Image
    
    .picResult.PaintPicture .PicTmp.Picture, 0, 0, , , , , , , vbSrcAnd

End With
End Sub

Sub GradientPlus(frm As PictureBox, FirstColor As Long, LastColor As Long, intGradType As Integer)
 
    On Error Resume Next
    Dim X As Integer
    Dim RedChange As Integer
    Dim GreenChange As Integer
    Dim BlueChange As Integer
    Dim chngColor As Long
    
    'Get colors values
    StartRed = GetRGBColor(FirstColor, gcRed)
    StartGreen = GetRGBColor(FirstColor, gcgreen)
    StartBlue = GetRGBColor(FirstColor, gcblue)
    EndRed = GetRGBColor(LastColor, gcRed)
    EndGreen = GetRGBColor(LastColor, gcgreen)
    EndBlue = GetRGBColor(LastColor, gcblue)

    frm.DrawStyle = 6 ' Inside Solid
    frm.ScaleMode = 3 ' Pixels
    frm.DrawMode = 13 ' Copy Pen
    frm.DrawWidth = 2
    Select Case intGradType
        Case 1
            frm.ScaleWidth = 256
        Case 2
            frm.ScaleHeight = 256
            frm.ScaleWidth = 256
        Case 3
            frm.ScaleHeight = 256 * 2
            frm.ScaleWidth = 256 * 2
    End Select
    For X = 0 To 255  'Start Loop
        chngColor = RGB(StartRed + RedChange, StartGreen + GreenChange, StartBlue + BlueChange)
        Select Case intGradType
            Case 1
                frm.Line (X, 0)-(X - 1, frm.ScaleHeight), chngColor, B 'Draws Line With correct color
            Case 2
                frm.Line (X, X)-(frm.ScaleWidth - X, frm.ScaleHeight - X), chngColor, B 'Draws Line With correct color
            Case 3
                frm.Circle (frm.ScaleWidth \ 2, frm.ScaleHeight \ 2), X + 2, chngColor
        End Select
        
        RedChange = RedChange + (EndRed - StartRed) / 255 '
        GreenChange = GreenChange + (EndGreen - StartGreen) / 255 ' Sets Next Loops Color
        BlueChange = BlueChange + (EndBlue - StartBlue) / 255 '
    Next X
End Sub

Public Function GetRGBColor(ByVal Color As String, ColorPart As RGBColor) As Long
    Dim strColor As String
    Select Case ColorPart
        Case gcRed
            strColor = Right$("000000" & Hex$(Color), 6)
            GetRGBColor = Val("&h" & Right$(strColor, 2))
        Case gcblue
            strColor = Right$("000000" & Hex$(Color), 6)
            GetRGBColor = Val("&h" & Left$(strColor, 2))
        Case gcgreen
            strColor = Right$("000000" & Hex$(Color), 6)
            GetRGBColor = Val("&h" & Mid$(strColor, 3, 2))
    End Select
End Function