modgradient.bas

某大学开发的一个用于对微波传输线状态进行模拟的软件

Public Const SM_RESERVED4 = 27
Public Const SM_SWAPBUTTON = 23
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function ExcludeClipRect Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function DrawFrameControl Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
Public Const DFC_CAPTION = 1
Public Const DFCS_CAPTIONRESTORE = &H3
Public Const DFCS_CAPTIONMIN = &H1
Public Const DFCS_CAPTIONMAX = &H2
Public Const DFCS_CAPTIONHELP = &H4
Public Const DFCS_CAPTIONCLOSE = &H0
Public Const DFCS_INACTIVE = &H100
Public Function GradientCallback(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim OldBMP As Long, NewBMP As Long
Dim rcWnd As RECT
Select Case wMsg
Case WM_NCACTIVATE, WM_MDIACTIVATE
  GetWindowRect GradhWnd, rcWnd
  GradientCallback = CallWindowProc(OldGradProc, hwnd, wMsg, wParam, lParam)
  tmpDC = GetWindowDC(GradhWnd)
  DrawDC = CreateCompatibleDC(tmpDC)
  NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50)
  OldBMP = SelectObject(DrawDC, NewBMP)
  With rcWnd
   hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
   SelectClipRgn tmpDC, hRgn
   OffsetClipRgn tmpDC, -.Left, -.Top
  End With
  If wParam And GetParent(GradhWnd) = 0 Then
   DrawGradient 0, GetSysColor(COLOR_ACTIVECAPTION)
  ElseIf wParam = GradhWnd And GetParent(GradhWnd) <> 0 Then
   DrawGradient 0, GetSysColor(COLOR_INACTIVECAPTION)
  ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
   DrawGradient 0, GetSysColor(COLOR_ACTIVECAPTION)
  Else
   DrawGradient 0, GetSysColor(COLOR_INACTIVECAPTION)
  End If
  'Cleanup
  SelectObject DrawDC, OldBMP
  DeleteObject NewBMP
  DeleteDC DrawDC
  OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
  GetClipRgn tmpDC, hRgn
  ReleaseDC GradhWnd, tmpDC
  DeleteObject hRgn
  tmpDC = 0
  Exit Function
Case WM_NCPAINT
  GetWindowRect GradhWnd, rcWnd
  tmpDC = GetWindowDC(GradhWnd)
  DrawDC = CreateCompatibleDC(tmpDC)
  NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50)
  OldBMP = SelectObject(DrawDC, NewBMP)
  With rcWnd
   hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
   SelectClipRgn tmpDC, hRgn
   OffsetClipRgn tmpDC, -.Left, -.Top
  End With
  If GetActiveWindow() = GradhWnd Then
   DrawGradient 0, GetSysColor(COLOR_ACTIVECAPTION)
  ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
   DrawGradient 0, GetSysColor(COLOR_ACTIVECAPTION)
  Else
   DrawGradient 0, GetSysColor(COLOR_INACTIVECAPTION)
  End If
  SelectObject DrawDC, OldBMP
  DeleteObject NewBMP
  DeleteDC DrawDC
  OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
  GetClipRgn tmpDC, hRgn
  GradientCallback = CallWindowProc(OldGradProc, hwnd, WM_NCPAINT, hRgn, lParam)
  ReleaseDC GradhWnd, tmpDC
  DeleteObject hRgn
  tmpDC = 0
  Exit Function
Case WM_SIZE
  If hwnd = GradhWnd Then SendMessage GradhWnd, WM_NCPAINT, 0, 0
End Select
GradientCallback = CallWindowProc(OldGradProc, hwnd, wMsg, wParam, lParam)
End Function
Public Sub GradientForm(frm As Form)
If OldGradProc <> 0 Then Exit Sub
GradhWnd = frm.hwnd
GradIcon = frm.Icon
OldGradProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf GradientCallback)
GradientGetCapsFont
End Sub
Public Sub GradientReleaseForm()
If OldGradProc = 0 Or GradhWnd = 0 Then Exit Sub
SetWindowLong GradhWnd, GWL_WNDPROC, OldGradProc
OldGradProc = 0
GradhWnd = 0
End Sub
Private Function DrawGradient(ByVal Color1 As Long, ByVal Color2 As Long) As Long
Dim i As Integer
Dim DestWidth As Long, DestHeight As Long
Dim StartPnt As Integer, EndPnt As Integer
Dim PixelStep As Long, XBorder As Long
Dim WndRect As RECT
Dim OldFont As Long
Dim fText As String
On Error Resume Next
GetWindowRect GradhWnd, WndRect
With WndRect
 DestWidth = .Right - .Left
