picturetranstion.bas

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

Attribute VB_Name = "Module2"
'定义效果类型
Public Const FromP1toP2 = 0     '整个图片从1幅到另一幅
Public Const FromLeftToRight = 1     '从左到右
Public Const FromRightToLeft = 2     '从右到左
Public Const FromUpToDwon = 3     '从上到下
Public Const FromDownToUp = 4     '从下到上
 

 '效果返回定义
 Public Const TransOK = 0    '正常
 Public Const TransP1NotFound = -1 '图片1没有找到或者不是图片文件
 Public Const TransP2NotFound = -2 '图片1没有找到或者不是图片文件
 Public Const TransUserBreak = -3 '用户中断


'下列程序完成从一幅图片转化到另一幅图片的过程
'入口参数: srcPictureFileName 原图片文件名
'          dstPictureFileName 转换后的目标文件名
'          w,h 目标设备的高，宽（以像素为单位）
'          dstDc 目标设备DC
'          Speed  转化速度（值越大效果越好，但速度最慢）
'          IsExit 表示是否中断，请用变量传递
'                 例：Call P1ToP2(,....IsExit)
'                     若要求中断，可以在另外的动作中要求IsExit=true
'         TransType 效果类型（见TransEnum说明）
'返回值：见TransError说明
Public Function P1ToP2(ByVal srcPictureFileName As String, ByVal dstPictureFileName As String, ByVal dstDc As Long, w As Long, h As Long, ByVal Speed As Integer, ByVal ShowType As Integer, IsExit As Boolean) As Integer
  Dim h1Dc, h2Dc, hMemDC, hMemPic As Long
  Dim p1, p2 As Picture
  Dim Result As Long
  
  IsExit = False '进入时，不中断
  
  On Error Resume Next
  
  Set p1 = LoadPicture(srcPictureFileName) '装入图片1
  If Err Then
      P1ToP2 = TransP1NotFound
      Exit Function '若出错，则退出
  End If
  
  Set p2 = LoadPicture(dstPictureFileName)
  If Err Then '装入图片2，若出错，则删除装入的图片1，然后退出
       Set p1 = Nothing
       P1ToP2 = TransP2NotFound
       Exit Function
  End If
  
  h1Dc = CreateCompatibleDC(dstDc) '建立一个和目标上下文环境兼容的DC
  Call SelectObject(h1Dc, p1) '将图片1选入中
  
  h2Dc = CreateCompatibleDC(dstDc) '建立一个和目标上下文环境兼容的DC
  Call SelectObject(h2Dc, p2) '将图片2选入中
  
  hMemDC = CreateCompatibleDC(dstDc) '建立一个兼容的内存位图
  hMemPic = CreateCompatibleBitmap(dstDc, w, h)
  Call SelectObject(hMemDC, hMemPic) '选入设备中
  
  Result = PictureTransition(h1Dc, h2Dc, hMemDC, dstDc, w, h, Speed, ShowType, IsExit)
  
  
  Set p1 = Nothing
  Set p2 = Nothing
  
  Call DeleteDC(h1Dc)
  Call DeleteDC(h2Dc)
  Call DeleteDC(hMemDC)
  Call DeleteObject(hMemPic)
  
  P1ToP2 = Result
  
End Function

'以下程序完成一幅图片h1到另一幅图片h2从左到右淡入
'入口参数：h1 原图片
'          h2目标图片
'          DscDC 目标上下文
'          w  目标上下文的宽度
'          h  目标上下文的高度
'          nStep 淡出速度
'          Speed 光带长度

