├── .gitattributes ├── .gitignore ├── LICENSE ├── README.md ├── contrib ├── AlphaBlendLabel.ctl └── AlphaBlendTabStrip.ctl ├── src └── AlphaBlendImage.ctl └── test ├── basic ├── Form1.frm ├── Form1.frx ├── Form2.frm ├── Project1.vbp ├── bbb.png └── garden.png └── tabstrip ├── Form1.frm └── Project1.vbp /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto eol=crlf working-tree-encoding=windows-1251 3 | * linguist-language=Visual Basic 4 | 5 | *.dll binary 6 | *.pdb binary 7 | *.doc binary 8 | *.docx binary 9 | *.pdf binary 10 | *.zip binary 11 | *.gz binary 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## VB6 workspace 2 | 3 | *.vbw 4 | *.vbg 5 | *.bak 6 | *.log 7 | *.scc 8 | _del/* 9 | bin/* 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Vladimir Vissoultchev 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## AlphaBlendImage Control 2 | 3 | Poor Man's Transparent Image Control 4 | 5 | ### Description 6 | 7 | `AlphaBlendImage` control is built-in `VB.Image` control replacement (sort of) that supports alpha transparent images through GDI+. Standard OLE automation `StdPicture` objects can load 32-bit alpha transparent images in `vbPicTypeIcon` subtype, although few controls paint the alpha channel on these `StdPicture`s. This `AlphaBlendImage` control brings this support. 8 | 9 | ### API 10 | 11 | The control's public `GdipLoadPicture` method can load 32-bit alpha transparent PNGs in `StdPicture` objects which can be assigned to control's `Picture` property. In the sample `Form1` such alpha transparent image is loaded to a `StdPicture` and is assigned both to a built-in `VB.Image` control and to an `AlphaBlendImage` control to compare difference in output. 12 | 13 | The control supports `Opacity` property for "global" control transparency level (in addition to per-pixel alpha). 14 | 15 | The control supports `MaskColor` property for color-key transparency (in addition to per-pixel alpha). 16 | 17 | The control supports `Rotation` property which rotates the assigned image (in degrees). 18 | 19 | The control supports `Zoom` property which scales the image (only when `Stretch` is off). 20 | 21 | The control is windowless and cannot get focus. Its `AutoRedraw` property controls if repaint is cached to memory 32-bit DIB for faster redraws. -------------------------------------------------------------------------------- /contrib/AlphaBlendLabel.ctl: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.UserControl AlphaBlendLabel 3 | BackStyle = 0 'Transparent 4 | CanGetFocus = 0 'False 5 | ClientHeight = 2880 6 | ClientLeft = 0 7 | ClientTop = 0 8 | ClientWidth = 3840 9 | ClipBehavior = 0 'None 10 | ScaleHeight = 240 11 | ScaleMode = 3 'Pixel 12 | ScaleWidth = 320 13 | Windowless = -1 'True 14 | End 15 | Attribute VB_Name = "AlphaBlendLabel" 16 | Attribute VB_GlobalNameSpace = False 17 | Attribute VB_Creatable = True 18 | Attribute VB_PredeclaredId = False 19 | Attribute VB_Exposed = False 20 | '========================================================================= 21 | ' 22 | ' AlphaBlendLabel (c) 2020 by wqweto@gmail.com 23 | ' 24 | ' Poor Man's Label Control 25 | ' 26 | '========================================================================= 27 | Option Explicit 28 | DefObj A-Z 29 | Private Const MODULE_NAME As String = "AlphaBlendLabel" 30 | 31 | '========================================================================= 32 | ' Public enums 33 | '========================================================================= 34 | 35 | Public Enum UcsLabelTextAlignEnum 36 | ucsLtaHorLeft = 0 37 | ucsLtaHorCenter = 1 38 | ucsLtaHorRight = 2 39 | ucsLtaVertTop = 0 40 | ucsLtaVertCenter = 4 41 | ucsLtaVertBottom = 8 42 | ucsLtaCenter = ucsLtaHorCenter Or ucsLtaVertCenter 43 | End Enum 44 | 45 | Public Enum UcsLabelTextFlagsEnum 46 | ucsLtfNone = 0 47 | ucsLtfDirectionRightToLeft = &H1 * 16 48 | ucsLtfDirectionVertical = &H2 * 16 49 | ucsLtfNoFitBlackBox = &H4 * 16 50 | ucsLtfDisplayFormatControl = &H20 * 16 51 | ucsLtfNoFontFallback = &H400 * 16 52 | ucsLtfMeasureTrailingSpaces = &H800& * 16 53 | ucsLtfNoWrap = &H1000& * 16 54 | ucsLtfLineLimit = &H2000& * 16 55 | ucsLtfNoClip = &H4000& * 16 56 | End Enum 57 | 58 | '========================================================================= 59 | ' Public events 60 | '========================================================================= 61 | 62 | Event Click() 63 | Event OwnerDraw(ByVal hGraphics As Long, ByVal hFont As Long, sCaption As String, sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single) 64 | Event DblClick() 65 | Event ContextMenu() 66 | Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 67 | Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 68 | Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 69 | 70 | '========================================================================= 71 | ' API 72 | '========================================================================= 73 | 74 | '--- DIB Section constants 75 | Private Const DIB_RGB_COLORS As Long = 0 76 | '--- for AlphaBlend 77 | Private Const AC_SRC_ALPHA As Long = 1 78 | '--- for GdipDrawImageXxx 79 | Private Const UnitPoint As Long = 3 80 | '--- for GdipSetTextRenderingHint 81 | Private Const TextRenderingHintAntiAlias As Long = 4 82 | Private Const TextRenderingHintClearTypeGridFit As Long = 5 83 | '--- for GdipSetSmoothingMode 84 | Private Const SmoothingModeAntiAlias As Long = 4 85 | Private Const DT_CALCRECT As Long = &H400 86 | 87 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long) 88 | Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long 89 | Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long 90 | Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long 91 | Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 92 | Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal Handle As Long, ByVal dw As Long) As Long 93 | Private Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, ByVal lX As Long, ByVal lY As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean 94 | Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long 95 | Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long 96 | Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long 97 | Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long 98 | Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Any, ByVal wFormat As Long) As Long 99 | '--- GDI+ 100 | Private Declare Function GdiplusStartup Lib "gdiplus" (hToken As Long, pInputBuf As Any, Optional ByVal pOutputBuf As Long = 0) As Long 101 | Private Declare Function GdipCreateFontFamilyFromName Lib "gdiplus" (ByVal lNamePtr As Long, ByVal hFontCollection As Long, hFontFamily As Long) As Long 102 | Private Declare Function GdipGetGenericFontFamilySansSerif Lib "gdiplus" (hFontFamily As Long) As Long 103 | Private Declare Function GdipDeleteFontFamily Lib "gdiplus" (ByVal hFontFamily As Long) As Long 104 | Private Declare Function GdipCreateFont Lib "gdiplus" (ByVal hFontFamily As Long, ByVal emSize As Single, ByVal lStyle As Long, ByVal lUnit As Long, hFont As Long) As Long 105 | Private Declare Function GdipDeleteFont Lib "gdiplus" (ByVal hFont As Long) As Long 106 | Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, hGraphics As Long) As Long 107 | Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, hBrush As Long) As Long 108 | Private Declare Function GdipSetSolidFillColor Lib "gdiplus" (ByVal hBrush As Long, ByVal argb As Long) As Long 109 | Private Declare Function GdipSetTextRenderingHint Lib "gdiplus" (ByVal hGraphics As Long, ByVal lMode As Long) As Long 110 | Private Declare Function GdipDrawString Lib "gdiplus" (ByVal hGraphics As Long, ByVal lStrPtr As Long, ByVal lLength As Long, ByVal hFont As Long, uRect As RECTF, ByVal hStringFormat As Long, ByVal hBrush As Long) As Long 111 | Private Declare Function GdipMeasureString Lib "gdiplus" (ByVal hGraphics As Long, ByVal lStrPtr As Long, ByVal lLength As Long, ByVal hFont As Long, uRect As RECTF, ByVal hStringFormat As Long, uBoundingBox As RECTF, lCodepointsFitted As Long, lLinesFilled As Long) As Long 112 | Private Declare Function GdipCreateStringFormat Lib "gdiplus" (ByVal hFormatAttributes As Long, ByVal nLanguage As Integer, hStringFormat As Long) As Long 113 | Private Declare Function GdipDeleteStringFormat Lib "gdiplus" (ByVal hStringFormat As Long) As Long 114 | Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal hBrush As Long) As Long 115 | Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal hGraphics As Long) As Long 116 | Private Declare Function GdipSetStringFormatFlags Lib "gdiplus" (ByVal hStringFormat As Long, ByVal lFlags As Long) As Long 117 | Private Declare Function GdipSetStringFormatAlign Lib "gdiplus" (ByVal hStringFormat As Long, ByVal eAlign As StringAlignment) As Long 118 | Private Declare Function GdipSetStringFormatLineAlign Lib "gdiplus" (ByVal hStringFormat As Long, ByVal eAlign As StringAlignment) As Long 119 | Private Declare Function GdipFillRectangle Lib "gdiplus" (ByVal hGraphics As Long, ByVal hBrush As Long, ByVal sngX As Single, ByVal sngY As Single, ByVal sngWidth As Single, ByVal sngHeight As Single) As Long 120 | Private Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal hGraphics As Long, ByVal lSmoothingMd As Long) As Long 121 | 122 | Private Type BITMAPINFOHEADER 123 | biSize As Long 124 | biWidth As Long 125 | biHeight As Long 126 | biPlanes As Integer 127 | biBitCount As Integer 128 | biCompression As Long 129 | biSizeImage As Long 130 | biXPelsPerMeter As Long 131 | biYPelsPerMeter As Long 132 | biClrUsed As Long 133 | biClrImportant As Long 134 | End Type 135 | 136 | Private Enum FontStyle 137 | FontStyleRegular = 0 138 | FontStyleBold = 1 139 | FontStyleItalic = 2 140 | FontStyleBoldItalic = 3 141 | FontStyleUnderline = 4 142 | FontStyleStrikeout = 8 143 | End Enum 144 | 145 | Public Enum StringAlignment 146 | StringAlignmentNear = 0 147 | StringAlignmentCenter = 1 148 | StringAlignmentFar = 2 149 | End Enum 150 | 151 | Private Type RECTF 152 | Left As Single 153 | Top As Single 154 | Right As Single 155 | Bottom As Single 156 | End Type 157 | 158 | Private Type UcsRgbQuad 159 | R As Byte 160 | G As Byte 161 | B As Byte 162 | A As Byte 163 | End Type 164 | 165 | '========================================================================= 166 | ' Constants and member variables 167 | '========================================================================= 168 | 169 | Private Const DEF_AUTOREDRAW As Boolean = False 170 | Private Const DEF_AUTOSIZE As Boolean = False 171 | Private Const DEF_TEXTOFFSETX As Single = 0 172 | Private Const DEF_TEXTOFFSETY As Single = 0 173 | Private Const DEF_FORECOLOR As Long = vbButtonText 174 | Private Const DEF_FOREOPACITY As Single = 1 175 | Private Const DEF_BACKCOLOR As Long = vbButtonFace 176 | Private Const DEF_BACKOPACITY As Single = 0 177 | Private Const DEF_SHADOWOFFSETX As Single = 1 178 | Private Const DEF_SHADOWOFFSETY As Single = 1 179 | Private Const DEF_SHADOWCOLOR As Long = vbBlack 180 | Private Const DEF_SHADOWOPACITY As Single = 0 181 | Private Const DEF_TEXTALIGN As Long = ucsLtaCenter 182 | Private Const DEF_TEXTFLAGS As Long = 0 183 | 184 | Private m_bAutoRedraw As Boolean 185 | Private m_bAutoSize As Boolean 186 | Private m_sCaption As String 187 | Private WithEvents m_oFont As StdFont 188 | Attribute m_oFont.VB_VarHelpID = -1 189 | Private m_sngTextOffsetX As Single 190 | Private m_sngTextOffsetY As Single 191 | Private m_clrFore As OLE_COLOR 192 | Private m_sngForeOpacity As Single 193 | Private m_clrBack As OLE_COLOR 194 | Private m_sngBackOpacity As Single 195 | Private m_sngShadowOffsetX As Single 196 | Private m_sngShadowOffsetY As Single 197 | Private m_clrShadow As OLE_COLOR 198 | Private m_sngShadowOpacity As Single 199 | Private m_eTextAlign As UcsLabelTextAlignEnum 200 | Private m_eTextFlags As UcsLabelTextFlagsEnum 201 | '--- run-time 202 | Private m_bShown As Boolean 203 | Private m_eContainerScaleMode As ScaleModeConstants 204 | Private m_hFont As Long 205 | Private m_hRedrawDib As Long 206 | Private m_nDownButton As Integer 207 | Private m_nDownShift As Integer 208 | Private m_sngDownX As Single 209 | Private m_sngDownY As Single 210 | Private m_sLastError As String 211 | 212 | '========================================================================= 213 | ' Error handling 214 | '========================================================================= 215 | 216 | Private Function PrintError(sFunction As String) As VbMsgBoxResult 217 | m_sLastError = Err.Description 218 | #If USE_DEBUG_LOG <> 0 Then 219 | DebugLog MODULE_NAME, sFunction & "(" & Erl & ")", Err.Description & " &H" & Hex$(Err.Number), vbLogEventTypeError 220 | #Else 221 | Debug.Print "Critical error: " & Err.Description & " [" & MODULE_NAME & "." & sFunction & "]" 222 | #End If 223 | End Function 224 | 225 | '========================================================================= 226 | ' Properties 227 | '========================================================================= 228 | 229 | Property Get AutoRedraw() As Boolean 230 | AutoRedraw = m_bAutoRedraw 231 | End Property 232 | 233 | Property Let AutoRedraw(ByVal bValue As Boolean) 234 | If m_bAutoRedraw <> bValue Then 235 | m_bAutoRedraw = bValue 236 | pvRefresh 237 | PropertyChanged 238 | End If 239 | End Property 240 | 241 | Property Get AutoSize() As Boolean 242 | AutoSize = m_bAutoSize 243 | End Property 244 | 245 | Property Let AutoSize(ByVal bValue As Boolean) 246 | If m_bAutoSize <> bValue Then 247 | m_bAutoSize = bValue 248 | If m_bAutoSize And TypeOf Extender Is VBControlExtender Then 249 | pvSizeExtender Extender 250 | End If 251 | pvRefresh 252 | PropertyChanged 253 | End If 254 | End Property 255 | 256 | Property Get Caption() As String 257 | Attribute Caption.VB_UserMemId = -518 258 | Caption = m_sCaption 259 | End Property 260 | 261 | Property Let Caption(sValue As String) 262 | If m_sCaption <> sValue Then 263 | m_sCaption = sValue 264 | If m_bAutoSize And TypeOf Extender Is VBControlExtender Then 265 | pvSizeExtender Extender 266 | End If 267 | pvRefresh 268 | PropertyChanged 269 | End If 270 | End Property 271 | 272 | Property Get Font() As StdFont 273 | Attribute Font.VB_UserMemId = -512 274 | Set Font = m_oFont 275 | End Property 276 | 277 | Property Set Font(oValue As StdFont) 278 | If Not m_oFont Is oValue Then 279 | Set m_oFont = oValue 280 | pvPrepareFont m_oFont, m_hFont 281 | If m_bAutoSize And TypeOf Extender Is VBControlExtender Then 282 | pvSizeExtender Extender 283 | End If 284 | pvRefresh 285 | PropertyChanged 286 | End If 287 | End Property 288 | 289 | Property Get TextOffsetX() As Single 290 | TextOffsetX = m_sngTextOffsetX 291 | End Property 292 | 293 | Property Let TextOffsetX(ByVal sngValue As Single) 294 | If m_sngTextOffsetX <> sngValue Then 295 | m_sngTextOffsetX = sngValue 296 | pvRefresh 297 | PropertyChanged 298 | End If 299 | End Property 300 | 301 | Property Get TextOffsetY() As Single 302 | TextOffsetY = m_sngTextOffsetY 303 | End Property 304 | 305 | Property Let TextOffsetY(ByVal sngValue As Single) 306 | If m_sngTextOffsetY <> sngValue Then 307 | m_sngTextOffsetY = sngValue 308 | pvRefresh 309 | PropertyChanged 310 | End If 311 | End Property 312 | 313 | Property Get ForeColor() As OLE_COLOR 314 | Attribute ForeColor.VB_UserMemId = -513 315 | ForeColor = m_clrFore 316 | End Property 317 | 318 | Property Let ForeColor(ByVal clrValue As OLE_COLOR) 319 | If m_clrFore <> clrValue Then 320 | m_clrFore = clrValue 321 | pvRefresh 322 | PropertyChanged 323 | End If 324 | End Property 325 | 326 | Property Get ForeOpacity() As Single 327 | ForeOpacity = m_sngForeOpacity 328 | End Property 329 | 330 | Property Let ForeOpacity(ByVal sngValue As Single) 331 | If m_sngForeOpacity <> sngValue Then 332 | m_sngForeOpacity = IIf(sngValue > 1, 1, IIf(sngValue < 0, 0, sngValue)) 333 | pvRefresh 334 | PropertyChanged 335 | End If 336 | End Property 337 | 338 | Property Get BackColor() As OLE_COLOR 339 | BackColor = m_clrBack 340 | End Property 341 | 342 | Property Let BackColor(ByVal clrValue As OLE_COLOR) 343 | If m_clrBack <> clrValue Then 344 | m_clrBack = clrValue 345 | pvRefresh 346 | PropertyChanged 347 | End If 348 | End Property 349 | 350 | Property Get BackOpacity() As Single 351 | BackOpacity = m_sngBackOpacity 352 | End Property 353 | 354 | Property Let BackOpacity(ByVal sngValue As Single) 355 | If m_sngBackOpacity <> sngValue Then 356 | m_sngBackOpacity = IIf(sngValue > 1, 1, IIf(sngValue < 0, 0, sngValue)) 357 | pvRefresh 358 | PropertyChanged 359 | End If 360 | End Property 361 | 362 | Property Get ShadowOffsetX() As Single 363 | ShadowOffsetX = m_sngShadowOffsetX 364 | End Property 365 | 366 | Property Let ShadowOffsetX(ByVal sngValue As Single) 367 | If m_sngShadowOffsetX <> sngValue Then 368 | m_sngShadowOffsetX = sngValue 369 | pvRefresh 370 | PropertyChanged 371 | End If 372 | End Property 373 | 374 | Property Get ShadowOffsetY() As Single 375 | ShadowOffsetY = m_sngShadowOffsetY 376 | End Property 377 | 378 | Property Let ShadowOffsetY(ByVal sngValue As Single) 379 | If m_sngShadowOffsetY <> sngValue Then 380 | m_sngShadowOffsetY = sngValue 381 | pvRefresh 382 | PropertyChanged 383 | End If 384 | End Property 385 | 386 | Property Get ShadowColor() As OLE_COLOR 387 | ShadowColor = m_clrShadow 388 | End Property 389 | 390 | Property Let ShadowColor(ByVal clrValue As OLE_COLOR) 391 | If m_clrShadow <> clrValue Then 392 | m_clrShadow = clrValue 393 | pvRefresh 394 | PropertyChanged 395 | End If 396 | End Property 397 | 398 | Property Get ShadowOpacity() As Single 399 | ShadowOpacity = m_sngShadowOpacity 400 | End Property 401 | 402 | Property Let ShadowOpacity(ByVal sngValue As Single) 403 | If m_sngShadowOpacity <> sngValue Then 404 | m_sngShadowOpacity = IIf(sngValue > 1, 1, IIf(sngValue < 0, 0, sngValue)) 405 | pvRefresh 406 | PropertyChanged 407 | End If 408 | End Property 409 | 410 | Property Get TextAlign() As UcsLabelTextAlignEnum 411 | TextAlign = m_eTextAlign 412 | End Property 413 | 414 | Property Let TextAlign(ByVal eValue As UcsLabelTextAlignEnum) 415 | If m_eTextAlign <> eValue Then 416 | m_eTextAlign = eValue 417 | pvRefresh 418 | PropertyChanged 419 | End If 420 | End Property 421 | 422 | Property Get TextFlags() As UcsLabelTextFlagsEnum 423 | TextFlags = m_eTextFlags 424 | End Property 425 | 426 | Property Let TextFlags(ByVal eValue As UcsLabelTextFlagsEnum) 427 | If m_eTextFlags <> eValue Then 428 | m_eTextFlags = eValue 429 | If m_bAutoSize And TypeOf Extender Is VBControlExtender Then 430 | pvSizeExtender Extender 431 | End If 432 | pvRefresh 433 | PropertyChanged 434 | End If 435 | End Property 436 | 437 | Property Get WordWrap() As Boolean 438 | WordWrap = (m_eTextFlags And ucsLtfNoWrap) = 0 439 | End Property 440 | 441 | Property Let WordWrap(ByVal bValue As Boolean) 442 | If bValue Then 443 | TextFlags = m_eTextFlags And Not ucsLtfNoWrap 444 | Else 445 | TextFlags = m_eTextFlags Or ucsLtfNoWrap 446 | End If 447 | End Property 448 | 449 | Property Get LastError() As String 450 | LastError = m_sLastError 451 | End Property 452 | 453 | '========================================================================= 454 | ' Methods 455 | '========================================================================= 456 | 457 | Public Function MeasureString(sCaption As String, sngWidth As Single, sngHeight As Single) As Boolean 458 | Dim hDC As Long 459 | Dim hGraphics As Long 460 | Dim uRect As RECTF 461 | Dim uBounds As RECTF 462 | Dim rcRect(0 To 3) As Long 463 | Dim pFont As IFont 464 | Dim hPrevFont As Long 465 | Dim hStringFormat As Long 466 | 467 | hDC = GetDC(ContainerHwnd) 468 | If hDC = 0 Then 469 | GoTo QH 470 | End If 471 | If m_hFont <> 0 Then 472 | If GdipCreateFromHDC(hDC, hGraphics) <> 0 Then 473 | GoTo QH 474 | End If 475 | If GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias) <> 0 Then 476 | GoTo QH 477 | End If 478 | If GdipSetTextRenderingHint(hGraphics, IIf(m_bAutoRedraw, TextRenderingHintAntiAlias, TextRenderingHintClearTypeGridFit)) <> 0 Then 479 | GoTo QH 480 | End If 481 | If Not pvPrepareStringFormat(m_eTextAlign Or m_eTextFlags, hStringFormat) Then 482 | GoTo QH 483 | End If 484 | uRect.Right = ScaleX(sngWidth, m_eContainerScaleMode, vbPixels) 485 | uRect.Bottom = ScaleY(sngHeight, m_eContainerScaleMode, vbPixels) 486 | If GdipMeasureString(hGraphics, StrPtr(sCaption), Len(sCaption), m_hFont, uRect, hStringFormat, uBounds, 0, 0) <> 0 Then 487 | GoTo QH 488 | End If 489 | '--- ceil 490 | sngWidth = -Int(-uBounds.Right) 491 | sngHeight = -Int(-uBounds.Bottom) 492 | Else 493 | Set pFont = m_oFont 494 | hPrevFont = SelectObject(hDC, pFont.hFont) 495 | rcRect(2) = ScaleX(sngWidth, m_eContainerScaleMode, vbPixels) 496 | rcRect(3) = ScaleY(sngHeight, m_eContainerScaleMode, vbPixels) 497 | Call DrawText(hDC, sCaption, Len(sCaption), rcRect(0), DT_CALCRECT) 498 | Call SelectObject(hDC, hPrevFont) 499 | sngWidth = rcRect(2) 500 | sngHeight = rcRect(3) 501 | End If 502 | sngWidth = ScaleY(sngWidth, vbPixels, m_eContainerScaleMode) 503 | sngHeight = ScaleY(sngHeight, vbPixels, m_eContainerScaleMode) 504 | '--- success 505 | MeasureString = True 506 | QH: 507 | If hStringFormat <> 0 Then 508 | Call GdipDeleteStringFormat(hStringFormat) 509 | hStringFormat = 0 510 | End If 511 | If hGraphics <> 0 Then 512 | Call GdipDeleteGraphics(hGraphics) 513 | hGraphics = 0 514 | End If 515 | If hDC <> 0 Then 516 | Call ReleaseDC(ContainerHwnd, hDC) 517 | hDC = 0 518 | End If 519 | End Function 520 | 521 | Public Sub Refresh() 522 | UserControl.Refresh 523 | End Sub 524 | 525 | '= private =============================================================== 526 | 527 | Private Function pvPaintControl(ByVal hDC As Long) As Boolean 528 | Const FUNC_NAME As String = "pvPaintControl" 529 | Dim hGraphics As Long 530 | Dim hFont As Long 531 | Dim sCaption As String 532 | Dim hStringFormat As Long 533 | Dim hBrush As Long 534 | Dim uRect As RECTF 535 | Dim sngLeft As Single 536 | Dim sngTop As Single 537 | Dim sngWidth As Single 538 | Dim sngHeight As Single 539 | Dim rcRect(0 To 3) As Long 540 | Dim pFont As IFont 541 | Dim hPrevFont As Long 542 | 543 | On Error GoTo EH 544 | If GetModuleHandle("gdiplus") = 0 Then 545 | rcRect(2) = ScaleX(ScaleWidth, ScaleMode, vbPixels) 546 | rcRect(3) = ScaleY(ScaleHeight, ScaleMode, vbPixels) 547 | Set pFont = m_oFont 548 | hPrevFont = SelectObject(hDC, pFont.hFont) 549 | Call DrawText(hDC, m_sCaption, -1, rcRect(0), 0) 550 | Call SelectObject(hDC, hPrevFont) 551 | GoTo QH 552 | End If 553 | If GdipCreateFromHDC(hDC, hGraphics) <> 0 Then 554 | GoTo QH 555 | End If 556 | If GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias) <> 0 Then 557 | GoTo QH 558 | End If 559 | If GdipSetTextRenderingHint(hGraphics, IIf(m_bAutoRedraw, TextRenderingHintAntiAlias, TextRenderingHintClearTypeGridFit)) <> 0 Then 560 | GoTo QH 561 | End If 562 | hFont = m_hFont 563 | sCaption = m_sCaption 564 | sngWidth = ScaleWidth 565 | sngHeight = ScaleHeight 566 | RaiseEvent OwnerDraw(hGraphics, hFont, sCaption, sngLeft, sngTop, sngWidth, sngHeight) 567 | If sngWidth > 0 Then 568 | If GdipCreateSolidFill(pvTranslateColor(m_clrBack, m_sngBackOpacity), hBrush) <> 0 Then 569 | GoTo QH 570 | End If 571 | If GdipFillRectangle(hGraphics, hBrush, sngLeft + 0.5, sngTop + 0.5, sngWidth - 1, sngHeight - 1) <> 0 Then 572 | GoTo QH 573 | End If 574 | If Not pvPrepareStringFormat(m_eTextAlign Or m_eTextFlags, hStringFormat) Then 575 | GoTo QH 576 | End If 577 | uRect.Left = sngLeft + m_sngTextOffsetX 578 | uRect.Top = sngTop + m_sngTextOffsetY 579 | uRect.Right = sngLeft + sngWidth 580 | uRect.Bottom = sngTop + sngHeight 581 | If m_sngShadowOpacity <> 0 Then 582 | If GdipSetSolidFillColor(hBrush, pvTranslateColor(m_clrShadow, m_sngShadowOpacity)) <> 0 Then 583 | GoTo QH 584 | End If 585 | uRect.Left = uRect.Left + m_sngShadowOffsetX 586 | uRect.Top = uRect.Top + m_sngShadowOffsetY 587 | If GdipDrawString(hGraphics, StrPtr(sCaption), -1, hFont, uRect, hStringFormat, hBrush) <> 0 Then 588 | GoTo QH 589 | End If 590 | uRect.Left = uRect.Left - m_sngShadowOffsetX 591 | uRect.Top = uRect.Top - m_sngShadowOffsetY 592 | End If 593 | If GdipSetSolidFillColor(hBrush, pvTranslateColor(m_clrFore, m_sngForeOpacity)) <> 0 Then 594 | GoTo QH 595 | End If 596 | If GdipDrawString(hGraphics, StrPtr(sCaption), -1, hFont, uRect, hStringFormat, hBrush) <> 0 Then 597 | GoTo QH 598 | End If 599 | End If 600 | '-- success 601 | pvPaintControl = True 602 | QH: 603 | On Error Resume Next 604 | If hFont <> 0 And hFont <> m_hFont Then 605 | Call GdipDeleteFont(hFont) 606 | hFont = 0 607 | End If 608 | If hStringFormat <> 0 Then 609 | Call GdipDeleteStringFormat(hStringFormat) 610 | hStringFormat = 0 611 | End If 612 | If hBrush <> 0 Then 613 | Call GdipDeleteBrush(hBrush) 614 | hBrush = 0 615 | End If 616 | If hGraphics <> 0 Then 617 | Call GdipDeleteGraphics(hGraphics) 618 | hGraphics = 0 619 | End If 620 | Exit Function 621 | EH: 622 | PrintError FUNC_NAME 623 | Resume QH 624 | End Function 625 | 626 | Private Function pvPrepareFont(oFont As StdFont, hFont As Long) As Boolean 627 | Const FUNC_NAME As String = "pvPrepareFont" 628 | Dim hFamily As Long 629 | Dim hNewFont As Long 630 | Dim eStyle As FontStyle 631 | 632 | On Error GoTo EH 633 | If GetModuleHandle("gdiplus") = 0 Then 634 | GoTo QH 635 | End If 636 | If oFont Is Nothing Then 637 | GoTo QH 638 | End If 639 | If GdipCreateFontFamilyFromName(StrPtr(oFont.Name), 0, hFamily) <> 0 Then 640 | If GdipGetGenericFontFamilySansSerif(hFamily) <> 0 Then 641 | GoTo QH 642 | End If 643 | End If 644 | eStyle = FontStyleBold * -oFont.Bold _ 645 | Or FontStyleItalic * -oFont.Italic _ 646 | Or FontStyleUnderline * -oFont.Underline _ 647 | Or FontStyleStrikeout * -oFont.Strikethrough 648 | If GdipCreateFont(hFamily, oFont.Size, eStyle, UnitPoint, hNewFont) <> 0 Then 649 | GoTo QH 650 | End If 651 | '--- commit 652 | If hFont <> 0 Then 653 | Call GdipDeleteFont(hFont) 654 | End If 655 | hFont = hNewFont 656 | hNewFont = 0 657 | '--- success 658 | pvPrepareFont = True 659 | QH: 660 | On Error Resume Next 661 | If hFamily <> 0 Then 662 | Call GdipDeleteFontFamily(hFamily) 663 | hFamily = 0 664 | End If 665 | If hNewFont <> 0 Then 666 | Call GdipDeleteFont(hNewFont) 667 | hNewFont = 0 668 | End If 669 | Exit Function 670 | EH: 671 | PrintError FUNC_NAME 672 | Resume QH 673 | End Function 674 | 675 | Private Function pvPrepareStringFormat(ByVal lFlags As Long, hStringFormat As Long) As Boolean 676 | Const FUNC_NAME As String = "pvPrepareStringFormat" 677 | Dim hNewFormat As Long 678 | 679 | On Error GoTo EH 680 | If GdipCreateStringFormat(0, 0, hNewFormat) <> 0 Then 681 | GoTo QH 682 | End If 683 | If GdipSetStringFormatAlign(hNewFormat, lFlags And 3) <> 0 Then 684 | GoTo QH 685 | End If 686 | If GdipSetStringFormatLineAlign(hNewFormat, (lFlags \ 4) And 3) <> 0 Then 687 | GoTo QH 688 | End If 689 | If GdipSetStringFormatFlags(hNewFormat, lFlags \ 16) <> 0 Then 690 | GoTo QH 691 | End If 692 | '--- commit 693 | If hStringFormat <> 0 Then 694 | Call GdipDeleteStringFormat(hStringFormat) 695 | End If 696 | hStringFormat = hNewFormat 697 | hNewFormat = 0 698 | '--- success 699 | pvPrepareStringFormat = True 700 | QH: 701 | On Error Resume Next 702 | If hNewFormat <> 0 Then 703 | Call GdipDeleteStringFormat(hNewFormat) 704 | hNewFormat = 0 705 | End If 706 | Exit Function 707 | EH: 708 | PrintError FUNC_NAME 709 | Resume Next 710 | End Function 711 | 712 | Private Function pvTranslateColor(ByVal clrValue As OLE_COLOR, Optional ByVal Alpha As Single = 1) As Long 713 | Dim uQuad As UcsRgbQuad 714 | Dim lTemp As Long 715 | 716 | Call OleTranslateColor(clrValue, 0, VarPtr(uQuad)) 717 | lTemp = uQuad.R 718 | uQuad.R = uQuad.B 719 | uQuad.B = lTemp 720 | lTemp = Alpha * &HFF 721 | If lTemp > 255 Then 722 | uQuad.A = 255 723 | ElseIf lTemp < 0 Then 724 | uQuad.A = 0 725 | Else 726 | uQuad.A = lTemp 727 | End If 728 | Call CopyMemory(pvTranslateColor, uQuad, 4) 729 | End Function 730 | 731 | Private Sub pvRefresh() 732 | m_bShown = False 733 | If m_hRedrawDib <> 0 Then 734 | Call DeleteObject(m_hRedrawDib) 735 | m_hRedrawDib = 0 736 | End If 737 | UserControl.Refresh 738 | End Sub 739 | 740 | Private Sub pvHandleMouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 741 | m_nDownButton = Button 742 | m_nDownShift = Shift 743 | m_sngDownX = X 744 | m_sngDownY = Y 745 | End Sub 746 | 747 | Private Sub pvSizeExtender(oExt As VBControlExtender) 748 | Dim sngWidth As Single 749 | Dim sngHeight As Single 750 | 751 | If WordWrap Then 752 | sngWidth = oExt.Width 753 | End If 754 | If MeasureString(m_sCaption, sngWidth, sngHeight) Then 755 | If Not WordWrap Then 756 | oExt.Width = sngWidth 757 | End If 758 | oExt.Height = sngHeight 759 | End If 760 | End Sub 761 | 762 | '= common ================================================================ 763 | 764 | Private Function pvCreateDib(ByVal hMemDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, hDib As Long, Optional lpBits As Long) As Boolean 765 | Const FUNC_NAME As String = "pvCreateDib" 766 | Dim uHdr As BITMAPINFOHEADER 767 | 768 | On Error GoTo EH 769 | With uHdr 770 | .biSize = Len(uHdr) 771 | .biPlanes = 1 772 | .biBitCount = 32 773 | .biWidth = lWidth 774 | .biHeight = -lHeight 775 | .biSizeImage = 4 * lWidth * lHeight 776 | End With 777 | hDib = CreateDIBSection(hMemDC, uHdr, DIB_RGB_COLORS, lpBits, 0, 0) 778 | If hDib = 0 Then 779 | GoTo QH 780 | End If 781 | '--- success 782 | pvCreateDib = True 783 | QH: 784 | Exit Function 785 | EH: 786 | PrintError FUNC_NAME 787 | Resume QH 788 | End Function 789 | 790 | Private Function ToScaleMode(sScaleUnits As String) As ScaleModeConstants 791 | Select Case sScaleUnits 792 | Case "Twip" 793 | ToScaleMode = vbTwips 794 | Case "Point" 795 | ToScaleMode = vbPoints 796 | Case "Pixel" 797 | ToScaleMode = vbPixels 798 | Case "Character" 799 | ToScaleMode = vbCharacters 800 | Case "Centimeter" 801 | ToScaleMode = vbCentimeters 802 | Case "Millimeter" 803 | ToScaleMode = vbMillimeters 804 | Case "Inch" 805 | ToScaleMode = vbInches 806 | Case Else 807 | ToScaleMode = vbTwips 808 | End Select 809 | End Function 810 | 811 | '========================================================================= 812 | ' Events 813 | '========================================================================= 814 | 815 | Private Sub m_oFont_FontChanged(ByVal PropertyName As String) 816 | pvPrepareFont m_oFont, m_hFont 817 | If m_bAutoSize And TypeOf Extender Is VBControlExtender Then 818 | pvSizeExtender Extender 819 | End If 820 | pvRefresh 821 | PropertyChanged 822 | End Sub 823 | 824 | Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 825 | RaiseEvent MouseDown(Button, Shift, ScaleX(X, ScaleMode, m_eContainerScaleMode), ScaleY(Y, ScaleMode, m_eContainerScaleMode)) 826 | pvHandleMouseDown Button, Shift, X, Y 827 | End Sub 828 | 829 | Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 830 | RaiseEvent MouseMove(Button, Shift, ScaleX(X, ScaleMode, m_eContainerScaleMode), ScaleY(Y, ScaleMode, m_eContainerScaleMode)) 831 | End Sub 832 | 833 | Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 834 | Const FUNC_NAME As String = "UserControl_MouseUp" 835 | 836 | On Error GoTo EH 837 | RaiseEvent MouseUp(Button, Shift, ScaleX(X, ScaleMode, m_eContainerScaleMode), ScaleY(Y, ScaleMode, m_eContainerScaleMode)) 838 | If Button = -1 Then 839 | GoTo QH 840 | End If 841 | If Button <> 0 And X >= 0 And X < ScaleWidth And Y >= 0 And Y < ScaleHeight Then 842 | If (m_nDownButton And Button And vbLeftButton) <> 0 Then 843 | RaiseEvent Click 844 | ElseIf (m_nDownButton And Button And vbRightButton) <> 0 Then 845 | RaiseEvent ContextMenu 846 | End If 847 | End If 848 | m_nDownButton = 0 849 | QH: 850 | Exit Sub 851 | EH: 852 | PrintError FUNC_NAME 853 | Resume QH 854 | End Sub 855 | 856 | Private Sub UserControl_DblClick() 857 | pvHandleMouseDown vbLeftButton, m_nDownShift, m_sngDownX, m_sngDownY 858 | RaiseEvent DblClick 859 | End Sub 860 | 861 | Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult As Integer) 862 | HitResult = vbHitResultHit 863 | End Sub 864 | 865 | Private Sub UserControl_Resize() 866 | pvRefresh 867 | End Sub 868 | 869 | Private Sub UserControl_Hide() 870 | m_bShown = False 871 | End Sub 872 | 873 | Private Sub UserControl_Paint() 874 | Const FUNC_NAME As String = "UserControl_Paint" 875 | Const Opacity As Long = &HFF 876 | Dim hMemDC As Long 877 | Dim hPrevDib As Long 878 | 879 | On Error GoTo EH 880 | If AutoRedraw Then 881 | hMemDC = CreateCompatibleDC(hDC) 882 | If hMemDC = 0 Then 883 | GoTo DefPaint 884 | End If 885 | If m_hRedrawDib = 0 Then 886 | If Not pvCreateDib(hMemDC, ScaleWidth, ScaleHeight, m_hRedrawDib) Then 887 | GoTo DefPaint 888 | End If 889 | hPrevDib = SelectObject(hMemDC, m_hRedrawDib) 890 | If Not pvPaintControl(hMemDC) Then 891 | GoTo DefPaint 892 | End If 893 | Else 894 | hPrevDib = SelectObject(hMemDC, m_hRedrawDib) 895 | End If 896 | If AlphaBlend(hDC, 0, 0, ScaleWidth, ScaleHeight, hMemDC, 0, 0, ScaleWidth, ScaleHeight, AC_SRC_ALPHA * &H1000000 + Opacity * &H10000) = 0 Then 897 | GoTo DefPaint 898 | End If 899 | Else 900 | If Not pvPaintControl(hDC) Then 901 | GoTo DefPaint 902 | End If 903 | End If 904 | If False Then 905 | DefPaint: 906 | If m_hRedrawDib <> 0 Then 907 | '--- note: before deleting DIB try de-selecting from dc 908 | Call SelectObject(hMemDC, hPrevDib) 909 | Call DeleteObject(m_hRedrawDib) 910 | m_hRedrawDib = 0 911 | End If 912 | End If 913 | QH: 914 | On Error Resume Next 915 | If hMemDC <> 0 Then 916 | Call SelectObject(hMemDC, hPrevDib) 917 | Call DeleteDC(hMemDC) 918 | hMemDC = 0 919 | End If 920 | Exit Sub 921 | EH: 922 | PrintError FUNC_NAME 923 | Resume QH 924 | End Sub 925 | 926 | Private Sub UserControl_InitProperties() 927 | Const FUNC_NAME As String = "UserControl_InitProperties" 928 | 929 | On Error GoTo EH 930 | m_eContainerScaleMode = ToScaleMode(Ambient.ScaleUnits) 931 | m_bAutoRedraw = DEF_AUTOREDRAW 932 | m_bAutoSize = DEF_AUTOSIZE 933 | m_sCaption = Ambient.DisplayName 934 | Set m_oFont = Ambient.Font 935 | m_sngTextOffsetX = DEF_TEXTOFFSETX 936 | m_sngTextOffsetY = DEF_TEXTOFFSETY 937 | m_clrFore = DEF_FORECOLOR 938 | m_sngForeOpacity = DEF_FOREOPACITY 939 | m_clrBack = DEF_BACKCOLOR 940 | m_sngBackOpacity = DEF_BACKOPACITY 941 | m_sngShadowOffsetX = DEF_SHADOWOFFSETX 942 | m_sngShadowOffsetY = DEF_SHADOWOFFSETY 943 | m_clrShadow = DEF_SHADOWCOLOR 944 | m_sngShadowOpacity = DEF_SHADOWOPACITY 945 | m_eTextAlign = DEF_TEXTALIGN 946 | m_eTextFlags = DEF_TEXTFLAGS 947 | pvPrepareFont m_oFont, m_hFont 948 | Exit Sub 949 | EH: 950 | PrintError FUNC_NAME 951 | End Sub 952 | 953 | Private Sub UserControl_ReadProperties(PropBag As PropertyBag) 954 | Const FUNC_NAME As String = "UserControl_ReadProperties" 955 | 956 | On Error GoTo EH 957 | m_eContainerScaleMode = ToScaleMode(Ambient.ScaleUnits) 958 | With PropBag 959 | m_bAutoRedraw = .ReadProperty("AutoRedraw", DEF_AUTOREDRAW) 960 | m_bAutoSize = .ReadProperty("AutoSize", DEF_AUTOSIZE) 961 | m_sCaption = .ReadProperty("Caption", vbNullString) 962 | Set m_oFont = .ReadProperty("Font", Ambient.Font) 963 | m_sngTextOffsetX = .ReadProperty("TextOffsetX", DEF_TEXTOFFSETX) 964 | m_sngTextOffsetY = .ReadProperty("TextOffsetY", DEF_TEXTOFFSETY) 965 | m_clrFore = .ReadProperty("ForeColor", DEF_FORECOLOR) 966 | m_sngForeOpacity = .ReadProperty("ForeOpacity", DEF_FOREOPACITY) 967 | m_clrBack = .ReadProperty("BackColor", DEF_BACKCOLOR) 968 | m_sngBackOpacity = .ReadProperty("BackOpacity", DEF_BACKOPACITY) 969 | m_sngShadowOffsetX = .ReadProperty("ShadowOffsetX", DEF_SHADOWOFFSETX) 970 | m_sngShadowOffsetY = .ReadProperty("ShadowOffsetY", DEF_SHADOWOFFSETY) 971 | m_clrShadow = .ReadProperty("ShadowColor", DEF_SHADOWCOLOR) 972 | m_sngShadowOpacity = .ReadProperty("ShadowOpacity", DEF_SHADOWOPACITY) 973 | m_eTextAlign = .ReadProperty("TextAlign", DEF_TEXTALIGN) 974 | m_eTextFlags = .ReadProperty("TextFlags", DEF_TEXTFLAGS) 975 | End With 976 | pvPrepareFont m_oFont, m_hFont 977 | QH: 978 | Exit Sub 979 | EH: 980 | PrintError FUNC_NAME 981 | Resume QH 982 | End Sub 983 | 984 | Private Sub UserControl_WriteProperties(PropBag As PropertyBag) 985 | Const FUNC_NAME As String = "UserControl_ReadProperties" 986 | 987 | On Error GoTo EH 988 | With PropBag 989 | .WriteProperty "AutoRedraw", m_bAutoRedraw, DEF_AUTOREDRAW 990 | .WriteProperty "AutoSize", m_bAutoSize, DEF_AUTOSIZE 991 | .WriteProperty "Caption", m_sCaption, vbNullString 992 | .WriteProperty "Font", m_oFont, Ambient.Font 993 | .WriteProperty "TextOffsetX", m_sngTextOffsetX, DEF_TEXTOFFSETX 994 | .WriteProperty "TextOffsetY", m_sngTextOffsetY, DEF_TEXTOFFSETY 995 | .WriteProperty "ForeColor", m_clrFore, DEF_FORECOLOR 996 | .WriteProperty "ForeOpacity", m_sngForeOpacity, DEF_FOREOPACITY 997 | .WriteProperty "BackColor", m_clrBack, DEF_BACKCOLOR 998 | .WriteProperty "BackOpacity", m_sngBackOpacity, DEF_BACKOPACITY 999 | .WriteProperty "ShadowOffsetX", m_sngShadowOffsetX, DEF_SHADOWOFFSETX 1000 | .WriteProperty "ShadowOffsetY", m_sngShadowOffsetY, DEF_SHADOWOFFSETY 1001 | .WriteProperty "ShadowColor", m_clrShadow, DEF_SHADOWCOLOR 1002 | .WriteProperty "ShadowOpacity", m_sngShadowOpacity, DEF_SHADOWOPACITY 1003 | .WriteProperty "TextAlign", m_eTextAlign, DEF_TEXTALIGN 1004 | .WriteProperty "TextFlags", m_eTextFlags, DEF_TEXTFLAGS 1005 | End With 1006 | QH: 1007 | Exit Sub 1008 | EH: 1009 | PrintError FUNC_NAME 1010 | Resume QH 1011 | End Sub 1012 | 1013 | 'Private Sub UserControl_AmbientChanged(PropertyName As String) 1014 | ' If PropertyName = "ScaleUnits" Then 1015 | ' m_eContainerScaleMode = ToScaleMode(Ambient.ScaleUnits) 1016 | ' End If 1017 | 'End Sub 1018 | 1019 | '========================================================================= 1020 | ' Base class events 1021 | '========================================================================= 1022 | 1023 | Private Sub UserControl_Initialize() 1024 | Dim aInput(0 To 3) As Long 1025 | 1026 | If GetModuleHandle("gdiplus") = 0 Then 1027 | aInput(0) = 1 1028 | On Error Resume Next 1029 | Call GdiplusStartup(0, aInput(0)) 1030 | On Error GoTo 0 1031 | End If 1032 | m_eContainerScaleMode = vbTwips 1033 | End Sub 1034 | 1035 | Private Sub UserControl_Terminate() 1036 | If m_hFont <> 0 Then 1037 | Call GdipDeleteFont(m_hFont) 1038 | m_hFont = 0 1039 | End If 1040 | If m_hRedrawDib <> 0 Then 1041 | Call DeleteObject(m_hRedrawDib) 1042 | m_hRedrawDib = 0 1043 | End If 1044 | End Sub 1045 | -------------------------------------------------------------------------------- /contrib/AlphaBlendTabStrip.ctl: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.UserControl AlphaBlendTabStrip 3 | BackStyle = 0 'Transparent 4 | CanGetFocus = 0 'False 5 | ClientHeight = 2880 6 | ClientLeft = 0 7 | ClientTop = 0 8 | ClientWidth = 5700 9 | ClipBehavior = 0 'None 10 | ScaleHeight = 2880 11 | ScaleWidth = 5700 12 | Windowless = -1 'True 13 | Begin Project1.AlphaBlendLabel labTab 14 | Height = 348 15 | Index = 0 16 | Left = 0 17 | Top = 0 18 | Visible = 0 'False 19 | Width = 1020 20 | _ExtentX = 1799 21 | _ExtentY = 614 22 | Caption = "Tab" 23 | BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 24 | Name = "Segoe UI" 25 | Size = 9 26 | Charset = 204 27 | Weight = 400 28 | Underline = 0 'False 29 | Italic = 0 'False 30 | Strikethrough = 0 'False 31 | EndProperty 32 | ForeOpacity = 0.75 33 | TextFlags = 65536 34 | End 35 | Begin Project1.AlphaBlendLabel labBackgr 36 | Height = 390 37 | Left = 0 38 | Top = 0 39 | Width = 4968 40 | _ExtentX = 8763 41 | _ExtentY = 699 42 | BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 43 | Name = "Segoe UI" 44 | Size = 9 45 | Charset = 204 46 | Weight = 400 47 | Underline = 0 'False 48 | Italic = 0 'False 49 | Strikethrough = 0 'False 50 | EndProperty 51 | BackColor = -2147483643 52 | BackOpacity = 0.75 53 | End 54 | End 55 | Attribute VB_Name = "AlphaBlendTabStrip" 56 | Attribute VB_GlobalNameSpace = False 57 | Attribute VB_Creatable = True 58 | Attribute VB_PredeclaredId = False 59 | Attribute VB_Exposed = False 60 | '========================================================================= 61 | ' 62 | ' AlphaBlendTabStrip (c) 2020 by wqweto@gmail.com 63 | ' 64 | ' Poor Man's TabStrip Control 65 | ' 66 | '========================================================================= 67 | Option Explicit 68 | DefObj A-Z 69 | Private Const MODULE_NAME As String = "AlphaBlendTabStrip" 70 | 71 | '========================================================================= 72 | ' Events 73 | '========================================================================= 74 | 75 | Event Click() 76 | Event BeforeClick(TabIndex As Long, Cancel As Boolean) 77 | 78 | '========================================================================= 79 | ' API 80 | '========================================================================= 81 | 82 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long) 83 | Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long 84 | Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long 85 | '--- GDI+ 86 | Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, hBrush As Long) As Long 87 | Private Declare Function GdipSetSolidFillColor Lib "gdiplus" (ByVal hBrush As Long, ByVal argb As Long) As Long 88 | Private Declare Function GdipFillRectangle Lib "gdiplus" (ByVal hGraphics As Long, ByVal hBrush As Long, ByVal sngX As Single, ByVal sngY As Single, ByVal sngWidth As Single, ByVal sngHeight As Single) As Long 89 | Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal hBrush As Long) As Long 90 | 91 | '========================================================================= 92 | ' Constants and member variables 93 | '========================================================================= 94 | 95 | Private m_aTabCaptions() As String 96 | Private m_oFont As StdFont 97 | Private m_oFontBold As StdFont 98 | Private m_lCurrentTab As Long 99 | 100 | Private Type UcsRgbQuad 101 | R As Byte 102 | G As Byte 103 | B As Byte 104 | A As Byte 105 | End Type 106 | 107 | '========================================================================= 108 | ' Error handling 109 | '========================================================================= 110 | 111 | Private Function PrintError(sFunction As String) As VbMsgBoxResult 112 | #If USE_DEBUG_LOG <> 0 Then 113 | DebugLog MODULE_NAME, sFunction & "(" & Erl & ")", Err.Description & " &H" & Hex$(Err.Number), vbLogEventTypeError 114 | #Else 115 | Debug.Print "Critical error: " & Err.Description & " [" & MODULE_NAME & "." & sFunction & "]" 116 | #End If 117 | End Function 118 | 119 | '========================================================================= 120 | ' Properties 121 | '========================================================================= 122 | 123 | Property Get Layout() As String 124 | Attribute Layout.VB_UserMemId = -518 125 | Layout = Join(m_aTabCaptions, "|") 126 | End Property 127 | 128 | Property Let Layout(sValue As String) 129 | m_aTabCaptions = Split(sValue, "|") 130 | pvLoadTabs 131 | CurrentTab = CurrentTab 132 | PropertyChanged 133 | End Property 134 | 135 | Property Get Font() As StdFont 136 | Set Font = m_oFont 137 | End Property 138 | 139 | Property Set Font(oValue As StdFont) 140 | If Not oValue Is Nothing Then 141 | Set m_oFont = oValue 142 | Else 143 | Set m_oFont = New StdFont 144 | End If 145 | Set m_oFontBold = pvCloneFont(m_oFont) 146 | m_oFontBold.Bold = True 147 | pvResizeTabs 148 | PropertyChanged 149 | End Property 150 | 151 | Property Get CurrentTab() As Long 152 | CurrentTab = m_lCurrentTab 153 | End Property 154 | 155 | Property Let CurrentTab(ByVal lValue As Long) 156 | m_lCurrentTab = lValue 157 | If m_lCurrentTab >= labTab.UBound Then 158 | m_lCurrentTab = labTab.UBound - 1 159 | ElseIf m_lCurrentTab < 0 Then 160 | m_lCurrentTab = 0 161 | End If 162 | pvResizeTabs 163 | PropertyChanged 164 | End Property 165 | 166 | Property Get TabCaption(ByVal Index As Long) As String 167 | TabCaption = m_aTabCaptions(Index) 168 | End Property 169 | 170 | Property Let TabCaption(ByVal Index As Long, sValue As String) 171 | m_aTabCaptions(Index) = sValue 172 | pvResizeTabs 173 | End Property 174 | 175 | Property Get TabCount() As Long 176 | TabCount = UBound(m_aTabCaptions) + 1 177 | End Property 178 | 179 | '========================================================================= 180 | ' Methods 181 | '========================================================================= 182 | 183 | Private Sub pvLoadTabs() 184 | Const FUNC_NAME As String = "pvLoadTabs" 185 | Dim lIdx As Long 186 | 187 | On Error GoTo EH 188 | For lIdx = 0 To UBound(m_aTabCaptions) 189 | If labTab.UBound < lIdx + 1 Then 190 | On Error GoTo QH 191 | Load labTab(lIdx + 1) 192 | On Error GoTo EH 193 | labTab(lIdx + 1).ZOrder vbBringToFront 194 | labTab(lIdx + 1).BackColor = vbButtonFace 195 | End If 196 | Next 197 | For lIdx = lIdx + 1 To labTab.UBound 198 | Unload labTab(lIdx) 199 | Next 200 | QH: 201 | Exit Sub 202 | EH: 203 | PrintError FUNC_NAME 204 | End Sub 205 | 206 | Private Sub pvResizeTabs() 207 | Const FUNC_NAME As String = "pvResizeTabs" 208 | Dim lIdx As Long 209 | Dim lTop As Long 210 | Dim lLeft As Long 211 | Dim lHeight As Long 212 | 213 | On Error GoTo EH 214 | labBackgr.Move 0, 0, ScaleWidth, ScaleHeight 215 | lTop = labBackgr.Top + IconScale(3) * ScreenTwipsPerPixelY 216 | lLeft = labBackgr.Left + IconScale(6) * ScreenTwipsPerPixelX 217 | lHeight = labBackgr.Height - IconScale(3) * ScreenTwipsPerPixelY 218 | For lIdx = 0 To labTab.UBound - 1 219 | With labTab(lIdx + 1) 220 | .Visible = False 221 | .Caption = m_aTabCaptions(lIdx) 222 | .Move lLeft, lTop 223 | Set .Font = IIf(lIdx = m_lCurrentTab, m_oFontBold, m_oFont) 224 | .BackOpacity = IIf(lIdx = m_lCurrentTab, 1, 0) 225 | .AutoSize = True 226 | .AutoSize = False 227 | .Width = .Width + IIf(lIdx = m_lCurrentTab, 240, 180) 228 | .Height = lHeight 229 | lLeft = lLeft + .Width 230 | .Visible = True 231 | End With 232 | Next 233 | Exit Sub 234 | EH: 235 | PrintError FUNC_NAME 236 | End Sub 237 | 238 | Private Function pvCloneFont(pFont As IFont) As StdFont 239 | If Not pFont Is Nothing Then 240 | pFont.Clone pvCloneFont 241 | Else 242 | Set pvCloneFont = New StdFont 243 | End If 244 | End Function 245 | 246 | Private Function pvTranslateColor(ByVal clrValue As OLE_COLOR, Optional ByVal Alpha As Single = 1) As Long 247 | Dim uQuad As UcsRgbQuad 248 | Dim lTemp As Long 249 | 250 | Call OleTranslateColor(clrValue, 0, VarPtr(uQuad)) 251 | lTemp = uQuad.R 252 | uQuad.R = uQuad.B 253 | uQuad.B = lTemp 254 | lTemp = Alpha * &HFF 255 | If lTemp > 255 Then 256 | uQuad.A = 255 257 | ElseIf lTemp < 0 Then 258 | uQuad.A = 0 259 | Else 260 | uQuad.A = lTemp 261 | End If 262 | Call CopyMemory(pvTranslateColor, uQuad, 4) 263 | End Function 264 | 265 | '========================================================================= 266 | ' Events 267 | '========================================================================= 268 | 269 | Private Sub labTab_Click(Index As Integer) 270 | Const FUNC_NAME As String = "labTab_Click" 271 | Dim bCancel As Boolean 272 | 273 | On Error GoTo EH 274 | RaiseEvent BeforeClick(Index - 1, bCancel) 275 | If Not bCancel Then 276 | m_lCurrentTab = Index - 1 277 | pvResizeTabs 278 | RaiseEvent Click 279 | End If 280 | Exit Sub 281 | EH: 282 | PrintError FUNC_NAME 283 | End Sub 284 | 285 | Private Sub labTab_OwnerDraw(Index As Integer, ByVal hGraphics As Long, ByVal hFont As Long, sCaption As String, sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single) 286 | Const FUNC_NAME As String = "labTab_OwnerDraw" 287 | Dim clrLight As Long 288 | Dim sngPixel As Single 289 | 290 | On Error GoTo EH 291 | sngPixel = IconScale(16!) / 16! 292 | If Index - 1 = m_lCurrentTab Then 293 | clrLight = pvTranslateColor(vbWindowBackground) 294 | pvDrawRect hGraphics, 0, 0, sngWidth, sngHeight, clrLight, clrLight, pvTranslateColor(vbWindowText), pvTranslateColor(vbButtonFace) 295 | sngLeft = sngLeft + sngPixel 296 | sngWidth = sngWidth - 2 * sngPixel 297 | ElseIf Index <> m_lCurrentTab Then 298 | pvDrawRect hGraphics, 0, 3 * sngPixel, sngWidth, sngHeight - 6 * sngPixel, 0, 0, pvTranslateColor(vbWindowText, 0.5), 0 299 | sngWidth = sngWidth - sngPixel 300 | End If 301 | sngTop = sngTop + sngPixel 302 | sngHeight = sngHeight - 2 * sngPixel 303 | Exit Sub 304 | EH: 305 | PrintError FUNC_NAME 306 | End Sub 307 | 308 | Private Sub labBackgr_OwnerDraw(ByVal hGraphics As Long, ByVal hFont As Long, sCaption As String, sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single) 309 | Const FUNC_NAME As String = "labBackgr_OwnerDraw" 310 | Dim clrDark As Long 311 | Dim sngPixel As Single 312 | 313 | On Error GoTo EH 314 | sngPixel = IconScale(16!) / 16! 315 | clrDark = pvTranslateColor(vbWindowText, 0.25) 316 | pvDrawRect hGraphics, 0, 0, sngWidth, sngHeight, clrDark, clrDark, clrDark, pvTranslateColor(vbWindowBackground) 317 | sngLeft = sngLeft + sngPixel 318 | sngTop = sngTop + sngPixel 319 | sngWidth = sngWidth - 2 * sngPixel 320 | sngHeight = sngHeight - sngPixel 321 | Exit Sub 322 | EH: 323 | PrintError FUNC_NAME 324 | End Sub 325 | 326 | Private Function pvDrawRect(ByVal hGraphics As Long, _ 327 | ByVal sngLeft As Single, ByVal sngTop As Single, ByVal sngWidth As Single, ByVal sngHeight As Single, _ 328 | ByVal clrLeft As Long, ByVal clrTop As Long, ByVal clrRight As Long, ByVal clrBottom As Long) As Boolean 329 | Const FUNC_NAME As String = "pvDrawRect" 330 | Dim hBrush As Long 331 | Dim sngPixel As Single 332 | 333 | On Error GoTo EH 334 | If GetModuleHandle("gdiplus") = 0 Then 335 | GoTo QH 336 | End If 337 | sngPixel = IconScale(16!) / 16! 338 | If GdipCreateSolidFill(clrLeft, hBrush) <> 0 Then 339 | GoTo QH 340 | End If 341 | If GdipFillRectangle(hGraphics, hBrush, sngLeft + 0.5, sngTop + 0.5, sngPixel, sngHeight) <> 0 Then 342 | GoTo QH 343 | End If 344 | If GdipSetSolidFillColor(hBrush, clrTop) <> 0 Then 345 | GoTo QH 346 | End If 347 | If GdipFillRectangle(hGraphics, hBrush, sngLeft + 0.5 + sngPixel, sngTop + 0.5, sngWidth, sngPixel) <> 0 Then 348 | GoTo QH 349 | End If 350 | If GdipSetSolidFillColor(hBrush, clrRight) <> 0 Then 351 | GoTo QH 352 | End If 353 | If GdipFillRectangle(hGraphics, hBrush, sngLeft + sngWidth - 0.5 - sngPixel, sngTop + 0.5 + sngPixel, sngPixel, sngHeight - sngPixel) <> 0 Then 354 | GoTo QH 355 | End If 356 | If GdipSetSolidFillColor(hBrush, clrBottom) <> 0 Then 357 | GoTo QH 358 | End If 359 | If GdipFillRectangle(hGraphics, hBrush, sngLeft + 0.5 + sngPixel, sngTop + sngHeight - 0.5 - sngPixel, sngWidth - 2 * sngPixel - 1, sngPixel) <> 0 Then 360 | GoTo QH 361 | End If 362 | pvDrawRect = True 363 | QH: 364 | If hBrush <> 0 Then 365 | Call GdipDeleteBrush(hBrush) 366 | hBrush = 0 367 | End If 368 | Exit Function 369 | EH: 370 | PrintError FUNC_NAME 371 | Resume QH 372 | End Function 373 | 374 | Private Property Get ScreenTwipsPerPixelX() As Single 375 | ScreenTwipsPerPixelX = Screen.TwipsPerPixelX 376 | End Property 377 | 378 | Private Property Get ScreenTwipsPerPixelY() As Single 379 | ScreenTwipsPerPixelY = Screen.TwipsPerPixelY 380 | End Property 381 | 382 | Private Function IconScale(ByVal sngSize As Single) As Long 383 | If ScreenTwipsPerPixelX < 6.5 Then 384 | IconScale = Int(sngSize * 3) 385 | ElseIf ScreenTwipsPerPixelX < 9.5 Then 386 | IconScale = Int(sngSize * 2) 387 | ElseIf ScreenTwipsPerPixelX < 11.5 Then 388 | IconScale = Int(sngSize * 3 \ 2) 389 | Else 390 | IconScale = Int(sngSize * 1) 391 | End If 392 | End Function 393 | 394 | '========================================================================= 395 | ' Base class events 396 | '========================================================================= 397 | 398 | Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult As Integer) 399 | HitResult = vbHitResultHit 400 | End Sub 401 | 402 | Private Sub UserControl_Resize() 403 | pvResizeTabs 404 | End Sub 405 | 406 | Private Sub UserControl_InitProperties() 407 | Const FUNC_NAME As String = "UserControl_InitProperties" 408 | 409 | On Error GoTo EH 410 | Set Font = Ambient.Font 411 | Layout = Ambient.DisplayName 412 | Exit Sub 413 | EH: 414 | PrintError FUNC_NAME 415 | End Sub 416 | 417 | Private Sub UserControl_ReadProperties(PropBag As PropertyBag) 418 | Const FUNC_NAME As String = "UserControl_ReadProperties" 419 | 420 | On Error GoTo EH 421 | With PropBag 422 | Set Font = .ReadProperty("Font", Ambient.Font) 423 | Layout = .ReadProperty("Layout", vbNullString) 424 | CurrentTab = .ReadProperty("CurrentTab", 0) 425 | End With 426 | Exit Sub 427 | EH: 428 | PrintError FUNC_NAME 429 | End Sub 430 | 431 | Private Sub UserControl_WriteProperties(PropBag As PropertyBag) 432 | Const FUNC_NAME As String = "UserControl_WriteProperties" 433 | 434 | On Error GoTo EH 435 | With PropBag 436 | .WriteProperty "Font", Font, Ambient.Font 437 | .WriteProperty "Layout", Layout, vbNullString 438 | .WriteProperty "CurrentTab", CurrentTab, 0 439 | End With 440 | Exit Sub 441 | EH: 442 | PrintError FUNC_NAME 443 | End Sub 444 | -------------------------------------------------------------------------------- /src/AlphaBlendImage.ctl: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.UserControl AlphaBlendImage 3 | BackStyle = 0 'Transparent 4 | CanGetFocus = 0 'False 5 | ClientHeight = 2880 6 | ClientLeft = 0 7 | ClientTop = 0 8 | ClientWidth = 3840 9 | ClipBehavior = 0 'None 10 | DrawStyle = 2 'Dot 11 | ScaleHeight = 240 12 | ScaleMode = 3 'Pixel 13 | ScaleWidth = 320 14 | Windowless = -1 'True 15 | End 16 | Attribute VB_Name = "AlphaBlendImage" 17 | Attribute VB_GlobalNameSpace = False 18 | Attribute VB_Creatable = True 19 | Attribute VB_PredeclaredId = False 20 | Attribute VB_Exposed = False 21 | '========================================================================= 22 | ' 23 | ' AlphaBlendImage (c) 2019 by wqweto@gmail.com 24 | ' 25 | ' Poor Man's Transparent Image Control 26 | ' 27 | '========================================================================= 28 | Option Explicit 29 | DefObj A-Z 30 | Private Const STR_MODULE_NAME As String = "AlphaBlendImage" 31 | 32 | '========================================================================= 33 | ' Public events 34 | '========================================================================= 35 | 36 | Event Click() 37 | Event OwnerDraw(ByVal hGraphics As Long, ClientLeft As Long, ClientTop As Long, ClientWidth As Long, ClientHeight As Long, ByVal hPicture As Long) 38 | Event DblClick() 39 | Event ContextMenu() 40 | Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 41 | Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 42 | Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 43 | 44 | '========================================================================= 45 | ' API 46 | '========================================================================= 47 | 48 | '--- for GdipCreateBitmapFromScan0 49 | Private Const PixelFormat32bppARGB As Long = &H26200A 50 | Private Const PixelFormat32bppPARGB As Long = &HE200B 51 | '--- for GdipDrawImageXxx 52 | Private Const UnitPixel As Long = 2 53 | '--- DIB Section constants 54 | Private Const DIB_RGB_COLORS As Long = 0 ' color table in RGBs 55 | '--- for GdipSetInterpolationMode 56 | Private Const InterpolationModeHighQualityBicubic As Long = 7 57 | '--- for Gdip*WorldTransform 58 | Private Const MatrixOrderAppend As Long = 1 59 | '--- for GdipBitmapLockBits 60 | Private Const ImageLockModeRead As Long = 1 61 | '--- for GlobalAlloc 62 | Private Const GMEM_DDESHARE As Long = &H2000 63 | Private Const GMEM_MOVEABLE As Long = &H2 64 | '--- for SetClipboardData 65 | Private Const CF_DIBV5 As Long = 17 66 | Private Const BI_BITFIELDS As Long = 3 67 | '--- for GetWindowLong 68 | Private Const GWL_EXSTYLE As Long = -20 69 | Private Const WS_EX_LAYERED As Long = &H80000 70 | '--- for UpdateLayeredWindow 71 | Private Const ULW_ALPHA As Long = 2 72 | Private Const AC_SRC_OVER As Long = 0 73 | Private Const AC_SRC_ALPHA As Long = 1 74 | '--- for CreateImagingFactory 75 | Private Const WINCODEC_SDK_VERSION1 As Long = &H236& 76 | Private Const WINCODEC_SDK_VERSION2 As Long = &H237& 77 | '--- for CreateDecoderFromFilename 78 | Private Const GENERIC_READ As Long = &H80000000 79 | '--- for IWICBitmapScaler 80 | Private Const WICBitmapInterpolationModeFant As Long = 3 81 | Private Const WICBitmapInterpolationModeHighQualityCubic As Long = 4 82 | 83 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long) 84 | Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long 85 | Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long 86 | Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long 87 | Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long 88 | Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long 89 | Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 90 | Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long 91 | Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, pIconInfo As ICONINFO) As Long 92 | Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long 93 | Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal Handle As Long, ByVal dw As Long) As Long 94 | Private Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, ByVal lX As Long, ByVal lY As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean 95 | Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long 96 | 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 97 | Private Declare Function CreateIconIndirect Lib "user32" (pIconInfo As ICONINFO) As Long 98 | Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long 99 | Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (pInit As Any, ByVal cbInit As Long) As stdole.IUnknown 100 | Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal clrColor As Long) As Long 101 | Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long 102 | Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long 103 | Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 104 | Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDest As Long, ptDst As Any, pSize As Any, ByVal hdcSrc As Long, ptSrc As Any, ByVal crKey As Long, pBlend As Any, ByVal dwFlags As Long) As Long 105 | Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long 106 | Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long 107 | Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As Any) As Long 108 | Private Declare Function MapWindowPoints Lib "user32" (ByVal hWndFrom As Long, ByVal hWndTo As Long, lppt As Any, ByVal cPoints As Long) As Long 109 | Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long 110 | '--- clipboard support 111 | Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long 112 | Private Declare Function CloseClipboard Lib "user32" () As Long 113 | Private Declare Function EmptyClipboard Lib "user32" () As Long 114 | Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long 115 | Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long 116 | Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long 117 | Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long 118 | Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long 119 | '--- GDI+ 120 | Private Declare Function GdiplusStartup Lib "gdiplus" (hToken As Long, pInputBuf As Any, Optional ByVal pOutputBuf As Long = 0) As Long 121 | Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal lWidth As Long, ByVal lHeight As Long, ByVal lStride As Long, ByVal lPixelFormat As Long, ByVal Scan0 As Long, hBitmap As Long) As Long 122 | Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal hImage As Long) As Long 123 | Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal hImage As Long, hGraphics As Long) As Long 124 | Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal hGraphics As Long) As Long 125 | Private Declare Function GdipDrawImageRectRect Lib "gdiplus" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal dstX As Single, ByVal dstY As Single, ByVal dstWidth As Single, ByVal dstHeight As Single, ByVal srcX As Single, ByVal srcY As Single, ByVal srcWidth As Single, ByVal srcHeight As Single, Optional ByVal srcUnit As Long = UnitPixel, Optional ByVal hImageAttributes As Long, Optional ByVal pfnCallback As Long, Optional ByVal lCallbackData As Long) As Long 126 | Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, hGraphics As Long) As Long 127 | Private Declare Function GdipCreateImageAttributes Lib "gdiplus" (hImgAttr As Long) As Long 128 | Private Declare Function GdipSetImageAttributesColorMatrix Lib "gdiplus" (ByVal hImgAttr As Long, ByVal lAdjustType As Long, ByVal fAdjustEnabled As Long, clrMatrix As Any, grayMatrix As Any, ByVal lFlags As Long) As Long 129 | Private Declare Function GdipSetImageAttributesColorKeys Lib "gdiplus" (ByVal hImgAttr As Long, ByVal lAdjustType As Long, ByVal fAdjustEnabled As Long, ByVal clrLow As Long, ByVal clrHigh As Long) As Long 130 | Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal hImgAttr As Long) As Long 131 | Private Declare Function GdipCloneBitmapAreaI Lib "gdiplus" (ByVal lX As Long, ByVal lY As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByVal lPixelFormat As Long, ByVal srcBitmap As Long, dstBitmap As Long) As Long 132 | Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hBmp As Long, ByVal hPal As Long, hBtmap As Long) As Long 133 | Private Declare Function GdipCreateBitmapFromHICON Lib "gdiplus" (ByVal hIcon As Long, hBitmap As Long) As Long 134 | Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal hImage As Long, nWidth As Single, nHeight As Single) As Long ' 135 | Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal sFileName As Long, mImage As Long) As Long 136 | Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal pStream As stdole.IUnknown, mImage As Long) As Long 137 | Private Declare Function GdipTranslateWorldTransform Lib "gdiplus" (ByVal hGraphics As Long, ByVal nDx As Single, ByVal nDy As Single, ByVal lOrder As Long) As Long 138 | Private Declare Function GdipScaleWorldTransform Lib "gdiplus" (ByVal hGraphics As Long, ByVal nSx As Single, ByVal nSy As Single, ByVal lOrder As Long) As Long 139 | Private Declare Function GdipRotateWorldTransform Lib "gdiplus" (ByVal hGraphics As Long, ByVal nRotation As Single, ByVal lOrder As Long) As Long 140 | Private Declare Function GdipSetInterpolationMode Lib "gdiplus" (ByVal hGraphics As Long, ByVal lMode As Long) As Long 141 | Private Declare Function GdipBitmapLockBits Lib "gdiplus" (ByVal hBitmap As Long, lpRect As Any, ByVal lFlags As Long, ByVal lPixelFormat As Long, uLockedBitmapData As BitmapData) As Long 142 | Private Declare Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal hBitmap As Long, uLockedBitmapData As BitmapData) As Long 143 | Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal hBitmap As Long, hbmReturn As Long, ByVal clrBackground As Long) As Long 144 | Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal hBitmap As Long, ByVal lX As Long, ByVal lY As Long, clrPixel As Long) As Long 145 | Private Declare Function GdipBitmapSetPixel Lib "gdiplus" (ByVal hBitmap As Long, ByVal lX As Long, ByVal lY As Long, ByVal clrPixel As Long) As Long 146 | '--- WIC 147 | Private Declare Function WICCreateImagingFactory_Proxy Lib "windowscodecs" (ByVal SDKVersion As Long, ppIImagingFactory As stdole.IUnknown) As Long 148 | Private Declare Function IWICImagingFactory_CreateDecoderFromFilename_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ByVal wzFilename As Long, pguidVendor As Any, ByVal dwDesiredAccess As Long, ByVal lMetadataOptions As Long, ppIDecoder As stdole.IUnknown) As Long 149 | Private Declare Function IWICImagingFactory_CreateDecoderFromStream_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ByVal pStream As stdole.IUnknown, pguidVendor As Any, ByVal lMetadataOptions As Long, ppIDecoder As stdole.IUnknown) As Long 150 | Private Declare Function IWICImagingFactory_CreateFormatConverter_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ppIFormatConverter As stdole.IUnknown) As Long 151 | Private Declare Function IWICImagingFactory_CreateBitmapScaler_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ppIBitmapScaler As stdole.IUnknown) As Long 152 | Private Declare Function IWICBitmapDecoder_GetFrameCount_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, pCount As Long) As Long 153 | Private Declare Function IWICBitmapDecoder_GetFrame_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal lIndex As Long, ppIBitmapFrame As stdole.IUnknown) As Long 154 | Private Declare Function IWICBitmapScaler_Initialize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal pISource As stdole.IUnknown, ByVal uiWidth As Long, ByVal uiHeight As Long, ByVal lMode As Long) As Long 155 | Private Declare Function IWICBitmapSource_CopyPixels_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, prc As Any, ByVal cbStride As Long, ByVal cbBufferSize As Long, pbBuffer As Any) As Long 156 | Private Declare Function IWICBitmapSource_GetSize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, puiWidth As Long, puiHeight As Long) As Long 157 | Private Declare Function IWICFormatConverter_Initialize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal pISource As stdole.IUnknown, dstFormat As Any, ByVal lDither As Long, ByVal pIPalette As stdole.IUnknown, ByVal dblAlphaThresholdPercent As Double, ByVal lPaletteTranslate As Long) As Long 158 | 159 | 160 | Private Type BITMAPINFOHEADER 161 | biSize As Long 162 | biWidth As Long 163 | biHeight As Long 164 | biPlanes As Integer 165 | biBitCount As Integer 166 | biCompression As Long 167 | biSizeImage As Long 168 | biXPelsPerMeter As Long 169 | biYPelsPerMeter As Long 170 | biClrUsed As Long 171 | biClrImportant As Long 172 | End Type 173 | 174 | Private Type ICONINFO 175 | fIcon As Long 176 | xHotspot As Long 177 | yHotspot As Long 178 | hbmMask As Long 179 | hbmColor As Long 180 | End Type 181 | 182 | Private Type PICTDESC 183 | lSize As Long 184 | lType As Long 185 | hBmp As Long 186 | hPal As Long 187 | End Type 188 | 189 | Private Type SAFEARRAY1D 190 | cDims As Integer 191 | fFeatures As Integer 192 | cbElements As Long 193 | cLocks As Long 194 | pvData As Long 195 | cElements As Long 196 | lLbound As Long 197 | End Type 198 | 199 | Private Type RECT 200 | Left As Long 201 | Top As Long 202 | Right As Long 203 | Bottom As Long 204 | End Type 205 | 206 | Private Type BitmapData 207 | Width As Long 208 | Height As Long 209 | Stride As Long 210 | PixelFormat As Long 211 | Scan0 As Long 212 | Reserved As Long 213 | End Type 214 | 215 | Private Type BITMAPV5HEADER 216 | bV5Size As Long 217 | bV5Width As Long 218 | bV5Height As Long 219 | bV5Planes As Integer 220 | bV5BitCount As Integer 221 | bV5Compression As Long 222 | bV5SizeImage As Long 223 | bV5XPelsPerMeter As Long 224 | bV5YPelsPerMeter As Long 225 | bV5ClrUsed As Long 226 | bV5ClrImportant As Long 227 | bV5RedMask As Long 228 | bV5GreenMask As Long 229 | bV5BlueMask As Long 230 | bV5AlphaMask As Long 231 | bV5CSType As Long 232 | bV5EndpointsRedX As Long 233 | bV5EndpointsRedY As Long 234 | bV5EndpointsRedZ As Long 235 | bV5EndpointsGreenX As Long 236 | bV5EndpointsGreenY As Long 237 | bV5EndpointsGreenZ As Long 238 | bV5EndpointsBlueX As Long 239 | bV5EndpointsBlueY As Long 240 | bV5EndpointsBlueZ As Long 241 | bV5GammaRed As Long 242 | bV5GammaGreen As Long 243 | bV5GammaBlue As Long 244 | bV5Intent As Long 245 | bV5ProfileData As Long 246 | bV5ProfileSize As Long 247 | bV5Reserved As Long 248 | End Type 249 | 250 | Private Type POINTAPI 251 | X As Long 252 | Y As Long 253 | End Type 254 | 255 | '========================================================================= 256 | ' Constants and member variables 257 | '========================================================================= 258 | 259 | Private Const DEF_OPACITY As Single = 1 260 | Private Const DEF_ROTATION As Single = 0 261 | Private Const DEF_ZOOM As Single = 1 262 | Private Const DEF_MASKCOLOR As Long = vbMagenta 263 | Private Const DEF_AUTOREDRAW As Boolean = False 264 | Private Const DEF_STRETCH As Boolean = False 265 | 266 | Private m_oPicture As StdPicture 267 | Private m_clrMask As OLE_COLOR 268 | Private m_bAutoRedraw As Boolean 269 | Private m_sngOpacity As Single 270 | Private m_sngRotation As Single 271 | Private m_sngZoom As Single 272 | Private m_bStretch As Boolean 273 | '--- run-time 274 | Private m_eContainerScaleMode As ScaleModeConstants 275 | Private m_bShown As Boolean 276 | Private m_hAttributes As Long 277 | Private m_hBitmap As Long 278 | Private m_hPictureBitmap As Long 279 | Private m_hPictureAttributes As Long 280 | Private m_hRedrawDib As Long 281 | Private m_nDownButton As Integer 282 | Private m_nDownShift As Integer 283 | Private m_sngDownX As Single 284 | Private m_sngDownY As Single 285 | Private m_pWicFactory As stdole.IUnknown 286 | Private m_sLastError As String 287 | 288 | Private Type UcsRgbQuad 289 | R As Byte 290 | G As Byte 291 | B As Byte 292 | A As Byte 293 | End Type 294 | 295 | '========================================================================= 296 | ' Error handling 297 | '========================================================================= 298 | 299 | Private Function PrintError(sFunction As String) As VbMsgBoxResult 300 | m_sLastError = Err.Description 301 | Debug.Print "Critical error: " & Err.Description & " [" & STR_MODULE_NAME & "." & sFunction & "]", Timer 302 | End Function 303 | 304 | '========================================================================= 305 | ' Properties 306 | '========================================================================= 307 | 308 | Property Get Picture() As StdPicture 309 | Set Picture = m_oPicture 310 | End Property 311 | 312 | Property Set Picture(oValue As StdPicture) 313 | If Not m_oPicture Is oValue Then 314 | Set m_oPicture = oValue 315 | pvPreparePicture m_oPicture, m_clrMask, m_hPictureBitmap, m_hPictureAttributes 316 | If Not m_bStretch And TypeOf Extender Is VBControlExtender Then 317 | pvSizeExtender m_hPictureBitmap, Extender 318 | End If 319 | pvRefresh 320 | PropertyChanged 321 | End If 322 | End Property 323 | 324 | Property Get MaskColor() As OLE_COLOR 325 | MaskColor = m_clrMask 326 | End Property 327 | 328 | Property Let MaskColor(ByVal clrValue As OLE_COLOR) 329 | If m_clrMask <> clrValue Then 330 | m_clrMask = clrValue 331 | pvPreparePicture m_oPicture, m_clrMask, m_hPictureBitmap, m_hPictureAttributes 332 | pvRefresh 333 | PropertyChanged 334 | End If 335 | End Property 336 | 337 | Property Get AutoRedraw() As Boolean 338 | AutoRedraw = m_bAutoRedraw 339 | End Property 340 | 341 | Property Let AutoRedraw(ByVal bValue As Boolean) 342 | If m_bAutoRedraw <> bValue Then 343 | m_bAutoRedraw = bValue 344 | pvRefresh 345 | PropertyChanged 346 | End If 347 | End Property 348 | 349 | Property Get Opacity() As Single 350 | Opacity = m_sngOpacity 351 | End Property 352 | 353 | Property Let Opacity(ByVal sngValue As Single) 354 | If m_sngOpacity <> sngValue Then 355 | m_sngOpacity = IIf(sngValue > 1, 1, IIf(sngValue < 0, 0, sngValue)) 356 | pvRefresh 357 | PropertyChanged 358 | End If 359 | End Property 360 | 361 | Property Get Rotation() As Single 362 | Rotation = m_sngRotation 363 | End Property 364 | 365 | Property Let Rotation(ByVal sngValue As Single) 366 | If m_sngRotation <> sngValue Then 367 | m_sngRotation = sngValue 368 | pvRefresh 369 | PropertyChanged 370 | End If 371 | End Property 372 | 373 | Property Get Zoom() As Single 374 | Zoom = m_sngZoom 375 | End Property 376 | 377 | Property Let Zoom(ByVal sngValue As Single) 378 | If m_sngZoom <> sngValue Then 379 | m_sngZoom = sngValue 380 | If Not m_bStretch And TypeOf Extender Is VBControlExtender Then 381 | pvSizeExtender m_hPictureBitmap, Extender 382 | End If 383 | pvRefresh 384 | PropertyChanged 385 | End If 386 | End Property 387 | 388 | Property Get Stretch() As Boolean 389 | Stretch = m_bStretch 390 | End Property 391 | 392 | Property Let Stretch(ByVal bValue As Boolean) 393 | If m_bStretch <> bValue Then 394 | m_bStretch = bValue 395 | If Not m_bStretch And TypeOf Extender Is VBControlExtender Then 396 | pvSizeExtender m_hPictureBitmap, Extender 397 | End If 398 | pvRefresh 399 | PropertyChanged 400 | End If 401 | End Property 402 | 403 | Property Get PixelARGB(ByVal lX As Long, ByVal lY As Long) As Long 404 | If m_hBitmap = 0 Then 405 | pvPrepareBitmap m_hBitmap 406 | End If 407 | Call GdipBitmapGetPixel(m_hBitmap, lX, lY, PixelARGB) 408 | End Property 409 | 410 | Property Let PixelARGB(ByVal lX As Long, ByVal lY As Long, ByVal clrValue As Long) 411 | If m_hBitmap = 0 Then 412 | pvPrepareBitmap m_hBitmap 413 | End If 414 | Call GdipBitmapSetPixel(m_hBitmap, lX, lY, clrValue) 415 | End Property 416 | 417 | Property Get LastError() As String 418 | LastError = m_sLastError 419 | End Property 420 | 421 | '========================================================================= 422 | ' Methods 423 | '========================================================================= 424 | 425 | Public Sub Refresh() 426 | Const FUNC_NAME As String = "Refresh" 427 | Dim hMemDC As Long 428 | Dim hPrevDib As Long 429 | 430 | On Error GoTo EH 431 | If m_hRedrawDib <> 0 Then 432 | Call DeleteObject(m_hRedrawDib) 433 | m_hRedrawDib = 0 434 | End If 435 | If AutoRedraw Then 436 | hMemDC = CreateCompatibleDC(0) 437 | If hMemDC = 0 Then 438 | GoTo QH 439 | End If 440 | If Not pvCreateDib(hMemDC, ScaleWidth, ScaleHeight, m_hRedrawDib) Then 441 | GoTo QH 442 | End If 443 | hPrevDib = SelectObject(hMemDC, m_hRedrawDib) 444 | pvPaintControl hMemDC 445 | End If 446 | UserControl.Refresh 447 | QH: 448 | On Error Resume Next 449 | If hMemDC <> 0 Then 450 | Call SelectObject(hMemDC, hPrevDib) 451 | Call DeleteDC(hMemDC) 452 | hMemDC = 0 453 | End If 454 | Exit Sub 455 | EH: 456 | PrintError FUNC_NAME 457 | Resume QH 458 | End Sub 459 | 460 | Public Sub Repaint() 461 | Const FUNC_NAME As String = "Repaint" 462 | 463 | On Error GoTo EH 464 | If m_bShown Then 465 | pvPrepareBitmap m_hBitmap 466 | pvPrepareAttribs m_sngOpacity, m_hAttributes 467 | Refresh 468 | End If 469 | QH: 470 | Exit Sub 471 | EH: 472 | PrintError FUNC_NAME 473 | Resume QH 474 | End Sub 475 | 476 | Public Function GdipLoadPicture(sFileName As String, Optional ByVal TargetWidth As Long, Optional ByVal TargetHeight As Long) As StdPicture 477 | Const FUNC_NAME As String = "GdipLoadPicture" 478 | Dim hBitmap As Long 479 | 480 | On Error GoTo EH 481 | If GdipLoadImageFromFile(StrPtr(sFileName), hBitmap) <> 0 Then 482 | GoTo QH 483 | End If 484 | Set GdipLoadPicture = pvLoadPicture(hBitmap, Nothing, TargetWidth, TargetHeight) 485 | QH: 486 | Exit Function 487 | EH: 488 | PrintError FUNC_NAME 489 | Resume QH 490 | End Function 491 | 492 | Public Function GdipLoadPictureArray(baBuffer() As Byte, Optional ByVal TargetWidth As Long, Optional ByVal TargetHeight As Long) As StdPicture 493 | Const FUNC_NAME As String = "GdipLoadPictureArray" 494 | Dim pStream As stdole.IUnknown 495 | Dim hBitmap As Long 496 | 497 | On Error GoTo EH 498 | Set pStream = SHCreateMemStream(baBuffer(LBound(baBuffer)), UBound(baBuffer) - LBound(baBuffer) + 1) 499 | If pStream Is Nothing Then 500 | GoTo QH 501 | End If 502 | If GdipLoadImageFromStream(pStream, hBitmap) <> 0 Then 503 | GoTo QH 504 | End If 505 | Set GdipLoadPictureArray = pvLoadPicture(hBitmap, Nothing, TargetWidth, TargetHeight) 506 | QH: 507 | Exit Function 508 | EH: 509 | PrintError FUNC_NAME 510 | Resume QH 511 | End Function 512 | 513 | Public Function GdipSetClipboardDib(oPic As StdPicture) As Boolean 514 | Const FUNC_NAME As String = "GdipSetClipboardDib" 515 | Const SIGN_BIT As Long = &H80000000 516 | Dim hPictureBitmap As Long 517 | Dim hPictureAttributes As Long 518 | Dim uData As BitmapData 519 | Dim bNeedClipClose As Boolean 520 | Dim uHdr As BITMAPINFOHEADER 521 | Dim aColors(0 To 2) As Long 522 | Dim lPtr As Long 523 | Dim hMem As Long 524 | 525 | On Error GoTo EH 526 | If Not pvPreparePicture(oPic, MaskColor, hPictureBitmap, hPictureAttributes) Then 527 | GoTo QH 528 | End If 529 | If GdipBitmapLockBits(hPictureBitmap, ByVal 0, ImageLockModeRead, PixelFormat32bppARGB, uData) <> 0 Then 530 | GoTo QH 531 | End If 532 | uHdr.biSize = LenB(uHdr) 533 | uHdr.biWidth = uData.Width 534 | uHdr.biHeight = -uData.Height 535 | uHdr.biPlanes = 1 536 | uHdr.biBitCount = 32 537 | uHdr.biCompression = BI_BITFIELDS 538 | uHdr.biSizeImage = uData.Stride * uData.Height 539 | aColors(0) = &HFF0000 540 | aColors(1) = &HFF00& 541 | aColors(2) = &HFF& 542 | hMem = GlobalAlloc(GMEM_DDESHARE Or GMEM_MOVEABLE, LenB(uHdr) + 12 + uData.Stride * uData.Height) 543 | If hMem = 0 Then 544 | GoTo QH 545 | End If 546 | lPtr = GlobalLock(hMem) 547 | If lPtr = 0 Then 548 | GoTo QH 549 | End If 550 | Call CopyMemory(ByVal lPtr, uHdr, LenB(uHdr)): lPtr = (lPtr Xor SIGN_BIT) + LenB(uHdr) Xor SIGN_BIT 551 | Call CopyMemory(ByVal lPtr, aColors(0), 12): lPtr = (lPtr Xor SIGN_BIT) + 12 Xor SIGN_BIT 552 | Call CopyMemory(ByVal lPtr, ByVal uData.Scan0, uData.Stride * uData.Height) 553 | Call GlobalUnlock(hMem) 554 | '--- clip copy 555 | If OpenClipboard(hWnd) = 0 Then 556 | GoTo QH 557 | End If 558 | bNeedClipClose = True 559 | If EmptyClipboard() = 0 Then 560 | GoTo QH 561 | End If 562 | If SetClipboardData(vbCFDIB, hMem) = 0 Then 563 | GoTo QH 564 | End If 565 | hMem = 0 566 | '--- success 567 | GdipSetClipboardDib = True 568 | QH: 569 | If bNeedClipClose Then 570 | Call CloseClipboard 571 | End If 572 | If hMem <> 0 Then 573 | Call GlobalFree(hMem) 574 | End If 575 | If uData.Scan0 <> 0 Then 576 | Call GdipBitmapUnlockBits(hPictureBitmap, uData) 577 | End If 578 | If hPictureBitmap <> 0 Then 579 | Call GdipDisposeImage(hPictureBitmap) 580 | End If 581 | If hPictureAttributes <> 0 Then 582 | Call GdipDisposeImageAttributes(hPictureAttributes) 583 | End If 584 | Exit Function 585 | EH: 586 | PrintError FUNC_NAME 587 | Resume QH 588 | End Function 589 | 590 | Public Function GdipSetClipboardDibV5(oPic As StdPicture) As Boolean 591 | Const FUNC_NAME As String = "GdipSetClipboardDibV5" 592 | Const SIGN_BIT As Long = &H80000000 593 | Dim hPictureBitmap As Long 594 | Dim hPictureAttributes As Long 595 | Dim uData As BitmapData 596 | Dim bNeedClipClose As Boolean 597 | Dim uHdr As BITMAPV5HEADER 598 | Dim lPtr As Long 599 | Dim hMem As Long 600 | 601 | On Error GoTo EH 602 | If Not pvPreparePicture(oPic, MaskColor, hPictureBitmap, hPictureAttributes) Then 603 | GoTo QH 604 | End If 605 | If GdipBitmapLockBits(hPictureBitmap, ByVal 0, ImageLockModeRead, PixelFormat32bppARGB, uData) <> 0 Then 606 | GoTo QH 607 | End If 608 | uHdr.bV5Size = LenB(uHdr) 609 | uHdr.bV5Width = uData.Width 610 | uHdr.bV5Height = -uData.Height 611 | uHdr.bV5Planes = 1 612 | uHdr.bV5BitCount = 32 613 | uHdr.bV5Compression = BI_BITFIELDS 614 | uHdr.bV5SizeImage = uData.Stride * uData.Height 615 | uHdr.bV5RedMask = &HFF0000 616 | uHdr.bV5GreenMask = &HFF00& 617 | uHdr.bV5BlueMask = &HFF& 618 | uHdr.bV5AlphaMask = &HFF000000 619 | hMem = GlobalAlloc(GMEM_DDESHARE Or GMEM_MOVEABLE, LenB(uHdr) + uData.Stride * uData.Height) 620 | If hMem = 0 Then 621 | GoTo QH 622 | End If 623 | lPtr = GlobalLock(hMem) 624 | If lPtr = 0 Then 625 | GoTo QH 626 | End If 627 | Call CopyMemory(ByVal lPtr, uHdr, LenB(uHdr)): lPtr = (lPtr Xor SIGN_BIT) + LenB(uHdr) Xor SIGN_BIT 628 | Call CopyMemory(ByVal lPtr, ByVal uData.Scan0, uData.Stride * uData.Height) 629 | Call GlobalUnlock(hMem) 630 | '--- clip copy 631 | If OpenClipboard(hWnd) = 0 Then 632 | GoTo QH 633 | End If 634 | bNeedClipClose = True 635 | If EmptyClipboard() = 0 Then 636 | GoTo QH 637 | End If 638 | If SetClipboardData(CF_DIBV5, hMem) = 0 Then 639 | GoTo QH 640 | End If 641 | hMem = 0 642 | '--- success 643 | GdipSetClipboardDibV5 = True 644 | QH: 645 | If bNeedClipClose Then 646 | Call CloseClipboard 647 | End If 648 | If hMem <> 0 Then 649 | Call GlobalFree(hMem) 650 | End If 651 | If uData.Scan0 <> 0 Then 652 | Call GdipBitmapUnlockBits(hPictureBitmap, uData) 653 | End If 654 | If hPictureBitmap <> 0 Then 655 | Call GdipDisposeImage(hPictureBitmap) 656 | End If 657 | If hPictureAttributes <> 0 Then 658 | Call GdipDisposeImageAttributes(hPictureAttributes) 659 | End If 660 | Exit Function 661 | EH: 662 | PrintError FUNC_NAME 663 | Resume QH 664 | End Function 665 | 666 | Public Function GdipUpdateLayeredWindow(ByVal hWnd As Long) As Boolean 667 | Const FUNC_NAME As String = "GdipUpdateLayeredWindow" 668 | Dim lStyle As Long 669 | Dim hScreenDC As Long 670 | Dim hMemDC As Long 671 | Dim hBmp As Long 672 | Dim hPrevBmp As Long 673 | Dim uRect(0 To 1) As POINTAPI 674 | Dim ptSrc As POINTAPI 675 | 676 | On Error GoTo EH 677 | lStyle = GetWindowLong(hWnd, GWL_EXSTYLE) 678 | If (lStyle And WS_EX_LAYERED) = 0 Then 679 | Call SetWindowLong(hWnd, GWL_EXSTYLE, lStyle Or WS_EX_LAYERED) 680 | End If 681 | hScreenDC = GetDC(0) 682 | If hScreenDC = 0 Then 683 | GoTo QH 684 | End If 685 | hMemDC = CreateCompatibleDC(hScreenDC) 686 | If hMemDC = 0 Then 687 | GoTo QH 688 | End If 689 | If GdipCreateHBITMAPFromBitmap(m_hBitmap, hBmp, 0) <> 0 Then 690 | GoTo QH 691 | End If 692 | hPrevBmp = SelectObject(hMemDC, hBmp) 693 | If hPrevBmp = 0 Then 694 | GoTo QH 695 | End If 696 | Call GetClientRect(hWnd, uRect(0)) 697 | Call MapWindowPoints(hWnd, GetParent(hWnd), uRect(0), 2) 698 | With uRect(1) 699 | .X = .X - uRect(0).X 700 | .Y = .Y - uRect(0).Y 701 | End With 702 | Call UpdateLayeredWindow(hWnd, hScreenDC, uRect(0), uRect(1), hMemDC, ptSrc, 0, _ 703 | AC_SRC_ALPHA * &H1000000 + CByte(255 * m_sngOpacity) * &H10000 + AC_SRC_OVER, ULW_ALPHA) 704 | '--- success 705 | GdipUpdateLayeredWindow = True 706 | QH: 707 | If hBmp <> 0 Then 708 | If hPrevBmp <> 0 Then 709 | Call SelectObject(hMemDC, hPrevBmp) 710 | End If 711 | Call DeleteObject(hBmp) 712 | End If 713 | If hMemDC <> 0 Then 714 | Call DeleteDC(hMemDC) 715 | End If 716 | If hScreenDC <> 0 Then 717 | Call ReleaseDC(0, hScreenDC) 718 | End If 719 | Exit Function 720 | EH: 721 | PrintError FUNC_NAME 722 | Resume QH 723 | End Function 724 | 725 | Public Function WicLoadPicture( _ 726 | sFileName As String, _ 727 | Optional ByVal TargetWidth As Long, _ 728 | Optional ByVal TargetHeight As Long, _ 729 | Optional ByVal ImageFrame As Long) As StdPicture 730 | Const FUNC_NAME As String = "WicLoadPicture" 731 | Dim pDecoder As stdole.IUnknown 732 | Dim lFameCount As Long 733 | Dim pFrame As stdole.IUnknown 734 | 735 | On Error GoTo EH 736 | If m_pWicFactory Is Nothing Then 737 | If WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION2, m_pWicFactory) < 0 Then 738 | If pvCheckHResult(WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION1, m_pWicFactory)) < 0 Then 739 | GoTo QH 740 | End If 741 | End If 742 | End If 743 | If pvCheckHResult(IWICImagingFactory_CreateDecoderFromFilename_Proxy(m_pWicFactory, StrPtr(sFileName), ByVal 0, GENERIC_READ, 0, pDecoder)) < 0 Or pDecoder Is Nothing Then 744 | GoTo QH 745 | End If 746 | If pvCheckHResult(IWICBitmapDecoder_GetFrameCount_Proxy(pDecoder, lFameCount)) < 0 Or ImageFrame >= lFameCount Then 747 | GoTo QH 748 | End If 749 | If pvCheckHResult(IWICBitmapDecoder_GetFrame_Proxy(pDecoder, ImageFrame, pFrame)) < 0 Or pFrame Is Nothing Then 750 | GoTo QH 751 | End If 752 | Set WicLoadPicture = pvLoadPicture(0, pFrame, TargetWidth, TargetHeight) 753 | QH: 754 | Exit Function 755 | EH: 756 | PrintError FUNC_NAME 757 | Resume QH 758 | End Function 759 | 760 | Public Function WicLoadPictureArray( _ 761 | baBuffer() As Byte, _ 762 | Optional ByVal TargetWidth As Long, _ 763 | Optional ByVal TargetHeight As Long, _ 764 | Optional ByVal ImageFrame As Long) As StdPicture 765 | Const FUNC_NAME As String = "WicLoadPictureArray" 766 | Dim pStream As stdole.IUnknown 767 | Dim pDecoder As stdole.IUnknown 768 | Dim lFameCount As Long 769 | Dim pFrame As stdole.IUnknown 770 | 771 | On Error GoTo EH 772 | If m_pWicFactory Is Nothing Then 773 | If WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION2, m_pWicFactory) < 0 Then 774 | If pvCheckHResult(WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION1, m_pWicFactory)) < 0 Then 775 | GoTo QH 776 | End If 777 | End If 778 | End If 779 | Set pStream = SHCreateMemStream(baBuffer(LBound(baBuffer)), UBound(baBuffer) - LBound(baBuffer) + 1) 780 | If pStream Is Nothing Then 781 | GoTo QH 782 | End If 783 | If pvCheckHResult(IWICImagingFactory_CreateDecoderFromStream_Proxy(m_pWicFactory, pStream, ByVal 0, 0, pDecoder)) < 0 Or pDecoder Is Nothing Then 784 | GoTo QH 785 | End If 786 | If pvCheckHResult(IWICBitmapDecoder_GetFrameCount_Proxy(pDecoder, lFameCount)) < 0 Or ImageFrame >= lFameCount Then 787 | GoTo QH 788 | End If 789 | If pvCheckHResult(IWICBitmapDecoder_GetFrame_Proxy(pDecoder, ImageFrame, pFrame)) < 0 Or pFrame Is Nothing Then 790 | GoTo QH 791 | End If 792 | Set WicLoadPictureArray = pvLoadPicture(0, pFrame, TargetWidth, TargetHeight) 793 | QH: 794 | Exit Function 795 | EH: 796 | PrintError FUNC_NAME 797 | Resume QH 798 | End Function 799 | 800 | 801 | '= private =============================================================== 802 | 803 | Private Function pvLoadPicture( _ 804 | ByVal hBitmap As Long, _ 805 | pFrame As stdole.IUnknown, _ 806 | ByVal sngTargetWidth As Single, _ 807 | ByVal sngTargetHeight As Single) As StdPicture 808 | Const FUNC_NAME As String = "pvLoadPicture" 809 | Const EPSILON As Single = 0.0001 810 | Dim sngWidth As Single 811 | Dim sngHeight As Single 812 | Dim lWidth As Long 813 | Dim lHeight As Long 814 | Dim hMemDC As Long 815 | Dim hDib As Long 816 | Dim hPrevDib As Long 817 | Dim hGraphics As Long 818 | Dim uInfo As ICONINFO 819 | Dim hIcon As Long 820 | Dim uDesc As PICTDESC 821 | Dim aGUID(0 To 3) As Long 822 | Dim pConverter As stdole.IUnknown 823 | Dim pScaler As stdole.IUnknown 824 | Dim lpBits As Long 825 | 826 | On Error GoTo EH 827 | If hBitmap <> 0 Then 828 | If GdipGetImageDimension(hBitmap, sngWidth, sngHeight) <> 0 Then 829 | GoTo QH 830 | End If 831 | Else 832 | If pvCheckHResult(IWICBitmapSource_GetSize_Proxy(pFrame, lWidth, lHeight)) < 0 Then 833 | GoTo QH 834 | End If 835 | sngWidth = lWidth 836 | sngHeight = lHeight 837 | End If 838 | hMemDC = CreateCompatibleDC(0) 839 | If hMemDC = 0 Then 840 | GoTo QH 841 | End If 842 | If Abs(sngTargetWidth) < EPSILON Then 843 | sngTargetWidth = sngWidth 844 | End If 845 | If Abs(sngTargetHeight) < EPSILON Then 846 | sngTargetHeight = sngHeight 847 | End If 848 | If Not pvCreateDib(hMemDC, sngTargetWidth, sngTargetHeight, hDib, lpBits) Then 849 | GoTo QH 850 | End If 851 | If hBitmap <> 0 Then 852 | hPrevDib = SelectObject(hMemDC, hDib) 853 | If GdipCreateFromHDC(hMemDC, hGraphics) <> 0 Then 854 | GoTo QH 855 | End If 856 | If GdipDrawImageRectRect(hGraphics, hBitmap, 0, 0, sngWidth, sngHeight, 0, 0, sngTargetWidth, sngTargetHeight) <> 0 Then 857 | GoTo QH 858 | End If 859 | Call SelectObject(hMemDC, hPrevDib) 860 | hPrevDib = 0 861 | Else 862 | If pvCheckHResult(IWICImagingFactory_CreateFormatConverter_Proxy(m_pWicFactory, pConverter)) < 0 Or pConverter Is Nothing Then 863 | GoTo QH 864 | End If 865 | '--- GUID_WICPixelFormat32bppPBGRA 866 | aGUID(0) = &H6FDDC324 867 | aGUID(1) = &H4BFE4E03 868 | aGUID(2) = &H773D85B1 869 | aGUID(3) = &H10C98D76 870 | If pvCheckHResult(IWICFormatConverter_Initialize_Proxy(pConverter, pFrame, aGUID(0), 0, Nothing, 0#, 0)) < 0 Then 871 | GoTo QH 872 | End If 873 | If Abs(sngWidth - sngTargetWidth) > EPSILON Or Abs(sngHeight - sngTargetHeight) > EPSILON Then 874 | If pvCheckHResult(IWICImagingFactory_CreateBitmapScaler_Proxy(m_pWicFactory, pScaler)) < 0 Then 875 | GoTo QH 876 | End If 877 | If IWICBitmapScaler_Initialize_Proxy(pScaler, pConverter, sngTargetWidth, sngTargetHeight, WICBitmapInterpolationModeHighQualityCubic) < 0 Then 878 | If pvCheckHResult(IWICBitmapScaler_Initialize_Proxy(pScaler, pConverter, sngTargetWidth, sngTargetHeight, WICBitmapInterpolationModeFant)) < 0 Then 879 | GoTo QH 880 | End If 881 | End If 882 | Else 883 | Set pScaler = pConverter 884 | End If 885 | If pvCheckHResult(IWICBitmapSource_CopyPixels_Proxy(pScaler, ByVal 0&, sngTargetWidth * 4, sngTargetWidth * sngTargetHeight * 4, ByVal lpBits)) < 0 Then 886 | GoTo QH 887 | End If 888 | End If 889 | With uInfo 890 | .fIcon = 1 891 | .hbmColor = hDib 892 | .hbmMask = CreateBitmap(sngTargetWidth, sngTargetHeight, 1, 1, ByVal 0) 893 | End With 894 | hIcon = CreateIconIndirect(uInfo) 895 | With uDesc 896 | .lSize = Len(uDesc) 897 | .lType = vbPicTypeIcon 898 | .hBmp = hIcon 899 | End With 900 | '--- IID_IPicture 901 | aGUID(0) = &H7BF80980 902 | aGUID(1) = &H101ABF32 903 | aGUID(2) = &HAA00BB8B 904 | aGUID(3) = &HAB0C3000 905 | If OleCreatePictureIndirect(uDesc, aGUID(0), 1, pvLoadPicture) <> 0 Then 906 | GoTo QH 907 | End If 908 | hIcon = 0 909 | QH: 910 | If hBitmap <> 0 Then 911 | Call GdipDisposeImage(hBitmap) 912 | hBitmap = 0 913 | End If 914 | If hMemDC <> 0 Then 915 | If hPrevDib <> 0 Then 916 | Call SelectObject(hMemDC, hPrevDib) 917 | End If 918 | Call DeleteDC(hMemDC) 919 | hMemDC = 0 920 | End If 921 | If hDib <> 0 Then 922 | Call DeleteObject(hDib) 923 | hDib = 0 924 | End If 925 | If hGraphics <> 0 Then 926 | Call GdipDeleteGraphics(hGraphics) 927 | hGraphics = 0 928 | End If 929 | If hIcon <> 0 Then 930 | Call DestroyIcon(hIcon) 931 | hIcon = 0 932 | End If 933 | If uInfo.hbmMask <> 0 Then 934 | Call DeleteObject(uInfo.hbmMask) 935 | uInfo.hbmMask = 0 936 | End If 937 | Exit Function 938 | EH: 939 | PrintError FUNC_NAME 940 | Resume QH 941 | End Function 942 | 943 | Private Sub pvRefresh() 944 | m_bShown = False 945 | If m_hRedrawDib <> 0 Then 946 | Call DeleteObject(m_hRedrawDib) 947 | m_hRedrawDib = 0 948 | End If 949 | UserControl.Refresh 950 | End Sub 951 | 952 | Private Function pvPaintControl(ByVal hDC As Long) As Boolean 953 | Const FUNC_NAME As String = "pvPaintControl" 954 | Dim hGraphics As Long 955 | 956 | On Error GoTo EH 957 | If Not m_bShown Then 958 | m_bShown = True 959 | pvPrepareBitmap m_hBitmap 960 | pvPrepareAttribs m_sngOpacity, m_hAttributes 961 | End If 962 | If m_hBitmap <> 0 Then 963 | If GdipCreateFromHDC(hDC, hGraphics) <> 0 Then 964 | GoTo QH 965 | End If 966 | If GdipDrawImageRectRect(hGraphics, m_hBitmap, 0, 0, ScaleWidth, ScaleHeight, 0, 0, ScaleWidth, ScaleHeight, , m_hAttributes) <> 0 Then 967 | GoTo QH 968 | End If 969 | '--- success 970 | pvPaintControl = True 971 | End If 972 | QH: 973 | On Error Resume Next 974 | If hGraphics <> 0 Then 975 | Call GdipDeleteGraphics(hGraphics) 976 | hGraphics = 0 977 | End If 978 | Exit Function 979 | EH: 980 | PrintError FUNC_NAME 981 | Resume QH 982 | End Function 983 | 984 | Private Function pvPrepareBitmap(hBitmap As Long) As Boolean 985 | Const FUNC_NAME As String = "pvPrepareBitmap" 986 | Const EPSILON As Single = 0.0001 987 | Dim hGraphics As Long 988 | Dim hNewBitmap As Long 989 | Dim lLeft As Long 990 | Dim lTop As Long 991 | Dim lWidth As Long 992 | Dim lHeight As Long 993 | Dim sngPicWidth As Single 994 | Dim sngPicHeight As Single 995 | Dim sngZoom As Single 996 | 997 | On Error GoTo EH 998 | If GdipCreateBitmapFromScan0(ScaleWidth, ScaleHeight, ScaleWidth * 4, PixelFormat32bppPARGB, 0, hNewBitmap) <> 0 Then 999 | GoTo QH 1000 | End If 1001 | If GdipGetImageGraphicsContext(hNewBitmap, hGraphics) <> 0 Then 1002 | GoTo QH 1003 | End If 1004 | If GdipSetInterpolationMode(hGraphics, InterpolationModeHighQualityBicubic) <> 0 Then 1005 | GoTo QH 1006 | End If 1007 | lWidth = ScaleWidth 1008 | lHeight = ScaleHeight 1009 | RaiseEvent OwnerDraw(hGraphics, lLeft, lTop, lWidth, lHeight, m_hPictureBitmap) 1010 | If lWidth > 0 And lHeight > 0 Then 1011 | If m_hPictureBitmap <> 0 Then 1012 | If GdipGetImageDimension(m_hPictureBitmap, sngPicWidth, sngPicHeight) <> 0 Then 1013 | GoTo QH 1014 | End If 1015 | If Not m_bStretch And Abs(m_sngZoom) > EPSILON Then 1016 | sngZoom = Abs(m_sngZoom) 1017 | Else 1018 | sngZoom = 1 1019 | End If 1020 | If GdipRotateWorldTransform(hGraphics, m_sngRotation, MatrixOrderAppend) <> 0 Then 1021 | GoTo QH 1022 | End If 1023 | If GdipTranslateWorldTransform(hGraphics, lWidth / 2 / sngZoom, lHeight / 2 / sngZoom, MatrixOrderAppend) <> 0 Then 1024 | GoTo QH 1025 | End If 1026 | If GdipScaleWorldTransform(hGraphics, sngZoom, sngZoom, MatrixOrderAppend) <> 0 Then 1027 | GoTo QH 1028 | End If 1029 | lLeft = lLeft - lWidth / 2 1030 | lTop = lTop - lHeight / 2 1031 | If m_bStretch Then 1032 | If GdipDrawImageRectRect(hGraphics, m_hPictureBitmap, lLeft, lTop, lWidth, lHeight, 0, 0, sngPicWidth, sngPicHeight, , m_hPictureAttributes) <> 0 Then 1033 | GoTo QH 1034 | End If 1035 | Else 1036 | If GdipDrawImageRectRect(hGraphics, m_hPictureBitmap, lLeft + (lWidth - sngPicWidth) / 2, lTop + (lHeight - sngPicHeight) / 2, sngPicWidth, sngPicHeight, 0, 0, sngPicWidth, sngPicHeight, , m_hPictureAttributes) <> 0 Then 1037 | GoTo QH 1038 | End If 1039 | End If 1040 | ElseIf Not Ambient.UserMode Then 1041 | Call GdipDisposeImage(hNewBitmap) 1042 | hNewBitmap = 0 1043 | End If 1044 | End If 1045 | '--- commit 1046 | If hNewBitmap <> hBitmap Then 1047 | If hBitmap <> 0 Then 1048 | Call GdipDisposeImage(hBitmap) 1049 | hBitmap = 0 1050 | End If 1051 | hBitmap = hNewBitmap 1052 | End If 1053 | hNewBitmap = 0 1054 | '-- success 1055 | pvPrepareBitmap = True 1056 | QH: 1057 | On Error Resume Next 1058 | If hNewBitmap <> 0 Then 1059 | Call GdipDisposeImage(hNewBitmap) 1060 | hNewBitmap = 0 1061 | End If 1062 | If hGraphics <> 0 Then 1063 | Call GdipDeleteGraphics(hGraphics) 1064 | hGraphics = 0 1065 | End If 1066 | Exit Function 1067 | EH: 1068 | PrintError FUNC_NAME 1069 | Resume QH 1070 | End Function 1071 | 1072 | Private Function pvPrepareAttribs(ByVal sngAlpha As Single, hAttributes As Long) As Boolean 1073 | Const FUNC_NAME As String = "pvPrepareAttribs" 1074 | Dim clrMatrix(0 To 4, 0 To 4) As Single 1075 | Dim hNewAttributes As Long 1076 | 1077 | On Error GoTo EH 1078 | If GdipCreateImageAttributes(hNewAttributes) <> 0 Then 1079 | GoTo QH 1080 | End If 1081 | clrMatrix(0, 0) = 1 1082 | clrMatrix(1, 1) = 1 1083 | clrMatrix(2, 2) = 1 1084 | clrMatrix(3, 3) = sngAlpha 1085 | clrMatrix(4, 4) = 1 1086 | If GdipSetImageAttributesColorMatrix(hNewAttributes, 0, 1, clrMatrix(0, 0), clrMatrix(0, 0), 0) <> 0 Then 1087 | GoTo QH 1088 | End If 1089 | '--- commit 1090 | If hAttributes <> 0 Then 1091 | Call GdipDisposeImageAttributes(hAttributes) 1092 | hAttributes = 0 1093 | End If 1094 | hAttributes = hNewAttributes 1095 | hNewAttributes = 0 1096 | '--- success 1097 | pvPrepareAttribs = True 1098 | QH: 1099 | On Error Resume Next 1100 | If hNewAttributes <> 0 Then 1101 | Call GdipDisposeImageAttributes(hNewAttributes) 1102 | hNewAttributes = 0 1103 | End If 1104 | Exit Function 1105 | EH: 1106 | PrintError FUNC_NAME 1107 | Resume QH 1108 | End Function 1109 | 1110 | Private Function pvPreparePicture(oPicture As StdPicture, ByVal clrMask As OLE_COLOR, hPictureBitmap As Long, hPictureAttributes As Long) As Boolean 1111 | Const FUNC_NAME As String = "pvPreparePicture" 1112 | Dim hTempBitmap As Long 1113 | Dim hNewBitmap As Long 1114 | Dim hNewAttributes As Long 1115 | Dim lWidth As Long 1116 | Dim lHeight As Long 1117 | Dim uHdr As BITMAPINFOHEADER 1118 | Dim hMemDC As Long 1119 | Dim uInfo As ICONINFO 1120 | Dim baColorBits() As Byte 1121 | Dim hDib As Long 1122 | Dim lpBits As Long 1123 | Dim hPrevDib As Long 1124 | Dim pPic As IPicture 1125 | Dim hBrush As Long 1126 | Dim rc As RECT 1127 | 1128 | On Error GoTo EH 1129 | If Not oPicture Is Nothing Then 1130 | If oPicture.Handle <> 0 Then 1131 | lWidth = HM2Pix(oPicture.Width) 1132 | lHeight = HM2Pix(oPicture.Height) 1133 | hMemDC = CreateCompatibleDC(0) 1134 | If hMemDC = 0 Then 1135 | GoTo QH 1136 | End If 1137 | With uHdr 1138 | .biSize = Len(uHdr) 1139 | .biPlanes = 1 1140 | .biBitCount = 32 1141 | .biWidth = lWidth 1142 | .biHeight = -lHeight 1143 | .biSizeImage = (4 * lWidth) * lHeight 1144 | End With 1145 | If oPicture.Type = vbPicTypeIcon Then 1146 | If GetIconInfo(oPicture.Handle, uInfo) = 0 Then 1147 | GoTo QH 1148 | End If 1149 | ReDim baColorBits(0 To uHdr.biSizeImage - 1) As Byte 1150 | If GetDIBits(hMemDC, uInfo.hbmColor, 0, lHeight, baColorBits(0), uHdr, DIB_RGB_COLORS) = 0 Then 1151 | GoTo QH 1152 | End If 1153 | If Not pvHasAlpha(VarPtr(baColorBits(0)), uHdr.biSizeImage) Then 1154 | '--- note: GdipCreateBitmapFromHICON is working ok for old-style (single-bit) transparent icons only 1155 | If GdipCreateBitmapFromHICON(oPicture.Handle, hNewBitmap) <> 0 Then 1156 | GoTo QH 1157 | End If 1158 | Else 1159 | If GdipCreateBitmapFromScan0(lWidth, lHeight, 4 * lWidth, PixelFormat32bppPARGB, VarPtr(baColorBits(0)), hTempBitmap) <> 0 Then 1160 | GoTo QH 1161 | End If 1162 | If GdipCloneBitmapAreaI(0, 0, lWidth, lHeight, PixelFormat32bppARGB, hTempBitmap, hNewBitmap) <> 0 Then 1163 | GoTo QH 1164 | End If 1165 | End If 1166 | Else 1167 | hDib = CreateDIBSection(hMemDC, uHdr, DIB_RGB_COLORS, lpBits, 0, 0) 1168 | If hDib = 0 Then 1169 | GoTo QH 1170 | End If 1171 | hPrevDib = SelectObject(hMemDC, hDib) 1172 | If oPicture.Type = vbPicTypeMetafile Or oPicture.Type = vbPicTypeEMetafile Then 1173 | clrMask = vbMagenta 1174 | End If 1175 | If clrMask <> -1 Then 1176 | Call OleTranslateColor(clrMask, 0, VarPtr(clrMask)) 1177 | hBrush = CreateSolidBrush(clrMask) 1178 | rc.Right = lWidth 1179 | rc.Bottom = lHeight 1180 | Call FillRect(hMemDC, rc, hBrush) 1181 | Call DeleteObject(hBrush) 1182 | End If 1183 | Set pPic = oPicture 1184 | pPic.Render hMemDC, 0, 0, lWidth, lHeight, 0, oPicture.Height, oPicture.Width, -oPicture.Height, ByVal 0 1185 | If Not pvHasAlpha(lpBits, uHdr.biSizeImage) Then 1186 | '--- note: GdipCreateBitmapFromHBITMAP is working ok for non-transparent bitmaps 1187 | If oPicture.Type = vbPicTypeBitmap Then 1188 | If GdipCreateBitmapFromHBITMAP(oPicture.Handle, oPicture.hPal, hNewBitmap) <> 0 Then 1189 | GoTo QH 1190 | End If 1191 | Else 1192 | If GdipCreateBitmapFromHBITMAP(hDib, 0, hNewBitmap) <> 0 Then 1193 | GoTo QH 1194 | End If 1195 | End If 1196 | Else 1197 | If GdipCreateBitmapFromScan0(lWidth, lHeight, 4 * lWidth, PixelFormat32bppPARGB, lpBits, hTempBitmap) <> 0 Then 1198 | GoTo QH 1199 | End If 1200 | If GdipCloneBitmapAreaI(0, 0, lWidth, lHeight, PixelFormat32bppARGB, hTempBitmap, hNewBitmap) <> 0 Then 1201 | GoTo QH 1202 | End If 1203 | End If 1204 | End If 1205 | If clrMask <> -1 Then 1206 | If GdipCreateImageAttributes(hNewAttributes) <> 0 Then 1207 | GoTo QH 1208 | End If 1209 | If GdipSetImageAttributesColorKeys(hNewAttributes, 0, 1, TranslateColor(clrMask), TranslateColor(clrMask)) <> 0 Then 1210 | GoTo QH 1211 | End If 1212 | End If 1213 | End If 1214 | End If 1215 | '--- commit 1216 | If hPictureBitmap <> 0 Then 1217 | Call GdipDisposeImage(hPictureBitmap) 1218 | hPictureBitmap = 0 1219 | End If 1220 | hPictureBitmap = hNewBitmap 1221 | hNewBitmap = 0 1222 | If hPictureAttributes <> 0 Then 1223 | Call GdipDisposeImageAttributes(hPictureAttributes) 1224 | hPictureAttributes = 0 1225 | End If 1226 | hPictureAttributes = hNewAttributes 1227 | hNewAttributes = 0 1228 | '--- success 1229 | pvPreparePicture = True 1230 | QH: 1231 | On Error Resume Next 1232 | If hNewBitmap <> 0 Then 1233 | Call GdipDisposeImage(hNewBitmap) 1234 | hNewBitmap = 0 1235 | End If 1236 | If hNewAttributes <> 0 Then 1237 | Call GdipDisposeImageAttributes(hNewAttributes) 1238 | hNewAttributes = 0 1239 | End If 1240 | If hTempBitmap <> 0 Then 1241 | Call GdipDisposeImage(hTempBitmap) 1242 | hTempBitmap = 0 1243 | End If 1244 | If hPrevDib <> 0 Then 1245 | Call SelectObject(hMemDC, hPrevDib) 1246 | hPrevDib = 0 1247 | End If 1248 | If hDib <> 0 Then 1249 | Call DeleteObject(hDib) 1250 | hDib = 0 1251 | End If 1252 | If uInfo.hbmColor <> 0 Then 1253 | Call DeleteObject(uInfo.hbmColor) 1254 | uInfo.hbmColor = 0 1255 | End If 1256 | If uInfo.hbmMask <> 0 Then 1257 | Call DeleteObject(uInfo.hbmMask) 1258 | uInfo.hbmMask = 0 1259 | End If 1260 | If hMemDC <> 0 Then 1261 | Call DeleteDC(hMemDC) 1262 | hMemDC = 0 1263 | End If 1264 | Exit Function 1265 | EH: 1266 | PrintError FUNC_NAME 1267 | Resume QH 1268 | End Function 1269 | 1270 | Private Sub pvSizeExtender(ByVal hBitmap As Long, oExt As VBControlExtender) 1271 | Dim sngWidth As Single 1272 | Dim sngHeight As Single 1273 | 1274 | If hBitmap = 0 Then 1275 | GoTo QH 1276 | End If 1277 | If GdipGetImageDimension(m_hPictureBitmap, sngWidth, sngHeight) <> 0 Then 1278 | GoTo QH 1279 | End If 1280 | oExt.Width = ScaleX(sngWidth * Abs(m_sngZoom), vbPixels, m_eContainerScaleMode) 1281 | oExt.Height = ScaleY(sngHeight * Abs(m_sngZoom), vbPixels, m_eContainerScaleMode) 1282 | QH: 1283 | End Sub 1284 | 1285 | Private Sub pvHandleMouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 1286 | m_nDownButton = Button 1287 | m_nDownShift = Shift 1288 | m_sngDownX = X 1289 | m_sngDownY = Y 1290 | End Sub 1291 | 1292 | Private Function pvHasAlpha(ByVal lPtr As Long, ByVal lSize As Long) As Boolean 1293 | Dim uArray As SAFEARRAY1D 1294 | Dim baBuffer() As Byte 1295 | Dim lIdx As Long 1296 | 1297 | With uArray 1298 | .cDims = 1 1299 | .fFeatures = 1 ' FADF_AUTO 1300 | .cbElements = 1 1301 | .pvData = lPtr 1302 | .cElements = lSize 1303 | End With 1304 | Call CopyMemory(ByVal ArrPtr(baBuffer), VarPtr(uArray), 4) 1305 | For lIdx = 3 To UBound(baBuffer) Step 4 1306 | If baBuffer(lIdx) <> 0 Then 1307 | pvHasAlpha = True 1308 | Exit Function 1309 | End If 1310 | Next 1311 | End Function 1312 | 1313 | Private Function pvCheckHResult(ByVal hResult As Long) As Long 1314 | If hResult < 0 Then 1315 | Err.Raise hResult 1316 | End If 1317 | pvCheckHResult = pvCheckHResult 1318 | End Function 1319 | 1320 | '= common ================================================================ 1321 | 1322 | Private Function pvCreateDib(ByVal hMemDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, hDib As Long, Optional lpBits As Long) As Boolean 1323 | Const FUNC_NAME As String = "pvCreateDib" 1324 | Dim uHdr As BITMAPINFOHEADER 1325 | 1326 | On Error GoTo EH 1327 | With uHdr 1328 | .biSize = Len(uHdr) 1329 | .biPlanes = 1 1330 | .biBitCount = 32 1331 | .biWidth = lWidth 1332 | .biHeight = -lHeight 1333 | .biSizeImage = 4 * lWidth * lHeight 1334 | End With 1335 | hDib = CreateDIBSection(hMemDC, uHdr, DIB_RGB_COLORS, lpBits, 0, 0) 1336 | If hDib = 0 Then 1337 | GoTo QH 1338 | End If 1339 | '--- success 1340 | pvCreateDib = True 1341 | QH: 1342 | Exit Function 1343 | EH: 1344 | PrintError FUNC_NAME 1345 | Resume QH 1346 | End Function 1347 | 1348 | Private Function TranslateColor(ByVal clrValue As OLE_COLOR, Optional ByVal Alpha As Single = 1) As Long 1349 | Dim uQuad As UcsRgbQuad 1350 | Dim lTemp As Long 1351 | 1352 | Call OleTranslateColor(clrValue, 0, VarPtr(uQuad)) 1353 | lTemp = uQuad.R 1354 | uQuad.R = uQuad.B 1355 | uQuad.B = lTemp 1356 | lTemp = Alpha * &HFF 1357 | If lTemp > 255 Then 1358 | uQuad.A = 255 1359 | ElseIf lTemp < 0 Then 1360 | uQuad.A = 0 1361 | Else 1362 | uQuad.A = lTemp 1363 | End If 1364 | Call CopyMemory(TranslateColor, uQuad, 4) 1365 | End Function 1366 | 1367 | Private Function HM2Pix(ByVal Value As Single) As Long 1368 | HM2Pix = Int(Value * 1440 / 2540 / Screen.TwipsPerPixelX + 0.5!) 1369 | End Function 1370 | 1371 | Private Function ToScaleMode(sScaleUnits As String) As ScaleModeConstants 1372 | Select Case sScaleUnits 1373 | Case "Twip" 1374 | ToScaleMode = vbTwips 1375 | Case "Point" 1376 | ToScaleMode = vbPoints 1377 | Case "Pixel" 1378 | ToScaleMode = vbPixels 1379 | Case "Character" 1380 | ToScaleMode = vbCharacters 1381 | Case "Centimeter" 1382 | ToScaleMode = vbCentimeters 1383 | Case "Millimeter" 1384 | ToScaleMode = vbMillimeters 1385 | Case "Inch" 1386 | ToScaleMode = vbInches 1387 | Case Else 1388 | ToScaleMode = vbTwips 1389 | End Select 1390 | End Function 1391 | 1392 | '========================================================================= 1393 | ' Events 1394 | '========================================================================= 1395 | 1396 | Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 1397 | RaiseEvent MouseDown(Button, Shift, ScaleX(X, ScaleMode, m_eContainerScaleMode), ScaleY(Y, ScaleMode, m_eContainerScaleMode)) 1398 | pvHandleMouseDown Button, Shift, X, Y 1399 | End Sub 1400 | 1401 | Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 1402 | RaiseEvent MouseMove(Button, Shift, ScaleX(X, ScaleMode, m_eContainerScaleMode), ScaleY(Y, ScaleMode, m_eContainerScaleMode)) 1403 | End Sub 1404 | 1405 | Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 1406 | Const FUNC_NAME As String = "UserControl_MouseUp" 1407 | 1408 | On Error GoTo EH 1409 | RaiseEvent MouseUp(Button, Shift, ScaleX(X, ScaleMode, m_eContainerScaleMode), ScaleY(Y, ScaleMode, m_eContainerScaleMode)) 1410 | If Button = -1 Then 1411 | GoTo QH 1412 | End If 1413 | If Button <> 0 And X >= 0 And X < ScaleWidth And Y >= 0 And Y < ScaleHeight Then 1414 | If (m_nDownButton And Button And vbLeftButton) <> 0 Then 1415 | RaiseEvent Click 1416 | ElseIf (m_nDownButton And Button And vbRightButton) <> 0 Then 1417 | RaiseEvent ContextMenu 1418 | End If 1419 | End If 1420 | m_nDownButton = 0 1421 | QH: 1422 | Exit Sub 1423 | EH: 1424 | PrintError FUNC_NAME 1425 | Resume QH 1426 | End Sub 1427 | 1428 | Private Sub UserControl_DblClick() 1429 | pvHandleMouseDown vbLeftButton, m_nDownShift, m_sngDownX, m_sngDownY 1430 | RaiseEvent DblClick 1431 | End Sub 1432 | 1433 | Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult As Integer) 1434 | HitResult = vbHitResultHit 1435 | End Sub 1436 | 1437 | Private Sub UserControl_Resize() 1438 | pvRefresh 1439 | End Sub 1440 | 1441 | Private Sub UserControl_Hide() 1442 | m_bShown = False 1443 | End Sub 1444 | 1445 | Private Sub UserControl_Paint() 1446 | Const FUNC_NAME As String = "UserControl_Paint" 1447 | Const Opacity As Long = &HFF 1448 | Dim hMemDC As Long 1449 | Dim hPrevDib As Long 1450 | 1451 | On Error GoTo EH 1452 | If AutoRedraw Then 1453 | hMemDC = CreateCompatibleDC(hDC) 1454 | If hMemDC = 0 Then 1455 | GoTo DefPaint 1456 | End If 1457 | If m_hRedrawDib = 0 Then 1458 | If Not pvCreateDib(hMemDC, ScaleWidth, ScaleHeight, m_hRedrawDib) Then 1459 | GoTo DefPaint 1460 | End If 1461 | hPrevDib = SelectObject(hMemDC, m_hRedrawDib) 1462 | If Not pvPaintControl(hMemDC) Then 1463 | GoTo DefPaint 1464 | End If 1465 | Else 1466 | hPrevDib = SelectObject(hMemDC, m_hRedrawDib) 1467 | End If 1468 | If AlphaBlend(hDC, 0, 0, ScaleWidth, ScaleHeight, hMemDC, 0, 0, ScaleWidth, ScaleHeight, AC_SRC_ALPHA * &H1000000 + Opacity * &H10000) = 0 Then 1469 | GoTo DefPaint 1470 | End If 1471 | Else 1472 | If Not pvPaintControl(hDC) Then 1473 | GoTo DefPaint 1474 | End If 1475 | End If 1476 | If False Then 1477 | DefPaint: 1478 | If m_hRedrawDib <> 0 Then 1479 | '--- note: before deleting DIB try de-selecting from dc 1480 | Call SelectObject(hMemDC, hPrevDib) 1481 | Call DeleteObject(m_hRedrawDib) 1482 | m_hRedrawDib = 0 1483 | End If 1484 | Line (0, 0)-(ScaleWidth - 1, ScaleHeight - 1), vbBlack, B 1485 | End If 1486 | If hWnd <> 0 Then 1487 | GdipUpdateLayeredWindow hWnd 1488 | End If 1489 | If (GetWindowLong(ContainerHwnd, GWL_EXSTYLE) And WS_EX_LAYERED) <> 0 Then 1490 | GdipUpdateLayeredWindow ContainerHwnd 1491 | End If 1492 | QH: 1493 | On Error Resume Next 1494 | If hMemDC <> 0 Then 1495 | Call SelectObject(hMemDC, hPrevDib) 1496 | Call DeleteDC(hMemDC) 1497 | hMemDC = 0 1498 | End If 1499 | Exit Sub 1500 | EH: 1501 | PrintError FUNC_NAME 1502 | Resume QH 1503 | End Sub 1504 | 1505 | Private Sub UserControl_InitProperties() 1506 | Const FUNC_NAME As String = "UserControl_InitProperties" 1507 | 1508 | On Error GoTo EH 1509 | m_eContainerScaleMode = ToScaleMode(Ambient.ScaleUnits) 1510 | BackStyle = IIf(hWnd = 0, vbTransparent, 1) 1511 | AutoRedraw = DEF_AUTOREDRAW 1512 | Opacity = DEF_OPACITY 1513 | Rotation = DEF_ROTATION 1514 | Zoom = DEF_ZOOM 1515 | MaskColor = DEF_MASKCOLOR 1516 | Stretch = DEF_STRETCH 1517 | Exit Sub 1518 | EH: 1519 | PrintError FUNC_NAME 1520 | End Sub 1521 | 1522 | Private Sub UserControl_ReadProperties(PropBag As PropertyBag) 1523 | Const FUNC_NAME As String = "UserControl_ReadProperties" 1524 | 1525 | On Error GoTo EH 1526 | m_eContainerScaleMode = ToScaleMode(Ambient.ScaleUnits) 1527 | BackStyle = IIf(hWnd = 0, vbTransparent, 1) 1528 | With PropBag 1529 | m_bAutoRedraw = .ReadProperty("AutoRedraw", DEF_AUTOREDRAW) 1530 | m_sngOpacity = .ReadProperty("Opacity", DEF_OPACITY) 1531 | m_sngRotation = .ReadProperty("Rotation", DEF_ROTATION) 1532 | m_sngZoom = .ReadProperty("Zoom", DEF_ZOOM) 1533 | m_clrMask = .ReadProperty("MaskColor", DEF_MASKCOLOR) 1534 | m_bStretch = .ReadProperty("Stretch", DEF_STRETCH) 1535 | Set m_oPicture = .ReadProperty("Picture", Nothing) 1536 | End With 1537 | pvPreparePicture m_oPicture, m_clrMask, m_hPictureBitmap, m_hPictureAttributes 1538 | If Not m_bStretch And TypeOf Extender Is VBControlExtender Then 1539 | pvSizeExtender m_hPictureBitmap, Extender 1540 | End If 1541 | pvRefresh 1542 | QH: 1543 | Exit Sub 1544 | EH: 1545 | PrintError FUNC_NAME 1546 | Resume QH 1547 | End Sub 1548 | 1549 | Private Sub UserControl_WriteProperties(PropBag As PropertyBag) 1550 | Const FUNC_NAME As String = "UserControl_ReadProperties" 1551 | 1552 | On Error GoTo EH 1553 | With PropBag 1554 | .WriteProperty "AutoRedraw", m_bAutoRedraw, DEF_AUTOREDRAW 1555 | .WriteProperty "Opacity", m_sngOpacity, DEF_OPACITY 1556 | .WriteProperty "Rotation", m_sngRotation, DEF_ROTATION 1557 | .WriteProperty "Zoom", m_sngZoom, DEF_ZOOM 1558 | .WriteProperty "MaskColor", m_clrMask, DEF_MASKCOLOR 1559 | .WriteProperty "Stretch", m_bStretch, DEF_STRETCH 1560 | .WriteProperty "Picture", m_oPicture, Nothing 1561 | End With 1562 | QH: 1563 | Exit Sub 1564 | EH: 1565 | PrintError FUNC_NAME 1566 | Resume QH 1567 | End Sub 1568 | 1569 | Private Sub UserControl_AmbientChanged(PropertyName As String) 1570 | If PropertyName = "ScaleUnits" Then 1571 | m_eContainerScaleMode = ToScaleMode(Ambient.ScaleUnits) 1572 | End If 1573 | End Sub 1574 | 1575 | '========================================================================= 1576 | ' Base class events 1577 | '========================================================================= 1578 | 1579 | Private Sub UserControl_Initialize() 1580 | Dim aInput(0 To 3) As Long 1581 | 1582 | If GetModuleHandle("gdiplus") = 0 Then 1583 | aInput(0) = 1 1584 | Call GdiplusStartup(0, aInput(0)) 1585 | End If 1586 | m_eContainerScaleMode = vbTwips 1587 | End Sub 1588 | 1589 | Private Sub UserControl_Terminate() 1590 | If m_hAttributes <> 0 Then 1591 | Call GdipDisposeImageAttributes(m_hAttributes) 1592 | m_hAttributes = 0 1593 | End If 1594 | If m_hBitmap <> 0 Then 1595 | Call GdipDisposeImage(m_hBitmap) 1596 | m_hBitmap = 0 1597 | End If 1598 | If m_hPictureBitmap <> 0 Then 1599 | Call GdipDisposeImage(m_hPictureBitmap) 1600 | m_hPictureBitmap = 0 1601 | End If 1602 | If m_hPictureAttributes <> 0 Then 1603 | Call GdipDisposeImageAttributes(m_hPictureAttributes) 1604 | m_hPictureAttributes = 0 1605 | End If 1606 | If m_hRedrawDib <> 0 Then 1607 | Call DeleteObject(m_hRedrawDib) 1608 | m_hRedrawDib = 0 1609 | End If 1610 | End Sub 1611 | -------------------------------------------------------------------------------- /test/basic/Form1.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form Form1 3 | BackColor = &H00FFFFFF& 4 | Caption = "Form1" 5 | ClientHeight = 10860 6 | ClientLeft = 108 7 | ClientTop = 456 8 | ClientWidth = 15348 9 | LinkTopic = "Form1" 10 | ScaleHeight = 10860 11 | ScaleWidth = 15348 12 | StartUpPosition = 3 'Windows Default 13 | Begin VB.Timer Timer1 14 | Interval = 50 15 | Left = 2772 16 | Top = 756 17 | End 18 | Begin VB.Image Image2 19 | Height = 660 20 | Left = 420 21 | Picture = "Form1.frx":0000 22 | Top = 2940 23 | Width = 768 24 | End 25 | Begin Project1.AlphaBlendImage AlphaBlendImage2 26 | Height = 1440 27 | Left = 4452 28 | Top = 2856 29 | Width = 1440 30 | _ExtentX = 2540 31 | _ExtentY = 2540 32 | End 33 | Begin Project1.AlphaBlendImage AlphaBlendImage1 34 | Height = 768 35 | Left = 2184 36 | Top = 2016 37 | Width = 768 38 | _ExtentX = 1355 39 | _ExtentY = 1355 40 | Opacity = 0.5 41 | Rotation = 60 42 | Zoom = 2 43 | Picture = "Form1.frx":1202 44 | End 45 | Begin VB.Image Image1 46 | Height = 1440 47 | Left = 168 48 | Top = 84 49 | Width = 1692 50 | End 51 | End 52 | Attribute VB_Name = "Form1" 53 | Attribute VB_GlobalNameSpace = False 54 | Attribute VB_Creatable = False 55 | Attribute VB_PredeclaredId = True 56 | Attribute VB_Exposed = False 57 | Option Explicit 58 | 59 | Private Sub Form_Click() 60 | Form2.Show 61 | End Sub 62 | 63 | Private Sub Form_Load() 64 | On Error GoTo EH 65 | Set AlphaBlendImage1.Picture = Image2.Picture ' AlphaBlendImage1.GdipLoadPictureArray(ReadBinaryFile(App.Path & "\bbb.png")) ' 66 | AlphaBlendImage1.Tag = -120 67 | AlphaBlendImage1.Width = AlphaBlendImage1.Width * 2 68 | AlphaBlendImage1.Height = AlphaBlendImage1.Height * 2 69 | Set Image1.Picture = AlphaBlendImage1.GdipLoadPicture(App.Path & "\bbb.png") 70 | AlphaBlendImage1.GdipSetClipboardDib Image1.Picture 71 | Image1.Tag = 80 72 | Exit Sub 73 | EH: 74 | MsgBox Err.Description, vbCritical 75 | End Sub 76 | 77 | Private Sub AlphaBlendImage1_Click() 78 | Timer1.Enabled = Not Timer1.Enabled 79 | End Sub 80 | 81 | Private Sub Timer1_Timer() 82 | AlphaBlendImage1.Rotation = AlphaBlendImage1.Rotation + 13 83 | AlphaBlendImage1.Left = AlphaBlendImage1.Left + AlphaBlendImage1.Tag 84 | If AlphaBlendImage1.Left + AlphaBlendImage1.Width > ScaleWidth Then 85 | AlphaBlendImage1.Tag = -Abs(AlphaBlendImage1.Tag) 86 | ElseIf AlphaBlendImage1.Left < 0 Then 87 | AlphaBlendImage1.Tag = Abs(AlphaBlendImage1.Tag) 88 | End If 89 | Caption = AlphaBlendImage1.Rotation 90 | Image1.Left = Image1.Left + Image1.Tag 91 | If Image1.Left + Image1.Width > ScaleWidth And Image1.Left > 0 Then 92 | Image1.Tag = -Abs(Image1.Tag) 93 | ElseIf Image1.Left < 0 And Image1.Left + Image1.Width < ScaleWidth Then 94 | Image1.Tag = Abs(Image1.Tag) 95 | End If 96 | End Sub 97 | 98 | Public Function ReadBinaryFile(sFile As String) As Byte() 99 | With CreateObject("ADODB.Stream") 100 | .Open 101 | .Type = 1 102 | .LoadFromFile sFile 103 | ReadBinaryFile = .Read 104 | End With 105 | End Function 106 | -------------------------------------------------------------------------------- /test/basic/Form1.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wqweto/AlphaBlendImage/ea789f6ef436580bfc08b6d6c29e73ef0ab84724/test/basic/Form1.frx -------------------------------------------------------------------------------- /test/basic/Form2.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form Form2 3 | BorderStyle = 0 'None 4 | Caption = "Form2" 5 | ClientHeight = 2316 6 | ClientLeft = 0 7 | ClientTop = 0 8 | ClientWidth = 3624 9 | LinkTopic = "Form2" 10 | ScaleHeight = 2316 11 | ScaleWidth = 3624 12 | ShowInTaskbar = 0 'False 13 | StartUpPosition = 3 'Windows Default 14 | Begin VB.Timer Timer1 15 | Interval = 10 16 | Left = 1764 17 | Top = 840 18 | End 19 | Begin Project1.AlphaBlendImage AlphaBlendImage1 20 | Height = 768 21 | Left = 0 22 | Top = 0 23 | Width = 768 24 | _ExtentX = 1355 25 | _ExtentY = 1355 26 | AutoRedraw = -1 'True 27 | Rotation = 60 28 | Zoom = 2 29 | End 30 | End 31 | Attribute VB_Name = "Form2" 32 | Attribute VB_GlobalNameSpace = False 33 | Attribute VB_Creatable = False 34 | Attribute VB_PredeclaredId = True 35 | Attribute VB_Exposed = False 36 | Option Explicit 37 | 38 | Private m_lX As Long 39 | Private m_lY As Long 40 | Private m_sngDelta As Single 41 | 42 | Private Sub Form_Load() 43 | Set AlphaBlendImage1.Picture = AlphaBlendImage1.GdipLoadPicture(App.Path & "\garden.png") 44 | Width = AlphaBlendImage1.Width 45 | Height = AlphaBlendImage1.Height 46 | AlphaBlendImage1.GdipUpdateLayeredWindow hWnd 47 | m_sngDelta = 0.01 48 | End Sub 49 | 50 | Private Sub AlphaBlendImage1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 51 | If Button = vbLeftButton Then 52 | m_lX = X 53 | m_lY = Y 54 | End If 55 | End Sub 56 | 57 | Private Sub AlphaBlendImage1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 58 | If (Button And vbLeftButton) <> 0 Then 59 | Move Left + X - m_lX, Top + Y - m_lY 60 | End If 61 | End Sub 62 | 63 | Private Sub AlphaBlendImage1_DblClick() 64 | Unload Me 65 | End Sub 66 | 67 | Private Sub Timer1_Timer() 68 | AlphaBlendImage1.Opacity = AlphaBlendImage1.Opacity + m_sngDelta 69 | If AlphaBlendImage1.Opacity <= 0 Or AlphaBlendImage1.Opacity >= 1 Then 70 | m_sngDelta = -m_sngDelta 71 | End If 72 | End Sub 73 | -------------------------------------------------------------------------------- /test/basic/Project1.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Form=Form1.frm 3 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation 4 | UserControl=..\..\src\AlphaBlendImage.ctl 5 | Form=Form2.frm 6 | IconForm="Form1" 7 | Startup="Form1" 8 | HelpFile="" 9 | Title="Project1" 10 | ExeName32="Project1.exe" 11 | Command32="" 12 | Name="Project1" 13 | HelpContextID="0" 14 | CompatibleMode="0" 15 | MajorVer=1 16 | MinorVer=0 17 | RevisionVer=0 18 | AutoIncrementVer=0 19 | ServerSupportFiles=0 20 | VersionCompanyName="Unicontsoft" 21 | CompilationType=0 22 | OptimizationType=0 23 | FavorPentiumPro(tm)=0 24 | CodeViewDebugInfo=0 25 | NoAliasing=0 26 | BoundsCheck=0 27 | OverflowCheck=0 28 | FlPointCheck=0 29 | FDIVCheck=0 30 | UnroundedFP=0 31 | StartMode=0 32 | Unattended=0 33 | Retained=0 34 | ThreadPerObject=0 35 | MaxNumberOfThreads=1 36 | -------------------------------------------------------------------------------- /test/basic/bbb.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wqweto/AlphaBlendImage/ea789f6ef436580bfc08b6d6c29e73ef0ab84724/test/basic/bbb.png -------------------------------------------------------------------------------- /test/basic/garden.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wqweto/AlphaBlendImage/ea789f6ef436580bfc08b6d6c29e73ef0ab84724/test/basic/garden.png -------------------------------------------------------------------------------- /test/tabstrip/Form1.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form Form1 3 | Caption = "Form1" 4 | ClientHeight = 5100 5 | ClientLeft = 108 6 | ClientTop = 456 7 | ClientWidth = 6948 8 | BeginProperty Font 9 | Name = "Segoe UI" 10 | Size = 9 11 | Charset = 204 12 | Weight = 400 13 | Underline = 0 'False 14 | Italic = 0 'False 15 | Strikethrough = 0 'False 16 | EndProperty 17 | LinkTopic = "Form1" 18 | ScaleHeight = 5100 19 | ScaleWidth = 6948 20 | StartUpPosition = 3 'Windows Default 21 | Begin Project1.AlphaBlendTabStrip AlphaBlendTabStrip1 22 | Height = 432 23 | Left = 504 24 | Top = 2436 25 | Width = 5136 26 | _ExtentX = 9059 27 | _ExtentY = 762 28 | BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 29 | Name = "Segoe UI" 30 | Size = 9 31 | Charset = 204 32 | Weight = 400 33 | Underline = 0 'False 34 | Italic = 0 'False 35 | Strikethrough = 0 'False 36 | EndProperty 37 | Layout = "Printers|Configuration|Logs" 38 | End 39 | Begin Project1.AlphaBlendLabel AlphaBlendLabel1 40 | Height = 2112 41 | Left = 1344 42 | Top = 336 43 | Width = 3180 44 | _ExtentX = 5609 45 | _ExtentY = 3725 46 | AutoSize = -1 'True 47 | Caption = "This is a test of the wrap mode This is a test of the wrap mode" 48 | BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 49 | Name = "PT Sans Narrow" 50 | Size = 19.8 51 | Charset = 204 52 | Weight = 700 53 | Underline = 0 'False 54 | Italic = 0 'False 55 | Strikethrough = 0 'False 56 | EndProperty 57 | ForeColor = -2147483627 58 | ShadowColor = -2147483630 59 | ShadowOpacity = 1 60 | End 61 | End 62 | Attribute VB_Name = "Form1" 63 | Attribute VB_GlobalNameSpace = False 64 | Attribute VB_Creatable = False 65 | Attribute VB_PredeclaredId = True 66 | Attribute VB_Exposed = False 67 | Option Explicit 68 | 69 | Private Sub AlphaBlendTabStrip1_BeforeClick(TabIndex As Long, Cancel As Boolean) 70 | If TabIndex = AlphaBlendTabStrip1.CurrentTab Then 71 | Cancel = True 72 | ElseIf AlphaBlendTabStrip1.CurrentTab = 1 Then 73 | Select Case MsgBox("Do you want to save configuration?", vbQuestion Or vbYesNoCancel) 74 | Case vbYes 75 | AlphaBlendTabStrip1.TabCaption(1) = Replace(AlphaBlendTabStrip1.TabCaption(1), "*", vbNullString) 76 | Case vbCancel 77 | Cancel = True 78 | End Select 79 | End If 80 | End Sub 81 | 82 | Private Sub AlphaBlendTabStrip1_Click() 83 | Debug.Print "AlphaBlendTabStrip1.CurrentTab=" & AlphaBlendTabStrip1.CurrentTab 84 | If AlphaBlendTabStrip1.CurrentTab = 1 And Right$(AlphaBlendTabStrip1.TabCaption(1), 1) <> "*" Then 85 | AlphaBlendTabStrip1.TabCaption(1) = AlphaBlendTabStrip1.TabCaption(1) & "*" 86 | End If 87 | End Sub 88 | 89 | -------------------------------------------------------------------------------- /test/tabstrip/Project1.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Form=Form1.frm 3 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation 4 | UserControl=..\..\contrib\AlphaBlendLabel.ctl 5 | UserControl=..\..\contrib\AlphaBlendTabStrip.ctl 6 | IconForm="Form1" 7 | Startup="Form1" 8 | Command32="" 9 | Name="Project1" 10 | HelpContextID="0" 11 | CompatibleMode="0" 12 | MajorVer=1 13 | MinorVer=0 14 | RevisionVer=0 15 | AutoIncrementVer=0 16 | ServerSupportFiles=0 17 | VersionCompanyName="Unicontsoft" 18 | CompilationType=0 19 | OptimizationType=0 20 | FavorPentiumPro(tm)=0 21 | CodeViewDebugInfo=0 22 | NoAliasing=0 23 | BoundsCheck=0 24 | OverflowCheck=0 25 | FlPointCheck=0 26 | FDIVCheck=0 27 | UnroundedFP=0 28 | StartMode=0 29 | Unattended=0 30 | Retained=0 31 | ThreadPerObject=0 32 | MaxNumberOfThreads=1 33 | --------------------------------------------------------------------------------