ctrl_listobject.ctl

基于51和VB的广告牌控制系统

VERSION 5.00
Begin VB.UserControl ctrl_ListObject 
   AutoRedraw      =   -1  'True
   BackStyle       =   0  '透明
   ClientHeight    =   2985
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2100
   PropertyPages   =   "ctrl_ListObject.ctx":0000
   ScaleHeight     =   2985
   ScaleWidth      =   2100
   ToolboxBitmap   =   "ctrl_ListObject.ctx":0010
   Begin VB.PictureBox pic_Viewport 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H00808080&
      BorderStyle     =   0  'None
      Height          =   615
      Left            =   0
      ScaleHeight     =   615
      ScaleWidth      =   1215
      TabIndex        =   3
      Top             =   600
      Width           =   1215
      Begin VB.PictureBox pic_MouseMove 
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         BorderStyle     =   0  'None
         Height          =   495
         Left            =   0
         ScaleHeight     =   495
         ScaleWidth      =   1215
         TabIndex        =   4
         Top             =   0
         Visible         =   0   'False
         Width           =   1215
         Begin VB.Label lbl_MouseMove 
            Alignment       =   2  'Center
            BackStyle       =   0  'Transparent
            Caption         =   "Item"
            BeginProperty Font 
               Name            =   "Tahoma"
               Size            =   8.25
               Charset         =   0
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   195
            Left            =   0
            TabIndex        =   6
            Top             =   0
            Width           =   330
         End
      End
      Begin VB.Label lbl_Item 
         Alignment       =   2  'Center
         BackStyle       =   0  'Transparent
         Caption         =   "Item"
         BeginProperty Font 
            Name            =   "Tahoma"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   195
         Index           =   0
         Left            =   0
         TabIndex        =   5
         Top             =   0
         Visible         =   0   'False
         Width           =   330
      End
   End
   Begin VB.PictureBox pic_DownBorder 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   495
      Left            =   0
      ScaleHeight     =   495
      ScaleWidth      =   1215
      TabIndex        =   2
      Top             =   1200
      Width           =   1215
      Begin VB.Image img_MoveDown 
         Height          =   360
         Left            =   0
         Top             =   0
         Width           =   300
      End
   End
   Begin VB.PictureBox pic_UpBorder 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   495
      Left            =   0
      ScaleHeight     =   495
      ScaleWidth      =   1215
      TabIndex        =   1
      Top             =   0
      Width           =   1215
      Begin VB.Image img_MoveUp 
         Height          =   360
         Left            =   0
         Top             =   0
         Width           =   300
      End
   End
   Begin VB.PictureBox pic_Source 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   495
      Left            =   0
      ScaleHeight     =   435
      ScaleWidth      =   1155
      TabIndex        =   0
      Top             =   1680
      Visible         =   0   'False
      Width           =   1215
   End
End
Attribute VB_Name = "ctrl_ListObject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020

Const DefForeColor = 0
Const DefMouseMoveColor = 0
Const DefMouseDownColor = 0

'Dim v_sSkinPath As String
Dim v_oForeColor As OLE_COLOR
Dim v_oMouseMoveColor As OLE_COLOR
Dim v_oMouseDownColor As OLE_COLOR
Dim v_iItemCount As Integer
Dim v_iLastItem As Integer

Public SkinPath As String

Event Click(Index As Integer)
Event MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

Public Sub DrawMenu()
    Dim v_lRtn As Long
    Dim v_iCenterImgFrequency As Integer
    Dim v_iLoop As Integer
    Dim v_iCurrentY As Integer

    With UserControl
        .pic_Source.Picture = LoadPicture(SkinPath & "\img_ListObject.bmp")
        .pic_UpBorder.Width = .Width
        .pic_UpBorder.Height = 360
        
        .pic_UpBorder.Cls
        v_lRtn = BitBlt(.pic_UpBorder.hdc, 0, 0, 20, 24, .pic_Source.hdc, 0, 0, SRCCOPY)
        v_iCenterImgFrequency = Abs((.Width / Screen.TwipsPerPixelX) / 20)
        If v_iCenterImgFrequency > 0 Then
            For v_iLoop = 1 To v_iCenterImgFrequency
                v_lRtn = BitBlt(.pic_UpBorder.hdc, v_iLoop * 20, 0, 20, 24, .pic_Source.hdc, 23, 0, SRCCOPY)
            Next v_iLoop
        End If
        v_lRtn = BitBlt(.pic_UpBorder.hdc, (.Width / Screen.TwipsPerPixelX) - 23, 0, 23, 24, .pic_Source.hdc, 44, 0, SRCCOPY)
        .pic_UpBorder.Refresh
            
        .pic_DownBorder.Cls
        .pic_DownBorder.Width = .Width
        .pic_DownBorder.Height = 360
        .pic_DownBorder.Top = .Height - .pic_DownBorder.Height
        v_lRtn = BitBlt(.pic_DownBorder.hdc, 0, 0, 20, 24, .pic_Source.hdc, 0, 96, SRCCOPY)
        v_iCenterImgFrequency = Abs((.Width / Screen.TwipsPerPixelX) / 20)
        If v_iCenterImgFrequency > 0 Then
            For v_iLoop = 1 To v_iCenterImgFrequency
                v_lRtn = BitBlt(.pic_DownBorder.hdc, v_iLoop * 20, 0, 20, 24, .pic_Source.hdc, 23, 96, SRCCOPY)
            Next v_iLoop
        End If
        v_lRtn = BitBlt(.pic_DownBorder.hdc, (.Width / Screen.TwipsPerPixelX) - 23, 0, 23, 24, .pic_Source.hdc, 44, 96, SRCCOPY)
        .pic_DownBorder.Refresh
    
        .pic_Viewport.Top = .pic_UpBorder.Height
        .pic_Viewport.Width = .Width
        .pic_Viewport.Height = .Height - .pic_UpBorder.Height - .pic_DownBorder.Height
        
      .pic_Viewport.Cls
        v_iCurrentY = 0
        While (v_iCurrentY * 15) < (.Height - 720)
            v_lRtn = BitBlt(.pic_Viewport.hdc, 0, v_iCurrentY, 20, 24, .pic_Source.hdc, 0, 24, SRCCOPY)
            v_iCenterImgFrequency = Abs((.Width / Screen.TwipsPerPixelX) / 20)
            If v_iCenterImgFrequency > 0 Then
                For v_iLoop = 1 To v_iCenterImgFrequency
                    v_lRtn = BitBlt(.pic_Viewport.hdc, v_iLoop * 20, v_iCurrentY, 20, 24, .pic_Source.hdc, 23, 24, SRCCOPY)
                Next v_iLoop
            End If
            v_lRtn = BitBlt(.pic_Viewport.hdc, (.Width / Screen.TwipsPerPixelX) - 23, v_iCurrentY, 23, 24, .pic_Source.hdc, 44, 24, SRCCOPY)
            v_iCurrentY = v_iCurrentY + 24
       Wend
       .pic_Viewport.Refresh
    End With
End Sub

Public Sub Refresh()
    Dim v_lRtn As Long
    Dim v_iCenterImgFrequency As Integer
    Dim v_iLoop As Integer
    Dim v_iCurrentY As Integer