Şeffaf UserForm Oluşturma Kodu
26 Aralık 2020
27 Aralık 2020
1194
Şeffaf UserForm Oluşturma Kodu isimli makro kodlarını kullanarak, bir UserForm nesnesinin şeffaf olarak açılamasını sağlayabilirsiniz.
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" ( _
ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, _
ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, _
ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, _
ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private frmRegion As Long, hWnd As Long, msg1 As String, msg2 As String
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
seffaf
End Sub
Private Sub seffaf()
Dim W As Single, H As Single, cl As Long
Dim ct As Long, cw As Long, ch As Long
Dim i As Integer, R As Long, Outer As Long, Inner As Long
' 1 pixel = 0.75 point / 1 point = 1.33 pixel
hWnd = FindWindow(vbNullString, Me.Caption)
W = Me.Width * 1.33: H = Me.Height * 1.33
frmRegion = CreateRectRgn(0, 0, 0, 0)
' X = (W - ScaleWidth) / 2 -> Genelde 3
' Y = H - X - ScaleHeight -> Genelde 22
Const X As Single = 3: Const Y As Single = 22
Const RGN_OR = 2
Const RGN_DIFF = 4
Outer = CreateRectRgn(0, 0, W, H)
Inner = CreateRectRgn(X, Y, W - X, H - X)
CombineRgn frmRegion, Outer, Inner, RGN_DIFF
For i = 0 To Me.Controls.Count - 1
If Me.Controls(i).Visible Then
ct = Y + (1.33 * Me.Controls(i).Top)
ch = ct + (1.33 * Me.Controls(i).Height)
cl = X + (1.33 * Me.Controls(i).Left)
cw = cl + (1.33 * Me.Controls(i).Width)
R = CreateRectRgn(cl, ct, cw, ch)
CombineRgn frmRegion, R, frmRegion, RGN_OR
End If
Next
SetWindowRgn hWnd, frmRegion, True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
SetWindowRgn hWnd, 0, False
DeleteObject frmRegion
End SubGerekli Adımlar
Kodu çalıştırmanız için aşağıdaki adımları yerine getirmeniz gerekir.
- Microsoft Visual Basic for Applications penceresini (Alt + F11) açın.
- Project - VBAProject alanının, ekranın sol tarafında görüldüğünden emin olun. Görünmüyorsa, Ctrl + R kısayolu ile hızlıca açın.
- Araç çubuklarından Insert -> UserForm yazısına tıklayın.
- Solunda klasör simgesi olan Forms yazısının başındaki + simgesine tıklayın.
- Alt kısma eklenecek olan UserForm(1) yazısına çift tıklayın.
- Üstteki kodu yapıştırın.
Kod Açıklaması
Kodlar sadece UserForm'un şeffa olarak açılmasını sağlayıp, üzerine eklenmiş diğer nesneleri şeffaflaştırmaz. 64 bit sürümlerde hata verebilir.
Etiketler :
| YARARLI KISAYOLLAR | |
|---|---|
| Kopyala Kısayolu | Ctrl C |
| Veri Aralığının En Altına Gitme | Ctrl ↓ |
| Aktif Sayfayı Kapatma | Ctrl F4 |
| Veri Aralığının En Soluna Gitme | Ctrl ← |
| Değiştir Penceresini Açma | Ctrl H |