GDI/图象编程

开发平台：
Visual Basic

AeroForm.ctl：源码内容
							VERSION 5.00
Begin VB.UserControl AeroForm 
   Alignable       =   -1  'True
   AutoRedraw      =   -1  'True
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   BeginProperty Font 
      Name            =   "Arial"
      Size            =   9
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ScaleHeight     =   240
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   ToolboxBitmap   =   "AeroForm.ctx":0000
   Begin VB.PictureBox Picture2 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C00000&
      BorderStyle     =   0  'None
      Height          =   570
      Left            =   480
      Picture         =   "AeroForm.ctx":0312
      ScaleHeight     =   38
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   100
      TabIndex        =   3
      Top             =   2160
      Width           =   1500
   End
   Begin VB.PictureBox pCaptionButtons 
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      Height          =   570
      Left            =   1800
      ScaleHeight     =   38
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   100
      TabIndex        =   2
      Top             =   1320
      Width           =   1500
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Aero Form"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   615
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   9
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00000000&
      Height          =   375
      Left            =   0
      ScaleHeight     =   25
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   206
      TabIndex        =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   3090
   End
End
Attribute VB_Name = "AeroForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'========================================================================================
' Subclasser declarations
'========================================================================================
Private Enum eMsgWhen
    [MSG_AFTER] = 1                                                           'Message calls back after the original (previous) WndProc
    [MSG_BEFORE] = 2                                                          'Message calls back before the original (previous) WndProc
    [MSG_BEFORE_AND_AFTER] = MSG_AFTER Or MSG_BEFORE                          'Message calls back before and after the original (previous) WndProc
End Enum
Private Type tSubData                                                         'Subclass data type
    hWnd                   As Long                                            'Handle of the window being subclassed
    nAddrSub               As Long                                            'The address of our new WndProc (allocated memory).
    nAddrOrig              As Long                                            'The address of the pre-existing WndProc
    nMsgCntA               As Long                                            'Msg after table entry count
    nMsgCntB               As Long                                            'Msg before table entry count
    aMsgTblA()             As Long                                            'Msg after table array
    aMsgTblB()             As Long                                            'Msg Before table array
End Type
Private sc_aSubData()      As tSubData                                        'Subclass data array
Private Const ALL_MESSAGES As Long = -1                                       'All messages added or deleted
Private Const GMEM_FIXED   As Long = 0                                        'Fixed memory GlobalAlloc flag
Private Const GWL_WNDPROC  As Long = -4                                       'Get/SetWindow offset to the WndProc procedure address
Private Const PATCH_04     As Long = 88                                       'Table B (before) address patch offset
Private Const PATCH_05     As Long = 93                                       'Table B (before) entry count patch offset
Private Const PATCH_08     As Long = 132                                      'Table A (after) address patch offset
Private Const PATCH_09     As Long = 137                                      'Table A (after) entry count patch offset
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'//
Private Enum eBorderStyle
  None = 0
  Fixed = 1
  Sizable = 2
  Dialog = 3
End Enum
Private Const LF_FACESIZE = 32
Private Type LOGFONT
   lfHeight As Long
   lfWidth As Long
   lfEscapement As Long
   lfOrientation As Long
   lfWeight As Long
   lfItalic As Byte
   lfUnderline As Byte
   lfStrikeOut As Byte
   lfCharSet As Byte
   lfOutPrecision As Byte
   lfClipPrecision As Byte
   lfQuality As Byte
   lfPitchAndFamily As Byte
   lfFaceName(LF_FACESIZE) As Byte
