userform her zaman en önde çalışsın

[zulfuernek]

örneğin bilgisayarda farklı bir programda çalışsam dahi userform ne olursa olsun her zaman en önde kalsın ve userformu hep ekranda görebileyim.

 

[Asri]

Aşağıdaki kodu userform un kod bölümüne ekleyiniz.

Option Explicit
 'API function to enable/disable the Excel Window
Private Declare Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Private Declare Function EnableWindow Lib "user32" _
(ByVal hwnd As Long, ByVal bEnable As Long) 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
 
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const FLAGS As Long = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private mlHWnd As Long
Private mbDragDrop As Boolean
Private FormHWnd As Long
 
Private Sub cmdNotTop_Click()
    SetWindowPos FormHWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS
End Sub
 
Private Sub cmdTop_Click()
    SetWindowPos FormHWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
End Sub
 
Private Sub UserForm_Activate()
    On Error Resume Next
     'Find the Excel main window
    mlHWnd = FindWindowA("XLMAIN", Application.Caption)
    FormHWnd = FindWindowA(vbNullString, Me.Caption)
    Call cmdTop_Click
     'Enable the Window - makes the userform modeless
    EnableWindow mlHWnd, 1
    mbDragDrop = Application.CellDragAndDrop
    Application.CellDragAndDrop = False
End Sub
 
Private Sub btnOK_Click()
    Application.CellDragAndDrop = mbDragDrop
    Call cmdNotTop_Click
    Unload Me
End Sub

 

[zulfuernek]

asri hocam on numarasın ) emeğine bilgine sağlık. çok işime yarayacak bir kod çünkü bu. ne kadar teşekkür etsem azdır. sağol varol. ))

 

[Asri]

asri hocam on numarasın ) emeğine bilgine sağlık. çok işime yarayacak bir kod çünkü bu. ne kadar teşekkür etsem azdır. sağol varol. ))

Sorunlara çözüm bulmak güzel.
Hep beraber öğreniyoruz

 

[halit3]

Alternatif kod

#If Win64 Then
Private Declare PtrSafe Sub 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)
Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
Private Declare Sub 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)
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
#If VBA7 Then
#Else
#End If


Private Sub CommandButton1_Click()
Dim hWnd As Long
hWnd = FindWindow(vbNullString, Me.Caption)
SetWindowPos hWnd, -2, 0, 0, 0, 0, &H10 _
Or &H40 Or &H2 Or &H1
End Sub

Private Sub CommandButton2_Click()
Dim hWnd As Long
hWnd = FindWindow(vbNullString, Me.Caption)
SetWindowPos hWnd, -1, 0, 0, 0, 0, &H10 _
Or &H40 Or &H2 Or &H1
End Sub


Private Sub UserForm_Activate()
CommandButton2_Click
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.Visible = True 'exceli gizler ve programı açar
End Sub

 

[Seyit Tiken]

Arkadaşlar Excel-2010 kullanıyorum, Userform'un kod bölümüne kopyaladığım kodların üst satırları KIRMIZI oldu, bunu nasıl düzeltebiliriz?, teşekkür ediyorum, Allah razı olsun.

 

[Haluk]

Seyit Bey, yukarıda Halit Beyin verdiği kodları kullandınız mı?

 

[Seyit Tiken]

Seyit Bey, yukarıda Halit Beyin verdiği kodları kullandınız mı?

Haluk bey, oda KIRMIZI oluyor. Halit beyin ikinci üç satırı KIRMIZI oluyor, teşekkür ediyorum...

 

[halit3]

Haluk bey, oda KIRMIZI oluyor. Halit beyin ikinci üç satırı KIRMIZI oluyor, teşekkür ediyorum...

birde bunu dene yinede çalışmaz ise kırmızı bölümdeki (Long) değerlerini (LongPtr) böyle yap

#If Win64 Then

[COLOR="Red"]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 FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr[/COLOR]
#Else
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
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If



Private Sub CommandButton1_Click()
Dim hwnd As Long
hwnd = FindWindow(vbNullString, Me.Caption)
SetWindowPos hwnd, -2, 0, 0, 0, 0, &H10 _
Or &H40 Or &H2 Or &H1
End Sub

Private Sub CommandButton2_Click()
Dim hwnd As Long
hwnd = FindWindow(vbNullString, Me.Caption)
SetWindowPos hwnd, -1, 0, 0, 0, 0, &H10 _
Or &H40 Or &H2 Or &H1
End Sub


Private Sub UserForm_Activate()
CommandButton2_Click
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.Visible = True 'exceli gizler ve programı açar
End Sub

Ayrıca aşağıdaki linkleride irdele

https://social.msdn.microsoft.com/F...m-without-titlebar-and-borders?forum=exceldev

http://www.jkp-ads.com/articles/apideclarations.asp

 

[zulfuernek]

halit hocam emeğinize sağlık. kodlar için teşekkür ederim

 

[Seyit Tiken]

Halit bey teşekkür ediyorum, sonuç almış değiliz.

Not : Bilgisayar KURUM bilgisayarıdır, ondan olabilir mi?