home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / An_amazing2126629122008.psc / ctlVistorButton.ctl < prev    next >
Text File  |  2008-08-25  |  16KB  |  577 lines
  1. VERSION 5.00
  2. Begin VB.UserControl ctlVistorButton 
  3.    AutoRedraw      =   -1  'True
  4.    ClientHeight    =   3600
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   4800
  8.    ControlContainer=   -1  'True
  9.    ScaleHeight     =   3600
  10.    ScaleWidth      =   4800
  11.    Begin VB.PictureBox PicOver 
  12.       AutoRedraw      =   -1  'True
  13.       AutoSize        =   -1  'True
  14.       BackColor       =   &H00C0C0C0&
  15.       BorderStyle     =   0  'None
  16.       Height          =   330
  17.       Left            =   1680
  18.       ScaleHeight     =   22
  19.       ScaleMode       =   3  'Pixel
  20.       ScaleWidth      =   27
  21.       TabIndex        =   2
  22.       Top             =   2160
  23.       Width           =   405
  24.    End
  25.    Begin VB.PictureBox PicUp 
  26.       AutoRedraw      =   -1  'True
  27.       AutoSize        =   -1  'True
  28.       BackColor       =   &H00E0E0E0&
  29.       BorderStyle     =   0  'None
  30.       Height          =   330
  31.       Left            =   1680
  32.       ScaleHeight     =   22
  33.       ScaleMode       =   3  'Pixel
  34.       ScaleWidth      =   27
  35.       TabIndex        =   1
  36.       Top             =   1800
  37.       Width           =   405
  38.    End
  39.    Begin VB.PictureBox PicDown 
  40.       AutoRedraw      =   -1  'True
  41.       AutoSize        =   -1  'True
  42.       BackColor       =   &H00AEAEAE&
  43.       BorderStyle     =   0  'None
  44.       Height          =   330
  45.       Left            =   1680
  46.       ScaleHeight     =   22
  47.       ScaleMode       =   3  'Pixel
  48.       ScaleWidth      =   27
  49.       TabIndex        =   0
  50.       Top             =   2520
  51.       Width           =   405
  52.    End
  53.    Begin VB.Label lblCaption 
  54.       AutoSize        =   -1  'True
  55.       BackStyle       =   0  'Transparent
  56.       Caption         =   "Button"
  57.       BeginProperty Font 
  58.          Name            =   "Segoe UI"
  59.          Size            =   9
  60.          Charset         =   0
  61.          Weight          =   400
  62.          Underline       =   0   'False
  63.          Italic          =   0   'False
  64.          Strikethrough   =   0   'False
  65.       EndProperty
  66.       Height          =   225
  67.       Left            =   120
  68.       TabIndex        =   3
  69.       Top             =   120
  70.       Width           =   540
  71.    End
  72. End
  73. Attribute VB_Name = "ctlVistorButton"
  74. Attribute VB_GlobalNameSpace = False
  75. Attribute VB_Creatable = True
  76. Attribute VB_PredeclaredId = False
  77. Attribute VB_Exposed = False
  78. '**********************************************************************
  79. '*
  80. '*                         Thomas John (2003)
  81. '*                        thomas.john@swing.be
  82. '*
  83. '**********************************************************************
  84.  
  85. 'variables
  86. Private bCapture As Boolean
  87. Private lngRep As Long
  88. Private EtatBut As Long
  89. Private TransOK As Boolean
  90. Private TransparanceSz As Long
  91. Private DessusSz As Boolean
  92. Private bPanel As Boolean
  93. '
  94. '--- API AlphaBlend ------------------
  95. '
  96. Private Type BLENDFUNCTION
  97.   BlendOp As Byte
  98.   BlendFlags As Byte
  99.   SourceConstantAlpha As Byte
  100.   AlphaFormat As Byte
  101. End Type
  102. '
  103. Private Const AC_SRC_OVER = &H0
  104. '
  105. Private Const AC_SRC_ALPHA = &H1
  106. '
  107. '---------------------------------------------------
  108. Private WithEvents MinSz As Minuteur
  109. Attribute MinSz.VB_VarHelpID = -1
  110. Event Click()
  111. Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  112. Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  113. Event MouseOver(x As Single, y As Single)
  114. Event MouseOut()
  115.  
  116. Public Function DoFadeOut()
  117.     BitBlt UserControl.hDc, 0, 0, PicUp.ScaleWidth, PicUp.ScaleHeight, PicUp.hDc, 0, 0, vbSrcCopy
  118.     UserControl.Refresh
  119. End Function
  120.  
  121. Public Function DoSetCapture()
  122.      bCapture = True
  123.      lngRep = SetCapture(UserControl.hwnd)
  124. End Function
  125.  
  126. Public Function DoReleaseCapture()
  127.      bCapture = False
  128.      ReleaseCapture
  129. End Function
  130.  
  131. Private Sub lblCaption_Click()
  132.     ReleaseCapture
  133.     RaiseEvent Click
  134. End Sub
  135.  
  136. Private Sub lblCaption_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  137.     MinSz.Actif = False
  138.     EtatBut = 1
  139.     BitBlt UserControl.hDc, 0, 0, PicDown.ScaleWidth, PicDown.ScaleHeight, PicDown.hDc, 0, 0, vbSrcCopy
  140.     UserControl.Refresh
  141.     RaiseEvent MouseDown(Button, Shift, x, y)
  142. End Sub
  143.  
  144. Private Sub lblCaption_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  145.  
  146.     DoEvents
  147.     If bCapture = False Then
  148.         bCapture = True
  149.         lngRep = SetCapture(UserControl.hwnd)
  150.         DessusSz = True
  151.         If TransOK = True Then
  152.             MinSz.Actif = True
  153.         Else
  154.             BitBlt UserControl.hDc, 0, 0, PicOver.ScaleWidth, PicOver.ScaleHeight, PicOver.hDc, 0, 0, vbSrcCopy
  155.             UserControl.Refresh
  156.         End If
  157.     End If
  158.     If x < 0 Or y < 0 Or x > UserControl.Width Or y > UserControl.Height Then
  159.         DessusSz = False
  160.         If EtatBut = 1 Then
  161.             BitBlt UserControl.hDc, 0, 0, PicOver.ScaleWidth, PicOver.ScaleHeight, PicOver.hDc, 0, 0, vbSrcCopy
  162.             UserControl.Refresh
  163.         Else
  164.             bCapture = False
  165.             lngRep = ReleaseCapture
  166.             If TransOK = True Then
  167.                 MinSz.Actif = True
  168.             Else
  169.                 BitBlt UserControl.hDc, 0, 0, PicUp.ScaleWidth, PicUp.ScaleHeight, PicUp.hDc, 0, 0, vbSrcCopy
  170.                 UserControl.Refresh
  171.             End If
  172.         End If
  173.         RaiseEvent MouseOut
  174.     Else
  175.         DessusSz = True
  176.         If EtatBut = 1 Then
  177.             BitBlt UserControl.hDc, 0, 0, PicDown.ScaleWidth, PicDown.ScaleHeight, PicDown.hDc, 0, 0, vbSrcCopy
  178.             UserControl.Refresh
  179.         Else
  180.             If TransOK = True Then
  181.                 MinSz.Actif = True
  182.             Else
  183.                 BitBlt UserControl.hDc, 0, 0, PicOver.ScaleWidth, PicOver.ScaleHeight, PicOver.hDc, 0, 0, vbSrcCopy
  184.                 UserControl.Refresh
  185.             End If
  186.  
  187.         End If
  188.         RaiseEvent MouseOver(x, y)
  189.     End If
  190.  
  191. End Sub
  192.  
  193. Private Sub lblCaption_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  194.     '
  195.     EtatBut = 0
  196.     bCapture = False
  197.     lngRep = ReleaseCapture
  198.     '
  199.     If DessusSz = False Then
  200.         '
  201.         MinSz.Actif = True
  202.         '
  203.     Else
  204.         '
  205.         MinSz.Actif = False
  206.         TransparanceSz = 0
  207.         '
  208.         BitBlt UserControl.hDc, 0, 0, PicUp.ScaleWidth, PicUp.ScaleHeight, PicUp.hDc, 0, 0, vbSrcCopy
  209.         '
  210.         UserControl.Refresh
  211.         '
  212.     End If
  213.     RaiseEvent MouseUp(Button, Shift, x, y)
  214.     '
  215. End Sub
  216.  
  217.  
  218. Private Sub MinSz_Action()
  219. On Error Resume Next
  220.  
  221.     Dim lBlend As Long
  222.     Dim bf As BLENDFUNCTION
  223.     '
  224.     If DessusSz = True Then
  225.         '
  226.         TransparanceSz = TransparanceSz + 10
  227.         If TransparanceSz >= 128 Then
  228.             '
  229.             MinSz.Actif = False
  230.             TransparanceSz = 128
  231.             '
  232.         End If
  233.         '
  234.         bf.BlendOp = 0
  235.         bf.BlendFlags = 0
  236.         bf.SourceConstantAlpha = TransparanceSz
  237.         bf.AlphaFormat = 0
  238.         CopyMemory lBlend, bf, 4
  239.         '
  240.         AlphaBlend UserControl.hDc, 0, 0, PicOver.ScaleWidth, PicOver.ScaleHeight, PicOver.hDc, 0, 0, PicOver.ScaleWidth, PicOver.ScaleHeight, lBlend
  241.         '
  242.     Else
  243.         '
  244.         TransparanceSz = TransparanceSz - 10
  245.         '
  246.         If TransparanceSz <= 0 Then
  247.             '
  248.             MinSz.Actif = False
  249.             TransparanceSz = 0
  250.             '
  251.         End If
  252.         '
  253.         bf.BlendOp = 0
  254.         bf.BlendFlags = 0
  255.         bf.SourceConstantAlpha = 128 - TransparanceSz
  256.         bf.AlphaFormat = 0
  257.         CopyMemory lBlend, bf, 4
  258.         '
  259.         AlphaBlend UserControl.hDc, 0, 0, PicUp.ScaleWidth, PicUp.ScaleHeight, PicUp.hDc, 0, 0, PicUp.ScaleWidth, PicUp.ScaleHeight, lBlend
  260.         '
  261.     End If
  262.     '
  263.     UserControl.Refresh
  264.     '
  265. End Sub
  266.  
  267. '
  268. Private Sub UserControl_Initialize()
  269.     '
  270.     PicUp.Visible = False
  271.     PicDown.Visible = False
  272.     PicOver.Visible = False
  273.     '
  274.     EtatBut = 0
  275.     TransparanceSz = 0
  276.     DessusSz = False
  277.     '
  278.     Set MinSz = New Minuteur
  279.     MinSz.Intervalle = 40
  280.     DoFadeOut
  281.     UserControl_Resize
  282.     '
  283. End Sub
  284. '
  285. Private Sub UserControl_InitProperties()
  286.     '
  287.     TransOK = False
  288.     '
  289. End Sub
  290. '
  291. Private Sub UserControl_DblClick()
  292.     
  293.     UserControl_MouseDown 1, 0, 0, 0
  294.     
  295. End Sub
  296. '
  297. Private Sub UserControl_Click()
  298.     '
  299.     ReleaseCapture
  300.     'RaiseEvent Click
  301.     '
  302. End Sub
  303. '
  304. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  305.     '
  306.     If bPanel = False Then
  307.     MinSz.Actif = False
  308.     EtatBut = 1
  309.     BitBlt UserControl.hDc, 0, 0, PicDown.ScaleWidth, PicDown.ScaleHeight, PicDown.hDc, 0, 0, vbSrcCopy
  310.     UserControl.Refresh
  311.     End If
  312.     RaiseEvent MouseDown(Button, Shift, x, y)
  313.     '
  314. End Sub
  315. '
  316. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  317.     
  318.     DoEvents
  319.     If bCapture = False Then
  320.         '
  321.         bCapture = True
  322.         lngRep = SetCapture(UserControl.hwnd)
  323.         '
  324.         DessusSz = True
  325.         If TransOK = True Then
  326.             '
  327.             MinSz.Actif = True
  328.             '
  329.         Else
  330.             'UserControl.Picture = PicOver.Picture
  331.             BitBlt UserControl.hDc, 0, 0, PicOver.ScaleWidth, PicOver.ScaleHeight, PicOver.hDc, 0, 0, vbSrcCopy
  332.             '
  333.             UserControl.Refresh
  334.             '
  335.         End If
  336.         '
  337.     End If
  338.     '
  339.     If x < 0 Or y < 0 Or x > UserControl.ScaleWidth Or y > UserControl.ScaleHeight Then
  340.         '
  341.         DessusSz = False
  342.         If EtatBut = 1 Then
  343.             '
  344.             'UserControl.Picture = PicOver.Picture
  345.             BitBlt UserControl.hDc, 0, 0, PicOver.ScaleWidth, PicOver.ScaleHeight, PicOver.hDc, 0, 0, vbSrcCopy
  346.             '
  347.             UserControl.Refresh
  348.             '
  349.         Else
  350.             '
  351.             bCapture = False
  352.             lngRep = ReleaseCapture
  353.             If TransOK = True Then
  354.                 '
  355.                 MinSz.Actif = True
  356.                 '
  357.             Else
  358.                 '
  359.                 'UserControl.Picture = PicUp.Picture
  360.                 BitBlt UserControl.hDc, 0, 0, PicUp.ScaleWidth, PicUp.ScaleHeight, PicUp.hDc, 0, 0, vbSrcCopy
  361.                 '
  362.                 UserControl.Refresh
  363.                 '
  364.             End If
  365.             '
  366.         End If
  367.         '
  368.         RaiseEvent MouseOut
  369.         '
  370.     Else
  371.         '
  372.         '
  373.         DessusSz = True
  374.         '
  375.         If EtatBut = 1 Then
  376.             '
  377.             'UserControl.Picture = PicDown.Picture
  378.             BitBlt UserControl.hDc, 0, 0, PicDown.ScaleWidth, PicDown.ScaleHeight, PicDown.hDc, 0, 0, vbSrcCopy
  379.             '
  380.             UserControl.Refresh
  381.             '
  382.         Else
  383.             '
  384.             If TransOK = True Then
  385.                 '
  386.                 MinSz.Actif = True
  387.                 '
  388.             Else
  389.                 '
  390.                 BitBlt UserControl.hDc, 0, 0, PicOver.ScaleWidth, PicOver.ScaleHeight, PicOver.hDc, 0, 0, vbSrcCopy
  391.                 UserControl.Refresh
  392.                 '
  393.             End If
  394.             '
  395.         End If
  396.         '
  397.         RaiseEvent MouseOver(x, y)
  398.         '
  399.     End If
  400.     '
  401. End Sub
  402. '
  403. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  404.     '
  405.     EtatBut = 0
  406.     bCapture = False
  407.     lngRep = ReleaseCapture
  408.     '
  409.     If DessusSz = False Then
  410.         '
  411.         MinSz.Actif = True
  412.         '
  413.     Else
  414.         If bPanel = False Then '
  415.         MinSz.Actif = False
  416.         TransparanceSz = 0
  417.         'UserControl.Picture = PicUp.Picture
  418.         BitBlt UserControl.hDc, 0, 0, PicUp.ScaleWidth, PicUp.ScaleHeight, PicUp.hDc, 0, 0, vbSrcCopy
  419.         UserControl.Refresh
  420.         End If
  421.     End If
  422.     '
  423.     RaiseEvent Click
  424.     RaiseEvent MouseUp(Button, Shift, x, y)
  425.     '
  426. End Sub
  427. '
  428. Private Sub UserControl_Resize()
  429.     '
  430.     UserControl.Width = PicUp.Width
  431.     UserControl.Height = PicUp.Height
  432.     lblCaption.Left = UserControl.Width / 2 - lblCaption.Width / 2
  433.     lblCaption.Top = UserControl.Height / 2 - lblCaption.Height / 2 + 10
  434.     '
  435. End Sub
  436. '
  437. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  438.     '
  439.     With PropBag
  440.         '
  441.         PicUp.Picture = .ReadProperty("ImgUp")
  442.         PicDown.Picture = .ReadProperty("ImgDown")
  443.         PicOver.Picture = .ReadProperty("ImgOver")
  444.         lblCaption.Caption = .ReadProperty("Caption", "ChariButton")
  445.         TransOK = .ReadProperty("UseAlphaBlend", False)
  446.         bPanel = .ReadProperty("Panel", False)
  447.         '
  448.     End With
  449.     '
  450.     'UserControl.Picture = PicUp.Picture
  451.     BitBlt UserControl.hDc, 0, 0, PicUp.ScaleWidth, PicUp.ScaleHeight, PicUp.hDc, 0, 0, vbSrcCopy
  452.     '
  453.     UserControl_Resize
  454.     '
  455. End Sub
  456. '
  457. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  458.     '
  459.     With PropBag
  460.         '
  461.         .WriteProperty "ImgUp", PicUp.Picture
  462.         .WriteProperty "ImgDown", PicDown.Picture
  463.         .WriteProperty "ImgOver", PicOver.Picture
  464.         .WriteProperty "Caption", lblCaption.Caption, "ChariButton"
  465.         .WriteProperty "UseAlphaBlend", TransOK, False
  466.         .WriteProperty "Panel", bPanel, False
  467.         '
  468.     End With
  469.     '
  470. End Sub
  471. '
  472. '*******************************************************************************************************
  473. '* PROPRIETES
  474. '*******************************************************************************************************
  475. '
  476. 'UTILISATION DE LA TRANSPARANCE OU PAS
  477. Public Property Let UseAlphaBlend(Valeur As Boolean)
  478.     '
  479.     TransOK = Valeur
  480.     '
  481.     PropertyChanged "UseAlphaBlend"
  482.     '
  483. End Property
  484. '
  485. Public Property Get UseAlphaBlend() As Boolean
  486.     '
  487.     UseAlphaBlend = TransOK
  488.     '
  489. End Property
  490.  
  491. Public Property Get Caption() As String
  492.     Caption = lblCaption.Caption
  493. End Property
  494.  
  495. Public Property Let Caption(strCaption As String)
  496.     lblCaption.Caption = strCaption
  497.     PropertyChanged "Caption"
  498.     lblCaption.Left = UserControl.Width / 2 - lblCaption.Width / 2
  499. End Property
  500.  
  501. Public Property Get Panel() As Boolean
  502.     Panel = bPanel
  503. End Property
  504.  
  505. Public Property Let Panel(value As Boolean)
  506.     bPanel = value
  507.     PropertyChanged "Panel"
  508. End Property
  509.  
  510. 'IMAGE BOUTTON NORMAL
  511. Public Property Let ImgUp(Valeur As StdPicture)
  512.     '
  513.     PicUp.Picture = Valeur
  514.     PropertyChanged "ImgUp"
  515.     UserControl_Resize
  516.     '
  517. End Property
  518. '
  519. Public Property Set ImgUp(Valeur As StdPicture)
  520.     '
  521.     PicUp.Picture = Valeur
  522.     PropertyChanged "ImgUp"
  523.     UserControl_Resize
  524.     '
  525. End Property
  526. '
  527. Public Property Get ImgUp() As StdPicture
  528.     '
  529.     Set ImgUp = PicUp.Picture
  530.     '
  531. End Property
  532. '
  533. 'IMAGE BOUTTON PRESSE
  534. Public Property Let ImgDown(Valeur As StdPicture)
  535.     '
  536.     PicDown.Picture = Valeur
  537.     PropertyChanged "ImgDown"
  538.     UserControl_Resize
  539.     '
  540. End Property
  541. '
  542. Public Property Set ImgDown(Valeur As StdPicture)
  543.     '
  544.     PicDown.Picture = Valeur
  545.     PropertyChanged "ImgDown"
  546.     UserControl_Resize
  547.     '
  548. End Property
  549. '
  550. Public Property Get ImgDown() As StdPicture
  551.     '
  552.     Set ImgDown = PicDown.Picture
  553.     '
  554. End Property
  555. '
  556. Public Property Let ImgOver(Valeur As StdPicture)
  557.     '
  558.     PicOver.Picture = Valeur
  559.     PropertyChanged "ImgOver"
  560.     UserControl_Resize
  561.     '
  562. End Property
  563. '
  564. Public Property Set ImgOver(Valeur As StdPicture)
  565.     '
  566.     PicOver.Picture = Valeur
  567.     PropertyChanged "ImgOver"
  568.     UserControl_Resize
  569.     '
  570. End Property
  571. '
  572. Public Property Get ImgOver() As StdPicture
  573.     '
  574.     Set ImgOver = PicOver.Picture
  575.     '
  576. End Property
  577.