Transparan ve Değişik Şekilli Formlar

Option Explicit

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 Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'// Used to let the user move the form
Private Declare Function ReleaseCapture Lib "user32" () 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 Const RGN_OR = 2 '// add the region to the existing area
Private Const RGN_XOR = 3 '// remove the region from the existing area (ie
'// make a hole!
Private Const WM_NCLBUTTONDOWN = &HA1

Private Sub cmdOK_Click()
Unload Me
End Sub

Private Sub Form_Load()
pCreateSkin
cboCombo.ListIndex = 0
Show
End Sub


'// allow the user to move the form
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture
SendMessage hWnd, WM_NCLBUTTONDOWN, 2, 0&
End Sub
Private Sub lblLabel_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call Form_MouseDown(-1, -1, -1, -1)
End Sub
'// When the mouse button is pressed over the minimize button it changes to a "pressed" image.
Private Sub Min_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> vbLeftButton Then Exit Sub
TempHolder.Picture = Min.Picture '// Remember the original picture
Min.Picture = MinHolder.Picture '// Display the pressed picture, held in MinHolder imagebox
End Sub
'// When the mouse button is released, put the button back up, and perform the action.
Private Sub Min_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> vbLeftButton Then Exit Sub
Min.Picture = TempHolder.Picture '// Put the picture back the way it was (remembered)
End Sub
Private Sub Min_Click()
If Min.Picture = TempHolder.Picture Then WindowState = 1 'Minimize the form
End Sub
'// Same here for the close button. See Min_MouseDown proc. for details
Private Sub CloseB_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> vbLeftButton Then Exit Sub
TempHolder.Picture = CloseB.Picture
CloseB.Picture = CloseHolder.Picture
End Sub
Private Sub CloseB_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> vbLeftButton Then Exit Sub
CloseB.Picture = TempHolder.Picture
End Sub
Private Sub CloseB_Click()
If CloseB.Picture = TempHolder.Picture Then Unload Me 'Exit the form when close is clicked
End Sub

Private Sub pCreateSkin()
Dim lRgnTmp As Long
Dim lSkinRgn As Long
Dim lWidth As Long
Dim lHeight As Long

Left = (Screen.Width / 2) - (ScaleWidth / 2)
Top = (Screen.Height / 2) - (ScaleHeight / 2)
lWidth = (ScaleWidth) / Screen.TwipsPerPixelX
lHeight = (ScaleHeight) / Screen.TwipsPerPixelY

'// CreateRoundRectRgn creates a rectangle
'// with rounded edges
'// X1 and Y1 specify the top left hand corner
'// X2 and Y2 specify the bottom right hand corner
'// X3 and Y3 specify how big the rounded edges are
lSkinRgn = CreateRectRgn(lWidth - 32, 0, lWidth, 14)
'lSkinRgn = CreateRoundRectRgn(lWidth - 50, 0, lWidth, 25, 100, 100)

'// CreateRoundRectRgn creates a rectangle
'// with rounded edges
lRgnTmp = CreateRoundRectRgn(0, 0, 110, 100, 10, 10)
'// combine with existing region
CombineRgn lSkinRgn, lSkinRgn, lRgnTmp, RGN_OR
'// create a circle
'// X1 and Y1 specify the top left hand corner
'// X2 and Y2 specify the bottom right hand corner
lRgnTmp = CreateEllipticRgn(180, 100, 300, 400)
'// combine with existing region
CombineRgn lSkinRgn, lSkinRgn, lRgnTmp, RGN_OR

'// tidy up
Call DeleteObject(lRgnTmp)
'// set the window region, using the skin we have created
Call SetWindowRgn(hWnd, lSkinRgn, True)
End Sub


Login olmuş kullanıcı adının Getirilmesi
Private Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long

Public Function UserName() As String
Dim llReturn As Long
Dim lsUserName As String
Dim lsBuffer As String

lsUserName = ""
lsBuffer = Space$(255)
llReturn = GetUserName(lsBuffer, 255)

If llReturn Then
lsUserName = Left$(lsBuffer, InStr(lsBuffer, Chr(0)) - 1)
End If

UserName = lsUserName
End Function