End Type
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const LOGPIXELSY = 90
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetMenu Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Const CaptionHeight = 25
Private Const LeftWidth = 9
Private Const RightWidth = 9
Private Const BottomHeight = 9
Private FBorderStyle As eBorderStyle, FMaxButton As Boolean, FMinButton As Boolean
Private WorkArea               As RECT
Private mDC As Long  ' Memory hDC
Private mainBitmap As Long ' Memory Bitmap
Private blendFunc32bpp As BLENDFUNCTION
Private Token As Long ' Needed to close GDI+
Private oldBitmap As Long
Private MainWnd As Long
Private MainRect As RECT
Private pIcon As New c32bppDIB
Private iFrame(3) As New c32bppDIB
Private bClose(1) As New c32bppDIB, bCloseS(1) As New c32bppDIB, bMaxRes(2) As New c32bppDIB, bMin(1) As New c32bppDIB
Private clH As Boolean, clHl As Boolean, clD As Boolean, clRct As RECT
Private mxH As Boolean, mxHl As Boolean, mxD As Boolean, mxRct As RECT
Private mnH As Boolean, mnHl As Boolean, mnD As Boolean, mnRct As RECT
Private R As RECT, CR As RECT, R1 As RECT
Private FormActive As Boolean
Private pCapt As New c32bppDIB, cRect As RECT
Private Sub pCaptionButtons_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If clH Then
    clD = True
  ElseIf mxH Then
    mxD = True
  ElseIf mnH Then
    mnD = True
  End If
  UpdateButtons
End Sub
Private Sub pCaptionButtons_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  clH = X > clRct.Left And X < clRct.Right And Y > clRct.Top And Y < clRct.Bottom
  If clH <> clHl Then UpdateButtons: clHl = clH: Exit Sub
  mxH = X > mxRct.Left And X < mxRct.Right And Y > mxRct.Top And Y < mxRct.Bottom And FMaxButton
  If mxH <> mxHl Then UpdateButtons: mxHl = mxH: Exit Sub
  mnH = X > mnRct.Left And X < mnRct.Right And Y > mnRct.Top And Y < mnRct.Bottom And FMinButton
  If mnH <> mnHl Then UpdateButtons: mnHl = mnH: Exit Sub
End Sub
Private Sub pCaptionButtons_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If clH Then
    SendMessage UserControl.Parent.hWnd, WM_SYSCOMMAND, SC_CLOSE, 0&
  ElseIf mxH Then
    If UserControl.Parent.WindowState = 0 Then
      SendMessage UserControl.Parent.hWnd, WM_SYSCOMMAND, SC_MAXIMIZE, 0&
    Else
      SendMessage UserControl.Parent.hWnd, WM_SYSCOMMAND, SC_RESTORE, 0&
    End If
  ElseIf mnH Then
    If UserControl.Parent.WindowState <> 1 Then
      SendMessage UserControl.Parent.hWnd, WM_SYSCOMMAND, SC_MINIMIZE, 0&
    Else
      SendMessage UserControl.Parent.hWnd, WM_SYSCOMMAND, SC_RESTORE, 0&
    End If
  End If
  clH = False: mxH = False: mnH = False
  clD = False: mxD = False: mnD = False
  UpdateButtons
