piclight.ctl

电脑编程技巧和源码。很不错的。

VERSION 5.00
Begin VB.UserControl AddLight 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.PictureBox PicCtrl 
      BackColor       =   &H80000012&
      ForeColor       =   &H000000FF&
      Height          =   3615
      Left            =   0
      ScaleHeight     =   237
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   317
      TabIndex        =   0
      Top             =   0
      Width           =   4815
      Begin VB.Timer Timer 
         Interval        =   50
         Left            =   720
         Top             =   2520
      End
   End
End
Attribute VB_Name = "AddLight"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
 
 
  Const LENS = 70  '镜长
 
  Const STEP = 3
 
  Private hP As Picture
  Private hBack As Long
 
 Private IsFirst, IsChage  As Boolean
 Private PicWidth, PicHeight As Integer
 Private TextLen, StartX, maxOffsetX As Integer
 Private Lix, Liy As Integer

'缺省属性值:
 Const m_def_LightSize = LENS
 Const m_def_PictureFileName = "c:\jiang\Userocx\light\AddSnow.jpg"
 Const m_def_TextString = "为深夜中的图片加电灯光照效果AddLightCtrol V1.0 设计：江龙  2000年1月31日"
 Const m_def_TextOffsetY = -1

 '属性变量:
 Dim m_PictureFileName As String
 Dim m_TextString As String
 Dim m_TextOffsetY As Integer
 Dim m_LightSize As Integer
 
'事件声明:
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=PicCtrl,PicCtrl,-1,MouseMove
Attribute MouseMove.VB_Description = "当用户移动鼠标时发生。"
Event Timer() 'MappingInfo=Timer,Timer,-1,Timer
Attribute Timer.VB_Description = "当 Timer 控件的内部预设置已使用时发生。"
 

 Private Sub UserControl_Initialize()
     IsFirst = True
     hBack = 0
     IsChange = False
     Set hP = Nothing
     
End Sub


'注意！不要删除或修改下列被注释的行！
'MappingInfo=PicCtrl,PicCtrl,-1,BorderStyle
Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "返回/设置对象的边框样式。"
    BorderStyle = PicCtrl.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    PicCtrl.BorderStyle() = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=PicCtrl,PicCtrl,-1,FontName
Public Property Get FontName() As String
Attribute FontName.VB_Description = "指定给定层的每一行出现的字体名。"
    FontName = PicCtrl.FontName
End Property

Public Property Let FontName(ByVal New_FontName As String)
    PicCtrl.Cls
    PicCtrl.FontName() = New_FontName
    PropertyChanged "FontName"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=PicCtrl,PicCtrl,-1,FontSize
Public Property Get FontSize() As Single
Attribute FontSize.VB_Description = "指定给定层的每一行出现的字体大小(以磅为单位)。"
    FontSize = PicCtrl.FontSize
End Property

Public Property Let FontSize(ByVal New_FontSize As Single)
    PicCtrl.Cls
    PicCtrl.FontSize() = New_FontSize
    maxOffsetX = PicCtrl.TextWidth(m_TextString)
    PropertyChanged "FontSize"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=Timer,Timer,-1,Interval
Public Property Get Speed() As Long
Attribute Speed.VB_Description = "返回/设置两次调用 Timer 控件的 Timer 事件间隔的毫秒数。"
    Speed = Timer.Interval
End Property

Public Property Let Speed(ByVal New_Speed As Long)
    Timer.Interval() = New_Speed
    PropertyChanged "Speed"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,"图片过度效果PicTrans V1.0 设计：江龙  2000年02月30日"
Public Property Get TextString() As String
Attribute TextString.VB_Description = "设置/返回显示字符串"
    TextString = m_TextString
End Property

Public Property Let TextString(ByVal New_TextString As String)
    PicCtrl.Cls
    m_TextString = New_TextString
    TextLen = Strlen(m_TextString)
    maxOffsetX = PicCtrl.TextWidth(m_TextString)
    PropertyChanged "TextString"
End Property

'注意！不要删除或修改下列被注释的行！
'MappingInfo=PicCtrl,PicCtrl,-1,ForeColor
Public Property Get TextColor() As OLE_COLOR
Attribute TextColor.VB_Description = "返回/设置对象中文本和图形的前景色。"
    TextColor = PicCtrl.ForeColor
End Property