Public Function PictureTransition(ByVal h1Dc As Long, ByVal h2Dc As Long, ByVal hMemDC As Long, ByVal dstDc As Long, ByVal w As Long, ByVal h As Long, ByVal Speed As Integer, ByVal TransType As Integer, IsExit As Boolean) As Integer
  
  Dim x, xx, yy, y, i, j, n As Long
  Dim srcColor, dstColor, curColor As Long
 
  Select Case TransType
         
         Case 0 ' FromP1toP2:
             
              For n = 0 To Speed
                  For x = 0 To w - 1
                      
                      For y = 0 To h - 1
                        srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
                        dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
                        curColor = GetTrienColor(srcColor, dstColor, Speed, n)
                        Call SetPixel(hMemDC, x, y, curColor)
                      Next y
                      
                      DoEvents
                      If IsExit = True Then GoTo exitPictureTransition
                Next x
                
                Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY)
     
            Next n
            
      Case 1 'FromLeftToRight:
          
          For xx = -Speed + 1 To w   '光条从-Speed到结束
              If xx > 0 Then '若左边已经有图2出来
                  Call BitBlt(hMemDC, 0, 0, xx, h, h2Dc, 0, 0, SRCCOPY) '则COPY图2的一部分
              End If
              
              If xx + Speed < w Then '图1还没有完全消失，则COPY部分图1
                 Call BitBlt(hMemDC, xx + Speed, 0, w - xx - Speed, h, h1Dc, xx + Speed, 0, SRCCOPY)
              End If
    
      
              For i = 0 To Speed
                 x = xx + i
                 If x >= 0 And x < w Then '当前的坐标在可视范围内
                    For y = 0 To h - 1
                        srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
                        dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
                        curColor = GetTrienColor(dstColor, srcColor, Speed, i)
                        Call SetPixel(hMemDC, x, y, curColor)
                    Next y
                    DoEvents
                    If IsExit = True Then GoTo exitPictureTransition
                 End If
             Next i
    
             Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY) '将当前变化的结果写入目标设备中
         Next xx
        
   Case 2 'FromRightToLeft:
        
        For xx = w To -Speed + 1 Step -1 '光条从-Speed到结束
              If xx > 0 Then '若左边已经有图2出来
                  Call BitBlt(hMemDC, 0, 0, xx, h, h1Dc, 0, 0, SRCCOPY) '则COPY图2的一部分
              End If
              
              If xx + Speed < w Then '图1还没有完全消失，则COPY部分图1
                 Call BitBlt(hMemDC, xx + Speed, 0, w - xx - Speed, h, h2Dc, xx + Speed, 0, SRCCOPY)
              End If
    
      
              For i = 0 To Speed
                 x = xx + i
                 If x >= 0 And x < w Then '当前的坐标在可视范围内
                    For y = 0 To h - 1
                        srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
                        dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
                        curColor = GetTrienColor(srcColor, dstColor, Speed, i)
                        Call SetPixel(hMemDC, x, y, curColor)
                    Next y
                    DoEvents
                    If IsExit = True Then GoTo exitPictureTransition
                 End If
             Next i
    
             Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY) '将当前变化的结果写入目标设备中
        Next xx
   
   Case 3 'FromUptodown:
        For yy = -Speed + 1 To h    '光条从-Speed到结束
              If yy > 0 Then '若左边已经有图2出来
                  Call BitBlt(hMemDC, 0, 0, w, yy, h2Dc, 0, 0, SRCCOPY) '则COPY图2的一部分
              End If
              
              If yy + Speed < h Then '图1还没有完全消失，则COPY部分图1
                 Call BitBlt(hMemDC, 0, yy + Speed, w, h - yy - Speed, h1Dc, 0, yy + Speed, SRCCOPY)
              End If
    
      
              For i = 0 To Speed
                 y = yy + i
                 If y >= 0 And y < h Then '当前的坐标在可视范围内
                    For x = 0 To w - 1
                        srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
                        dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
                        curColor = GetTrienColor(dstColor, srcColor, Speed, i)
                        Call SetPixel(hMemDC, x, y, curColor)
                    Next x
                    DoEvents
                    If IsExit = True Then GoTo exitPictureTransition
                 End If
             Next i
    
             Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY) '将当前变化的结果写入目标设备中
        Next yy
        
   Case 4  ' FromDownToUp
        For yy = h - 1 To -Speed + 1 Step -1
              If yy > 0 Then '若左边已经有图2出来
                  Call BitBlt(hMemDC, 0, 0, w, yy, h1Dc, 0, 0, SRCCOPY) '则COPY图2的一部分
              End If
              
              If yy + Speed < h Then '图1还没有完全消失，则COPY部分图1
                 Call BitBlt(hMemDC, 0, yy + Speed, w, h - yy - Speed, h2Dc, 0, yy + Speed, SRCCOPY)
              End If
    
      
              For i = 0 To Speed
                 y = yy + i
                 If y >= 0 And y < h Then '当前的坐标在可视范围内
                    For x = 0 To w - 1
                        srcColor = GetPixel(h1Dc, x, y): If srcColor = -1 Then srcColor = GetBkColor(dstDc)
                        dstColor = GetPixel(h2Dc, x, y): If dstColor = -1 Then dstColor = GetBkColor(dstDc)
                        curColor = GetTrienColor(srcColor, dstColor, Speed, i)
                        Call SetPixel(hMemDC, x, y, curColor)
                    Next x
                    DoEvents
                    If IsExit = True Then GoTo exitPictureTransition
                 End If
             Next i
    
             Call BitBlt(dstDc, 0, 0, w, h, hMemDC, 0, 0, SRCCOPY) '将当前变化的结果写入目标设备中
        Next yy
  End Select
  
exitPictureTransition:
  
  If IsExit Then '退出为真
     PictureTransition = TransUserBreak '表示用户中断
  Else
     PictureTransition = TransOK '否则OK
  End If
  
End Function