End Sub
Private Sub pCaptionButtons_Resize()
  With pCaptionButtons
    clRct.Left = .ScaleWidth - 10 - 44: clRct.Top = 14
    clRct.Right = clRct.Left + 44: clRct.Bottom = clRct.Top + 18
    mxRct.Left = .ScaleWidth - 10 - 44 - 26: mxRct.Top = 14
    mxRct.Right = mxRct.Left + 26: mxRct.Bottom = mxRct.Top + 18
    mnRct.Left = .ScaleWidth - 10 - 44 - 26 - 26: mnRct.Top = 14
    mnRct.Right = mnRct.Left + 26: mnRct.Bottom = mnRct.Top + 18
  End With
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Dim lngReturnValue As Long
  If Button = 1 Then
    Call ReleaseCapture
    lngReturnValue = SendMessage(MainWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
  End If
End Sub
Private Sub UserControl_Paint()
    Debug.Print "sfsdfd"
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  If Ambient.UserMode Then
    Command1.Visible = False
    MainWnd = UserControl.Parent.hWnd
    
    Subclass_Start MainWnd
    Subclass_AddMsg MainWnd, WM_GETMINMAXINFO
    Subclass_AddMsg MainWnd, WM_SYSCOMMAND
    Subclass_AddMsg MainWnd, WM_MOVING
    Subclass_AddMsg MainWnd, WM_LBUTTONDOWN
    Subclass_AddMsg MainWnd, WM_SIZE
    Subclass_AddMsg MainWnd, WM_SHOWWINDOW
    Subclass_AddMsg MainWnd, WM_SETFOCUS
    Subclass_AddMsg MainWnd, MSM_NCACTIVATE
    Subclass_AddMsg MainWnd, WM_NCLBUTTONDOWN
    Subclass_AddMsg MainWnd, WM_PAINT
    Subclass_AddMsg MainWnd, WM_ACTIVATEAPP
    Subclass_AddMsg MainWnd, WM_CLOSE
    Subclass_AddMsg MainWnd, WM_DESTROY
    Subclass_AddMsg MainWnd, WM_KILLFOCUS
    Subclass_AddMsg MainWnd, WM_MOVE
  
    If Not TypeOf UserControl.Parent Is MDIForm Then
      FBorderStyle = UserControl.Parent.BorderStyle
      If FBorderStyle = 4 Then FBorderStyle = Fixed
      If FBorderStyle = 5 Then FBorderStyle = Sizable
      
      FMaxButton = UserControl.Parent.MaxButton
      FMinButton = UserControl.Parent.MinButton
    Else
      FBorderStyle = Sizable
      FMaxButton = True
      FMinButton = True
    End If
    pIcon.LoadPicture_StdPicture UserControl.Parent.Icon
    iFrame(0).LoadPicture_File App.Path & "ImagesWindowFrameTop.png"
    iFrame(1).LoadPicture_File App.Path & "ImagesWindowFrameBottom.png"
    iFrame(2).LoadPicture_File App.Path & "ImagesWindowFrameLeft.png"
    iFrame(3).LoadPicture_File App.Path & "ImagesWindowFrameRight.png"
    bCloseS(0).LoadPicture_File App.Path & "ImagesCloseButtonSingle.png"
    bCloseS(1).LoadPicture_File App.Path & "Imagesclose-s-glow.png"
    bClose(0).LoadPicture_File App.Path & "ImagesCloseButton.png"
    bClose(1).LoadPicture_File App.Path & "Imagesclose-glow.png"
    bMaxRes(0).LoadPicture_File App.Path & "ImagesMaxButton.png"
    bMaxRes(1).LoadPicture_File App.Path & "Imagesmax-glow.png"
    bMaxRes(2).LoadPicture_File App.Path & "ImagesResButton.png"
    bMin(0).LoadPicture_File App.Path & "ImagesMinButton.png"
    bMin(1).LoadPicture_File App.Path & "Imagesmin-glow.png"
    
'    RepaintWindow
  End If
End Sub
Private Sub UserControl_Resize()
  On Error Resume Next
  If Ambient.UserMode Then
    Picture1.Move LeftWidth, 0, ScaleWidth - 28 - 75 - 68, CaptionHeight
    cRect.Right = Picture1.ScaleWidth: cRect.Bottom = Picture1.ScaleHeight
    pCaptionButtons_Resize
  Else
    UserControl.Width = 48 * Screen.TwipsPerPixelX
    UserControl.Height = 48 * Screen.TwipsPerPixelY
    Command1.Move 0, 0, ScaleWidth, ScaleHeight
  End If
End Sub
Private Sub UserControl_Show()
  On Error Resume Next
  If Not TypeOf UserControl.Parent Is MDIForm Then UserControl.Parent.BackColor = RGB(240, 240, 240)
End Sub
Private Sub UserControl_Terminate()
  On Error Resume Next
  Subclass_StopAll
  Call GdiplusShutdown(Token)
  SelectObject mDC, oldBitmap
  DeleteObject mainBitmap
  DeleteObject oldBitmap
  DeleteDC mDC
End Sub
Private Sub GetWorkArea()
    SystemParametersInfo 48&, 0&, WorkArea, 0&
End Sub
'========================================================================================
' UserControl subclass procedure
'========================================================================================
Public Sub zSubclass_Proc(ByVal bBefore As Boolean, _
                          ByRef bHandled As Boolean, _
                          ByRef lReturn As Long, _
                          ByRef lhWnd As Long, _
                          ByRef uMsg As Long, _
                          ByRef wParam As Long, _
                          ByRef lParam As Long _
                          )
  On Error Resume Next
  Select Case lhWnd
  Case MainWnd
    Select Case uMsg
    Case WM_GETMINMAXINFO
        Dim MMI As MINMAXINFO, cy&, cx&
        cy = GetSystemMetrics(SM_CYCAPTION)
        cx = GetSystemMetrics(SM_CXFRAME)
        GetWorkArea
        CopyMemory MMI, ByVal lParam, LenB(MMI)
        'set the minmaxinfo data to the
        'minimum and maximum values set
        'by the option choice
        With MMI
            .ptMaxPosition.X = WorkArea.Left - cx + 8
            .ptMaxPosition.Y = WorkArea.Top - cy - cx + 24
            .ptMaxSize.X = (WorkArea.Right - WorkArea.Left) - .ptMaxPosition.X - cx '+ cX + cX - 16
            .ptMaxSize.Y = (WorkArea.Bottom - WorkArea.Top) - .ptMaxPosition.Y - cx '+ cX + cX - cY '- CaptionHeight
            .ptMinTrackSize.X = 200
            .ptMinTrackSize.Y = 100
        End With
        CopyMemory ByVal lParam, MMI, LenB(MMI)
    
    Case WM_NCLBUTTONDOWN
      Resize False, False, SWP_NOZORDER
    
    Case WM_SIZE
      Call Resize((uMsg = WM_SIZE), True, , True)
    
    Case WM_MOVING
      Call Resize((uMsg = WM_SIZE), True)
    
    Case WM_MOVE
      Call Resize((uMsg = WM_SIZE), True)
      
    Case WM_LBUTTONDOWN
      Call Resize((uMsg = WM_SIZE), False)
    
    Case WM_ACTIVATEAPP
      Select Case wParam
      Case WA_ACTIVE, WA_CLICKACTIVE
        FormActive = True
      Case WA_INACTIVE
        FormActive = False
      End Select
      Call Resize(True, False, , True)
      
    Case MSM_NCACTIVATE
      On Local Error Resume Next
      Select Case wParam
      Case WA_ACTIVE, WA_CLICKACTIVE
        FormActive = True
      Case WA_INACTIVE
        FormActive = False
      End Select
      Call Resize(True, False, , True)
    
    Case WM_SETFOCUS
      FormActive = True
      Call Resize(True, False, , False)
    
    Case WM_SHOWWINDOW
      Dim curWinLong As Long
      'Border
      curWinLong = GetWindowLong(UserControl.hWnd, GWL_EXSTYLE)
      curWinLong = curWinLong Or WS_EX_TOOLWINDOW
      SetWindowLong UserControl.hWnd, GWL_EXSTYLE, curWinLong
      Call SetParent(UserControl.hWnd, GetParent(MainWnd))
      curWinLong = GetWindowLong(UserControl.hWnd, GWL_EXSTYLE)
      curWinLong = curWinLong Or WS_EX_LAYERED
      SetWindowLong UserControl.hWnd, GWL_EXSTYLE, curWinLong
      
      'Caption Buttons
      curWinLong = GetWindowLong(pCaptionButtons.hWnd, GWL_EXSTYLE)
      curWinLong = curWinLong Or WS_EX_TOOLWINDOW
      SetWindowLong pCaptionButtons.hWnd, GWL_EXSTYLE, curWinLong
      Call SetParent(pCaptionButtons.hWnd, GetParent(MainWnd))
      curWinLong = GetWindowLong(pCaptionButtons.hWnd, GWL_EXSTYLE)
      curWinLong = curWinLong Or WS_EX_LAYERED
      SetWindowLong pCaptionButtons.hWnd, GWL_EXSTYLE, curWinLong
      Call Resize(True, True, , True)
    
    Case WM_CLOSE
    
    Case WM_DESTROY
    
    End Select
  End Select
End Sub
Public Sub Resize(SetWndRect As Boolean, SetPosition As Boolean, Optional lFlag As Long = SWP_FRAMECHANGED, Optional bRepaint As Boolean)
  Dim cy, lStyle, cx
  On Error Resume Next
  
  cy = GetSystemMetrics(SM_CYCAPTION)
  cx = GetSystemMetrics(SM_CXFRAME)
      
  GetWindowRect MainWnd, MainRect
  If SetWndRect = True Then
    Dim lRet As Long
    Dim GRET As Long
    
    ' form g鰎黱黰

						