آيا راهي هست كه فرم شكل يه شكل خاص در بيايد

[mohsen_iceman2000]

سلام
آيا راهي هست كه فرم شبيه يك عكس باشه مثل عكس هايي كه transparent داشته باشن

[امین مستانی]

سلام
شاید این بدردت بخوره

[بهروز عباسی]

دوست عزیز اینم یک کلاس دستو پا شکسته در این مورد
Rem programmer : behrooz abbasi
Rem WWW.ProGrammIng-Co.CoM

Option Explicit
'-=-=-=-=- API Skin -=-=-=-=-=-=
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y 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 CreateRectRgn 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'-=-=-=-=- API XP Skin -=-=-=-=-=-=
Private Declare Function InitCommonControls Lib "Comctl32.dll" () As Long
'-=-=-=-=- API Alpha Mode -=-=-=-=-=-=
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'-=-=-=-=- API FormDrag -=-=-=-=-=-=
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 ReleaseCapture Lib "user32" () As Long
'-=-=-=-=- API ONTop -=-=-=-=-=-=
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
'-=-=-=-=- CONST Alpha Mode -=-=-=-=-=-=
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
'-=-=-=-=- CONST Alpha Mode -=-=-=-=-=-=
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const WS_EX_LAYERED = &H80000
'-=-=-=-=- CONST Skin -=-=-=-=-=-=
Private Const RGN_OR = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Function MakeRegion(Picskin As PictureBox) As Long
Dim X As Long, Y As Long, StartLineX As Long
Dim FullRegion As Long, LineRegion As Long
Dim TransparentColor As Long
Dim InFirstRegion As Boolean
Dim InLine As Boolean
Dim hdc As Long
Dim PicWidth As Long
Dim PicHeight As Long
hdc = Picskin.hdc
PicWidth = Picskin.ScaleWidth
PicHeight = Picskin.ScaleHeight
InFirstRegion = True: InLine = False
X = Y = StartLineX = 0
TransparentColor = GetPixel(hdc, 0, 0)
For Y = 0 To PicHeight - 1
For X = 0 To PicWidth - 1
If GetPixel(hdc, X, Y) = TransparentColor Or X = PicWidth Then
If InLine Then
InLine = False
LineRegion = CreateRectRgn(StartLineX, Y, X, Y + 1)
If InFirstRegion Then
FullRegion = LineRegion
InFirstRegion = False
Else
CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
DeleteObject LineRegion
End If
End If
Else
If Not InLine Then
InLine = True
StartLineX = X
End If
End If
Next
Next
MakeRegion = FullRegion
End Function
Public Sub apply_Skin(picSource As PictureBox, frmName As Form)
Dim WindowRegion As Long
picSource.ScaleMode = vbPixels
picSource.AutoRedraw = True
picSource.AutoSize = True
picSource.BorderStyle = vbBSNone

frmName.BorderStyle = vbBSNone
Set picSource.Picture = picSource.Picture
frmName.Width = picSource.Width
frmName.Height = picSource.Height

WindowRegion = MakeRegion(picSource)
SetWindowRgn frmName.hWnd, WindowRegion, True
End Sub

Public Sub XPSkin()
Dim lngRet As Long
lngRet = InitCommonControls
End Sub
Public Sub FormDrag(ByVal hWnd As Long)
ReleaseCapture
Call SendMessage(hWnd, &HA1, 2, 0&)
End Sub
Public Function AlphaMode(ByVal hWnd As Long, bytValue As Byte) As Long
Dim lngRet As Long
Dim Trans As Long
On Error Resume Next

If bytValue < 0 Or bytValue > 255 Then
Trans = 1
Else
lngRet = GetWindowLong(hWnd, GWL_EXSTYLE)
lngRet = lngRet Or WS_EX_LAYERED
SetWindowLong hWnd, GWL_EXSTYLE, lngRet
SetLayeredWindowAttributes hWnd, 0, bytValue, LWA_ALPHA
Trans = 0

End If
If Err Then
Trans = 2
End If
End Function

Public Sub OnTop(ByVal hWnd As Long, blnOnTop As Boolean)
Dim lngFlags As Long
Dim lngPlacement As Long
lngFlags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW Or SWP_NOACTIVATE
Select Case blnOnTop
Case True
lngPlacement = HWND_TOPMOST
Case False
lngPlacement = HWND_NOTOPMOST
End Select
SetWindowPos hWnd, lngPlacement, 0, 0, 0, 0, lngFlags
End Sub

[بهروز عباسی]

قبلا یه نمونه گذاشته بودم ایــــــــــــنم (http://barnamenevis.org/showthread.php?332093-%D9%81%D8%B1%D9%85-%D8%A8%D8%B1%D9%86%D8%A7%D9%85%D9%87-%D8%B1%D9%88-%D8%A8%D9%87-%D8%B4%DA%A9%D9%84-%DB%8C%DA%A9-%D8%B9%DA%A9%D8%B3-%D8%AF%D8%B1-%D8%A8%DB%8C%D8%A7%D8%B1%DB%8C%D8%AF.)ببین