tv.bas

广播级有线电视台MTV互动点播系统

    End If
    If Zhou = "x" Then
        For Q = Begin To XEnd Step Fuhao
           BitBlt Obj.hdc, Q, 0, Obj.Width, Obj.Height, hMemDc, 0, 0, vbSrcCopy
        Next Q
    End If
    DeleteObject hMemDc: DeleteObject OldDc
End Sub
Sub Instal(sBmp As String, sObj As Object)
   '把图形 Load 入 Pic
   sObj.Cls
   Set pic = LoadPicture(App.Path + "\picturebj\" + sBmp + ".jpg")
   'Set Pic = sObj.Picture
   '获得 Pic 的数据
   GetObject pic.Handle, Len(Bm), Bm
   '建立和 picturebox 相兼容的虚拟 DC
   hMemDc = CreateCompatibleDC(sObj.hdc)
   '建立以后恢复用的 DC
   OldDc = CreateCompatibleDC(sObj.hdc)
   SelectObject OldDc, sObj.Picture.Handle
   '把已经 Load 图形的 Pic 选入虚拟 DC
   SelectObject hMemDc, pic.Handle
End Sub

Sub DH(Xh As Integer, sBmp As String, sObj As Object)
Dim Fen As Integer, Kuan As Single
Dim Ystep As Single
 Call Instal(sBmp, sObj)
 Select Case Xh
'==单轴计算的图形载入方式(A)===
   Case 1
      MoveForm sObj, Bm.bmHeight, 0, "-40", "y"
'==单轴计算的图形载入方式(<)====
   Case 2
      MoveForm sObj, Bm.bmWidth, 0, "-40", "x"
'==单轴计算的图形载入方式(>)====
   Case 3
      MoveForm sObj, 0 - Bm.bmWidth, 0, "+40", "x"
'==单轴计算的图形载入方式(V)====
   Case 4
      MoveForm sObj, 0 - Bm.bmHeight, 0, "+40", "y"
'==X轴的百叶窗==================
   Case 5
      Fen = 20: sObj.Cls
      sX = Bm.bmWidth / Fen
      For Kuan = 0 To sX + 1
        For Q = 0 To Fen
           BitBlt sObj.hdc, sX * Q, 0, Kuan, sObj.Height, hMemDc, sX * Q, 0, vbSrcCopy
        Next Q
        Delay 0.0001
      Next Kuan
      DeleteObject hMemDc: DeleteObject OldDc
'==Y轴的百叶窗====
   Case 6
      Fen = 20: sObj.Cls
      sY = Bm.bmHeight / Fen
      For Kuan = 0 To sY + 1
        For Q = 0 To Fen
          BitBlt sObj.hdc, 0, sY * Q, sObj.Width, Kuan, hMemDc, 0, sY * Q, vbSrcCopy
        Next Q
        Delay 0.0001
      Next Kuan
      DeleteObject hMemDc: DeleteObject OldDc
'==由小到大的图形载入方式====
   Case 7
      Dim DifX As Single, DifY As Single
      Dim W As Single, H As Single
      sObj.Cls: Fen = 20
      DifX = Bm.bmWidth / Fen: DifY = Bm.bmHeight / Fen
      For Q = 1 To Fen
         sX = (Bm.bmWidth - DifX * Q) / 2: sY = (Bm.bmHeight - DifY * Q) / 2
         StretchBlt sObj.hdc, sX, sY, DifX * Q, DifY * Q, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
         Delay 0.0001
      Next Q
      DeleteObject hMemDc: DeleteObject OldDc
'==斜向载入图形(\)====
   Case 8
      Ystep = Bm.bmHeight / Bm.bmWidth
      XieX sObj, Bm.bmWidth, 0, Bm.bmHeight, 0, "-40", Ystep * 40, 0, 0
'==斜向载入图形(\)====
   Case 9
      Ystep = Bm.bmHeight / Bm.bmWidth
      XieX sObj, 0 - Bm.bmWidth, 0, 0 - Bm.bmHeight, 0, "+40", 0 - Ystep * 40, 0, 0
'==斜向载入图形(/)====
   Case 10
      Ystep = Bm.bmHeight / Bm.bmWidth
      XieX sObj, 0 - Bm.bmWidth, 0, Bm.bmHeight, 0, "+40", Ystep * 40, 0, 0
'==斜向载入图形(/)====
   Case 11
      Ystep = Bm.bmHeight / Bm.bmWidth
      XieX sObj, Bm.bmWidth, 0, 0 - Bm.bmHeight, 0, "-40", 0 - Ystep * 40, 0, 0
'==分成两块X轴的载入方式====
   Case 12
      Dim iY As Long
      sObj.Cls: iY = Bm.bmWidth: Q = 0 - Bm.bmWidth / 2
      For Q = 0 - Bm.bmWidth / 2 - 1 To 0 Step 20
        iY = iY - 20
        BitBlt sObj.hdc, iY, 0, Bm.bmWidth / 2 + 1, Bm.bmHeight, hMemDc, Bm.bmWidth / 2, 0, vbSrcCopy
        BitBlt sObj.hdc, Q, 0, Bm.bmWidth / 2, Bm.bmHeight, hMemDc, 0, 0, vbSrcCopy
        Delay 0.0001
      Next Q
      BitBlt sObj.hdc, 0, 0, Bm.bmWidth, Bm.bmHeight, hMemDc, 0, 0, vbSrcCopy
      DeleteObject hMemDc: DeleteObject OldDc
'==分成四块的图形载入方式====
   Case 13
      Dim ILUx As Single, ILUy As Single, IRUx As Single, IRUy As Single, _
          ILDx As Single, ILDy As Single, IRDx As Single, IRDy As Single, _
          Lsbmp As Long, Leij As Single
      sObj.Cls
      Leij = sObj.ScaleHeight / sObj.ScaleWidth
   '---制作时的参照-----
      ILUx = 0 - Bm.bmWidth / 2: ILUy = 0 - Bm.bmHeight / 2
      IRUx = Bm.bmWidth: IRUy = 0 - Bm.bmHeight / 2
      ILDx = 0: ILDy = Bm.bmHeight
      IRDx = Bm.bmWidth / 2: IRDy = Bm.bmHeight / 2
   '---分别计算四个图块X，Y 轴的运动轨迹------
      For ILUx = 0 - Bm.bmWidth / 2 To 0 Step 20
         ILUy = ILUy + Leij * 20
         IRUx = IRUx - 1 * 20
         IRUy = IRUy + Leij * 20
         ILDy = ILDy - Leij * 20
   '---直接显示在picturebox上------------
         BitBlt sObj.hdc, ILUx, ILUy, Bm.bmWidth / 2, Bm.bmHeight / 2, hMemDc, 0, 0, vbSrcCopy
         BitBlt sObj.hdc, IRUx, IRUy, Bm.bmWidth / 2, Bm.bmHeight / 2, hMemDc, Bm.bmWidth / 2, 0, vbSrcCopy
         BitBlt sObj.hdc, ILUx, ILDy, Bm.bmWidth / 2, Bm.bmHeight / 2, hMemDc, 0, Bm.bmHeight / 2, vbSrcCopy
         BitBlt sObj.hdc, IRUx, ILDy, Bm.bmWidth / 2, Bm.bmHeight / 2, hMemDc, Bm.bmWidth / 2, Bm.bmHeight / 2, vbSrcCopy
   '---延时--------
         Delay 0.0001
      Next ILUx
   '---去除接缝---------
      BitBlt sObj.hdc, 0, 0, sObj.ScaleWidth, sObj.ScaleHeight, hMemDc, 0, 0, vbSrcCopy
   '---删除无用的DC-------
      DeleteObject hMemDc: DeleteObject OldDc
   Case 14  '-->
      For Fen = 0 To Bm.bmWidth Step 100
          StretchBlt sObj.hdc, 0, 0, Fen, Bm.bmHeight, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
      Next
      DeleteObject hMemDc: DeleteObject OldDc
   Case 15  '<--
      For Fen = 0 To Bm.bmWidth Step 100
          StretchBlt sObj.hdc, Bm.bmWidth - Fen, 0, Fen, Bm.bmHeight, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
      Next
      DeleteObject hMemDc: DeleteObject OldDc
   Case 16  'V
      For Fen = 0 To Bm.bmHeight Step 100
          StretchBlt sObj.hdc, 0, 0, Bm.bmWidth, Fen, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
      Next
      DeleteObject hMemDc: DeleteObject OldDc
   Case 17  'A
      For Fen = 0 To Bm.bmHeight Step 100
          StretchBlt sObj.hdc, 0, Bm.bmHeight - Fen, Bm.bmWidth, Fen, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
      Next
      DeleteObject hMemDc: DeleteObject OldDc
   Case 18  '<->
      For Fen = 0 To Bm.bmWidth / 2 Step 50
          StretchBlt sObj.hdc, Bm.bmWidth / 2 - Fen, 0, Fen * 2, Bm.bmHeight, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
      Next
      DeleteObject hMemDc: DeleteObject OldDc
   Case 19  'H
      For Fen = 0 To Bm.bmHeight / 2 Step 50
          StretchBlt sObj.hdc, 0, Bm.bmHeight / 2 - Fen, Bm.bmWidth, Fen * 2, hMemDc, 0, 0, Bm.bmWidth, Bm.bmHeight, vbSrcCopy
      Next
      DeleteObject hMemDc: DeleteObject OldDc
   Case 20  '雨滴
      Dim i As Long
      Dim j As Long
      Dim height5 As Long, width5 As Long
      Dim Picture1 As New StdPicture
      sObj.ScaleMode = 3 '设定成Pixel的度量单位
      '设定待Display的图
      Set Picture1 = LoadPicture(App.Path + "\picturebj\" + sBmp + ".jpg")
      'stdPicture物件的度量单位是Himetric所以要转换成Pixel
      'height5 = ScaleY(Picture1.Height, vbHimetric, vbPixels)
      'If height5 > sObj.ScaleHeight Then
         height5 = sObj.ScaleHeight
      'End If
      'width5 = ScaleX(Picture1.Width, vbHimetric, vbPixels)
      'If width5 > sObj.ScaleWidth Then
         width5 = sObj.ScaleWidth
      'End If
      hMemDc = CreateCompatibleDC(sObj.hdc)
      '将Picture1的BitMap图指定给hMemDc
      Call SelectObject(hMemDc, Picture1.Handle)
      For i = height5 To 1 Step -1
         Call BitBlt(sObj.hdc, 0, i, width5, 1, hMemDc, 0, i, vbSrcCopy)
         For j = i - 1 To 1 Step -10
            Call BitBlt(sObj.hdc, 0, j, width5, 1, hMemDc, 0, i, vbSrcCopy)
         Next j
      Next i
      'Call DeleteDC(hMemDc)
      DeleteObject hMemDc: DeleteObject OldDc
   Case 21
      Dim A(0 To 1000) As Integer
      Dim B(0 To 400) As Integer
      Dim S1, S2 As Integer
      Dim k, v1, k2, k1, r%, kk
      sObj.Cls
      '产生随机数组
      For i = 0 To 1000
         A(i) = 0
      Next
      For i = 0 To 400
Loop1:   k = Int(Rnd() * 1000) + 1
         If Not (A(k) = 0) Then GoTo Loop1
         A(k) = i
      Next
      v1 = 0
      For i = 0 To 1000
         If Not (A(i) = 0) Then
            B(v1) = A(i)
            v1 = v1 + 1
         End If
      Next
      '根据随机数组的值，拷贝小图片
      S1 = Bm.bmWidth / 20
      S2 = Bm.bmHeight / 20
      For i = 0 To 400
         k2 = B(i) Mod 20
         k1 = ((Int(B(i)) - k2) / 20) * S2
         k2 = k2 * S1
         r% = BitBlt(sObj.hdc, k2, k1, S1 + 2, S2 + 2, hMemDc, k2, k1, &HCC0020)
         For kk = 0 To 200
           DoEvents
         Next kk
      Next
      DeleteObject hMemDc: DeleteObject OldDc
 End Select
End Sub