Public Property Let TextColor(ByVal New_TextColor As OLE_COLOR)
    PicCtrl.ForeColor() = New_TextColor
    PropertyChanged "TextColor"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get TextOffsetY() As Integer
Attribute TextOffsetY.VB_Description = "设置/返回显示字符串的Y轴偏移量"
    TextOffsetY = m_TextOffsetY
End Property

Public Property Let TextOffsetY(ByVal New_TextOffsetY As Integer)
    If (New_TextOffsetY < 0) Then
        m_TextOffsetY = -1
    Else
        m_TextOffsetY = New_TextOffsetY
    End If
    PicCtrl.Cls
    PropertyChanged "TextOffsetY"
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_TextString = m_def_TextString
    m_TextOffsetY = m_def_TextOffsetY
    m_PictureFileName = m_def_PictureFileName
    m_LightSize = m_def_LightSize
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    PicCtrl.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
    PicCtrl.FontName = PropBag.ReadProperty("FontName", "宋体")
    PicCtrl.FontSize = PropBag.ReadProperty("FontSize", 9)
    Timer.Interval = PropBag.ReadProperty("Speed", 50)
    m_TextString = PropBag.ReadProperty("TextString", m_def_TextString)
    PicCtrl.ForeColor = PropBag.ReadProperty("TextColor", &H80000012)
    m_TextOffsetY = PropBag.ReadProperty("TextOffsetY", m_def_TextOffsetY)
    m_PictureFileName = PropBag.ReadProperty("PictureFileName", m_def_PictureFileName)
    m_LightSize = PropBag.ReadProperty("LightSize", m_def_LightSize)
End Sub

Private Sub UserControl_Show()
On Error Resume Next
If IsFirst Then '是第一次
 
      StartX = PicWidth
      IsFirst = False
      Set hP = LoadPicture(m_PictureFileName) '装入图片
      If Err Then
           Set hP = Nothing
      End If
      TextLen = Strlen(m_TextString)
      Lix = PicWidth \ 2
      Liy = PicHeight \ 2
      maxOffsetX = PicCtrl.TextWidth(m_TextString)
      
  
  End If

End Sub
Private Sub UserControl_Terminate()
 
  If Not (hP Is Nothing) Then Set hP = Nothing
  If hBack <> 0 Then Call DeleteObject(hBack)
End Sub


'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BorderStyle", PicCtrl.BorderStyle, 1)
    Call PropBag.WriteProperty("FontName", PicCtrl.FontName, "宋体")
    Call PropBag.WriteProperty("FontSize", PicCtrl.FontSize, 9)
    Call PropBag.WriteProperty("Speed", Timer.Interval, 50)
    Call PropBag.WriteProperty("TextString", m_TextString, m_def_TextString)
    Call PropBag.WriteProperty("TextColor", PicCtrl.ForeColor, &H80000012)
    Call PropBag.WriteProperty("TextOffsetY", m_TextOffsetY, m_def_TextOffsetY)
    Call PropBag.WriteProperty("PictureFileName", m_PictureFileName, m_def_PictureFileName)
    Call PropBag.WriteProperty("LightSize", m_LightSize, m_def_LightSize)
End Sub

Private Sub Timer_Timer()
    
    Dim m As Integer
    Dim sm As String
    If IsChange Then Exit Sub
    
    If StartX < -maxOffsetX - PicWidth Then '图片已切换完，则换源和目的
       StartX = PicWidth
    End If
       
    
    
    StartX = StartX - STEP '下一步
    
     If m_TextOffsetY < 0 Then
        m = PicHeight - PicCtrl.FontSize - 5
     Else
       m = m_TextOffsetY
     End If
    
     
        
      If hP Is Nothing Then
          sm = m_PictureFileName & "不能装入"
          Call TextOut(PicCtrl.hdc, 0, m, sm, Strlen(sm))
      Else
        Lix = Lix + Rnd * m_LightSize - m_LightSize / 2
        Liy = Liy + Rnd * m_LightSize - m_LightSize / 2
         Call GetTransBitmap(Lix, Liy)
         Call TextOut(PicCtrl.hdc, StartX, m, m_TextString, TextLen)
      End If
      
    RaiseEvent Timer
    
