|
Code des Controls ListBoxMaskOCX
UserControl ListBoxMask (Public):
Private Const kMarginWidth = 2
Public Event Click()
Public Event DblClick()
Public Event MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Public Event OLEDragDrop(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event OLEDragOver(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single, _
State As Integer)
Public Enum lbmAppearanceConstants
lbm2D
lbm3D
End Enum
Public Enum lbmOLEDropConstants
lbmOLEDropNone = vbOLEDropNone
lbmOLEDropManual = vbOLEDropManual
lbmOLEDropContainer = 99
End Enum
Private pMarginWidth As Single
Private pOLEDropMode As lbmOLEDropConstants
Private pShowMask As Boolean
Public Property Get Appearance() As lbmAppearanceConstants
Appearance = ucBorder.Appearance
End Property
Public Property Let Appearance(ByVal New_Appearance _
As lbmAppearanceConstants)
Select Case New_Appearance
Case ucBorder.Appearance
Case lbm2D, lbm3D
ucBorder.Appearance = New_Appearance
UserControl_Resize
Case Else
Err.Raise 380
End Select
PropertyChanged "Appearance"
End Property
Public Property Get MarginColor() As OLE_COLOR
MarginColor = ucBorder.BackColor
End Property
Public Property Let MarginColor(ByVal New_MarginColor As OLE_COLOR)
ucBorder.BackColor = New_MarginColor
PropertyChanged "MarginColor"
End Property
Public Property Get MarginWidth() As Single
MarginWidth = pMarginWidth * Screen.TwipsPerPixelX
End Property
Public Property Let MarginWidth(ByVal New_MarginWidth As Single)
Select Case New_MarginWidth
Case pMarginWidth
Case Is >= 2 * Screen.TwipsPerPixelX
pMarginWidth = New_MarginWidth \ Screen.TwipsPerPixelX
UserControl_Resize
Case Else
pMarginWidth = 2
UserControl_Resize
End Select
PropertyChanged "MarginWidth"
End Property
Public Property Get MaskColor() As OLE_COLOR
MaskColor = UserControl.BackColor
End Property
Public Property Let MaskColor(ByVal New_MaskColor As OLE_COLOR)
UserControl.BackColor = New_MaskColor
PropertyChanged "MaskColor"
End Property
Public Property Get OLEDropMode() As lbmOLEDropConstants
OLEDropMode = pOLEDropMode
End Property
Public Property Let OLEDropMode(ByVal New_OLEDropMode _
As lbmOLEDropConstants)
Select Case New_OLEDropMode
Case lbmOLEDropContainer
pOLEDropMode = New_OLEDropMode
On Error Resume Next
UserControl.OLEDropMode = Extender.Container.OLEDropMode
If Err.Number Then
Err.Clear
UserControl.OLEDropMode = vbOLEDropNone
End If
Case lbmOLEDropNone, lbmOLEDropManual
pOLEDropMode = New_OLEDropMode
UserControl.OLEDropMode = pOLEDropMode
Case Else
Err.Raise 380
End Select
PropertyChanged "OLEDropMode"
End Property
Public Property Get ShowMask() As Boolean
ShowMask = pShowMask
End Property
Public Property Let ShowMask(ByVal New_ShowMask As Boolean)
If pShowMask <> New_ShowMask Then
pShowMask = New_ShowMask
UserControl_Resize
End If
PropertyChanged "ShowMask"
End Property
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub
Private Sub UserControl_MouseDown(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
Dim nX As Single
Dim nY As Single
If zConvertToContainer(X, Y, nX, nY) Then
RaiseEvent MouseDown(Button, Shift, nX, nY)
End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
Dim nX As Single
Dim nY As Single
If zConvertToContainer(X, Y, nX, nY) Then
RaiseEvent MouseMove(Button, Shift, nX, nY)
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
Dim nX As Single
Dim nY As Single
If zConvertToContainer(X, Y, nX, nY) Then
RaiseEvent MouseUp(Button, Shift, nX, nY)
End If
End Sub
Private Sub UserControl_OLEDragDrop(Data As DataObject, _
Effect As Long, Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Dim nX As Single
Dim nY As Single
If zConvertToContainer(X, Y, nX, nY) Then
RaiseEvent OLEDragDrop(Data, Effect, Button, Shift, nX, nY)
End If
End Sub
Private Sub UserControl_OLEDragOver(Data As DataObject, _
Effect As Long, Button As Integer, Shift As Integer, _
X As Single, Y As Single, State As Integer)
Dim nX As Single
Dim nY As Single
If zConvertToContainer(X, Y, nX, nY) Then
RaiseEvent OLEDragOver(Data, Effect, Button, Shift, _
nX, nY, State)
End If
End Sub
Private Sub UserControl_Initialize()
pMarginWidth = kMarginWidth
pShowMask = True
End Sub
Private Sub UserControl_InitProperties()
ucBorder.BackColor = vbWindowBackground
UserControl.BackColor = Ambient.BackColor
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
ucBorder.Appearance = PropBag.ReadProperty("Appearance", lbm3D)
ucBorder.BackColor = PropBag.ReadProperty("MarginColor", _
vbWindowBackground)
pMarginWidth = PropBag.ReadProperty("MarginWidth", kMarginWidth)
UserControl.BackColor = PropBag.ReadProperty("MaskColor", _
Ambient.BackColor)
Me.OLEDropMode = PropBag.ReadProperty("OLEDropMode", _
lbmOLEDropNone)
pShowMask = PropBag.ReadProperty("ShowMask", True)
End Sub
Private Sub UserControl_Resize()
If pShowMask Then
ln.Visible = False
With UserControl
If .Width < 6 * Screen.TwipsPerPixelX Then
ucBorder.Visible = False
Else
On Error Resume Next
ucBorder.Move .ScaleWidth - _
(pMarginWidth * Screen.TwipsPerPixelX), 0, _
.Width, .ScaleHeight
ucBorder.Visible = Not CBool(Err.Number)
Err.Clear
End If
End With
UserControl.BackStyle = 1
Else
ucBorder.Visible = False
UserControl.BackStyle = 0
If Ambient.UserMode Then
ln.Visible = False
Else
ln.X1 = UserControl.ScaleWidth - Screen.TwipsPerPixelX
ln.X2 = ln.X1
ln.Y1 = 0
ln.Y2 = UserControl.ScaleHeight
ln.Visible = True
ln.Refresh
End If
End If
ucBorder.Refresh
UserControl.Refresh
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "Appearance", ucBorder.Appearance, lbm3D
PropBag.WriteProperty "MarginColor", ucBorder.BackColor, _
vbWindowBackground
PropBag.WriteProperty "MaskColor", UserControl.BackColor, _
Ambient.BackColor
PropBag.WriteProperty "MarginWidth", pMarginWidth, kMarginWidth
PropBag.WriteProperty "OLEDropMode", pOLEDropMode, lbmOLEDropNone
PropBag.WriteProperty "ShowMask", pShowMask, True
End Sub
Private Function zConvertToContainer(ByVal X As Single, _
ByVal Y As Single, rX As Single, rY As Single) As Boolean
If X < ucBorder.Left Then
With Extender
rX = UserControl.ScaleX(X, vbTwips, vbContainerPosition) _
+ .Left
rY = UserControl.ScaleY(Y, vbTwips, vbContainerPosition) _
+ .Top
End With
zConvertToContainer = True
End If
End Function
UserControl ucBorder (Private):
Private pBackColor As Long
Public Property Get Appearance() As Integer
Appearance = UserControl.Appearance
End Property
Public Property Let Appearance(ByVal New_Appearance As Integer)
UserControl.Appearance = New_Appearance
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = pBackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
pBackColor = New_BackColor
UserControl.BackColor = pBackColor
End Property
Public Sub Refresh()
UserControl.Refresh
UserControl.BackColor = pBackColor
End Sub
|