End With
DestHeight = GetSystemMetrics(SM_CYCAPTION)
fText = Space$(255)
Call GetWindowText(GradhWnd, fText, 255)
fText = Trim$(fText)
XBorder = GetSystemMetrics(SM_CXDLGFRAME)
DestWidth = DestWidth - (XBorder * 2) - (GetSystemMetrics(SM_CXSMSIZE) * 3) + 6
StartPnt = XBorder
EndPnt = XBorder + DestWidth - 4
PixelStep = DestWidth \ 8
ReDim Colors(PixelStep) As Long
GradateColors Colors(), Color1, Color2
Dim rct As RECT
Dim hBr As Long
With rct
 .Top = XBorder
 .Left = XBorder
 .Right = XBorder + (DestWidth \ PixelStep)
 .Bottom = XBorder + DestHeight - 1
For i = 0 To PixelStep - 1
 hBr = CreateSolidBrush(Colors(i))
 FillRect DrawDC, rct, hBr
 DeleteObject hBr
 OffsetRect rct, (DestWidth \ PixelStep), 0
 If i = PixelStep - 2 Then .Right = EndPnt
Next
If GradIcon <> 0 Then
 .Left = XBorder + GetSystemMetrics(SM_CXSMSIZE) + 2
 DrawIconEx DrawDC, XBorder + 1, XBorder + 1, GradIcon, GetSystemMetrics(SM_CXSMSIZE) - 2, GetSystemMetrics(SM_CYSMSIZE) - 2, ByVal 0&, ByVal 0&, 2
Else
 .Left = XBorder
End If
If CaptionFont.lfHeight = 0 And tmpGradFont = 0 Then
 tmpGradFont = SendMessage(GradhWnd, WM_GETFONT, 0, 0)
ElseIf tmpGradFont = 0 Then
 tmpGradFont = CreateFontIndirect(CaptionFont)
End If
OldFont = SelectObject(DrawDC, tmpGradFont)
SetBkMode DrawDC, 1
SetTextColor DrawDC, RGB(255, 255, 255)
.Left = .Left + 2
.Right = .Right - 10
DrawText DrawDC, fText, Len(fText) - 1, rct, DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_VCENTER
SelectObject DrawDC, OldFont
DeleteObject tmpGradFont
tmpGradFont = 0
.Left = XBorder
.Right = .Right + 12
If tmpDC <> 0 Then
 BitBlt tmpDC, .Left, .Top, .Right - .Left - 10, .Bottom - .Top, DrawDC, .Left, .Top, vbSrcCopy
 ExcludeClipRect tmpDC, XBorder, XBorder, .Right - .Left - 8, .Bottom - .Top + 4
End If
End With
End Function
Private Sub GradateColors(Colors() As Long, ByVal Color1 As Long, ByVal Color2 As Long)
Dim i As Integer
Dim dblR As Double, dblG As Double, dblB As Double
Dim addR As Double, addG As Double, addB As Double
Dim bckR As Double, bckG As Double, bckB As Double
dblR = CDbl(Color1 And &HFF)
dblG = CDbl(Color1 And &HFF00&) / 255
dblB = CDbl(Color1 And &HFF0000) / &HFF00&
bckR = CDbl(Color2 And &HFF&)
bckG = CDbl(Color2 And &HFF00&) / 255
bckB = CDbl(Color2 And &HFF0000) / &HFF00&
addR = (bckR - dblR) / UBound(Colors)
addG = (bckG - dblG) / UBound(Colors)
addB = (bckB - dblB) / UBound(Colors)
For i = 0 To UBound(Colors)
 dblR = dblR + addR
 dblG = dblG + addG
 dblB = dblB + addB
 If dblR > 255 Then dblR = 255
 If dblG > 255 Then dblG = 255
 If dblB > 255 Then dblB = 255
 If dblR < 0 Then dblR = 0
 If dblG < 0 Then dblG = 0
 If dblG < 0 Then dblB = 0
 Colors(i) = RGB(dblR, dblG, dblB)
Next
End Sub
Public Sub GradientGetCapsFont()
Dim NCM As NONCLIENTMETRICS
Dim lfNew As LOGFONT
NCM.cbSize = Len(NCM)
Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, NCM, 0)
If NCM.iCaptionHeight = 0 Then
 CaptionFont.lfHeight = 0
Else
 CaptionFont = NCM.lfSMCaptionFont
End If
End Sub