End Sub

 Private Sub UserControl_Resize()
  Dim hdc, HBrush As Long
  On Error Resume Next
  
  PicCtrl.Height = Height
  PicCtrl.Width = Width
  PicWidth = Int(PicCtrl.ScaleWidth + 1)
  PicHeight = Int(PicCtrl.ScaleHeight + 1)
  
  If hBack Then DeleteObject hBack
  
  hBack = CreateCompatibleBitmap(PicCtrl.hdc, PicWidth, PicHeight) '建立位置
    
  
End Sub


'获取颜效果图形
Private Sub GetTransBitmap(ByVal x As Integer, ByVal y As Integer)
 
 
  Dim s, mx, my, ty, tx, Len2, r, g, b As Integer
  Dim i, j, MaxLen As Integer
  Dim n, hdc, hBackDc, srcColor, dstColor, curColor As Long
   
  
  If hP Is Nothing Then Exit Sub
  
  hdc = CreateCompatibleDC(PicCtrl.hdc) '建立一个兼容的图片DC
  Call SelectObject(hdc, hP)
  
  hBackDc = CreateCompatibleDC(PicCtrl.hdc) '建立一个兼容的DC
   
  Call SelectObject(hBackDc, hBack) '将背景清为黑色
  
  Call PatBlt(hBackDc, 0, 0, PicWidth, PicHeight, BLACKNESS)
  
   
  Len2 = m_LightSize \ 2
   
  mx = x + Len2
  my = y + Len2

   l2 = (Len2 + 1) \ 2
  
  For j = 0 To m_LightSize - 1
       ty = y + j
       If ty >= 0 And ty < PicWidth Then
       
         For i = 0 To m_LightSize - 1
           
           tx = i + x
                    
           If tx >= 0 And tx < PicWidth Then
              s = Int(Sqr((tx - mx) * (tx - mx) + (ty - my) * (ty - my)) + 0.5)
              
              srcColor = GetPixel(hdc, tx, ty)
              If srcColor < 0 Then srcColor = 0
               
              If s > Len2 Then
                  s = Len2
              Else
                  If s < 0 Then s = 0
              End If
             
              If s < l2 Then
                  curColor = GetTrienColor(srcColor, RGB(255, 255, 255), l2, l2 - s)
                Else
                  s = s - l2
               
                  curColor = GetTrienColor(RGB(0, 0, 0), srcColor, l2, l2 - s)
               End If
                   
              Call SetPixel(hBackDc, tx, ty, curColor)
                       
           End If
        Next i
        
      End If
Next j
    
Call BitBlt(PicCtrl.hdc, 0, 0, PicWidth, PicHeight, hBackDc, 0, 0, SRCCOPY)

Call DeleteDC(hdc)
Call DeleteDC(hBackDc)


 
 
  
End Sub


'注意！不要删除或修改下列被注释的行！
'MemberInfo=13,0,0,""
Public Property Get PictureFileName() As String
Attribute PictureFileName.VB_Description = "设置/返回图片的文件名"
    PictureFileName = m_PictureFileName
End Property

Public Property Let PictureFileName(ByVal New_PictureFileName As String)
    On Error Resume Next
    Dim old As Boolean
    m_PictureFileName = New_PictureFileName
    
    If hP Is Nothing Then old = True Else old = False
    
    Set hP = LoadPicture(New_PictureFileName)
    
    If Err Then
        PicCtrl.Cls
        Set hP = Nothing
    Else
        If old Then StartX = PicWidth
    End If
    PropertyChanged "PictureFileName"
End Property

Private Sub PicCtrl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    IsChange = True
    Call GetTransBitmap(x - m_LightSize / 2, y - m_LightSize / 2)
    Lix = x
    Liy = y
    RaiseEvent MouseMove(Button, Shift, x, y)
    IsChange = False
End Sub

'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get LightSize() As Integer
Attribute LightSize.VB_Description = "设置/返回光源的长度(10-100)"
    LightSize = m_LightSize
End Property

Public Property Let LightSize(ByVal New_LightSize As Integer)
    If New_LightSize < 10 Or New_LightSize > 150 Then
       m_LightSize = LENS
    Else
       m_LightSize = New_LightSize
    End If
    PropertyChanged "LightSize"
End Property

'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function AboutBox() As Variant
Attribute AboutBox.VB_Description = "关于信息"
  MsgBox "Add Light For Picture Ctrol V1.0 By DragonJiang" & Chr(13) & "Date: 2000.01.31", vbInformation
End Function