Şeffaf UserForm Oluşturma

Şeffaf UserForm Oluşturma

Şeffaf UserForm Oluşturma isimli içerikte, ilgili işlemin VBA kodları ile nasıl yapacağınızı öğreten bir Hazır Makro Kodu yer almaktadır.

[*]Araç çubuklarından Insert -> UserForm yazısına tıklayın.[*]Alt kısma eklenecek gelecek olan UserForm yazısına çift tıklayın.

Hazır Kod​

VBA:
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 Sub

Açıklama​

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.

Faydalanılması temennisiyle
 
Benzer Konular Popüler İçerikler Daha Fazlası
Geri
Üst