Snippet

Vlastní přesouvání a změna velikosti formuláře

Přidáno: 18.6.2009 Kategorie: Aplikace Autor: Ondřej Linhart

Při použití stylu formuláře FormBorderStyle.None (využívá se pro vlastní vykreslování) přestane fungovat výchozí přesouvání a změna velikosti (přesouvání tažením za titulkový pruh, změna velikosti tažením za okraje). Tato funkčnost se dá jednoduše suplovat níže uvedeným ukázkovým kódem. Kód simuluje vlastní titulkový pruh pro přesouvání, ale patřičnou úpravou kódu lze přesouvat tažením kdekoliv v klientské oblasti formuláře. Pro spuštění ukázky vytvořte nový projekt typu Windows Forms Application a kód vložte do výchozího formuláře.

Public Class Form1
  'Definice konstant Windows API
  Private Const HTCAPTION As Integer = 2
  Private Const HTLEFT As Integer = 10
  Private Const HTRIGHT As Integer = 11
  Private Const HTTOP As Integer = 12
  Private Const HTTOPLEFT As Integer = 13
  Private Const HTTOPRIGHT As Integer = 14
  Private Const HTBOTTOM As Integer = 15
  Private Const HTBOTTOMLEFT As Integer = 16
  Private Const HTBOTTOMRIGHT As Integer = 17
  Private Const WM_NCHITTEST As Integer = &H84
  Private Const WM_NCLBUTTONDOWN As Integer = &HA1
  'Určuje, jak daleko od okraje formuláře se má zahájit změna velikosti
  Private Const resizeBorder As Integer = 5
  Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
    'Vlastní ošetření přesouvání a změny velikosti formuláře
    'pomocí odeslání Windows zprávy.
    If m.Msg = WM_NCHITTEST Then
      Dim pt As New Point(m.LParam.ToInt32)
      pt = Me.PointToClient(pt)
      If pt.X < resizeBorder AndAlso pt.Y < resizeBorder Then
        m.Result = New IntPtr(HTTOPLEFT)
      ElseIf pt.X > (Me.Width - resizeBorder) AndAlso pt.Y < resizeBorder Then
        m.Result = New IntPtr(HTTOPRIGHT)
      ElseIf pt.Y < resizeBorder Then
        m.Result = New IntPtr(HTTOP)
      ElseIf pt.X < resizeBorder AndAlso pt.Y > (Me.Height - resizeBorder) Then
        m.Result = New IntPtr(HTBOTTOMLEFT)
      ElseIf pt.X > (Me.Width - resizeBorder) AndAlso pt.Y > (Me.Height - resizeBorder) Then
        m.Result = New IntPtr(HTBOTTOMRIGHT)
      ElseIf pt.Y > (Me.Height - resizeBorder) Then
        m.Result = New IntPtr(HTBOTTOM)
      ElseIf pt.X < resizeBorder Then
        m.Result = New IntPtr(HTLEFT)
      ElseIf pt.X > (Me.Width - resizeBorder) Then
        m.Result = New IntPtr(HTRIGHT)
      Else
        MyBase.WndProc(m)
      End If
    Else
      MyBase.WndProc(m)
    End If
  End Sub
  Private Sub Form1_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs) Handles Me.MouseDown
    'Přesouvání pouze pomocí vlastního titulkového pruhu.
    'Pokud chcete formulář přesouvat tažením kdekoliv v klientské
    'oblasti formuláře, odstraňte podmínku.
    If e.Y <= 32 Then
      Me.Capture = False
      WndProc(Message.Create(Me.Handle, WM_NCLBUTTONDOWN, IntPtr.op_Explicit(HTCAPTION), IntPtr.Zero))
    End If
  End Sub
  Private Sub Form1_Paint(ByVal sender As Object, ByVal e As PaintEventArgs) Handles Me.Paint
    'Vykreslování vlastního titulkového pruhu (vysokého 32 pixelů).
    e.Graphics.FillRectangle(Brushes.Black, 0, 0, Me.Width, 32)
  End Sub
End Class