خالي كردن سطل اشغال با استفاده از ويژال بيسيك
در شروع يك فرم جديد ايجاد كرده و يك كامند يا دكمه نيز روي ان قرار دهيد
حالا كد زير را به فرم تون اضافه كنيد
Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hWnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Const SHERB_NOPROGRESSUI = &H2

Private Sub Command1_Click()
Dim retvaL
retvaL = SHEmptyRecycleBin(Form1.hWnd, "", SHERB_NOPROGRESSUI)
End Sub

در ضمن اين برنامه اگر سطل اشغال خالي باشد كار نمي كند


پايان




شروع يك كار گرافيكي يه نگاهي هم به اين بنداز پشيمون نميشي
براي شروع يك فرم جديد باز كرده و كد زير را به ان اضافه كنيد

Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const alt = (550 / 600)

Private Sub Form_DblClick()
alpha = (ScaleWidth / Screen.TwipsPerPixelX)
beta = (ScaleWidth / Screen.TwipsPerPixelX / 2)
delta = (ScaleHeight / Screen.TwipsPerPixelY * alt)
a = 400
b = 550
start = Timer
For k = 1 To 250000
n = Rnd
If n < (1 / 3) Then
a = (a + 1) / 2
b = (b + 1) / 2
c = vbRed
ElseIf n > (1 / 3) And n < (2 / 3) Then
a = (a + alpha) / 2
b = (b + 1) / 2
c = vbGreen
Else ' n > (2 / 3) Then
a = (a + beta) / 2
b = (b + delta) / 2
c = vbYellow
End If
SetPixelV Form1.hdc, a, b, c
Next k
stopt = Timer
'MsgBox (stopt - start)
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = KeyCodeConstants.vbKeyEscape Then End
End Sub

Private Sub Form_Load()
Me.BackColor = vbBlack
Form1.BorderStyle = 0
Form1.WindowState = vbMaximized
Form1.Show
Form_DblClick
End Sub


پايان اميدوارم خوشتون اومده باشه


چطور يك اسكرول تكست ايجاد كنيم شايد متوجع نشده باشيد پس امتحان كنيد تا بفهميد
براي شروع يك پيكچر بوكس و يك تايمر روي فرم بگزاريد و حالا كد زير را به فرم اضافه كنيد



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
Const speed As Byte = 1
Dim wid%
Dim hei%
Dim dc&
Const text = " HELLO WORLD!!! "
Private Sub Form_load()
Timer1.Interval = 5
dc = Picture1.hDC
Picture1.CurrentX = 0
Picture1.CurrentY = 0
Picture1.Print text
Picture1.ScaleMode = vbPixels
wid = Picture1.TextWidth(text)
hei = Picture1.TextHeight(text)
Picture1.Width = wid * Screen.TwipsPerPixelX
Picture1.Height = hei * Screen.TwipsPerPixelY
End Sub

Private Sub Timer1_Timer()

For i = 0 To speed
BitBlt dc, wid + 1, hei + 1, 1, hei, dc, 0, 0, &HCC0020 ' &hcc0020 is equvilent to vbSrcCopy
BitBlt dc, 0, 0, wid, hei, dc, 1, 0, &HCC0020
BitBlt dc, wid, 0, 1, hei, dc, wid + 1, hei + 1, &HCC0020
Next i
Picture1.Refresh
End Sub


پايان

چطور افكت اتش را كد نويسي ايجاد كنيم
براي شروع يك پيكچر بوكس و يك تيمر روي فرم قرار داده و كد زير را به فرم اضافه كنيد


Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

Private FlameArray() As Byte
Private Frame As Integer

Const temp = 256 / 50

Private Sub Form_Load()
Timer1.Interval = 1
Picture1.AutoRedraw = True
Picture1.BackColor = vbBlack

ReDim FlameArray(0 To 50, 0 To 50) As Byte

For x = 0 To 50
For y = 46 To 50
FlameArray(x, y) = 50
Next y
Next x
On Error Resume Next

