PDA

View Full Version : فرم



شفیعی
یک شنبه 21 دی 1382, 04:58 صبح
سلام
لطفا ادرس زیر را نگاه کنید مشابه همین کار را در VB می خواهم انجام دهیم
http://www.barnamenevis.org/forum/viewtopic.php?t=5989

giahchin
یک شنبه 21 دی 1382, 16:13 عصر
سلام ،
اگه فرمی می خوای بسازی که شکلی غیر از مستطیل یا مربع داشته باشه (مثلا بیضی) بگو ما در خدمتیم :wink:

شفیعی
یک شنبه 21 دی 1382, 18:42 عصر
سلام
دوست عزیز شکل فرم نمی خواهم تغییر دهم فقط می خواهم فرم وقتی ظاهر می شود به صورت چرخشی یا به شکلی خاص بر روی صفحه ظاهر شود .ادرس بالا را دقیقتر بخوانی متوجه می شوی باتشکر شفیعی

M-Gheibi
یک شنبه 21 دی 1382, 22:32 عصر
من دقیقاً اون چیزی که شما میخواید رو دارم ولی شرمنده چون دیگه فضایی برای ارسال فایل ندارم. :( :cry: :cry: :roll: مگر اینکه جناب کرامتی لطف کنند و ...

شفیعی
دوشنبه 22 دی 1382, 01:04 صبح
سلام
دوست عزیز برنامه ای که شما دارید را از کجا بدست آورده اید اگر از اینترنت دانلود کرده اید لطفا ادرس سایتش را برایم اینجا بنویسید

M-Gheibi
دوشنبه 22 دی 1382, 16:12 عصر
Window Show
میتونید این اکتیوایکس را همراه با مثال برای ویژوال بیسیک از سایت http://www.jcomsoft.com بگیرید که البته باید رجیستر شود. من نسخه کرک شده اون رو (اگه بشه گفت کرک شده (چون خودم کاری کردم که پیغام نده)) دارم. اگه خواستی بگو. البته اول اون رو از سایتش دریافت کن و بعد اگه بدردتون میخورد اینجا بنویسید.

S.Azish
دوشنبه 22 دی 1382, 16:26 عصر
http://www.mentalis.org/apilist/AnimateWindow.shtml

M-Gheibi
دوشنبه 22 دی 1382, 17:08 عصر
آقای آذیش از راهنمایتون ممنونم ولی متاسفانه وقتی کد نمونه را امتحان کردم به هنگام خروج از برنامه تست، صفحه اصلی برنامه فقط سیاه شد و بعد خارج شد. نمیدونید مشکل از کجاست؟! :roll:

S.Azish
دوشنبه 22 دی 1382, 20:50 عصر
تابع AnimateWindow با پارامتراهای مختلف استفاده میشه و اونو اونجوری که میخواهید عوضش کنید مثل



Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
'Set the graphic mode to persistent
Me.AutoRedraw = True
Me.Print "Unload me"

'Animate the windowe
AnimateWindow Me.hwnd, 2000, AW_BLEND

End Sub


یا




Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: KPDTeam@Allapi.net
'Set the graphic mode to persistent
Me.AutoRedraw = True
Me.Print "Unload me"

'Animate the windowe
AnimateWindow Me.hwnd, 2000, AW_SLIDE

End Sub

jannati
سه شنبه 23 دی 1382, 07:41 صبح
آقای آذیش
من اینکار را کردم .اما تابع animatewindowsشناسایی نشد!چرا؟ :?

شفیعی
سه شنبه 23 دی 1382, 14:36 عصر
سلام
فکر می کنم این خط را باید اول برنامه بنویسی
Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean

jannati
چهارشنبه 24 دی 1382, 07:19 صبح
این خط را هم اضافه کردم .باز اجرا نشد . :(

S.Azish
چهارشنبه 24 دی 1382, 12:47 عصر
به مثالی که در آدرس زیر هست نگاه کنید

http://www.mentalis.org/apilist/AnimateWindow.shtml

M-Gheibi
چهارشنبه 24 دی 1382, 13:47 عصر
آقای آذیش من همه این مثالها رو امتحان کردم ولی هیچکدوم کار خاصی انجام نداد. :( :roll: :|

Abbas Arizi
چهارشنبه 24 دی 1382, 14:16 عصر
این کد رو توی یک ماژول کپی کنید و از تابع AnimateForm داخل اون استفاده کنید. به این نکته هم توجه کنید که بعضی حالات رو نمیشه هر موقعی اجرا کرد. مثلا بعضی مخصوص موقع Load هستند بعضی موقع Unload و ...

Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex 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
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Declare Function AnimateWindow Lib "user32" (ByVal hWnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal Mul As Long, ByVal Nom As Long, ByVal Den As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal DestL As Long)

Const PROP_PREVPROC = "PrevProc"
Const PROP_FORM = "FormObject"

Const GWL_WNDPROC = (-4)

Const WM_PRINTCLIENT = &H318

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Enum AnimateWindowFlags
AW_HOR_POSITIVE = &H1
AW_HOR_NEGATIVE = &H2
AW_VER_POSITIVE = &H4
AW_VER_NEGATIVE = &H8
AW_CENTER = &H10
AW_HIDE = &H10000
AW_ACTIVATE = &H20000
AW_SLIDE = &H40000
AW_BLEND = &H80000
End Enum
'
' AnimateWindow
'
' Wrapper for AnimateWindow api
'
Public Sub AnimateForm(ByVal Form As Form, ByVal dwTime As Long, _
ByVal dwFlags As AnimateWindowFlags)
Dim lRet As Long
' Set the properties
SetProp Form.hWnd, PROP_PREVPROC, GetWindowLong(Form.hWnd, GWL_WNDPROC)
SetProp Form.hWnd, PROP_FORM, ObjPtr(Form)

' Subclass the window
SetWindowLong Form.hWnd, GWL_WNDPROC, AddressOf AnimateWinProc

' Call AnimateWindow API
lRet = AnimateWindow(Form.hWnd, dwTime, dwFlags)
If lRet = 0 Then MsgBox "Error in window animation: " & vbCr & vbCr & _
"Can't animate window in this position", vbExclamation
' Unsubclass the window
SetWindowLong Form.hWnd, GWL_WNDPROC, GetProp(Form.hWnd, PROP_PREVPROC)

' Remove the properties
RemoveProp Form.hWnd, PROP_FORM
RemoveProp Form.hWnd, PROP_PREVPROC

' Refresh the form
Form.Refresh

End Sub

'
' AnimateWinProc
'
' Window procedure for AnimateWindow
'
Private Function AnimateWinProc(ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Dim lPrevProc As Long
Dim lForm As Long
Dim oForm As Form

' Get the previous WinProc pointer
lPrevProc = GetProp(hWnd, PROP_PREVPROC)

' Get the form object
lForm = GetProp(hWnd, PROP_FORM)
MoveMemory oForm, lForm, 4&

Select Case Msg

Case WM_PRINTCLIENT
Dim tRect As RECT
Dim hBr As Long

' Get the window client size
GetClientRect hWnd, tRect

' Create a brush with the
' form background color
hBr = CreateSolidBrush(TranslateColor(oForm.BackColor))

' Fill the DC with the
' background color
FillRect wParam, tRect, hBr

' Delete the brush
DeleteObject hBr

If Not oForm.Picture Is Nothing Then
Dim lScrDC As Long
Dim lMemDC As Long
Dim lPrevBMP As Long

' Create a compatible DC
lScrDC = GetDC(0&)
lMemDC = CreateCompatibleDC(lScrDC)
ReleaseDC 0, lScrDC

' Select the form picture in the DC
lPrevBMP = SelectObject(lMemDC, oForm.Picture.Handle)

' Draw the picture in the DC
BitBlt wParam, _
0, 0, _
HM2Pix(oForm.Picture.Width), HM2Pix(oForm.Picture.Height), _
lMemDC, 0, 0, vbSrcCopy

' Release the picture
SelectObject lMemDC, lPrevBMP

' Delete the DC
DeleteDC lMemDC

End If

End Select

' Release the form object
MoveMemory oForm, 0&, 4&

' Call the original window procedure
AnimateWinProc = CallWindowProc(lPrevProc, hWnd, Msg, wParam, lParam)

End Function

'
' HM2Pix
'
' Converts HIMETRIC to Pixel
'
Private Function HM2Pix(ByVal Value As Long) As Long
HM2Pix = MulDiv(Value, 1440, 2540) / Screen.TwipsPerPixelX
End Function

'
' OleTranslateColor
'
' Wrapper for OleTranslateColor API
'
Private Function TranslateColor(ByVal Clr As Long) As Long
OleTranslateColor Clr, 0, TranslateColor
End Function