چند تا کد زیبا برای فُرم

[HjSoft]

ایجاد خطوط 3 بعدی روی فرم

Function Dist(x1, y1, x2, y2) As Single
Dim A As Single, B As Single
A = (x2 - y1) * (x2 - x1)
B = (y2 - y1) * (y2 - y1)
Dist = Sqr(A + B)
End Function
Sub MoveIt(A, B, t)
A = (1 - t) * A + t * B
End Sub

Private Sub Form_Click()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub

Private Sub Form_Resize()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub

[HjSoft]

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Command Button to your form.
'Insert the following code to your module:

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

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal _
hdc As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal _
crColor As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "user32" (ByVal hdc As Long, ByVal hObject _
As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Sub ExplodeForm(f As Form, Movement As Integer)
Dim myRect As RECT
Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
Dim TheScreen As Long
Dim Brush As Long
GetWindowRect f.hwnd, myRect
formWidth = (myRect.Right - myRect.Left)
formHeight = myRect.Bottom - myRect.Top
TheScreen = GetDC(0)
Brush = CreateSolidBrush(f.BackColor)
For i = 1 To Movement
Cx = formWidth * (i / Movement)
Cy = formHeight * (i / Movement)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle TheScreen, X, Y, X + Cx, Y + Cy
Next i
X = ReleaseDC(0, TheScreen)
DeleteObject (Brush)
End Sub

Private Sub ImplodeForm(f As Form, Movement As Integer)
Dim myRect As RECT
Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
Dim TheScreen As Long
Dim Brush As Long
GetWindowRect f.hwnd, myRect
formWidth = (myRect.Right - myRect.Left)
formHeight = myRect.Bottom - myRect.Top
TheScreen = GetDC(0)
Brush = CreateSolidBrush(f.BackColor)
For i = Movement To 1 Step -1
Cx = formWidth * (i / Movement)
Cy = formHeight * (i / Movement)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle TheScreen, X, Y, X + Cx, Y + Cy
Next i
X = ReleaseDC(0, TheScreen)
DeleteObject (Brush)
End Sub

'Insert this code to your form:

Private Sub Command1_Click()
'Replace all the '500' below with the Speed of the Explode\Implode Effect.
Call ImplodeForm(Me, 500)
End
Set Form1 = Nothing
End Sub

Private Sub Form_Load()
Call ExplodeForm(Me, 500)
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call ImplodeForm(Me, 500)

[HjSoft]

Public Sub CenterC(frm As Form)
Dim SpcF As Integer 'ÚÏÏ ÇáãÓÇÝÇÊ ÇáãÖÇÝå
Dim clen As Integer 'Øæá ÇáÚäæÇä
Dim oldc As String 'ÇáÚäæÇä ÇáÞÏíã
Dim i As Integer

oldc = frm.Caption

Do While Left(oldc, 1) = Space(1)

DoEvents
oldc = Right(oldc, Len(oldc) - 1)
Loop
Do While Right(oldc, 1) = Space(1)

DoEvents
oldc = Left(oldc, Len(oldc) - 1)
Loop

clen = Len(oldc)

If InStr(oldc, "!") <> 0 Then

If InStr(oldc, " ") <> 0 Then
clen = clen * 1.5
Else
clen = clen * 1.4
End If

Else

If InStr(oldc, " ") <> 0 Then
clen = clen * 1.4
Else
clen = clen * 1.3
End If

End If

' ÊÍÏíÏ ÚÏÏ ÇáÇÍÑÝ ÇááÇÒã ÇÖÇÝÊåÇ
SpcF = frm.Width / 61.2244
SpcF = SpcF - clen


If SpcF > 1 Then
DoEvents
frm.Caption = Space(Int(SpcF / 2)) + oldc
Else 'Ýí ÍÇáÉ ÇáÝæÑã ÇÕÛÑ ãä ÇáÚäæÇä ÇáÌÏíÏ
frm.Caption = oldc
End If

End Sub

Private Sub Form_Resize()
If Me.Width = oldsize Then
Exit Sub
Else
CenterC Me
oldsize = Me.Width
End If

End Sub

Private Sub Form_Load()
CenterC Me
oldsize = Me.Width
End Sub

[HjSoft]

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


Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) 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 Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 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 WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

Private Function GetTextRgn() As Long
Dim hRgn1 As Long, hRgn2 As Long
Dim rct As RECT

BeginPath hdc

TextOut hdc, 10, 10, Chr$(255), 1 'Windows Flag

'Circle (2000, 2000), 1000 'Circle window

'Create any path you want in this section to create your irregular window.

EndPath hdc

hRgn1 = PathToRegion(hdc)
GetRgnBox hRgn1, rct
hRgn2 = CreateRectRgnIndirect(rct)
CombineRgn hRgn2, hRgn2, hRgn1, 1
DeleteObject hRgn1
GetTextRgn = hRgn2
End Function

Private Sub Form_DblClick()
Unload Me
End Sub

Private Sub Form_Load()
Dim hRgn As Long
Me.Font.Name = "Wingdings"
Me.Font.Size = 100
hRgn = GetTextRgn()
SetWindowRgn hwnd, hRgn, 1
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&
End Sub

[HjSoft]

' #VBIDEUtils#************************************** **********************
' * Programmer Name : Thomas Detoux
' * Web Site : http://www.vbasic.org/
' * E-Mail : Detoux@hol.Fr
' * Date : 8/12/98
' * Time : 14:41
' * Module Name : WingWang_Module
' * Module Filename : YingYang.bas
' ************************************************** ********************
' * Comments : Create YING YANG forms
' * Sample of call
' * Call YingYang(Me)
' *
' *
' ************************************************** ********************

Option Explicit

'Créé une region en forme de rectangle entre les points (X1,Y1) et (X2,Y2)
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'Créé une région en forme d'éllipse entre les points (X1,Y1) et (X2,Y2)
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'Combine deux régions pour en créer unr troisième selon le mode nCombineMode
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

'Supprime un objet et libère de la mémoire
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'Créé une feuille ayant la forme d'une région
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

'Constantes pour CombineRgn
Private Const RGN_AND = 1 'Intersection des deux régions
Private Const RGN_OR = 2 'Addition des deux régions
Private Const RGN_XOR = 3 'Difficile à décrire ... essayez
'En fait, c'est un XOR : l'addition des 2 régions
'en retirant les parties communes aux 2 régions
Private Const RGN_DIFF = 4 'Soustraction de la région 2 à la région 1
Private Const RGN_COPY = 5 'Copie la région 1

Private YY As Long

' #VBIDEUtils#************************************** **********************
' * Programmer Name : Thomas Detoux
' * Web Site : http://www.vbasic.org/
' * E-Mail : Detoux@hol.Fr
' * Date : 8/12/98
' * Time : 14:41
' * Module Name : WingWang_Module
' * Module Filename : YingYang.bas
' ************************************************** ********************
' * Comments : Create YING YANG forms
' * Sample of call
' * Call YingYang(Me)
' *
' *
' ************************************************** ********************
Public Sub YingYang(obj As Form)

'Déclaration des différents "handles" des différentes "régions" de la feuille, qui, réunies, formeront le Ying Yang
Dim Cercle As Long
Dim Rect As Long
Dim PCercleH As Long
Dim PCercleB As Long
Dim HCercle As Long
Dim Cadre As Long
Dim TrouB As Long
Dim TrouH As Long
Dim CercleBis As Long
Dim HCercleBis As Long
Dim CercleBisBis As Long
Dim Ying_Yang As Long
Dim YYang As Long

Dim H As Long
Dim L As Long
Dim HBord As Long
Dim LBord As Long
Dim HT As Long
Dim LT As Long

H = obj.Height / Screen.TwipsPerPixelY
L = obj.Width / Screen.TwipsPerPixelX

HBord = Int(H / 100)
LBord = Int(L / 100)

HT = Int(H / 10)
LT = Int(L / 10)

'Création des différentes "régions", et combinaisons entre elles
'Attention : pour réaliser une combinaison, la variable-région de destination
'doit déjà avoir été intialisée en lui affectant une région auparavant.

HCercle = CreateEllipticRgn(((L - (2 * LBord)) / 4) + LBord, ((H - (2 * HBord)) / 2) + HBord, 3 * (((L - (2 * LBord)) / 4) + LBord), (H - HBord))
Cercle = CreateEllipticRgn(LBord, HBord, L - LBord, H - HBord)
Rect = CreateRectRgn(L / 2, 0, L, H)
CombineRgn HCercle, Cercle, Rect, RGN_DIFF

HCercleBis = CreateEllipticRgn(LBord, HBord, L - LBord, H - HBord)
PCercleB = CreateEllipticRgn(((L - (2 * LBord)) / 4) + LBord, ((H - (2 * HBord)) / 2) + HBord, 3 * (((L - (2 * LBord)) / 4) + LBord), (H - HBord))
CombineRgn HCercleBis, HCercle, PCercleB, RGN_DIFF

CercleBis = CreateEllipticRgn(LBord, HBord, L - LBord, H - HBord)
PCercleH = CreateEllipticRgn(((L - (2 * LBord)) / 4) + LBord, HBord, 3 * (((L - (2 * LBord)) / 4) + LBord), ((H - (2 * HBord)) / 2) + HBord)
CombineRgn CercleBis, Cercle, PCercleH, RGN_DIFF

CercleBisBis = CreateEllipticRgn(LBord, HBord, L - LBord, H - HBord)
HCercle = CreateEllipticRgn(0, 0, L, H)
CombineRgn CercleBisBis, CercleBis, HCercleBis, RGN_DIFF

Ying_Yang = CreateEllipticRgn(0, 0, L, H)
Cadre = CreateEllipticRgn(0, 0, L, H)
CombineRgn Ying_Yang, Cadre, CercleBisBis, RGN_DIFF

YYang = CreateEllipticRgn(0, 0, L, H)
TrouB = CreateEllipticRgn(((L - (2 * LBord)) / 2) + LBord - (LT / 2), ((3 * (H - (2 * HBord)) / 4)) + HBord - (HT / 2), ((L - (2 * LBord)) / 2) + LBord + (LT / 2), ((3 * (H - (2 * HBord)) / 4)) + HBord + (HT / 2))
CombineRgn YYang, Ying_Yang, TrouB, RGN_OR

YY = CreateEllipticRgn(0, 0, L, H)
TrouH = CreateEllipticRgn(((L - (2 * LBord)) / 2) + LBord - (LT / 2), ((H - (2 * HBord)) / 4) + HBord - (HT / 2), ((L - (2 * LBord)) / 2) + LBord + (LT / 2), ((H - (2 * HBord)) / 4) + HBord + (HT / 2))
CombineRgn YY, YYang, TrouH, RGN_DIFF

SetWindowRgn obj.hwnd, YY, True 'Applique la région finale à la feuille

'Suppression des régions
DeleteObject Cercle
DeleteObject Rect
DeleteObject PCercleH
DeleteObject PCercleB
DeleteObject HCercle
DeleteObject Cadre
DeleteObject TrouB
DeleteObject TrouH
DeleteObject CercleBis
DeleteObject HCercleBis
DeleteObject CercleBisBis
DeleteObject Ying_Yang
DeleteObject YYang

End Sub


Private Sub Form_Load()
YingYang Me
End Sub

[HjSoft]

Sub ThreeDForm(frmForm As Form)
Const cPi = 3.1415926
Dim intLineWidth As Integer
intLineWidth = 5
' 'save scale mode
Dim intSaveScaleMode As Integer
intSaveScaleMode = frmForm.ScaleMode
frmForm.ScaleMode = 3
Dim intScaleWidth As Integer
Dim intScaleHeight As Integer
intScaleWidth = frmForm.ScaleWidth
intScaleHeight = frmForm.ScaleHeight
' 'clear form
frmForm.Cls
' 'draw white lines
frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF
frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF
' 'draw grey lines
frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, intScaleHeight), &H808080, BF
frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, intScaleHeight), &H808080, BF
' 'draw triangles(actually circles) at corners
Dim intCircleWidth As Integer
intCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth * intLineWidth)
frmForm.FillStyle = 0
frmForm.FillColor = QBColor(15)
frmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), intCircleWidth, QBColor(15), _
-3.1415926, -3.90953745777778 '-180 * cPi / 180, -224 * cPi / 180
frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), intCircleWidth, QBColor(15), _
-0.78539815, -1.5707963 ' -45 * cPi / 180, -90 * cPi / 180
' 'draw black frame
frmForm.Line (0, intScaleHeight)-(0, 0), 0
frmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0
frmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, intScaleHeight - 1), 0
frmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, intScaleHeight - 1), 0
frmForm.ScaleMode = intSaveScaleMode
End Sub

Private Sub Form_Paint()
ThreeDForm Me

End Sub

[HjSoft]

Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function CreatePolygonRgn _
Lib "gdi32" (lpPoint As POINTAPI, _
ByVal nCount As Long, _
ByVal nPolyFillMode As Long) As Long
Private Declare Function SetWindowRgn _
Lib "user32" (ByVal hWnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Boolean) As Long
Public Sub CreatePolygon(ByRef oWindow As Object)
Dim hRgn As Long
Dim Points(0 To 5) As POINTAPI
With oWindow
'Set up some points
Points(0).x = 0
Points(0).y = 10
Points(1).x = 220
Points(1).y = 0
Points(2).x = 300
Points(2).y = 150
Points(3).x = 120
Points(3).y = 140
Points(4).x = 25
Points(4).y = 160
Points(5).x = 0
Points(5).y = 10
'Create a region from the points
hRgn = CreatePolygonRgn(Points(0), (UBound(Points) + 1), 2)
SetWindowRgn .hWnd, hRgn, True
End With
End Sub
Private Sub Form_Load()
CreatePolygon Me
End Sub

[HjSoft]

Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function GetCursor Lib "user32" () As Long
Private Sub Form_Paint()
DrawIcon Me.hdc, 30, 30, GetCursor
End Sub

[HjSoft]

'Start new project
'Place a timer
Dim Tit As String 'Public variable

Sub ScrolTit()
Tit = String(30, " ") & "I'm moving..." 'Set blank up to 30 chararcters long]
'You can insert date and time fucntion here
'Tit =String(30, " "), & "The time is : " & Time
'Tit = String(30, " "), & "Today's date : " & Date
End Sub

Public Sub Form_Load()
Timer1.Interval = 200 'set scrolling speed
ScrolTit 'Start scrolling form caption
End Sub

Public Sub Timer1_Timer()
Tit = Mid(Tit, 2) & Left(Tit, 1)
Me.Caption = Tit
End Sub

[HjSoft]

'ضع هذه التصریحات فی Moudel

Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Sub Form_Load()
Timer1.Interval = 250
End Sub

Private Sub Timer1_Timer()
Randomize
Me.BackColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.Move Rnd * 12000, Rnd * 9000, Rnd * 12000, Rnd * 9000
End Sub

[HjSoft]

بقیه کد ها را بعدا می نویسم هر کی که موافقه اعلام کنه و اگه کد در خواستی خواستین بگین تا براتون بنویسم ______________

[M8SPY_OK]

بقیه کد ها را بعدا می نویسم هر کی که موافقه اعلام کنه و اگه کد در خواستی خواستین بگین تا براتون بنویسم ______________

با سلام

آقای wolf-sky من روی اون کدی که فرم رو به صورت انفجاری باز می کرد مشکل دارم - یعنی در واقع نمی فهمم کد چی گفته ؟ اگه اشکالی نداره یه توضیح کلی بدید که ما مبتدیا هم لااقل بفهمیم شا چی کپی کردین !!!

[Mbt925]

بقیه کد ها را بعدا می نویسم هر کی که موافقه اعلام کنه و اگه کد در خواستی خواستین بگین تا براتون بنویسم ______________

دوست عزیز ممنون از کدهاتون.

نیازی نیست انقدر بزرگ بنویسید ، با این کار نظم تاپیک رو بهم میریزید.

[HjSoft]

چشم آقای mbt و شما اقای m8spy منظورم اینه که فرم سریع از کوچ به حلت بزرگ در میاد و در موقع بستن هم سریع کوچک میشه و میره

[MMR_1344]

دوست عزیز کدهای جالبی بود متشکر

[M8SPY_OK]

چشم آقای mbt و شما اقای m8spy منظورم اینه که فرم سریع از کوچ به حلت بزرگ در میاد و در موقع بستن هم سریع کوچک میشه و میره

منظورم این بود که توضیح برنامه نویسی بدین . مثلاً بگین فلان قسمت کد چیکار می کنه .

اکه میشه کل کد ....
مرسی

[ftmotlagh]

جالب بود ...
ولی بعضی از کدها مبهمه!

[HjSoft]

چشم اون هم به مقع خودش آقای m8spy

[atlantic_nights]

در مورد رنگارنگ شدن فرم فکر نکنم نیازی به declare function داشته باشه

[HjSoft]

دوست عزیز این کد با رنگارنگ شدن که شما فکر می کنید فرق داره امتحان کنید

[mlh_poorranjbar]

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

[bobrus]

این تاپیک رو هم نگاه کنین بد نیست
http://barnamenevis.org/forum/showthread.php?t=89384