Visual Basic - PRogrami Süsleme Kodlari - Harika - Harikulade

Merhabalar;
Yine ßen Yine Anlatım Visual Basic - PRogrami Süsleme Kodlari - Harika - Harikulade 001_smile

Uzatmadan Başlıyım

Labelin Rengini Değiştirmek:

'Formumuza Bir Timer Ekliyoruz...
'Bu Timer'ın İnvertial'ı 100 Ola Bilir
'Bir tanede Label Ekliyoruz
'Caption'u nu İstediğimiz İle Değiştirip.
'Ve Timer'ı mıza Şu Kodları Ekliyoruz...
'-------------------------------------------
Private Sub Timer1_Timer()
Label1.ForeColor = Rnd * 1677216
End Sub
'-------------------------------------------
'Bu Kod'un Mantığı Random İle Sürekli Renk Seçimi Yaparak
'Timer'ın Yardımcılığıyla Renk Değiştirmekdir..

_______________________________________________________________________________________
Formun Rengini Değiştirmek:

Private Sub Form_Click() '

Show '

For i = 1 To Form1.Height '

DrawWidth = Int(Rnd * 15) + 1 '

Randomize '

Line (1, i)-(Form1.Width, i), Rnd * 5000 '

Next '

End Sub '

_______________________________________________________________________________________
Forma Cerceve Koyma:

Sub Form_Click()
Dim CX, CY, Radius, Limit
ScaleMode = 3
CX = ScaleWidth / 2
CY = ScaleHeight / 2
If CX > CY Then Limit = CY Else Limit = CX
For Radius = 0 To Limit
Circle (CX, CY), Radius, RGB(Rnd * 100, Rnd * 100, Rnd * 100)
Next Radius
End Sub
_______________________________________________________________________________________
Göz Kırpan Yazı:

Private Sub Timer1_Timer()
If Label1.Visible = True Then
Label1.Visible = False
Else
Label1.Visible = True
End If

End Sub
_______________________________________________________________________________________
Formun Arka Planını Değiştirmek:

Private Sub RenkGecisi(Ref As Form)

Dim intLoop As Integer

Ref.DrawStyle = vbInsideSolid

Ref.DrawMode = vbCopyPen

Ref.ScaleMode = vbPixels

Ref.DrawWidth = 2

Ref.ScaleHeight = 256

For intLoop = 0 To 255

Ref.Line (0, intLoop)-(Screen.Width, intLoop - 1), RGB(255, 0, 255 - intLoop), B

Next intLoop

End Sub

Private Sub Form_Activate()

RenkGecisi Me

End Sub
_______________________________________________________________________________________
Süslü Animasyonlar:

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

FillStyle = Rnd * 6
FillColor = Rnd * 17137223
Circle (X, Y) , 500
_______________________________________________________________________________________
Text Efect:

Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32" _
(ByVal hdc As Long, ByVal nCharExtra As Long) As Long

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