Kill "Flames.lst"
End Sub

Private Sub Timer1_Timer()
On Error Resume Next

Static x As Integer
Static y As Integer
Static Color As Integer
Static temp2 As Byte

For y = 50 To 4 Step -1

For x = 0 To 50

FlameArray(x, y) = FlameArray(x, y) - Int(Rnd * 3)

temp2 = Int(Rnd * 3)

FlameArray(x, y - temp2) = FlameArray(x, y)
Color = (Int(FlameArray(x, y) * temp))
SetPixel Picture1.hDC, x + (Rnd * 2), y, RGB(Color + Color, Color, Color / 2)

Next x

Next y


For x = 0 To 50
For y = 46 To 50
FlameArray(x, y) = 50
Next y
Next x
Picture1.Refresh


Exit Sub

Static PicName As String
Frame = Frame + 1
Label1.Caption = Frame
If Frame > 20 Then
PicName = "picflame" & (Frame - 15) & ".bmp"
SavePicture Picture1.Image, PicName
Open "Flames.lst" For Append As #1
Print #1, PicName
Close #1
End If

End Sub


پايان

چطور قبل از اجراي فرم يك فورم ابوت يا اطلاعاتي را نشان دهيم اين كار خيلي سادست ولي منظور من
نشان دادن فورم ابوت خود ويندوز است كه شما مي توانيد براي خودتان ان را كمي ويرايش كنيد
كد زير را به فرم اضافه كنيد
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long

Private Sub Form_Load()
ShellAbout Me.hwnd, "abbas", "vb 6 test about to you", 1

End Sub


پايان


ديدن اطلاعات كامل يك عكس اگه بخايم كامل تر بگيم يعني مثلا پيدا كردن نوع عكس –اندازه و يا هجم عكس و غيره براي اين كه بهتر متوجع بشين موس خودتون رو روي يك عكس ببرين و ميبينيد كه يك پوپ اپ از
اطلاعات اون عكس براي شما ضاهر مي شه ما مي خايم اين اطلاعات را به وسيله ويژال بيسيك از عكس استخراج كنيم

براي شروع يك فرم جديد باز كرده و گزينه هاي زير را روي فرم مي گزاريم
Textbox
Image
CommonDialog
براي اوردن كمند ديالونگ در ليست
Ctrl+t
دكمه كنترل تي را بزنيد و در ليست موجود گزينه زير را تيك دار كنيد
Microsoft Common Dialog Control 6.0
حالا مي بينيد كه اين گزينه نيز در ليست ابزار هاي امده است ان را با موس روي فرم درگ يا بكشيد همينطور گزينه امج را روي فرم بگزاريد و يك تكست باكس نيز روي فرم قرار دهيد
براي تكست بوكس در خصمت خصوصيات ان گزينه مالتي لاين ان را فعال كنيد

حالا برسيم به قسمت كد ها
كد ها زير را به فرم تان كپي كنيد
Private Sub Image1_Click()
CommonDialog1.ShowOpen
Image1.Picture = LoadPicture(CommonDialog1.FileName)
Dim cType As Class1
Dim strTemp As String
Dim strType As String
Set cType = New Class1
cType.FileName = CommonDialog1.FileName
cType.FileName = CommonDialog1.FileName
cType.GetImageFileInfo
If cType.TypeOfImage <> UNKNOWN Then
Text1.ForeColor = vbBlue
strType = IIf(cType.TypeOfImage = 1, "GIF", IIf(cType.TypeOfImage = JPEG, "JPEG", IIf(cType.TypeOfImage = 3, "PNG", "BMP")))
strTemp = strTemp & " File type is : " & strType & vbCrLf
strTemp = strTemp & " Height : " & cType.Height & vbCrLf
strTemp = strTemp & " Width : " & cType.Width & vbCrLf
strTemp = strTemp & " Depth : " & cType.Depth & vbCrLf
Else
Text1.ForeColor = vbRed
strTemp = strTemp & " Sorry, file's type is unknown"
End If
Text1.Text = strTemp
End Sub

