*** درخواست ضروری ***

سلام :

من کد یه همچین فرمی رو میخوام :

[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

لطف میکنید اگه کدش رو برام بزارید. فقط زود فوری هستش .

با تشکر (Bvk)
:5:

بیا بلا می سر!
اول این رو بریز توی یه ماژول:

کد:

---

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Private Declare Function CreateRoundRectRgn Lib "gdi32" _
    (ByVal RectX1 As Long, ByVal RectY1 As Long, ByVal RectX2 As Long, _
    ByVal RectY2 As Long, ByVal EllipseWidth As Long, _
    ByVal EllipseHeight As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal HWND As Long, _
ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Public Declare Sub ReleaseCapture Lib "user32" ()
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

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 HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2



Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE



Public Sub Make_On_Top(ByVal HWND As Long, Optional OnTop As Boolean = True)
   
On Error GoTo Err_Handler
   
    Dim r As Long
   
    If OnTop = True Then
        r = SetWindowPos(HWND, HWND_TOPMOST, _
            0&, 0&, 0&, 0&, TOPMOST_FLAGS)
    Else
        r = SetWindowPos(HWND, HWND_NOTOPMOST, _
            0&, 0&, 0&, 0&, TOPMOST_FLAGS)
    End If

Exit_Sub:
    Exit Sub

Err_Handler:
    Resume Exit_Sub

End Sub


Public Sub Round_Corners(ByRef FRM As Form)
    FRM.ScaleMode = vbPixels
    mlWidth = FRM.ScaleWidth
    mlHeight = FRM.ScaleHeight
   
   
    SetWindowRgn FRM.HWND, CreateRoundRectRgn(1, 1, _
                (FRM.Width / Screen.TwipsPerPixelX), (FRM.Height / Screen.TwipsPerPixelY), _
              60, 60), _
                True
    FRM.ScaleMode = vbTwips
End Sub

---

حالا این رو بریز توی فرم:

کد:

---

Private Sub Form_Load()
    Module1.Round_Corners Me
    Module1.Make_On_Top Me.HWND, True
End Sub

---

حله!
اگر هم خواستی که فرم قشنگتر بشه حاشیه فرم رو بردار....

نقل قول:

---

نوشته شده توسط Dark.Lord [ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

بیا بلا می سر!
اول این رو بریز توی یه ماژول:

کد:

---

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Private Declare Function CreateRoundRectRgn Lib "gdi32" _
    (ByVal RectX1 As Long, ByVal RectY1 As Long, ByVal RectX2 As Long, _
    ByVal RectY2 As Long, ByVal EllipseWidth As Long, _
    ByVal EllipseHeight As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal HWND As Long, _
ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Public Declare Sub ReleaseCapture Lib "user32" ()
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

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 HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2



Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE



Public Sub Make_On_Top(ByVal HWND As Long, Optional OnTop As Boolean = True)
   
On Error GoTo Err_Handler
   
    Dim r As Long
   
    If OnTop = True Then
        r = SetWindowPos(HWND, HWND_TOPMOST, _
            0&, 0&, 0&, 0&, TOPMOST_FLAGS)
    Else
        r = SetWindowPos(HWND, HWND_NOTOPMOST, _
            0&, 0&, 0&, 0&, TOPMOST_FLAGS)
    End If

Exit_Sub:
    Exit Sub

Err_Handler:
    Resume Exit_Sub

End Sub


Public Sub Round_Corners(ByRef FRM As Form)
    FRM.ScaleMode = vbPixels
    mlWidth = FRM.ScaleWidth
    mlHeight = FRM.ScaleHeight
   
   
    SetWindowRgn FRM.HWND, CreateRoundRectRgn(1, 1, _
                (FRM.Width / Screen.TwipsPerPixelX), (FRM.Height / Screen.TwipsPerPixelY), _
              60, 60), _
                True
    FRM.ScaleMode = vbTwips
End Sub

---

حالا این رو بریز توی فرم:

کد:

---

Private Sub Form_Load()
    Module1.Round_Corners Me
    Module1.Make_On_Top Me.HWND, True
End Sub

---

حله!
اگر هم خواستی که فرم قشنگتر بشه حاشیه فرم رو بردار....

---

خیلی ممنون از اینکه کمک کردی . :11:

یه قسمت این کد مربوط به OnTop کردن فرم هست،
اجباری در استفاده کردن از اون وجود نداره،
می تونید دستوراتش را از ماژول و فرم اصلی حذف کنید،
یعنی به این شکل:
ماژول:

کد:

---

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Private Declare Function CreateRoundRectRgn Lib "gdi32" _
    (ByVal RectX1 As Long, ByVal RectY1 As Long, ByVal RectX2 As Long, _
    ByVal RectY2 As Long, ByVal EllipseWidth As Long, _
    ByVal EllipseHeight As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal HWND As Long, _
ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Public Declare Sub ReleaseCapture Lib "user32" ()
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

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 HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2



Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

Public Sub Round_Corners(ByRef FRM As Form)
    FRM.ScaleMode = vbPixels
    mlWidth = FRM.ScaleWidth
    mlHeight = FRM.ScaleHeight
   
   
    SetWindowRgn FRM.HWND, CreateRoundRectRgn(1, 1, _
                (FRM.Width / Screen.TwipsPerPixelX), (FRM.Height / Screen.TwipsPerPixelY), _
              60, 60), _
                True
    FRM.ScaleMode = vbTwips
End Sub

---

فرم:

کد:

---

Private Sub Form_Load()
    Module1.Round_Corners Me
End Sub

---

در این حالت خاصیت Always OnTop از بین می رود...

نقل قول:

---

خیلی ممنون از اینکه کمک کردی . :11:

---

خواهش می کنم،
وظیفه بود... :46:

پست قبلی اشتباهی 2 مرتبه ارسال شد!