pictrans.ctl

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

VERSION 5.00
Begin VB.UserControl PicTrans 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.PictureBox PicCtrl 
      Height          =   3615
      Left            =   0
      ScaleHeight     =   237
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   317
      TabIndex        =   0
      Top             =   0
      Width           =   4815
      Begin VB.Timer Timer 
         Interval        =   1
         Left            =   720
         Top             =   2520
      End
   End
End
Attribute VB_Name = "PicTrans"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Const F1 = "c:\picture\jpeg\photo\phot010.jpg"
Const F2 = "c:\picture\jpeg\photo\phot011.jpg"

Const STEP = 6
Const MAXW = 50
Const MAXH = 500
 
 
 Private hP0, hP1 As Picture
 Private hP2  As Long
 Private IsFirst As Boolean
 Private PicWidth, PicHeight, StartX, si, di As Integer

 Type ShowEnum
      FromLeftToRight = 0
      FromRightToLeft = 1
      FromUpToDown = 2
      FromDownToUp = 3
      FromRLToMid = 4
      FromMidToRL = 5
      FromCenterToSide = 6
      FromSideToCenter = 7
 End Type

'缺省属性值:
 Const m_def_TextString = "图片过度效果PicTrans V1.0 设计：江龙  2000年02月30日"
 Const m_def_TextOffsetY = 0

'属性变量:
 Dim m_TextString As String
 Dim m_TextOffsetY As Integer
 
 
'事件声明:
Event Timer() 'MappingInfo=Timer,Timer,-1,Timer
Attribute Timer.VB_Description = "当 Timer 控件的内部预设置已使用时发生。"



Private Sub PicCtrl_Click()

End Sub

Private Sub UserControl_Initialize()
     IsFirst = True
     
End Sub


Private Sub UserControl_Show()

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.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.FontSize() = New_FontSize
    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)
    m_TextString = New_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)
    m_TextOffsetY = New_TextOffsetY
    PropertyChanged "TextOffsetY"
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_TextString = m_def_TextString
    m_TextOffsetY = m_def_TextOffsetY
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", 0)
    m_TextString = PropBag.ReadProperty("TextString", m_def_TextString)
    PicCtrl.ForeColor = PropBag.ReadProperty("TextColor", &H80000012)
    m_TextOffsetY = PropBag.ReadProperty("TextOffsetY", m_def_TextOffsetY)
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, 0)
    Call PropBag.WriteProperty("Speed", Timer.Interval, 0)
    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)
End Sub

Private Sub Timer_Timer()
    Dim i As Integer
     
    
    If StartX > PicWidth Then '图片已切换完，则换源和目的
       StartX = -MAXW
       i = si
       si = di
       di = i
    End If
    
    
     
         
     
    Call PaintMemBitmap
    
    StartX = StartX + STEP '下一步
    Call TextOut(PicCtrl.hdc, StartX, TextOffsetY, TextString, textlen)
     
    RaiseEvent Timer
    
End Sub

Private Sub UserControl_Resize()
  Dim hdc, HBrush As Long
 
  PicCtrl.Height = Height
  PicCtrl.Width = Width
  
  PicWidth = PicCtrl.ScaleWidth + 1
  PicHeight = PicCtrl.ScaleHeight + 1
  
  If hP3 Then DeleteObject (hP3) '若已有了内存位图，则删除之
  
  hP3 = CreateCompatibleBitmap(PicCtrl.hdc, PicWidth, PicHeight)
  
 End Sub

Private Sub IsFirstRun()
    '将文件读入中
     StartX = -PicWidth
     
     si = 0
     di = 1
     
     Set hP0 = LoadPicture(F1) '装入图片
     Set hP1 = LoadPicture(F2)
     
   
    
     IsFirst = False
  

End Sub

     
     
  
  End If
  