حالا يك كلاس ماجول نيز بايد ايجاد كنيد براي ايجاد كلاس ما جول از منوي ماجول گزينه زير را انتخاب و اوكي كنيد
Add Class Modules
حالا كد هاي زير را كلاس ماجول كپي كنيد


Option Explicit
Public FileName As String
Public Width As Long
Public Height As Long
Public Depth As Long
Public TypeOfImage As eType
Private Const BufferSize As Long = 65535
Public Enum eType
UNKNOWN = 0
GIF = 1
JPEG = 2
PNG = 3
BMP = 4
End Enum

Public Sub GetImageFileInfo()
On Error GoTo ErrorSnap
Dim arrTemp(BufferSize) As Byte
Dim FileNumber As Integer
FileNumber = FreeFile()
Open FileName For Binary As FileNumber
Get #FileNumber, 1, arrTemp()
Close FileNumber
If arrTemp(0) = 137 And arrTemp(1) = 80 And arrTemp(2) = 78 Then
TypeOfImage = PNG
Select Case arrTemp(25)
Case 0
Depth = arrTemp(24)
Case 2
Depth = arrTemp(24) * 3
Case 3
Depth = 8
Case 4
Depth = arrTemp(24) * 2
Case 6

Depth = arrTemp(24) * 4
Case Else
TypeOfImage = UNKNOWN
End Select

If TypeOfImage Then
Width = arrTemp(19) + arrTemp(18) * 256
Height = arrTemp(23) + arrTemp(22) * 256
End If

End If

If arrTemp(0) = 71 And arrTemp(1) = 73 And arrTemp(2) = 70 Then
TypeOfImage = GIF
Width = arrTemp(6) + arrTemp(7) * 256
Height = arrTemp(8) + arrTemp(9) * 256
Depth = (arrTemp(10) And 7) + 1
End If

If arrTemp(0) = 66 And arrTemp(1) = 77 Then
TypeOfImage = BMP

Width = arrTemp(18) + arrTemp(19) * 256

Height = arrTemp(22) + arrTemp(23) * 256
Depth = arrTemp(28)
End If

If TypeOfImage = UNKNOWN Then
Dim lngStep As Long
Do
If (arrTemp(lngStep) = &HFF And arrTemp(lngStep + 1) = &HD8 _
And arrTemp(lngStep + 2) = &HFF) Or (lngStep >= BufferSize - 10) Then Exit Do
lngStep = lngStep + 1
Loop

lngStep = lngStep + 2
If lngStep >= BufferSize - 10 Then Exit Sub
Do
Do
If arrTemp(lngStep) = &HFF And arrTemp(lngStep + 1) <> &HFF Then Exit Do
lngStep = lngStep + 1
If lngStep >= BufferSize - 10 Then Exit Sub
Loop
lngStep = lngStep + 1

Select Case arrTemp(lngStep)
Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, &HCD To &HCF

Exit Do
End Select

lngStep = lngStep + (arrTemp(lngStep + 2) + arrTemp(lngStep + 1) * 256)
If lngStep >= BufferSize - 10 Then Exit Sub
Loop

TypeOfImage = JPEG

Height = arrTemp(lngStep + 5) + arrTemp(lngStep + 4) * 256

Width = arrTemp(lngStep + 7) + arrTemp(lngStep + 6) * 256

Depth = arrTemp(lngStep + 8) * 8
End If
Exit Sub
ErrorSnap:
MsgBox " Error occurs : " & Err.Description
End Sub


Private Sub Class_Initialize()
Height = 0
Width = 0
Depth = 0
TypeOfImage = UNKNOWN
End Sub

كد نويسي به پايان رسيد براي ازمايش روي
Image1
كليك كنيد و يك عكس را فرا خاني كنيد مي بينيد كه اطلاعاتي در باره اون عكس در تكست باكس نوشته شده