modmakexpbutton.bas

打印预览程序

            Set oPict = Button.Picture
         ElseIf oPict.Handle = 0 Then
            Set oPict = Button.Picture
         End If
      Else
         Set oPict = Button.Picture
      End If

   ElseIf bChecked Or bPushed Then

      lState = 3

      Set oPict = Button.DownPicture

      If oPict Is Nothing Then
         Set oPict = Button.Picture
      ElseIf oPict.Handle = 0 Then
         Set oPict = Button.Picture
      End If

   ElseIf GetProp(hwnd, "Hot") = 1 Then

      lState = 2
      Set oPict = Button.Picture

   ElseIf bFocused Then

      lState = 5
      Set oPict = Button.Picture

   Else

      lState = 1
      Set oPict = Button.Picture

   End If

   If oPict Is Nothing Then
      bNoPicture = True
   ElseIf oPict.Handle = 0 Then
      bNoPicture = True
   End If

   ' Draw the button background
   DrawThemeBackground hTheme, hdc, 1, lState, tCR, tCR

   If bFocused Then

      ' Draw the focus rectangle
      tCRText = tCR
      InflateRect tCRText, -3, -3

      DrawFocusRect hdc, tCRText

   End If

   If Len(Button.Caption) Then

      ' Select the button font
      Set oFont = Button.Font
      lFontOld = SelectObject(hdc, oFont.hFont)

      ' Calculate the text size
      tCRText = tCR
      DrawText hdc, Button.Caption, -1, tCRText, DT_CALCRECT Or DT_CENTER Or DT_WORDBREAK

      tCRText.Left = tCR.Left
      tCRText.Right = tCR.Right

      If bNoPicture Then
         tCRText.Top = (tCR.Bottom - tCRText.Bottom) / 2
         tCRText.Bottom = tCRText.Top + tCRText.Bottom
      Else
         tCRText.Top = tCR.Bottom - tCRText.Bottom - 5
         tCRText.Bottom = tCR.Bottom
      End If

      ' Set the text background
      SetBkMode hdc, TRANSPARENT

      ' Set the color
      If Button.Enabled Then
         SetTextColor hdc, GetThemeSysColor(hTheme, COLOR_BTNTEXT)
      Else
         SetTextColor hdc, GetThemeSysColor(hTheme, COLOR_GRAYTEXT)
      End If

      ' Draw the text
      DrawText hdc, Button.Caption, -1, tCRText, DT_CENTER Or DT_WORDBREAK

      ' Restore the original font
      SelectObject hdc, lFontOld

      tCR.Bottom = tCRText.Top

   End If

   If Not bNoPicture Then

      Dim lW As Long, lH As Long

      ' Convert from HIMETRIC to Pixels
      lW = oPict.Width / 2540 * (1440 / Screen.TwipsPerPixelX)
      lH = oPict.Height / 2540 * (1440 / Screen.TwipsPerPixelY)

      If Button.Enabled Then

         If Button.UseMaskColor Then
            ' Draw the image using the mask color
            DrawTransparentPicture oPict, hdc, (tCR.Right - lW) / 2, (tCR.Bottom - lH) / 2, _
                                   lW, lH, Button.MaskColor
         Else
            ' Draw the image without using the mask color
            oPict.Render hdc, (tCR.Right - lW) / 2, (tCR.Bottom - lH) / 2 + lH, lW, -lH, _
                         0, 0, oPict.Width, oPict.Height, ByVal 0&
         End If

      Else

         ' Draw the image in disabled mode
         DrawDisabledPicture oPict, hdc, (tCR.Right - lW) / 2, (tCR.Bottom - lH) / 2, _
                             lW, lH, Button.MaskColor

      End If

   End If

   ' Release button object
   CopyMemory Button, 0&, 4&

   ' Release the DC
   EndPaint hwnd, tPS

   ' Close the theme
   CloseThemeData hTheme

End Sub

'
' DrawTransparentPicture
'
' Draws a transparent picture
'
Private Sub DrawTransparentPicture( _
   ByVal picSource As Picture, _
   ByVal hDCDest As Long, _
   ByVal xDest As Long, _
   ByVal yDest As Long, _
   ByVal cxDest As Long, _
   ByVal cyDest As Long, _
   ByVal clrMask As Long, _
   Optional ByVal xSrc As Long, _
   Optional ByVal ySrc As Long, _
   Optional ByVal cxSrc As Long, _
   Optional ByVal cySrc As Long)