'图片切换程序
Private Sub PaintMemBitmap(ByVal ShowTyle As Integer)
   
  Dim rr As RECT
  Dim i, j As Integer
  Dim color, dPdc(3), HBrush As Long
  Dim s, sn As Single
  
  Static num As Integer
  
  For i = 0 To 3 '建立需要的兼容设备上下文HDC
      hPdc(i) = CreateCompatibleDC(PicCtrl.hdc)
  Next i
     
  Call SelectObject(hPdc(0), hP0) '为设备DC选入各自的位图
  Call SelectObject(hPdc(1), hP1)
  Call SelectObject(hPdc(2), hP2)
  
  HBrush = CreateSolidBrush(PicCtrl.BackColor) '建立一个实心的刷子
  rr.Top = 0 '定义填充的区域
  rr.Left = 0
  rr.Bottom = PicHeight
  rr.Right = PicWidth
  
  Call FillRect(hPdc(2), rr, HBrush) '用当前的背景色填充即将画向屏幕的位置
  Call DeleteObject(HBrush) '删除建立的刷子
   
    
 Select Case ShowType
        Case FromLeftToRight
        
     

  
   w2 = w \ 2
   n = x + w2
  
If n > 0 Then '若图1左半部分可以COPY
       Call BitBlt(hMem, 0, 0, n, hh, hP0, 0, 0, SRCCOPY)
       If ww - n > 0 Then
          Call BitBlt(hMem, n + 1, 0, ww - n, hh, hP1, n + 1, 0, SRCCOPY)
       End If
   Else
        Call BitBlt(hMem, 0, 0, ww, hh, hP1, 0, 0, SRCCOPY)
End If
   
     Brush.lbStyle = PS_USERSTYLE
     Brush.lbHatch = 0
     Brush.lbColor = &HFFFFFF
     
     rr.Top = 0
     rr.Bottom = hh
     
     For i = 0 To w2
        rr.Left = i
        rr.Right = w - 2 * i
        Brush.lbHatch = i * 2 / MAXW * &HFFFFFF
        HBrush = CreateBrushIndirect(Brush)
        Call FillRect(hDst, rr, HBrush)
        DeleteObject HBrush
      
     Next i
      
   
 Call BitBlt(PicCtrl.hdc, 0, 0, pcwidth, PicHeight, hPdc(2), 0, 0, SRCCOPY)
 
 For i = 0 To 3 '删除所建立的HDC
    DeleteDC (hPdc(i))
 Next i
     
  
  ' For i = 0 To w2
          
   '      t = i + x
         
    '     If t >= 0 And t <= ww Then
     '      If i > w2 * 2 / 3 Then
      '         sn = 0: s = 1
       '    Else
        '       sn = Rnd * 1: s = Rnd + 1
         '  End If
         ' For j = sn To hh Step s
          '  n = GetPixel(hP1, t, j)
          '  s = (w2 - i) / w2
          '  r = Int(GetRed(n) * s)
          '  b = Int(GetBlue(n) * s)
          '  g = Int(GetGreen(n) * s)
          '  Call SetPixel(hP3, t, (j), RGB(r, g, b))
          ' Next j
         'End If
    'Next i
       
       
    'For i = w2 To w
     '  t = i + x
      ' If t >= 0 And t <= ww Then
       '   If i < w2 / 3 Then
        '       sn = 0: s = 1
         '  Else
          '     sn = Rnd * 1: s = Rnd + 1
           'End If
        ' For j = sn To hh Step s
         ' n = GetPixel(hP2, t, j)
         ' s = (i - w2) / w2
         ' r = Int(GetRed(n) * s)
         ' b = Int(GetBlue(n) * s)
         ' g = Int(GetGreen(n) * s)
         ' Call SetPixel(hP3, t, (j), RGB(r, g, b))
        'Next j
      'End If
   ' Next i
 
  
  

  'Call BitBlt(hMem, x, y, w, hh, hMask, 0, 0, SRCPAINT)
  
'  Call BitBlt(hDst, 0, 0, ww, hh, hMem, 0, 0, SRCCOPY)
  
End Sub