Private Declare Function OffsetRect Lib "user32" (lpRect _
As RECT, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc _
As Long, ByVal crColor 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 CreateSolidBrush Lib "gdi32" (ByVal _
crColor As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal _
hObject As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal _
nIndex As Long) As Long

Private Const COLOR_BTNFACE = 15

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 DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long

Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4 ' Character-stream, PLP
Private Const DT_DISPFILE = 6 ' Display-file
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_LEFT = &H0
Private Const DT_METAFILE = 5 ' Metafile, VDM
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0 ' Vector plotter
Private Const DT_RASCAMERA = 3 ' Raster camera
Private Const DT_RASDISPLAY = 1 ' Raster display
Private Const DT_RASPRINTER = 2 ' Raster printer
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10

Private Declare Function OleTranslateColor Lib "olepro32.dll" _
(ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1

Public Sub TextEffect(obj As Object, ByVal sText As String, _
ByVal lX As Long, ByVal lY As Long, Optional ByVal bLoop _
As Boolean = False, Optional ByVal lStartSpacing As Long = 128, _
Optional ByVal lEndSpacing As Long = -1, Optional ByVal oColor _
As OLE_COLOR = vbWindowText)

Dim lhDC As Long
Dim i As Long
Dim x As Long
Dim lLen As Long
Dim hBrush As Long
Static tR As RECT
Dim iDir As Long
Dim bNotFirstTime As Boolean
Dim lTime As Long
Dim lIter As Long
Dim bSlowDown As Boolean
Dim lCOlor As Long
Dim bDoIt As Boolean

lhDC = obj.hdc
iDir = -1
i = lStartSpacing
tR.Left = lX: tR.Top = lY: tR.Right = lX: tR.Bottom = lY
OleTranslateColor oColor, 0, lCOlor

hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
lLen = Len(sText)

SetTextColor lhDC, lCOlor
bDoIt = True

Do While bDoIt
lTime = timeGetTime
If (i < -3) And Not (bLoop) And Not (bSlowDown) Then
bSlowDown = True
iDir = 1
lIter = (i + 4)
End If
If (i > 128) Then iDir = -1
If Not (bLoop) And iDir = 1 Then
If (i = lEndSpacing) Then
' Stop
bDoIt = False
Else
lIter = lIter - 1
If (lIter <= 0) Then
i = i + iDir
lIter = (i + 4)
End If
End If
Else
i = i + iDir
End If

FillRect lhDC, tR, hBrush
x = 32 - (i * lLen)
SetTextCharacterExtra lhDC, i
DrawText lhDC, sText, lLen, tR, DT_CALCRECT
tR.Right = tR.Right + 4
If (tR.Right > obj.ScaleWidth Screen.TwipsPerPixelX) Then _
tR.Right = obj.ScaleWidth Screen.TwipsPerPixelX
DrawText lhDC, sText, lLen, tR, DT_LEFT
obj.Refresh

Do
DoEvents
If obj.Visible = False Then Exit Sub
Loop While (timeGetTime - lTime) < 20

Loop
DeleteObject hBrush

End Sub

'-------------------------------------------------buton kısmı--------
Private Sub Command1_Click()
Me.ScaleMode = vbTwips
Me.AutoRedraw = True
Call TextEffect(Me, "vbasicmaster.com", 12, 12, False, 128, 0)
End Sub
_______________________________________________________________________________________
Form Efecti Süper! Visual Basic - PRogrami Süsleme Kodlari - Harika - Harikulade Wink

Visual Basic - PRogrami Süsleme Kodlari - Harika - Harikulade Wink

Private Sub Form_load()
'ÖZELLIKLER AYARLANIYOR
Me.AutoRedraw = True
'RENKLERI DEGISTIRIYORUZ
Me.BackColor = RGB(0, 0, 0)

'GELDI SIRA EFEKT ICIN HAZIRLIKLARA
Me.DrawMode = 5
Me.DrawWidth = 3
Me.WindowState = 2
End Sub

Private Sub Form_Click()
'DEGISKENLER I TANIMLIYORUZ
Dim A 'ANA DEGISKENIMIZ
Dim b 'RENKLERI GÖSTERMEK ICIN KULLANACAGIMIZ DEGISKEN

For A = 1 To Me.Width / 15
b = b + 1

'ÇIZGILER VE DAIRELER CIZILIYOR
'YENI EKLENEN CIZGILER VE DAIRELER SILINIYOR
'VE KARSINIZA MUHTESEM EFEKT LER ÇIKIYOR Visual Basic - PRogrami Süsleme Kodlari - Harika - Harikulade 001_smile

'DEGISIKLIKLERI UZUN UZUN IZLEYIN RAHATLAYACAKSINIZ Visual Basic - PRogrami Süsleme Kodlari - Harika - Harikulade 001_smile

' r
Me.Line (A * 15, 0)-(A * 15, Me.Height), RGB(255, b, 255)
Me.Line (0, A * 15)-(Me.Width, A * 15), RGB(b, b, 255)
Me.Circle (Me.Width / 2, Me.Height / 2), A * 15, RGB(b, b, 255)
Me.Circle (Me.Width / 1.5, Me.Height / 1.5), A * 15, RGB(0, b, 255)
Me.Circle (Me.Width / 4, Me.Height / 4), A * 15, RGB(255, b, b)
Me.Circle (Me.Width / 6, Me.Height / 6), A * 15, RGB(b, 0, 255)
Me.Circle (Me.Width, Me.Height), A * 15, RGB(b, 255, 255)
'Me.Refresh

DoEvents
Next
End Sub
_______________________________________________________________________________________
Texti Kalın ve İtalik Yapma
Private Sub Check1_Click()
' Metni kalın yapmak içIn
If Check1.Value = 1 Then ' check edilmişse
Text1.FontBold = True
Else 'check edilmemişse
Text1.FontBold = False
End If
End Sub

Private Sub Check2_Click()
' metni italik yapmak içIn
If Check2.Value = 1 Then ' check edilmişse
Text1.FontItalic = True
Else ' check edilmemişse
Text1.FontItalic = False
End If
End Sub

Private Sub Command1_Click()
Unload Me ' formu kapatır.
End Sub
_______________________________________________________________________________________
Kapama Buton Kod:
Unload Me
_______________________________________________________________________________________
Zar:
Option Explicit

Private CenterX As Integer
Private CenterY As Integer
Private Size As Integer
Private renk As Boolean
Private Radius As Integer
Private Winkel As Integer
Private CurX As Integer
Private CurY As Integer
Private Pi As Double
Private Ecke(1 To 8, 1 To 3) As Integer
Private X( Cool

As Integer
Private Y( Cool

As Integer

Private Sub Form_Load()
With Me
.ForeColor = RGB(255, 255, 255)
.BackColor = RGB(143, 143, 143)
.AutoRedraw = True
.DrawWidth = 1
.ScaleMode = vbPixels
CenterX = .ScaleWidth / 2
CenterY = .ScaleHeight / 2
.Show
End With

With Combo1
.AddItem "renk"
.AddItem "kirmizi"
.AddItem "yesil"
.AddItem "mavi"
.AddItem "sari"
.AddItem "lila"
.AddItem "beyaz"
End With
Combo1.ListIndex = 4
renk = False

With Combo2
.AddItem "1"
.AddItem "2"
.AddItem "3"
.AddItem "4"
.AddItem "5"
.AddItem "6"
End With
Combo2.ListIndex = 1

Size = 200
Winkel = 0
Radius = Sqr(2 * (Size / 2) ^ 2)
Pi = Atn(1) * 4

Ecke(1, 2) = Size / 2
Ecke(2, 2) = Size / 2
Ecke(3, 2) = -Size / 2
Ecke(4, 2) = -Size / 2
Ecke(5, 2) = Size / 2
Ecke(6, 2) = Size / 2
Ecke(7, 2) = -Size / 2
Ecke(8, 2) = -Size / 2

Timer1.Interval = 1
End Sub

Private Sub WuerfelDrehen()
Dim i As Integer

Me.Cls

For i = 1 To 8
X(i) = CenterX + Ecke(i, 1) + Ecke(i, 3) / 8
Y(i) = CenterY + Ecke(i, 2) + Sgn(Ecke(i, 2)) * Ecke(i, 3) / 8
Next i

Line (X(3), Y(3))-(X(4), Y(4))
Line (X(4), Y(4))-(X( Cool

, Y(

)
Line (X(3), Y(3))-(X(7), Y(7))
Line (X(7), Y(7))-(X( Cool

, Y(

)
Line (X(1), Y(1))-(X(3), Y(3))
Line (X(1), Y(1))-(X(2), Y(2))
Line (X(5), Y(5))-(X(6), Y(6))
Line (X(5), Y(5))-(X(1), Y(1))
Line (X(5), Y(5))-(X(7), Y(7))
Line (X(6), Y(6))-(X( Cool

, Y(

)
Line (X(2), Y(2))-(X(4), Y(4))
Line (X(2), Y(2))-(X(6), Y(6))
Line (X(4), Y(4))-(X( Cool

, Y(

)
Line (X(3), Y(3))-(X(7), Y(7))

DoEvents
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
CurX = X
CurY = Y
If renk Then
Randomize Timer
Me.ForeColor = RGB(256 * Rnd, 256 * Rnd, 256 * Rnd)
End If
End Sub

Private Sub Timer1_Timer()
Dim i As Integer

Select Case CurX
Case Is > ScaleWidth / 2
Winkel = Winkel + Abs(CurX - ScaleWidth / 2) / 20
If Winkel = 360 Then Winkel = 0
Case Else
Winkel = Winkel - Abs(CurX - ScaleWidth / 2) / 20
If Winkel = 0 Then Winkel = 360
End Select

For i = 1 To 3 Step 2
Ecke(i, 3) = Radius * Cos((Winkel) * Pi / 180)
Ecke(i, 1) = Radius * Sin((Winkel) * Pi / 180)
Next i

For i = 2 To 4 Step 2
Ecke(i, 3) = Radius * Cos((Winkel + 2 * 45) * Pi / 180)
Ecke(i, 1) = Radius * Sin((Winkel + 2 * 45) * Pi / 180)
Next i

For i = 5 To 7 Step 2
Ecke(i, 3) = Radius * Cos((Winkel + 6 * 45) * Pi / 180)
Ecke(i, 1) = Radius * Sin((Winkel + 6 * 45) * Pi / 180)
Next i

For i = 6 To 8 Step 2
Ecke(i, 3) = Radius * Cos((Winkel + 4 * 45) * Pi / 180)
Ecke(i, 1) = Radius * Sin((Winkel + 4 * 45) * Pi / 180)
Next i

Call WuerfelDrehen
End Sub

Private Sub Combo1_Click()
Select Case Combo1.ListIndex
Case 0
renk = True
Case 1
renk = False
Me.ForeColor = vbRed
Case 2
renk = False
Me.ForeColor = vbGreen
Case 3
renk = False
Me.ForeColor = vbBlue
Case 4
renk = False
Me.ForeColor = vbYellow
Case 5
renk = False
Me.ForeColor = vbMagenta
Case 6
renk = False
Me.ForeColor = vbWhite
End Select
End Sub

Private Sub Combo2_Click()
Me.DrawWidth = Combo2.ListIndex + 1
End Sub
_______________________________________________________________________________________
Butonun Üstüne Gelince Rengi Değişşin:
`Not=Properties Bölümünden butonunun (command1) Style özelliğini 1-Graphical yapın

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.BackColor = &HC0C000
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.BackColor = &H8000000F
End Sub