اكواد لعمل مؤثرات على الفروم جديده

Option Explicit 


Private Sub Form_Load() 
Me.AutoRedraw = True 
Me.ScaleMode = vbTwips 
Me.Caption = "Rainbow Generator by " & _ 
"K. O. Thaha Hussain" 
End Sub 


Private Sub Form_Resize() 
Call Rainbow 
End Sub 


Private Sub Rainbow() 
On Error Resume Next 
Dim Position As Integer, Red As Integer, Green As _ 
Integer, Blue As Integer 
Dim ScaleFactor As Double, Length As Integer 
ScaleFactor = Me.ScaleWidth / (255 * 6) 
Length = Int(ScaleFactor * 255) 
Position = 0 
Red = 255 
Blue = 1 
'Purposfully avoided nested loops 
'------------- 1 


For Green = 1 To Length 
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ 
RGB(Red, Green \ ScaleFactor, Blue) 
Position = Position + 1 
Next Green 
'--------------- 2 


For Red = Length To 1 Step -1 
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ 
RGB(Red \ ScaleFactor, Green, Blue) 
Position = Position + 1 
Next Red 
'---------------- 3 


For Blue = 0 To Length 
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ 
RGB(Red, Green, Blue \ ScaleFactor) 
Position = Position + 1 
Next Blue 

'----------------- 4 


For Green = Length To 1 Step -1 
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ 
RGB(Red, Green \ ScaleFactor, Blue) 
Position = Position + 1 
Next Green 

'------------------ 5 


For Red = 1 To Length 
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ 
RGB(Red \ ScaleFactor, Green, Blue) 
Position = Position + 1 
Next Red 
'------------------- 6 


For Blue = Length To 1 Step -1 
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ 
RGB(Red, Green, Blue \ ScaleFactor) 
Position = Position + 1 
Next Blue 
End Sub

 
Public Sub ThreeDForm(frmForm As Form) 
Const cPi = 3.1415926 
Dim intLineWidth As Integer 
intLineWidth = 5 
Dim intSaveScaleMode As Integer 
intSaveScaleMode = frmForm.ScaleMode 
frmForm.ScaleMode = 3 
Dim intScaleWidth As Integer 
Dim intScaleHeight As Integer 
intScaleWidth = frmForm.ScaleWidth 
intScaleHeight = frmForm.ScaleHeight 
frmForm.Cls 
frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF 
frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF 
frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, _ 
intScaleHeight), &H808080, BF 
frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, _ 
intScaleHeight), &H808080, BF 
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 
frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), _ 
intCircleWidth, _ 
QBColor(15), -0.78539815, -1.5707963 
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_Resize() 
ThreeDForm Me 
End Sub 

 
Private Declare Function CreateRoundRectRgn Lib "gdi32.dll" _ 
(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 'MODULE 1152 
Private Declare Function SetWindowRgn Lib "user32" _ 
(ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long 

'v is the size of the top corners and w is the size of the bottom corners... 

Sub RoundRect(ByVal uObject As Object, ByVal v As Long, ByVal w As Long) 
Dim lRight As Long 
Dim lBottom As Long 
Dim hRgn As Long 
With uObject 
lRight = .Width / Screen.TwipsPerPixelX 
lBottom = .Height / Screen.TwipsPerPixelY 
hRgn = CreateRoundRectRgn(0, 0, lRight, lBottom, v, w) 
SetWindowRgn .hwnd, hRgn, True 
End With 
End Sub 
Private Sub Form_Load() 
RoundRect Me, 40, 40 'Leave it on 40. 
End Sub 

 

Private str**** As String 
Private Sub Form_Load() 
Timer1.Interval = 75 
str**** = "Guten Tag! Wie ght's Ihnen? Ich hoffe Ihnen alles Gutes!" 
str**** = Space(50) & str**** 
End Sub 
Private Sub Timer1_Timer() 
str**** = Mid(str****, 2) & Left(str****, 1) 
****1.**** = str**** 
Me.Caption = str**** 
End Sub 

 

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 CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean
Const RGN_DIFF = 4
Dim lOriginalForm As Long
Dim ltheHole As Long
Dim lNewForm As Long
Dim lFwidth As Single
Dim lFHeight As Single
Dim lborder_width As Single
Dim ltitle_height As Single

On Error GoTo Trap
lFwidth = ScaleX(Width, vbTwips, vbPixels)
lFHeight = ScaleY(Height, vbTwips, vbPixels)
lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)
lborder_width = (lFHeight - ScaleWidth) / 2
ltitle_height = lFHeight - lborder_width - ScaleHeight
Select Case AreaType
Case "Elliptic"
ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RectAngle"
ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RoundRect"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))
Case "Circle"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
Case Else
MsgBox "Unknown Shape!!"
Exit Function
End Select
lNewForm = CreateRectRgn(0, 0, 0, 0)
CombineRgn lNewForm, lOriginalForm, ltheHole, RGN_DIFF
SetWindowRgn hWnd, lNewForm, True
Me.Refresh
fMakeATranspArea = True
Exit Function
Trap:
MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description
End Function

Private Sub Form_Load()
Dim lParam(1 To 6) As Long
lParam(1) = 100
lParam(2) = 208
lParam(3) = 50
lParam(4) = 50
lParam(5) = 666
lParam(6) = 555
'Call fMakeATranspArea("RoundRect", lParam())
'Call fMakeATranspArea("RectAngle", lParam())
'Call fMakeATranspArea("Circle", lParam())
Call fMakeATranspArea("Elliptic", lParam())
End Sub

 
Sub Explode(form1 As Form)
form1.Width = 0
form1.Height = 0
form1.Show
For x = 0 To 5000 Step 1
form1.Width = x
form1.Height = x
With form1
.Left = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / 2
End With
Next

End Sub
Private Sub Form_Load()
Explode Me
End Sub

 
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000

Private Sub Form_Load()
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA
End Sub

 

Private Sub Form_Resize() 
Width = 3000 
Height = 3000 
End Sub

 

Sub Fade(vForm As Form) 
Dim intLoop As Integer 
vForm.DrawStyle = vbInsideSolid 
vForm.DrawMode = vbCopyPen 
vForm.ScaleMode = vbPixels 
vForm.DrawWidth = 2 
vForm.ScaleHeight = 256 
For intLoop = 0 To 255 
vForm.Line (0, intLoop)-(Screen.Width, intLoop - 1), _ 
RGB(0, 0, 255 - intLoop), B 
Next intLoop 
End Sub 
Private Sub Form_Activate() 
Fade Me 
End Sub