home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD94408302000.psc / ButtonEx_PSC / ButtonEx.ctl next >
Encoding:
Visual Basic user-defined control file  |  2000-08-30  |  43.0 KB  |  1,135 lines
  1. VERSION 5.00
  2. Begin VB.UserControl ButtonEx 
  3.    AutoRedraw      =   -1  'True
  4.    ClientHeight    =   2265
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   3345
  8.    DefaultCancel   =   -1  'True
  9.    ScaleHeight     =   151
  10.    ScaleMode       =   3  'Pixel
  11.    ScaleWidth      =   223
  12.    ToolboxBitmap   =   "ButtonEx.ctx":0000
  13.    Begin VB.PictureBox pictNewPicture 
  14.       AutoRedraw      =   -1  'True
  15.       AutoSize        =   -1  'True
  16.       BorderStyle     =   0  'None
  17.       Height          =   495
  18.       Left            =   240
  19.       ScaleHeight     =   495
  20.       ScaleWidth      =   1215
  21.       TabIndex        =   3
  22.       Top             =   1560
  23.       Visible         =   0   'False
  24.       Width           =   1215
  25.    End
  26.    Begin VB.PictureBox pictTempHighlight 
  27.       AutoRedraw      =   -1  'True
  28.       AutoSize        =   -1  'True
  29.       BorderStyle     =   0  'None
  30.       Height          =   495
  31.       Left            =   1800
  32.       ScaleHeight     =   495
  33.       ScaleWidth      =   1215
  34.       TabIndex        =   2
  35.       Top             =   240
  36.       Visible         =   0   'False
  37.       Width           =   1215
  38.    End
  39.    Begin VB.PictureBox pictTempDestination 
  40.       AutoRedraw      =   -1  'True
  41.       AutoSize        =   -1  'True
  42.       BorderStyle     =   0  'None
  43.       Height          =   495
  44.       Left            =   1800
  45.       ScaleHeight     =   495
  46.       ScaleWidth      =   1215
  47.       TabIndex        =   1
  48.       Top             =   960
  49.       Visible         =   0   'False
  50.       Width           =   1215
  51.    End
  52.    Begin VB.PictureBox imgPicture 
  53.       AutoRedraw      =   -1  'True
  54.       AutoSize        =   -1  'True
  55.       BorderStyle     =   0  'None
  56.       Height          =   495
  57.       Left            =   240
  58.       ScaleHeight     =   495
  59.       ScaleWidth      =   1215
  60.       TabIndex        =   0
  61.       Top             =   720
  62.       Visible         =   0   'False
  63.       Width           =   1215
  64.    End
  65.    Begin VB.Timer Timer1 
  66.       Enabled         =   0   'False
  67.       Interval        =   1
  68.       Left            =   720
  69.       Top             =   120
  70.    End
  71. End
  72. Attribute VB_Name = "ButtonEx"
  73. Attribute VB_GlobalNameSpace = False
  74. Attribute VB_Creatable = True
  75. Attribute VB_PredeclaredId = False
  76. Attribute VB_Exposed = False
  77. Option Explicit
  78. '**************************************************************
  79. '*  FILE:  ButtonEx.ctl                                       *
  80. '*                                                            *
  81. '*  DESCRIPTION:                                              *
  82. '*      Provides a enhanced CommandButton control, including  *
  83. '*      custom graphics as well MouseOver event, etc.         *
  84. '*                                                            *
  85. '*  CHANGE HISTORY:                                           *
  86. '*      Aug 2000    J. Pearson      Initial code              *
  87. '**************************************************************
  88.  
  89. '//---------------------------------------------------------------------------------------
  90. '// Windows API constants
  91. '//---------------------------------------------------------------------------------------
  92. Private Const BLACKNESS = &H42              '(DWORD) dest = BLACK
  93. Private Const NOTSRCCOPY = &H330008         '(DWORD) dest = (NOT source)
  94. Private Const NOTSRCERASE = &H1100A6        '(DWORD) dest = (NOT src) AND (NOT dest)
  95. Private Const SRCAND = &H8800C6             '(DWORD) dest = source AND dest
  96. Private Const SRCCOPY = &HCC0020            '(DWORD) dest = source
  97. Private Const SRCERASE = &H440328           '(DWORD) dest = source AND (NOT dest )
  98. Private Const SRCINVERT = &H660046          '(DWORD) dest = source XOR dest
  99. Private Const SRCPAINT = &HEE0086           '(DWORD) dest = source OR dest
  100. Private Const WHITENESS = &HFF0062          '(DWORD) dest = WHITE
  101.  
  102. Private Const BDR_RAISEDINNER = &H4
  103. Private Const BDR_RAISEDOUTER = &H1
  104. Private Const BDR_SUNKENINNER = &H8
  105. Private Const BDR_SUNKENOUTER = &H2
  106.  
  107. Private Const BDR_RAISED = &H5
  108. Private Const BDR_OUTER = &H3
  109. Private Const BDR_INNER = &HC
  110.  
  111. Private Const BF_ADJUST = &H2000        'Calculate the space left over.
  112. Private Const BF_FLAT = &H4000          'For flat rather than 3-D borders.
  113. Private Const BF_MONO = &H8000          'For monochrome borders.
  114. Private Const BF_SOFT = &H1000          'Use for softer buttons.
  115. Private Const BF_BOTTOM = &H8
  116. Private Const BF_LEFT = &H1
  117. Private Const BF_RIGHT = &H4
  118. Private Const BF_TOP = &H2
  119. Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
  120.  
  121. Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
  122. Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
  123. Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
  124. Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
  125.  
  126. Private Const DT_CENTER = &H1
  127. Private Const DT_RTLREADING = &H20000
  128. Private Const DT_SINGLELINE = &H20
  129. Private Const DT_VCENTER = &H4
  130.  
  131. Private Const DST_COMPLEX = &H0
  132. Private Const DST_TEXT = &H1
  133. Private Const DST_PREFIXTEXT = &H2
  134. Private Const DST_ICON = &H3
  135. Private Const DST_BITMAP = &H4
  136.  
  137. Private Const DSS_NORMAL = &H0
  138. Private Const DSS_UNION = &H10                   '/* Gray string appearance */
  139. Private Const DSS_DISABLED = &H20
  140. Private Const DSS_RIGHT = &H8000
  141.  
  142. '//---------------------------------------------------------------------------------------
  143. '// Windows API types
  144. '//---------------------------------------------------------------------------------------
  145. Private Type POINTAPI
  146.     X As Long
  147.     Y As Long
  148. End Type
  149.  
  150. Private Type RECT
  151.     Left As Long
  152.     Top As Long
  153.     Right As Long
  154.     Bottom As Long
  155. End Type
  156.  
  157. '//---------------------------------------------------------------------------------------
  158. '// Windows API declarations
  159. '//---------------------------------------------------------------------------------------
  160. Private Declare Function BitBlt Lib "gdi32" (ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
  161. Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
  162. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  163. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  164. Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
  165. Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, lpRect As RECT) As Long
  166. Private Declare Function DrawState Lib "user32" Alias "DrawStateA" (ByVal hDC As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal lParam As Long, ByVal wParam As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
  167. Private Declare Function DrawStateText Lib "user32" Alias "DrawStateA" (ByVal hDC As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal lParam As String, ByVal wParam As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
  168. Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
  169. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  170. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  171. Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
  172. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
  173. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  174. Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
  175. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  176. Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
  177.  
  178. '//---------------------------------------------------------------------------------------
  179. '// Private constants
  180. '//---------------------------------------------------------------------------------------
  181. Private Enum BorderTypeEnum
  182.     btDown
  183.     btUp
  184.     btOver
  185. End Enum
  186.  
  187. Private Enum RasterOperationConstants
  188.     roNotSrcCopy = NOTSRCCOPY
  189.     roNotSrcErase = NOTSRCERASE
  190.     roSrcAnd = SRCAND
  191.     roSrcCopy = SRCCOPY
  192.     roSrcErase = SRCERASE
  193.     roSrcInvert = SRCINVERT
  194.     roSrcPaint = SRCPAINT
  195. End Enum
  196.  
  197. '//---------------------------------------------------------------------------------------
  198. '// Private constants
  199. '//---------------------------------------------------------------------------------------
  200. Private lState As BorderTypeEnum
  201. Private bLeftFocus As Boolean
  202. Private bHasFocus As Boolean
  203.  
  204. '//---------------------------------------------------------------------------------------
  205. '// Public constants
  206. '//---------------------------------------------------------------------------------------
  207. Public Enum beAppearance
  208.     Flat = 0
  209.     [3D] = 1
  210. End Enum
  211.  
  212. '//---------------------------------------------------------------------------------------
  213. '// Control property constants
  214. '//---------------------------------------------------------------------------------------
  215. Private Const m_def_Appearance = [3D]
  216. Private Const m_def_BackColor = vbButtonFace
  217. Private Const m_def_Caption = "ButtonEx1"
  218. Private Const m_def_Enabled = True
  219. Private Const m_def_ForeColor = vbButtonText
  220. Private Const m_def_HighlightColor = vbButtonText
  221. Private Const m_def_HighlightPicture = False
  222. Private Const m_def_MousePointer = vbDefault
  223. Private Const m_def_RightToLeft = False
  224. Private Const m_def_ToolTipText = ""
  225. Private Const m_def_TransparentColor = vbBlue
  226. Private Const m_def_WhatsThisHelpID = 0
  227.  
  228. '//---------------------------------------------------------------------------------------
  229. '// Control property variables
  230. '//---------------------------------------------------------------------------------------
  231. Private m_Appearance As beAppearance
  232. Private m_BackColor As OLE_COLOR
  233. Private m_Caption As String
  234. Private m_Enabled As Boolean
  235. Private m_ForeColor As OLE_COLOR
  236. Private m_Font As Font
  237. Private m_HighlightColor As OLE_COLOR
  238. Private m_HighlightPicture As Boolean
  239. Private m_MouseIcon As Picture
  240. Private m_MousePointer As MousePointerConstants
  241. Private m_Picture As Picture
  242. Private m_RightToLeft As Boolean
  243. Private m_ToolTipText As String
  244. Private m_TransparentColor As OLE_COLOR
  245. Private m_WhatsThisHelpID As Long
  246.  
  247. '//---------------------------------------------------------------------------------------
  248. '// Control property events
  249. '//---------------------------------------------------------------------------------------
  250. Public Event Click()
  251. Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
  252. Public Event KeyDown(KeyCode As Integer, Shift As Integer)
  253. Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
  254. Public Event KeyPress(KeyAscii As Integer)
  255. Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
  256. Public Event KeyUp(KeyCode As Integer, Shift As Integer)
  257. Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
  258. Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  259. Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
  260. Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  261. Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
  262. Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  263. Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."
  264. Public Event Resize()
  265. Attribute Resize.VB_Description = "Occurs when a form is first displayed or the size of an object changes."
  266.  
  267. '//---------------------------------------------------------------------------------------
  268. '// Control properties
  269. '//---------------------------------------------------------------------------------------
  270.  
  271. Public Property Get Appearance() As beAppearance
  272. Attribute Appearance.VB_Description = "Returns/sets whether or not an object is painted with 3-D effects."
  273.     Appearance = m_Appearance
  274. End Property
  275.  
  276. Public Property Let Appearance(ByVal NewValue As beAppearance)
  277.     m_Appearance = NewValue
  278.         
  279.     Call DrawButton(lState)
  280.     
  281.     PropertyChanged "Appearance"
  282. End Property
  283.  
  284. Public Property Get BackColor() As OLE_COLOR
  285. Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
  286.     BackColor = m_BackColor
  287. End Property
  288.  
  289. Public Property Let BackColor(ByVal NewValue As OLE_COLOR)
  290.     m_BackColor = NewValue
  291.     UserControl.BackColor = NewValue
  292.     imgPicture.BackColor = NewValue
  293.     
  294.     Call DrawButton(lState)
  295.     
  296.     PropertyChanged "BackColor"
  297. End Property
  298.  
  299. Public Property Get Caption() As String
  300. Attribute Caption.VB_Description = "Returns/sets the text displayed in an object."
  301.     Caption = m_Caption
  302. End Property
  303.  
  304. Public Property Let Caption(ByVal NewValue As String)
  305.     Dim lPlace As Long
  306.     
  307.     m_Caption = NewValue
  308.     
  309.     'set access key
  310.     lPlace = 0
  311.     lPlace = InStr(lPlace + 1, NewValue, "&", vbTextCompare)
  312.     Do While lPlace <> 0
  313.         If Mid$(NewValue, lPlace + 1, 1) <> "&" Then
  314.             UserControl.AccessKeys = Mid$(NewValue, lPlace + 1, 1)
  315.             Exit Do
  316.         Else
  317.             lPlace = lPlace + 1
  318.         End If
  319.     
  320.         lPlace = InStr(lPlace + 1, NewValue, "&", vbTextCompare)
  321.     Loop
  322.     
  323.     Call DrawButton(lState)
  324.     
  325.     PropertyChanged "Caption"
  326. End Property
  327.  
  328. Public Property Get Enabled() As Boolean
  329. Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
  330.     Enabled = m_Enabled
  331. End Property
  332.  
  333. Public Property Let Enabled(ByVal NewValue As Boolean)
  334.     m_Enabled = NewValue
  335.     UserControl.Enabled = NewValue
  336.     imgPicture.Enabled = NewValue
  337.     
  338.     Call DrawButton(lState)
  339.     
  340.     PropertyChanged "Enabled"
  341. End Property
  342.  
  343. Public Property Get ForeColor() As OLE_COLOR
  344. Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
  345.     ForeColor = m_ForeColor
  346. End Property
  347.  
  348. Public Property Let ForeColor(ByVal NewValue As OLE_COLOR)
  349.     m_ForeColor = NewValue
  350.     UserControl.ForeColor = NewValue
  351.     imgPicture.ForeColor = NewValue
  352.     
  353.     Call DrawButton(lState)
  354.     
  355.     PropertyChanged "ForeColor"
  356. End Property
  357.  
  358. Public Property Get Font() As Font
  359. Attribute Font.VB_Description = "Returns/sets a Font object used to display text in the object."
  360.     Set Font = m_Font
  361. End Property
  362.  
  363. Public Property Set Font(ByVal NewValue As Font)
  364.     Set m_Font = NewValue
  365.     Set UserControl.Font = NewValue
  366.     Set imgPicture.Font = NewValue
  367.     
  368.     Call DrawButton(lState)
  369.     
  370.     PropertyChanged "Font"
  371. End Property
  372.  
  373. Public Property Get HighlightColor() As OLE_COLOR
  374. Attribute HighlightColor.VB_Description = "Returns/sets the highlight color used to display text and graphics when the  mouse is over the object"
  375.     HighlightColor = m_HighlightColor
  376. End Property
  377.  
  378. Public Property Let HighlightColor(ByVal NewValue As OLE_COLOR)
  379.     m_HighlightColor = NewValue
  380.     
  381.     Call DrawButton(lState)
  382.     
  383.     PropertyChanged "HighlightColor"
  384. End Property
  385.  
  386. Public Property Get HighlightPicture() As Boolean
  387. Attribute HighlightPicture.VB_Description = "Returns/sets whether or not to highlight the object's picture with the HighlightColor."
  388.     HighlightPicture = m_HighlightPicture
  389. End Property
  390.  
  391. Public Property Let HighlightPicture(ByVal NewValue As Boolean)
  392.     m_HighlightPicture = NewValue
  393.     PropertyChanged "HighlightPicture"
  394. End Property
  395.  
  396. Public Property Get MouseIcon() As Picture
  397. Attribute MouseIcon.VB_Description = "Returns/sets a custom mouse icon."
  398.     Set MouseIcon = m_MouseIcon
  399. End Property
  400.  
  401. Public Property Set MouseIcon(ByVal NewValue As Picture)
  402.     Set m_MouseIcon = NewValue
  403.     Set UserControl.MouseIcon = NewValue
  404.     Set imgPicture.MouseIcon = NewValue
  405.     
  406.     PropertyChanged "MouseIcon"
  407. End Property
  408.  
  409. Public Property Get MousePointer() As MousePointerConstants
  410. Attribute MousePointer.VB_Description = "Returns/sets the type of mouse pointer displayed when over part of an object."
  411.     MousePointer = m_MousePointer
  412. End Property
  413.  
  414. Public Property Let MousePointer(ByVal NewValue As MousePointerConstants)
  415.     m_MousePointer = NewValue
  416.     UserControl.MousePointer = NewValue
  417.     imgPicture.MousePointer = NewValue
  418.     
  419.     PropertyChanged "MousePointer"
  420. End Property
  421.  
  422. Public Property Get Picture() As Picture
  423. Attribute Picture.VB_Description = "Returns/sets a graphic to be displayed in a control."
  424.     Set Picture = m_Picture
  425. End Property
  426.  
  427. Public Property Set Picture(ByVal NewValue As Picture)
  428.     Set m_Picture = NewValue
  429.     Set imgPicture.Picture = NewValue
  430.     
  431.     Call DrawButton(lState)
  432.     
  433.     PropertyChanged "Picture"
  434. End Property
  435.  
  436. Public Property Get RightToLeft() As Boolean
  437. Attribute RightToLeft.VB_Description = "Determines text display direction and control visual appearance on a bidirectional system."
  438.     RightToLeft = m_RightToLeft
  439. End Property
  440.  
  441. Public Property Let RightToLeft(ByVal NewValue As Boolean)
  442.     m_RightToLeft = NewValue
  443.     UserControl.RightToLeft = NewValue
  444.     imgPicture.RightToLeft = NewValue
  445.     
  446.     Call DrawButton(lState)
  447.     
  448.     PropertyChanged "RightToLeft"
  449. End Property
  450.  
  451. Public Property Get ToolTipText() As String
  452. Attribute ToolTipText.VB_Description = "Returns/sets the text displayed when the mouse cursor is over the control."
  453.     ToolTipText = m_ToolTipText
  454. End Property
  455.  
  456. Public Property Let ToolTipText(ByVal NewValue As String)
  457.     m_ToolTipText = NewValue
  458.     imgPicture.ToolTipText = NewValue
  459.     
  460.     PropertyChanged "ToolTipText"
  461. End Property
  462.  
  463. Public Property Get TransparentColor() As OLE_COLOR
  464. Attribute TransparentColor.VB_Description = "Returns/sets the color of the Picture property to make transparent."
  465.     TransparentColor = m_TransparentColor
  466. End Property
  467.  
  468. Public Property Let TransparentColor(ByVal NewValue As OLE_COLOR)
  469.     m_TransparentColor = NewValue
  470.     
  471.     Call DrawButton(lState)
  472.     
  473.     PropertyChanged "TransparentColor"
  474. End Property
  475.  
  476. Public Property Get WhatsThisHelpID() As Long
  477. Attribute WhatsThisHelpID.VB_Description = "Returns/sets an associated help context ID for the control."
  478.     WhatsThisHelpID = m_WhatsThisHelpID
  479. End Property
  480.  
  481. Public Property Let WhatsThisHelpID(ByVal NewValue As Long)
  482.     m_WhatsThisHelpID = NewValue
  483.     imgPicture.WhatsThisHelpID = NewValue
  484.     
  485.     PropertyChanged "WhatsThisHelpID"
  486. End Property
  487.  
  488. '//---------------------------------------------------------------------------------------
  489. '// Image functions
  490. '//---------------------------------------------------------------------------------------
  491.  
  492. Private Sub imgPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  493.     Call UserControl_MouseDown(Button, Shift, imgPicture.Left + (X \ Screen.TwipsPerPixelX), imgPicture.Top + (Y \ Screen.TwipsPerPixelY))
  494. End Sub
  495.  
  496. Private Sub imgPicture_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  497.     Call UserControl_MouseMove(Button, Shift, imgPicture.Left + (X \ Screen.TwipsPerPixelX), imgPicture.Top + (Y \ Screen.TwipsPerPixelY))
  498. End Sub
  499.  
  500. Private Sub imgPicture_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  501.     Call UserControl_MouseUp(Button, Shift, imgPicture.Left + (X \ Screen.TwipsPerPixelX), imgPicture.Top + (Y \ Screen.TwipsPerPixelY))
  502. End Sub
  503.  
  504. '//---------------------------------------------------------------------------------------
  505. '// Timer functions
  506. '//---------------------------------------------------------------------------------------
  507.  
  508. Private Sub Timer1_Timer()
  509.     'check for mouse leaving control
  510.     Dim pnt As POINTAPI
  511.     
  512.     GetCursorPos pnt
  513.     ScreenToClient UserControl.hWnd, pnt
  514.     
  515.     If pnt.X < UserControl.ScaleLeft Or _
  516.             pnt.Y < UserControl.ScaleTop Or _
  517.             pnt.X > (UserControl.ScaleLeft + UserControl.ScaleWidth) Or _
  518.             pnt.Y > (UserControl.ScaleTop + UserControl.ScaleHeight) Then
  519.         Timer1.Enabled = False
  520.     
  521.         'left focus
  522.         If lState <> btUp Then
  523.             Call DrawButton(btUp)
  524.         End If
  525.         bLeftFocus = True
  526.     Else
  527.         'gained focus
  528.         If bLeftFocus Then
  529.             Call DrawButton(btDown)
  530.         End If
  531.     End If
  532. End Sub
  533.  
  534. '//---------------------------------------------------------------------------------------
  535. '// UserControl functions
  536. '//---------------------------------------------------------------------------------------
  537.  
  538. Private Sub UserControl_InitProperties()
  539.     'Initialize Properties for User Control
  540.     Appearance = m_def_Appearance
  541.     BackColor = m_def_BackColor
  542.     Caption = m_def_Caption
  543.     Enabled = m_def_Enabled
  544.     ForeColor = m_def_ForeColor
  545.     Set Font = Ambient.Font
  546.     HighlightColor = m_def_HighlightColor
  547.     HighlightPicture = m_def_HighlightPicture
  548.     Set MouseIcon = LoadPicture("")
  549.     MousePointer = m_def_MousePointer
  550.     Set Picture = LoadPicture("")
  551.     RightToLeft = m_def_RightToLeft
  552.     ToolTipText = m_def_ToolTipText
  553.     TransparentColor = m_def_TransparentColor
  554.     WhatsThisHelpID = m_def_WhatsThisHelpID
  555. End Sub
  556.  
  557. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  558.     'Load property values from storage
  559.     Appearance = PropBag.ReadProperty("Appearance", m_def_Appearance)
  560.     BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
  561.     Caption = PropBag.ReadProperty("Caption", m_def_Caption)
  562.     Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
  563.     ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
  564.     Set Font = PropBag.ReadProperty("Font", Ambient.Font)
  565.     HighlightColor = PropBag.ReadProperty("HighlightColor", m_def_HighlightColor)
  566.     HighlightPicture = PropBag.ReadProperty("HighlightPicture", m_def_HighlightPicture)
  567.     Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
  568.     MousePointer = PropBag.ReadProperty("MousePointer", m_def_MousePointer)
  569.     Set Picture = PropBag.ReadProperty("Picture", Nothing)
  570.     RightToLeft = PropBag.ReadProperty("RightToLeft", m_def_RightToLeft)
  571.     ToolTipText = PropBag.ReadProperty("ToolTipText", m_def_ToolTipText)
  572.     TransparentColor = PropBag.ReadProperty("TransparentColor", m_def_TransparentColor)
  573.     WhatsThisHelpID = PropBag.ReadProperty("WhatsThisHelpID", m_def_WhatsThisHelpID)
  574. End Sub
  575.  
  576. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  577.     'Write property values to storage
  578.     Call PropBag.WriteProperty("Appearance", m_Appearance, m_def_Appearance)
  579.     Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
  580.     Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
  581.     Call PropBag.WriteProperty("Caption", m_Caption, m_def_Caption)
  582.     Call PropBag.WriteProperty("ForeColor", m_ForeColor, m_def_ForeColor)
  583.     Call PropBag.WriteProperty("Font", m_Font, Ambient.Font)
  584.     Call PropBag.WriteProperty("HighlightColor", m_HighlightColor, m_def_HighlightColor)
  585.     Call PropBag.WriteProperty("HighlightPicture", m_HighlightPicture, m_def_HighlightPicture)
  586.     Call PropBag.WriteProperty("Picture", m_Picture, Nothing)
  587.     Call PropBag.WriteProperty("RightToLeft", m_RightToLeft, m_def_RightToLeft)
  588.     Call PropBag.WriteProperty("TransparentColor", m_TransparentColor, m_def_TransparentColor)
  589.     Call PropBag.WriteProperty("MouseIcon", m_MouseIcon, Nothing)
  590.     Call PropBag.WriteProperty("MousePointer", m_MousePointer, m_def_MousePointer)
  591.     Call PropBag.WriteProperty("ToolTipText", m_ToolTipText, m_def_ToolTipText)
  592.     Call PropBag.WriteProperty("WhatsThisHelpID", m_WhatsThisHelpID, m_def_WhatsThisHelpID)
  593. End Sub
  594.  
  595. Private Sub UserControl_Click()
  596.     RaiseEvent Click
  597. End Sub
  598.  
  599. Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  600.     RaiseEvent KeyDown(KeyCode, Shift)
  601. End Sub
  602.  
  603. Private Sub UserControl_KeyPress(KeyAscii As Integer)
  604.     RaiseEvent KeyPress(KeyAscii)
  605. End Sub
  606.  
  607. Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  608.     RaiseEvent KeyUp(KeyCode, Shift)
  609. End Sub
  610.  
  611. Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
  612.     RaiseEvent Click
  613. End Sub
  614.  
  615. Private Sub UserControl_AmbientChanged(PropertyName As String)
  616.     If PropertyName = "DisplayAsDefault" Then
  617.         If UserControl.Ambient.DisplayAsDefault Then
  618.             bHasFocus = True
  619.         Else
  620.             bHasFocus = False
  621.         End If
  622.         Call DrawButton(lState)
  623.     End If
  624. End Sub
  625.  
  626. Private Sub UserControl_Initialize()
  627.     'note: this really sets to 1215x375
  628.     UserControl.Width = 1200
  629.     UserControl.Height = 360
  630. End Sub
  631.  
  632. Private Sub UserControl_GotFocus()
  633.     bHasFocus = True
  634.     Call DrawButton(lState)
  635. End Sub
  636.  
  637. Private Sub UserControl_LostFocus()
  638.     bHasFocus = False
  639.     Call DrawButton(lState)
  640. End Sub
  641.  
  642. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  643.     bLeftFocus = False
  644.     
  645.     If Button = vbLeftButton Then
  646.         Call DrawButton(btDown)
  647.     End If
  648.     
  649.     RaiseEvent MouseDown(Button, Shift, X * Screen.TwipsPerPixelX, Y * Screen.TwipsPerPixelY)
  650. End Sub
  651.  
  652. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  653.     bLeftFocus = False
  654.     
  655.     If UserControl.Ambient.UserMode = True And Not Timer1.Enabled Then
  656.         'start tracking
  657.         Timer1.Enabled = True
  658.     
  659.     ElseIf Button = 0 Then
  660.         'mouse over (for flat button)
  661.         If lState <> btOver Then
  662.             Call DrawButton(btOver)
  663.         End If
  664.  
  665.     ElseIf Button = vbLeftButton Then
  666.         If lState <> btDown Then
  667.             Call DrawButton(btDown)
  668.         End If
  669.     End If
  670.  
  671.     RaiseEvent MouseMove(Button, Shift, X * Screen.TwipsPerPixelX, Y * Screen.TwipsPerPixelY)
  672. End Sub
  673.  
  674. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  675.     bLeftFocus = False
  676.     
  677.     If Button = vbLeftButton Then
  678.         Call DrawButton(btUp)
  679.     End If
  680.  
  681.     RaiseEvent MouseUp(Button, Shift, X * Screen.TwipsPerPixelX, Y * Screen.TwipsPerPixelY)
  682. End Sub
  683.  
  684. Private Sub UserControl_Resize()
  685.     Call DrawButton(btUp)
  686.     RaiseEvent Resize
  687. End Sub
  688.  
  689. '//---------------------------------------------------------------------------------------
  690. '// Private functions
  691. '//---------------------------------------------------------------------------------------
  692.  
  693. Private Sub TransparentBlt_New2(ByVal hDC As Long, ByVal Source As PictureBox, ByRef DestPoint As POINTAPI, ByRef SrcPoint As POINTAPI, ByVal Width As Long, ByVal Height As Long, Optional ByVal TransparentColor As OLE_COLOR = -1, Optional ByVal Clear As Boolean = False, Optional ByVal Resize As Boolean = False, Optional ByVal Refresh As Boolean = False)
  694.     Dim MonoMaskDC As Long
  695.     Dim hMonoMask As Long
  696.     Dim MonoInvDC As Long
  697.     Dim hMonoInv As Long
  698.     Dim ResultDstDC As Long
  699.     Dim hResultDst As Long
  700.     Dim ResultSrcDC As Long
  701.     Dim hResultSrc As Long
  702.     Dim hPrevMask As Long
  703.     Dim hPrevInv As Long
  704.     Dim hPrevSrc As Long
  705.     Dim hPrevDst As Long
  706.     Dim OldBC As Long
  707.     
  708.     If TransparentColor = -1 Then
  709.         TransparentColor = GetPixel(Source.hDC, 1, 1)
  710.     End If
  711.     
  712.     'create monochrome mask and inverse masks
  713.     MonoMaskDC = CreateCompatibleDC(hDC)
  714.     MonoInvDC = CreateCompatibleDC(hDC)
  715.     hMonoMask = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
  716.     hMonoInv = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
  717.     hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
  718.     hPrevInv = SelectObject(MonoInvDC, hMonoInv)
  719.     
  720.     'create keeper DCs and bitmaps
  721.     ResultDstDC = CreateCompatibleDC(hDC)
  722.     ResultSrcDC = CreateCompatibleDC(hDC)
  723.     hResultDst = CreateCompatibleBitmap(hDC, Width, Height)
  724.     hResultSrc = CreateCompatibleBitmap(hDC, Width, Height)
  725.     hPrevDst = SelectObject(ResultDstDC, hResultDst)
  726.     hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
  727.     
  728.     'copy src to monochrome mask
  729.     OldBC = SetBkColor(Source.hDC, TransparentColor)
  730.     Call BitBlt(MonoMaskDC, 0, 0, Width, Height, Source.hDC, SrcPoint.X, SrcPoint.Y, SRCCOPY)
  731.     TransparentColor = SetBkColor(Source.hDC, OldBC)
  732.     
  733.     'create inverse of mask
  734.     Call BitBlt(MonoInvDC, 0, 0, Width, Height, MonoMaskDC, 0, 0, NOTSRCCOPY)
  735.     
  736.     'get background
  737.     Call BitBlt(ResultDstDC, 0, 0, Width, Height, hDC, DestPoint.X, DestPoint.Y, SRCCOPY)
  738.     
  739.     'AND with Monochrome mask
  740.     Call BitBlt(ResultDstDC, 0, 0, Width, Height, MonoMaskDC, 0, 0, SRCAND)
  741.     
  742.     'get overlapper
  743.     Call BitBlt(ResultSrcDC, 0, 0, Width, Height, Source.hDC, SrcPoint.X, SrcPoint.Y, SRCCOPY)
  744.     
  745.     'AND with inverse monochrome mask
  746.     Call BitBlt(ResultSrcDC, 0, 0, Width, Height, MonoInvDC, 0, 0, SRCAND)
  747.     
  748.     'XOR these two
  749.     Call BitBlt(ResultDstDC, 0, 0, Width, Height, ResultSrcDC, 0, 0, SRCINVERT)
  750.     
  751.     'output results
  752.     Call BitBlt(hDC, DestPoint.X, DestPoint.Y, Width, Height, ResultDstDC, 0, 0, SRCCOPY)
  753.     
  754.     'clean up
  755.     hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
  756.     DeleteObject hMonoMask
  757.     
  758.     hMonoInv = SelectObject(MonoInvDC, hPrevInv)
  759.     DeleteObject hMonoInv
  760.     
  761.     hResultDst = SelectObject(ResultDstDC, hPrevDst)
  762.     DeleteObject hResultDst
  763.     
  764.     hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
  765.     DeleteObject hResultSrc
  766.     
  767.     DeleteDC MonoMaskDC
  768.     DeleteDC MonoInvDC
  769.     DeleteDC ResultDstDC
  770.     DeleteDC ResultSrcDC
  771. End Sub
  772.  
  773. Private Sub DrawButton(ByVal BorderType As BorderTypeEnum)
  774.     'draw button around button
  775.     Const clTop As Long = 6
  776.     Const clLeft As Long = 6
  777.     Const clFocusOffset As Long = 4
  778.     Const clDownOffset As Long = 1
  779.     
  780.     Dim rct As RECT
  781.     Dim bFocus As Boolean
  782.     Dim lFormat As Long
  783.     Dim lLeft As Long
  784.     Dim lTop As Long
  785.     Dim lPrevColor As OLE_COLOR
  786.     Dim bUserMode As Boolean
  787.     
  788.     'clear control
  789.     UserControl.Cls
  790.     
  791.     'initialize variable
  792.     bFocus = bHasFocus
  793.     bUserMode = False
  794.     
  795.     'get user mode
  796.     On Local Error Resume Next
  797.     bUserMode = UserControl.Ambient.UserMode
  798.     On Local Error GoTo 0
  799.     
  800.     'get rect
  801.     With rct
  802.         .Left = 0
  803.         .Top = 0
  804.         .Bottom = UserControl.ScaleHeight
  805.         .Right = UserControl.ScaleWidth
  806.     End With
  807.     
  808.     Select Case BorderType
  809.         Case btUp
  810.             If m_Appearance = [3D] Then
  811.                 'draw raised border
  812.                 If bFocus Then
  813.                     Call DrawEdge(UserControl.hDC, rct, BDR_OUTER, BF_RECT Or BF_ADJUST Or BF_MONO)
  814.                     Call DrawEdge(UserControl.hDC, rct, EDGE_RAISED, BF_RECT)
  815.                 Else
  816.                     Call DrawEdge(UserControl.hDC, rct, EDGE_RAISED, BF_RECT)
  817.                 End If
  818.             Else
  819.                 bFocus = False
  820.             End If
  821.         
  822.         Case btOver
  823.             'draw raised border
  824.             If bFocus Then
  825.                 Call DrawEdge(UserControl.hDC, rct, BDR_OUTER, BF_RECT Or BF_ADJUST Or BF_MONO)
  826.                 Call DrawEdge(UserControl.hDC, rct, EDGE_RAISED, BF_RECT)
  827.             Else
  828.                 Call DrawEdge(UserControl.hDC, rct, EDGE_RAISED, BF_RECT)
  829.             End If
  830.             UserControl.ForeColor = m_HighlightColor
  831.         
  832.         Case btDown
  833.             'draw sunken border
  834.             If bFocus Then
  835.                 Call DrawEdge(UserControl.hDC, rct, BDR_OUTER, BF_RECT Or BF_ADJUST Or BF_MONO)
  836.                 Call DrawEdge(UserControl.hDC, rct, BDR_SUNKENOUTER, BF_RECT Or BF_FLAT)
  837.             Else
  838.                 Call DrawEdge(UserControl.hDC, rct, EDGE_SUNKEN, BF_RECT)
  839.             End If
  840.             UserControl.ForeColor = m_HighlightColor
  841.     End Select
  842.  
  843.     'calculate caption position
  844.     If imgPicture.Picture <> 0 Then
  845.         lLeft = imgPicture.Left + imgPicture.Width - clLeft
  846.     End If
  847.     
  848.     lLeft = lLeft \ 2 + ((UserControl.ScaleWidth \ 2) - (UserControl.TextWidth(m_Caption) \ 2))
  849.     lTop = (UserControl.ScaleHeight \ 2) - (UserControl.TextHeight(m_Caption) \ 2)
  850.     
  851.     If BorderType = btDown Then
  852.         lLeft = lLeft + clDownOffset
  853.         lTop = lTop + clDownOffset
  854.     End If
  855.     
  856.     'draw caption in button
  857.     lFormat = DST_PREFIXTEXT Or DSS_NORMAL
  858.     If Not m_Enabled Then
  859.         lFormat = lFormat Or DSS_DISABLED
  860.     End If
  861.     If m_RightToLeft Then
  862.         lFormat = lFormat Or DSS_RIGHT
  863.     End If
  864.     
  865.     Call DrawStateText(UserControl.hDC, 0, 0, m_Caption, Len(m_Caption), lLeft, lTop, 0, 0, lFormat)
  866.  
  867.     If bUserMode Then
  868.         If bFocus Then
  869.             'draw focus rect
  870.             With rct
  871.                 .Left = clFocusOffset
  872.                 .Top = clFocusOffset
  873.                 .Bottom = UserControl.ScaleHeight - clFocusOffset
  874.                 .Right = UserControl.ScaleWidth - clFocusOffset
  875.             End With
  876.             lPrevColor = UserControl.ForeColor
  877.             UserControl.ForeColor = vbBlack
  878.             Call DrawFocusRect(UserControl.hDC, rct)
  879.             UserControl.ForeColor = lPrevColor
  880.         End If
  881.     End If
  882.  
  883.     'move image
  884.     With imgPicture
  885.         If .Picture <> 0 Then
  886.             lLeft = clLeft
  887.             lTop = (UserControl.ScaleHeight \ 2) - (.Height \ 2)
  888.             If lTop < clTop Then
  889.                 lTop = clTop
  890.             End If
  891.             
  892.             If BorderType = btDown Then
  893.                 lLeft = lLeft + clDownOffset
  894.                 lTop = lTop + clDownOffset
  895.             End If
  896.         
  897.             If .Left <> lLeft Then
  898.                 .Left = lLeft
  899.             End If
  900.             If .Top <> lTop Then
  901.                 .Top = lTop
  902.             End If
  903.         
  904.             Dim ptDest As POINTAPI
  905.             Dim ptSrc As POINTAPI
  906.             
  907.             ptDest.X = .Left
  908.             ptDest.Y = .Top
  909.             ptSrc.X = 0
  910.             ptSrc.Y = 0
  911.             
  912.             pictNewPicture.Cls
  913.             If (BorderType = btDown Or BorderType = btOver Or (Not m_Enabled And BorderType = btUp)) And m_HighlightPicture = True Then
  914.                 If m_Enabled Then
  915.                     Call HighlightBltEx(imgPicture, pictNewPicture, pictTempDestination, pictTempHighlight, m_HighlightColor, 0, 0, 0, 0, .Width, .Height)
  916.                 Else
  917.                     Call HighlightBltEx(imgPicture, pictNewPicture, pictTempDestination, pictTempHighlight, vbGrayText, 0, 0, 0, 0, .Width, .Height)
  918.                 End If
  919.                 Call TransparentBlt_New2(UserControl.hDC, pictNewPicture, ptDest, ptSrc, imgPicture.Width, imgPicture.Height, pictNewPicture.BackColor)
  920.             Else
  921.                 Call TransparentBlt_New2(UserControl.hDC, imgPicture, ptDest, ptSrc, imgPicture.Width, imgPicture.Height, m_TransparentColor)
  922.             End If
  923.         End If
  924.     End With
  925.     
  926.     'set state
  927.     lState = BorderType
  928.     
  929.     'reset forecolor
  930.     UserControl.ForeColor = m_ForeColor
  931. End Sub
  932.  
  933. Private Function BitBltEx(ByVal Source As Object, ByVal Destination As Object, ByVal Operation As RasterOperationConstants, Optional ByVal xDest As Long = 0, Optional ByVal yDest As Long = 0, Optional ByVal XSrc As Long = 0, Optional ByVal YSrc As Long = 0, Optional ByVal Width As Long = -1, Optional ByVal Height As Long = -1, Optional ByVal Refresh As Boolean = False) As Boolean
  934.     Dim lReturn As Long
  935.     
  936.     If Width = -1 Then
  937.         Width = Source.Width \ Screen.TwipsPerPixelX
  938.     End If
  939.     If Height = -1 Then
  940.         Height = Source.Height \ Screen.TwipsPerPixelX
  941.     End If
  942.     
  943.     'BitBlt
  944.     lReturn = BitBlt(Destination.hDC, xDest, yDest, Width, Height, Source.hDC, XSrc, YSrc, Operation)
  945.     
  946.     If Refresh Then
  947.         'refresh destination
  948.         Destination.Refresh
  949.     End If
  950.     
  951.     'return result
  952.     If lReturn = 0 Then
  953.         BitBltEx = False
  954.     Else
  955.         BitBltEx = True
  956.     End If
  957. End Function
  958.  
  959. Private Function MaskBltEx(ByVal Source As Object, ByVal Destination As Object, Optional ByVal MaskColor As OLE_COLOR = -1, Optional ByVal xDest As Long = 0, Optional ByVal yDest As Long = 0, Optional ByVal XSrc As Long = 0, Optional ByVal YSrc As Long = 0, Optional ByVal Width As Long = -1, Optional ByVal Height As Long = -1, Optional ByVal Refresh As Boolean = False) As Boolean
  960.     Dim MonoMaskDC As Long
  961.     Dim hMonoMask As Long
  962.     Dim MonoInvDC As Long
  963.     Dim hMonoInv As Long
  964.     Dim ResultDstDC As Long
  965.     Dim hResultDst As Long
  966.     Dim ResultSrcDC As Long
  967.     Dim hResultSrc As Long
  968.     Dim hPrevMask As Long
  969.     Dim hPrevInv As Long
  970.     Dim hPrevSrc As Long
  971.     Dim hPrevDst As Long
  972.     Dim OldBC As Long
  973.     Dim lReturn As Long
  974.     
  975.     If Width = -1 Then
  976.         Width = Source.Width \ Screen.TwipsPerPixelX
  977.     End If
  978.     If Height = -1 Then
  979.         Height = Source.Height \ Screen.TwipsPerPixelX
  980.     End If
  981.     
  982.     If MaskColor = -1 Then
  983.         MaskColor = GetPixel(Source.hDC, 0, 0)
  984.     End If
  985.     
  986.     'create monochrome mask and inverse masks
  987.     MonoMaskDC = CreateCompatibleDC(Destination.hDC)
  988.     hMonoMask = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
  989.     hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
  990.     
  991.     'copy src to monochrome mask
  992.     OldBC = SetBkColor(Source.hDC, MaskColor)
  993.     lReturn = BitBlt(MonoMaskDC, 0, 0, Width, Height, Source.hDC, XSrc, YSrc, SRCCOPY)
  994.     If lReturn <> 0 Then
  995.         MaskColor = SetBkColor(Source.hDC, OldBC)
  996.         
  997.         'output results
  998.         lReturn = BitBlt(Destination.hDC, xDest, yDest, Width, Height, MonoMaskDC, 0, 0, SRCCOPY)
  999.     End If
  1000.     
  1001.     'clean up
  1002.     hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
  1003.     DeleteObject hMonoMask
  1004.     DeleteDC MonoMaskDC
  1005.  
  1006.     If Refresh Then
  1007.         'refresh destination
  1008.         Destination.Refresh
  1009.     End If
  1010.     
  1011.     'return result
  1012.     If lReturn = 0 Then
  1013.         MaskBltEx = False
  1014.     Else
  1015.         MaskBltEx = True
  1016.     End If
  1017. End Function
  1018.  
  1019. Private Function TransparentBltEx(ByVal Source As Object, ByVal Destination As Object, Optional ByVal TransparentColor As OLE_COLOR = -1, Optional ByVal xDest As Long = 0, Optional ByVal yDest As Long = 0, Optional ByVal XSrc As Long = 0, Optional ByVal YSrc As Long = 0, Optional ByVal Width As Long = -1, Optional ByVal Height As Long = -1, Optional ByVal Refresh As Boolean = False) As Boolean
  1020.     Dim MonoMaskDC As Long
  1021.     Dim hMonoMask As Long
  1022.     Dim MonoInvDC As Long
  1023.     Dim hMonoInv As Long
  1024.     Dim ResultDstDC As Long
  1025.     Dim hResultDst As Long
  1026.     Dim ResultSrcDC As Long
  1027.     Dim hResultSrc As Long
  1028.     Dim hPrevMask As Long
  1029.     Dim hPrevInv As Long
  1030.     Dim hPrevSrc As Long
  1031.     Dim hPrevDst As Long
  1032.     Dim OldBC As Long
  1033.     Dim lReturn As Long
  1034.     
  1035.     If Width = -1 Then
  1036.         Width = Source.Width \ Screen.TwipsPerPixelX
  1037.     End If
  1038.     If Height = -1 Then
  1039.         Height = Source.Height \ Screen.TwipsPerPixelX
  1040.     End If
  1041.     
  1042.     If TransparentColor = -1 Then
  1043.         TransparentColor = GetPixel(Source.hDC, 0, 0)
  1044.     End If
  1045.     
  1046.     'create monochrome mask and inverse masks
  1047.     MonoMaskDC = CreateCompatibleDC(Destination.hDC)
  1048.     MonoInvDC = CreateCompatibleDC(Destination.hDC)
  1049.     hMonoMask = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
  1050.     hMonoInv = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
  1051.     hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
  1052.     hPrevInv = SelectObject(MonoInvDC, hMonoInv)
  1053.     
  1054.     'create keeper DCs and bitmaps
  1055.     ResultDstDC = CreateCompatibleDC(Destination.hDC)
  1056.     ResultSrcDC = CreateCompatibleDC(Destination.hDC)
  1057.     hResultDst = CreateCompatibleBitmap(Destination.hDC, Width, Height)
  1058.     hResultSrc = CreateCompatibleBitmap(Destination.hDC, Width, Height)
  1059.     hPrevDst = SelectObject(ResultDstDC, hResultDst)
  1060.     hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
  1061.     
  1062.     'copy src to monochrome mask
  1063.     OldBC = SetBkColor(Source.hDC, TransparentColor)
  1064.     lReturn = BitBlt(MonoMaskDC, 0, 0, Width, Height, Source.hDC, XSrc, YSrc, SRCCOPY)
  1065.     If lReturn <> 0 Then
  1066.         TransparentColor = SetBkColor(Source.hDC, OldBC)
  1067.         
  1068.         'create inverse of mask
  1069.         lReturn = BitBlt(MonoInvDC, 0, 0, Width, Height, MonoMaskDC, 0, 0, NOTSRCCOPY)
  1070.         If lReturn <> 0 Then
  1071.             'get background
  1072.             lReturn = BitBlt(ResultDstDC, 0, 0, Width, Height, Destination.hDC, xDest, yDest, SRCCOPY)
  1073.             If lReturn <> 0 Then
  1074.                 'AND with Monochrome mask
  1075.                 lReturn = BitBlt(ResultDstDC, 0, 0, Width, Height, MonoMaskDC, 0, 0, SRCAND)
  1076.                 If lReturn <> 0 Then
  1077.                     'get overlapper
  1078.                     lReturn = BitBlt(ResultSrcDC, 0, 0, Width, Height, Source.hDC, XSrc, YSrc, SRCCOPY)
  1079.                     If lReturn <> 0 Then
  1080.                         'AND with inverse monochrome mask
  1081.                         lReturn = BitBlt(ResultSrcDC, 0, 0, Width, Height, MonoInvDC, 0, 0, SRCAND)
  1082.                         If lReturn <> 0 Then
  1083.                             'XOR these two
  1084.                             lReturn = BitBlt(ResultDstDC, 0, 0, Width, Height, ResultSrcDC, 0, 0, SRCINVERT)
  1085.                             If lReturn <> 0 Then
  1086.                                 'output results
  1087.                                 lReturn = BitBlt(Destination.hDC, xDest, yDest, Width, Height, ResultDstDC, 0, 0, SRCCOPY)
  1088.                             End If
  1089.                         End If
  1090.                     End If
  1091.                 End If
  1092.             End If
  1093.         End If
  1094.     End If
  1095.     
  1096.     'clean up
  1097.     hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
  1098.     DeleteObject hMonoMask
  1099.     
  1100.     hMonoInv = SelectObject(MonoInvDC, hPrevInv)
  1101.     DeleteObject hMonoInv
  1102.     
  1103.     hResultDst = SelectObject(ResultDstDC, hPrevDst)
  1104.     DeleteObject hResultDst
  1105.     
  1106.     hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
  1107.     DeleteObject hResultSrc
  1108.     
  1109.     DeleteDC MonoMaskDC
  1110.     DeleteDC MonoInvDC
  1111.     DeleteDC ResultDstDC
  1112.     DeleteDC ResultSrcDC
  1113.  
  1114.     If Refresh Then
  1115.         'refresh destination
  1116.         Destination.Refresh
  1117.     End If
  1118.     
  1119.     'return result
  1120.     If lReturn = 0 Then
  1121.         TransparentBltEx = False
  1122.     Else
  1123.         TransparentBltEx = True
  1124.     End If
  1125. End Function
  1126.  
  1127. Private Function HighlightBltEx(ByVal Source As Object, ByVal Destination As Object, ByVal TempDestination As Object, ByVal Highlight As Object, ByVal HighlightColor As OLE_COLOR, Optional ByVal xDest As Long = 0, Optional ByVal yDest As Long = 0, Optional ByVal XSrc As Long = 0, Optional ByVal YSrc As Long = 0, Optional ByVal Width As Long = -1, Optional ByVal Height As Long = -1, Optional ByVal Refresh As Boolean = False) As Boolean
  1128.     Highlight.BackColor = HighlightColor
  1129.     
  1130.     Call MaskBltEx(Source, TempDestination, -1, 0, 0, XSrc, YSrc, Width, Height)
  1131.     Call BitBltEx(TempDestination, Highlight, roSrcInvert, 0, 0, 0, 0, Width, Height)
  1132.     Call TransparentBltEx(Highlight, Destination, -1, xDest, yDest, 0, 0, Width, Height, Refresh)
  1133. End Function
  1134.  
  1135.