نمایش Gradient

[بابک زواری]

بیکار بودم این کد نظرم رو جلب کرد با خودم گفتم با دوستان هم سفره بشیم


'All Gradient Method Are Availble Here.
'
'
'
'
Option Explicit
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long

Public OffsetX As Long
Public OffsetY As Long

Public Enum CSFadeTypes
CSFadeNone
CSFadeLeft2Right
CSFadeRight2Left
CSFadeTop2Bottom
CSFadeBottom2Top
CSFadeCircleIn
CSFadeCircleOut
CSFadeRectangleIn
CSFadeRectangleOut
End Enum

Public Sub Fade(ByVal newFadeType As CSFadeTypes, newForm As Object, Optional ByVal FromColor As OLE_COLOR = vbBlue, Optional ByVal ToColor As OLE_COLOR = vbBlack)

Dim i As Integer

Dim FadeColor As OLE_COLOR
Dim FadeStep As Long
Dim oldMouse As MousePointerConstants

oldMouse = Screen.MousePointer
Screen.MousePointer = vbHourglass

Call RealizePalette(newForm.hdc)
newForm.AutoRedraw = True
newForm.DrawWidth = 3
Select Case (newFadeType)
Case CSFadeTypes.CSFadeLeft2Right
newForm.Scale (0, 0)-(256, 1)
FadeColor = FromColor
FadeStep = ((ToColor - FromColor) \ 255)
newForm.BackColor = IIf(OffsetX <= 0, ToColor, FromColor)
For i = 0 To 255
newForm.Line (i + OffsetX, 0)-(i + OffsetX + 1, 1), FadeColor, BF
FadeColor = FadeColor + FadeStep
Next i
Case CSFadeTypes.CSFadeRight2Left
Fade CSFadeLeft2Right, newForm, ToColor, FromColor
Case CSFadeTypes.CSFadeTop2Bottom
newForm.Scale (0, 0)-(1, 256)
FadeColor = FromColor
FadeStep = ((ToColor - FromColor) \ 255)
newForm.BackColor = IIf(OffsetY <= 0, ToColor, FromColor)
For i = 0 To 255
newForm.Line (0, i + OffsetY)-(1, i + OffsetY + 1), FadeColor, BF
FadeColor = FadeColor + FadeStep
Next i
Case CSFadeTypes.CSFadeBottom2Top
Fade CSFadeTop2Bottom, newForm, ToColor, FromColor
Case CSFadeTypes.CSFadeCircleIn
newForm.Scale (0, 0)-(256, 256)
FadeColor = FromColor
FadeStep = ((ToColor - FromColor) \ 255)
newForm.FillStyle = vbFSSolid
newForm.BackColor = FadeColor
For i = 255 To 0 Step -1
newForm.FillColor = FadeColor
newForm.Circle (127 + OffsetX, 127 + OffsetY), (i + 1), FadeColor
FadeColor = FadeColor + FadeStep
Next i
newForm.FillStyle = vbFSTransparent
Case CSFadeTypes.CSFadeCircleOut
Fade CSFadeCircleIn, newForm, ToColor, FromColor
Case CSFadeTypes.CSFadeRectangleIn
newForm.Scale (0, 0)-(256, 256)
FadeColor = FromColor
FadeStep = ((ToColor - FromColor) \ 255)
newForm.FillStyle = vbFSSolid
newForm.BackColor = FadeColor
For i = 0 To 127
newForm.FillColor = FadeColor
newForm.Line (i + OffsetX, i + OffsetY)-Step(256 - (i * 2), 256 - (i * 2)), FadeColor, BF
FadeColor = FadeColor + (FadeStep * 2)
Next i
newForm.FillStyle = vbFSTransparent
Case CSFadeTypes.CSFadeRectangleOut
Fade CSFadeRectangleIn, newForm, ToColor, FromColor
End Select

newForm.AutoRedraw = False
Screen.MousePointer = oldMouse

End Sub

[hadi2345]

ممنون آقای کد نویس :flower:

[R_BABAZADEH]

با تشکر
ولی من فکر می کنم یه برنامه کوچولو هم با هاش می دادی خیلی خوب میشد

[R_BABAZADEH]

ببینید از این دوتا خوشتون میاد
من این دو رو zip کردم اید وارم دیگه مشگل نداشته باشید

[Success]

آقای بابا زاده عزیز سلام

ممنون از فایلهای زیادی که در قسمتهای مختلف جهت Download قرار می دهید . اما من یک خواهشی از شما دارم و اون اینه که اگه ممکنه در فایلهای خودتون ربجای Rar از Zip استفاده کنید (‌ مثل آقای کد نویس )‌ چون من هر چی که تو این سایت با پسوند Rar هست نمی تونم باز کنم . البته بگم که من هم Rar دارم و هم Ace و هم zip ولی نمی دونم چرا Rar های شما همه Error می زنه و باز نمی شه . اگه لطف بفرمایید چون zip عمومی تره از اون استفاده کنید بسیار ممنون می شم . :موفق: :flower:

[R_BABAZADEH]

چشم سعی می کنم از این به بعد رعایت کنم و این فایلهارو هم درست می کنم

[hadi2345]

با سلام .
جالب بود . موفق باشید :flower: :flower: :flower: