🚀 go-pugleaf

Użytkownik "MaciejF"  napisał w wiadomości grup 
dyskusyjnych:0e2b6492-921d-45e6-af54-429a8bcbfb86@googlegroups.com...

Witam
Zbigniew byłbym zainteresowany.
Może będzie od Ciebie coś zgrabniejszego...

[...]

Sprawdź, czy poniższy przykład jest zgrabniejszy ;-)

Option Compare Database
Option Explicit

#If VBA7 Then
  Private Declare PtrSafe Function SystemParametersInfo Lib "user32" _
          Alias "SystemParametersInfoA" _
          (ByVal uAction As Long, _
          ByVal uParam As Long, _
          ByRef lpvParam As Any, _
          ByVal fuWinIni As Long) As Long

  Private Declare PtrSafe Function GetWindowRect Lib "user32" _
          (ByVal hwnd As LongPtr, _
          lpRect As RECT) As Long

  Private Declare PtrSafe Function SetWindowPos Lib "user32" _
          (ByVal hwnd As LongPtr, _
          ByVal hWndInsertAfter As LongPtr, _
          ByVal x As Long, _
          ByVal y As Long, _
          ByVal cx As Long, _
          ByVal cy As Long, _
          ByVal wFlags As Long) As Long

  Private Declare PtrSafe Function GetParent Lib "user32" _
          (ByVal hwnd As LongPtr) As LongPtr
#Else
    Private Declare Function SystemParametersInfo Lib "user32" _
          Alias "SystemParametersInfoA" _
          (ByVal uAction As Long, _
          ByVal uParam As Long, _
          ByRef lpvParam As Any, _
          ByVal fuWinIni As Long) As Long

  Private Declare Function GetWindowRect Lib "user32" _
          (ByVal hwnd As Long, _
          lpRect As RECT) As Long

  Private Declare Function SetWindowPos Lib "user32" _
          (ByVal hwnd As Long, _
          ByVal hWndInsertAfter As Long, _
          ByVal x As Long, _
          ByVal y As Long, _
          ByVal cx As Long, _
          ByVal cy As Long, _
          ByVal wFlags As Long) As Long
#End If

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type POINTAPI
        x As Long
        y As Long
End Type

' SystemParametersInfo
Private Const SPI_GETWORKAREA = 48
' SetWindowPos
Private Const HWND_TOP = 0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOMOVE = &H2
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80

' Chowa okno MS Access i ustawia formularz typu PopUp (podręczny)
' w narożnikach dostępnego obszaru pulpitu lub centralnie.
' lPos - dla wartości od 1 do 4 ustawia formularz kolejno w narożniku:
' 1 - lewy górny, 2 - prawy górny, 3 - prawy dolny, 4 - lewy dolny,
' dla innych wartości centruje formularz
'______________________________________
Private Sub MovePopUpForm(lPos As Long)

#If VBA7 Then
  Dim hWind   As LongPtr
#Else
  Dim hWind   As Long
#End If

Dim lRet      As Long
Dim x         As Long
Dim y         As Long
Dim rctFrm    As RECT
Dim rctScreen As RECT

  If Me.PopUp = False Then
    MsgBox "Niestety, przykład dotyczy formularza PopUp !" & vbNewLine & _
           "Na stronie: www.faq.accdb.pl/11a_VbaWinFrmFaq.htm#vba11a_05" & 
vbNewLine & _
           "znajduje się przykład:" & vbNewLine & vbNewLine & _
           "Jak ustawić formularz w/m wolnej dostępnej przestrzeni w oknie 
Accessa"
    Exit Sub
  End If

  ' ukryj okno MS Access nie zmieniając jego rozmiaru i położenia
  lRet = SetWindowPos( _
                Application.hWndAccessApp, _
                0&, 0&, 0&, 0&, 0&, _
                SWP_NOZORDER Or SWP_NOSIZE Or _
                SWP_NOMOVE Or SWP_HIDEWINDOW)

  ' pobierz dostępny obszar pulpitu
  lRet = SystemParametersInfo(SPI_GETWORKAREA, vbNull, rctScreen, 0&)

  ' pobierz rozmiar i położenie okna formularza
  lRet = GetWindowRect(Me.hwnd, rctFrm)

    Select Case lPos
      Case 1  'lewy górny róg
          x = rctScreen.Left
          y = rctScreen.Top
      Case 2  ' prawy górny róg
          x = (rctScreen.Right - rctScreen.Left) - (rctFrm.Right - 
rctFrm.Left)
          y = rctScreen.Top
      Case 3  'prawy dolny róg
          x = (rctScreen.Right - rctScreen.Left) - (rctFrm.Right - 
rctFrm.Left)
          y = (rctScreen.Bottom - rctScreen.Top) - (rctFrm.Bottom - 
rctFrm.Top)
      Case 4   ' lewy dolny róg
          x = rctScreen.Left
          y = rctScreen.Bottom - (rctFrm.Bottom - rctFrm.Top)
      Case Else ' centralnie
          x = (rctScreen.Right - rctScreen.Left) / 2 - (rctFrm.Right - 
rctFrm.Left) / 2
          y = (rctScreen.Bottom - rctScreen.Top) / 2 - (rctFrm.Bottom - 
rctFrm.Top) / 2
    End Select

    ' przesuń formularz
    lRet = SetWindowPos(Me.hwnd, HWND_TOP, x, y, 0&, 0&, SWP_NOSIZE)

End Sub

'_____________________
Private Sub ShowAccess()
    ' odkryj okno MS Access w poprzednim miejscu i rozmiarze
    SetWindowPos Application.hWndAccessApp, _
                HWND_TOP, _
                0&, 0&, 0&, 0&, _
                SWP_NOZORDER Or SWP_NOSIZE Or _
                SWP_NOMOVE Or SWP_SHOWWINDOW

End Sub

'____________________
Private Sub Form_Load()
  Me.TimerInterval = 300
  ' niestety w Access 2007 nie za bardzo działa. Znika wszystko
  ' Call MovePopUpForm(2)
End Sub

'_____________________
Private Sub Form_Timer()
  Me.TimerInterval = 0
  Call MovePopUpForm(2)
End Sub

'______________________________________
Private Sub Form_Unload(Cancel As Integer)
  Call ShowAccess
End Sub

Formularz musi mieć ustawioną właściwość  "Podręczny" = TRUE (PopUp),
ale nic nie stoi na przeszkodzie by mu dołożyć właściwość Modal.
Będzie wtedy zawsze na wierzchu.

U mnie działa na Win 7 64bit i Acc2010-64bit  oraz  Acc2007-32bit.

-- 
Pozdrowienia
BraZby
www.faq.accdb.pl/
www.acc97.accdb.pl/