Dim hDCSrc As Long, hDCScreen As Long
Dim hbmOld As Long

   If picSource Is Nothing Then Exit Sub
   If picSource.Type <> vbPicTypeBitmap Then Exit Sub

   If cxSrc = 0 Then cxSrc = cxDest
   If cySrc = 0 Then cySrc = cyDest

   hDCScreen = GetDC(0&)

   ' Select passed picture into an HDC
   hDCSrc = CreateCompatibleDC(hDCScreen)
   hbmOld = SelectObject(hDCSrc, picSource.Handle)

   ' Draw the bitmap in the destination DC
   TransparentBlt hDCDest, xDest, yDest, cxDest, cyDest, hDCSrc, xSrc, ySrc, cxSrc, cySrc, clrMask

   ' Restore the original bitmap
   SelectObject hDCSrc, hbmOld

   ' Release the DCs
   DeleteDC hDCSrc
   ReleaseDC 0&, hDCScreen

End Sub

'
' DrawDisabledPicture
'
' Draws a picture in B&W
'
Private Sub DrawDisabledPicture( _
   ByVal picSource As Picture, _
   ByVal hDCDest As Long, _
   ByVal xDest As Long, _
   ByVal yDest As Long, _
   ByVal cxDest As Long, _
   ByVal cyDest As Long, _
   ByVal MaskColor As Long)
Dim hDCSrc As Long, hDCScreen As Long, hDCBW As Long
Dim lBMPBW As Long, lBMPOld As Long

   If picSource Is Nothing Then Exit Sub
   If picSource.Type <> vbPicTypeBitmap Then Exit Sub

   hDCScreen = GetDC(0&)

   ' Select passed picture into an HDC
   hDCSrc = CreateCompatibleDC(hDCScreen)
   lBMPOld = SelectObject(hDCSrc, picSource.Handle)

   ' Create a B&W picture
   hDCBW = CreateCompatibleDC(hDCScreen)
   lBMPBW = CreateBitmap(cxDest, cyDest, 1, 1, ByVal 0&)
   DeleteObject SelectObject(hDCBW, lBMPBW)

   ' Set the source background to white
   ' When you use BitBlt to copy from a
   ' color to a B&W bitmap, windows
   ' will convert all pixels matching
   ' the source background color to white
   ' and everything else to black
   SetBkColor hDCSrc, MaskColor

   BitBlt hDCBW, 0, 0, cxDest, cyDest, hDCSrc, 0, 0, vbSrcCopy

   ' Draw the image using white
   ' as the transparent color
   TransparentBlt hDCDest, xDest, yDest, cxDest, cyDest, hDCBW, 0, 0, cxDest, cyDest, vbWhite

   SelectObject hDCSrc, lBMPOld

   DeleteDC hDCBW
   DeleteDC hDCSrc
   ReleaseDC 0&, hDCScreen

End Sub


'
' TranslateColor
'
' Converts an OLE_COLOR to RGB
'
Function TranslateColor(ByVal Clr As OLE_COLOR)

   If (Clr And &H80000000) = &H80000000 Then
      TranslateColor = GetSysColor(Clr And &HFF)
   Else
      TranslateColor = Clr
   End If

End Function

'
' WinProc_Button
'
' Button window procedure
'
Private Function WinProc_Button( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
Dim tTME As TrackMouseEvent
Dim lProc As Long

   ' Get the previous window procedure
   lProc = GetProp(hwnd, "WinProc")

   Select Case Msg

      Case WM_NCPAINT
         ' Do nothing
         Exit Function

      Case WM_PAINT

         ' Draw the button
         DrawButton hwnd
         Exit Function

      Case WM_DESTROY

         ' Unsubclass the window
         SetWindowLong hwnd, GWL_WNDPROC, lProc
         RemoveProp hwnd, "WinProc"
         RemoveProp hwnd, "Button"

   End Select

   ' Call the previous window procedure
   WinProc_Button = CallWindowProc(lProc, hwnd, Msg, wParam, lParam)

   Select Case Msg

      Case WM_MOUSEHOVER

         ' Mouse is over the button

         SetProp hwnd, "Hot", 1

         ' Redraw the button
         DrawButton hwnd

      Case WM_MOUSELEAVE

         ' Mouse has left the button

         RemoveProp hwnd, "Hot"
         DrawButton hwnd

      Case WM_MOUSEMOVE

         If GetProp(hwnd, "Hot") = 0 Then

            tTME.cbSize = LenB(tTME)
            tTME.hwndTrack = hwnd
            tTME.dwFlags = TME_HOVER Or TME_LEAVE
            tTME.dwHoverTime = 1

            TrackMouseEvent tTME

         End If

      Case WM_SETFOCUS, WM_KILLFOCUS, _
           WM_LBUTTONDOWN, WM_LBUTTONUP, _
           WM_KEYDOWN, WM_KEYUP, _
           WM_ENABLE, WM_MOUSEACTIVATE

         ' Draw the button
         DrawButton hwnd

   End Select


End Function