Office中国论坛/Access中国论坛

标题: 【求助】无边框窗体拉伸 [打印本页]

作者: like5188 时间: 2009-12-30 11:49
标题: 【求助】无边框窗体拉伸
在网上找了下面的代码，在VB中能成功拉伸窗体，请求高手指点怎么把它用在access中来！！！！！急

Option Explicit

  Private Const WM_NCLBUTTONDOWN = &HA1
  Private Const HTLEFT = 10
  Private Const HTRIGHT = 11
  Private Const HTTOP = 12
  Private Const HTBOTTOM = 15
  Private Const HTBOTTOMRIGHT = 17
  Private Const HTBOTTOMLEFT = 16
  Private Const HTTOPLEFT = 13
  Private Const HTTOPRIGHT = 14

  'sendmessage函数声明
  Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  Private Declare Function ReleaseCapture Lib "user32" () As Long
  Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long

  Private intEdge As Integer    '临界距离，鼠标在离边框距离小于等于该值则判定在边框上……

  Private Sub Form_Load()
      '相当于三个象素
      intEdge = Me.ScaleX(3, vbPixels, Me.ScaleMode)
  End Sub

  Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
      'Critical:将处理四角的代码放在前面
      If X + intEdge >= ScaleWidth And Y + intEdge >= ScaleHeight Then          '右下角
            ReleaseCapture
            SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0
      ElseIf Y + intEdge >= ScaleHeight And X <= intEdge Then                   '左下角
            ReleaseCapture
            SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOMLEFT, 0
      ElseIf Y <= intEdge And X <= intEdge Then                                        '左上角
            ReleaseCapture
            SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOPLEFT, 0
      ElseIf Y <= intEdge And X + intEdge <= ScaleWidth Then                      '右上边
            ReleaseCapture
            SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOPRIGHT, 0
      ElseIf X + intEdge >= ScaleWidth And Y <= ScaleHeight Then          '右边
            ReleaseCapture
            SendMessage hwnd, WM_NCLBUTTONDOWN, HTRIGHT, 0
      ElseIf Y + intEdge >= ScaleHeight And X <= ScaleWidth Then             '下边
            ReleaseCapture
            SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOM, 0
      ElseIf X <= intEdge And Y <= ScaleHeight Then                            '左边
            ReleaseCapture
            SendMessage hwnd, WM_NCLBUTTONDOWN, HTLEFT, 0
      ElseIf Y <= intEdge And X <= ScaleWidth Then                               '上边
            ReleaseCapture
            SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOP, 0
      End If
  End Sub

  Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
      'Critical:将处理四角的代码放在前面
      If (X + intEdge >= ScaleWidth And Y + intEdge >= ScaleHeight) Or (Y <= intEdge And X <= intEdge) Then                      '右下\左上角
            MousePointer = vbSizeNWSE
      ElseIf Y + intEdge >= ScaleHeight And X <= intEdge Or Y <= intEdge And X + intEdge <= ScaleWidth Then                      '左下\右上角
            MousePointer = vbSizeNESW
      ElseIf X + intEdge >= ScaleWidth And Y <= ScaleHeight Or X <= intEdge And Y <= ScaleHeight Then    '左、右
            MousePointer = vbSizeWE
      ElseIf Y + intEdge >= ScaleHeight And X <= ScaleWidth Or Y <= intEdge And X <= ScaleWidth Then       '上边下边
            MousePointer = vbSizeNS
      Else
            MousePointer = vbNormal
      End If
  End Sub

  Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
      SetCapture hwnd
  End Sub

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)