ويژال بيسيك واي

چطور تسك بار را مخفي و ظاهر كنيم

براي اين كار دو تا دكمه يا كامند براي مخفي و ظاهر كردن تسك بار روي فرم بگزاريد

حالا كد زير را به فرم كپي كنيد

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Const SWP_HIDEWINDOW = &H80
Const SWP_SHOWWINDOW = &H40

Private Sub Command1_Click()
hwnd1 = FindWindow("Shell_traywnd", "")
Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW
End Sub

Private Sub Command2_Click()
Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub

حالا اگر روي دكمه اول كليك كنيد تسك بار مخفي و اگر روي دكمه دومي كليك كنيد تسك بار
ظاهر مي شود



پايان




پيدا كردن ليست تمامي سخت افزار هاي كه روي كامپيوتر شما نصب است براي شروع يك پروژه جديد

باز كرده و ابزار زير به روي فرم بگزاريد

Command1
Listbox

همان طور كه در بالا نوشتيم براي اين پروژه فقط دو ابزار لازم است يكي كامند باتون و ديگري ليست بوكس

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

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



Dim DeviceFound() As Variant
Dim DeviceList() As Variant
Dim DeviCecount As Integer
Dim ramas As Variant
Dim ramotipas As Variant
Dim PelesInt() As Variant
Dim PelesTipas() As Variant

Private isClient As Boolean
Private isClienta As Boolean
Private strUserName As String
Private strPassword As String
Private klientoID As Integer
Private webUserName As String
Private webPassword As String
Private oDeviceType() As Variant
Private oDeviceCaption() As Variant
Private oDeviceParam() As Variant
Private oDeviceInterf() As Variant
Private eilute As Integer
Private isHardware As Boolean

Private Sub Client()
Klientai.Show
End Sub


Public Sub ScanH()

List1.Clear
eilute = 0
'MSFlexGrid1
ReDim Preserve DeviceList(40)
ReDim Preserve DeviceFound(40)
DeviceListLen = 16
DeviceList = Array("Win32_FloppyDrive", "Win32_DiskDrive", "Win32_CDROMDrive", _
"Win32_Processor", _
"Win32_PhysicalMemory", _
"Win32_SoundDevice", "Win32_SCSIController", "Win32_VideoController", _
"Win32_Keyboard", _
"Win32_PointingDevice", _
"Win32_NetworkAdapter", "Win32_POTSModem", _
"Win32_InfraredDevice", _
"Win32_PCMCIAController", _
"Win32_TapeDrive", _
"Win32_PortableBattery")


strServer = Text3
isconnect = ConnectTO("root\cimv2", _
strUserName, _
strPassword, _
strServer, _
objService)
If Not isconnect Then
MsgBox "Please check the server name, " _
& "credentials and WBEM Core."

End If
DeviCecount = 0
For i = 0 To DeviceListLen - 1
Set objDeviceSet = objService.InstancesOf(DeviceList(i))
If objDeviceSet.Count <> 0 Then
DeviceFound(DeviCecount) = DeviceList(i)
DeviCecount = DeviCecount + 1
Call GetSndDevInfo(objService, DeviceList(i))
'MsgBox MSFlexGrid1.Rows
End If
Next

End Sub

Private Function ConnectTO(ByVal strNameSpace, _
ByVal strUserName, _
ByVal strPassword, _
ByRef strServer, _
ByRef objService)

On Error Resume Next

Dim objLocator, objWshNet

ConnectTO = True 'There is no error.

'Create Locator object to connect to remote CIM object manager
Set objLocator = CreateObject("WbemScripting.SWbemLocator")
If Err.Number Then
MsgBox "Error 0x" & CStr(Hex(Err.Number)) & _
" occurred in creating a locator object."
If Err.Description <> "" Then
MsgBox "Error description: " & Err.Description & "."
End If
Err.Clear
ConnectTO = False 'An error occurred
Exit Function
End If

'Connect to the namespace which is either local or remote
Set objService = objLocator.ConnectServer(strServer, strNameSpace, _
strUserName, strPassword)
objService.Security_.impersonationlevel = 3
If Err.Number Then
MsgBox "Error 0x" & CStr(Hex(Err.Number)) & _
" occurred in connecting to server " _
& strServer & "."
If Err.Description <> "" Then
MsgBox "Error description: " & Err.Description & "."
End If
Err.Clear
ConnectTO = False 'An error occurred
End If
End Function
Private Sub GetSndDevInfo(objService, strWBEMClass)

On Error Resume Next

ReDim Preserve oDeviceType(100)
ReDim Preserve oDeviceCaption(100)
ReDim Preserve oDeviceParam(100)
ReDim Preserve oDeviceInterf(100)


Set objDeviceSet = objService.InstancesOf(strWBEMClass)
'MsgBox strWBEMClass
If objDeviceSet.Count <> 0 Then
For Each Device In objDeviceSet

Select Case strWBEMClass
' GARSAS----------------------------------
Case "Win32_SoundDevice"
List1.AddItem "Sound Device" & vbTab & Device.Caption & vbTab & "" & vbTab & ""
oDeviceType(eilute) = "Sound Device"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' VIDIO-----------------------------------
Case "Win32_VideoController"
List1.AddItem "Video Controller" & vbTab & Device.Caption & vbTab & Device.AdapterRAM / 1048576 & vbTab & ""
oDeviceType(eilute) = "Video Controller"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.AdapterRAM / 1048576
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' NETWORK----------------------------------
Case "Win32_NetworkAdapter"
If (Device.NetConnectionID = "Local Area Connection") And (Device.MACAddress <> "") Then
List1.AddItem "Network Adapter" & vbTab & Device.Caption & vbTab & Device.MACAddress & vbTab & ""
oDeviceType(eilute) = "Network Adapter"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.MACAddress
oDeviceInterf(eilute) = ""
eilute = eilute + 1
End If
' KEYBOARD---------------------------------
Case "Win32_Keyboard"
List1.AddItem "Keyboard" & vbTab & vbTab & Device.Description & vbTab & "" & vbTab & ""
oDeviceType(eilute) = "Keyboard"
oDeviceCaption(eilute) = Device.Description
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' MOUSE---------------------------------
Case "Win32_PointingDevice"
List1.AddItem "Pointing Device" & vbTab & Device.Caption & vbTab & PelesTipas(Device.PointingType) & vbTab & PelesInt(Device.DeviceInterface)
oDeviceType(eilute) = "Pointing Device"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = PelesTipas(Device.PointingType)
oDeviceInterf(eilute) = PelesInt(Device.DeviceInterface)
eilute = eilute + 1
' DISK----------------------------------
Case "Win32_DiskDrive"
List1.AddItem Device.Description & vbTab & Device.Caption & vbTab & Device.Size & vbTab & Device.InterfaceType
oDeviceType(eilute) = Device.Description
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.Size
oDeviceInterf(eilute) = Device.InterfaceType
eilute = eilute + 1
' CD-ROM--------------------------------------
Case "Win32_CDROMDrive"
List1.AddItem Device.Description & vbTab & Device.Caption & vbTab & Device.Size & vbTab & ""
oDeviceType(eilute) = Device.Description
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.Size
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' SCSI------------------------------------------
Case "Win32_SCSIController"
List1.AddItem "SCSI Controller" & vbTab & Device.Caption & vbTab & "" & vbTab & ""
oDeviceType(eilute) = "SCSI Controller"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' PROCESSOR-------------------------------------
Case "Win32_Processor"
List1.AddItem Device.Role & vbTab & vbTab & Device.Name & vbTab & Device.CurrentClockSpeed & vbTab & ""
oDeviceType(eilute) = Device.Role
oDeviceCaption(eilute) = Device.Name
oDeviceParam(eilute) = Device.CurrentClockSpeed
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' MEMORY-----------------------------------------
Case "Win32_PhysicalMemory"
List1.AddItem Device.Description & vbTab & ramas(Device.FormFactor) & vbTab & Device.Capacity / 1048576 & vbTab & ramotipas(Device.MemoryType)
oDeviceType(eilute) = Device.Description
oDeviceCaption(eilute) = ramas(Device.FormFactor)
oDeviceParam(eilute) = Device.Capacity / 1048576
oDeviceInterf(eilute) = ramotipas(Device.MemoryType)
eilute = eilute + 1
' FLOPYY--------------------------------------
Case "Win32_FloppyDrive"
List1.AddItem Device.Description & vbTab & Device.Caption & vbTab & Device.MaxMediaSize & vbTab & ""
oDeviceType(eilute) = Device.Description
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.MaxMediaSize
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' MODEM------------------------------------
Case "Win32_POTSModem"
List1.AddItem "POTS Modem" & vbTab & Device.Caption & vbTab & Device.MaxBaudRateToPhone & vbTab & Device.Description
oDeviceType(eilute) = "POTS Modem"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.MaxBaudRateToPhone
oDeviceInterf(eilute) = Device.Description
eilute = eilute + 1
' INFRARED----------------------------------
Case "Win32_InfraredDevice"
List1.AddItem "Infrared Device" & vbTab & Device.Caption & vbTab & "" & vbTab & ""
oDeviceType(eilute) = "Infrared Device"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' PCMCIA ----------------------------------
Case "Win32_PCMCIAController"
List1.AddItem "PCMCIA Controller" & vbTab & Device.Caption & vbTab & "" & vbTab & ""
oDeviceType(eilute) = "PCMCIA Controller"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = ""
eilute = eilute + 1
' TAPE -------------------------------------
Case "Win32_TapeDrive"
List1.AddItem "Tape Drive" & vbTab & Device.Caption & vbTab & Device.MaxMediaSize & vbTab & Device.Description
oDeviceType(eilute) = "Tape Drive"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = Device.MaxMediaSize
oDeviceInterf(eilute) = Device.Description
eilute = eilute + 1
' BATTERY-----------------------------------
Case "Win32_PortableBattery"
List1.AddItem "Portable Battery" & vbTab & Device.Caption & vbTab & "" & vbTab & Device.Chemistry
oDeviceType(eilute) = "Portable Battery"
oDeviceCaption(eilute) = Device.Caption
oDeviceParam(eilute) = ""
oDeviceInterf(eilute) = Device.Chemistry
eilute = eilute + 1
End Select

Next
End If

End Sub


Private Sub Command1_Click()
Call ScanH

End Sub


براي اجراي برنامه وديدن ليست تمامي سخت افزار ها برنامه را اجرا كرده و روي كامند يا دكمه كليد كنيد

با كمي تخيير ليست سخت افزار ها در ليست باكسي كه گزاشتيد اضافه مي شود


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




پايان


تنظيم ميزان شفافيت فرم براي اين كار ما به ابزار اسكرول نياز داريم

vscrollbar

ابزار vscroll1 در جعبه ابزار پيش فرض ويژال موجود است ان را روي فرم بگزاريد

حالا كد زير را به فرم پيست كنيد

Option Explicit

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2

Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long

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 SetLayeredWindowAttributes Lib _
"user32" (ByVal hWnd As Long, ByVal crKey As Long, _
ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Sub Form_Load()
VScroll1.Max = 255
VScroll1.Min = 1
VScroll1.Value = 255
TranslucentForm Me, 255

End Sub

Public Function TranslucentForm(frm As Form, TranslucenceLevel As Byte) As Boolean

SetWindowLong frm.hWnd, GWL_EXSTYLE, WS_EX_LAYERED

SetLayeredWindowAttributes frm.hWnd, 0, TranslucenceLevel, LWA_ALPHA

TranslucentForm = Err.LastDllError = 0

End Function


Private Sub VScroll1_Change()
TranslucentForm Me, VScroll1.Value
End Sub



پايان



چطور ميزان شفافيت تسك بار ويندوز را تغيير دهيم

براي اين كار يك پروژه جديد باز كرده و ابزار زير را به روي فرم بگزاريد

HScrollbar

بعد از گزاشتن ابزار HScroll1 روي فرم كد زير را به فرم پيست كنيد


Private Sub Form_Load()
HScroll1.Max = 255
HScroll1.Min = 55

End Sub

Private Sub HScroll1_Change()
Dim LnLevel As Byte
LnLevel = HScroll1.Value
HScroll1 = LnLevel

SaveSetting App.EXEName, "Settings", "TransparencyLevel", HScroll1.Value

MakeTaskbarTransparent HScroll1.Value

End Sub


حالا يك ماژول Module1 به پروژه اضافه كرده و كد زير را به ماژول پيست كنيد





Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const WS_EX_TRANSPARENT = &H20&
Private Const LWA_ALPHA = &H2&
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
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 SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long


Public Sub MakeTaskbarTransparent(ByVal bLevel As Byte)
Dim lOldStyle As Long
Dim LhWnd As Long

LhWnd = FindWindow("Shell_TrayWnd", vbNullString)
If (LhWnd <> 0) Then
lOldStyle = GetWindowLong(LhWnd, GWL_EXSTYLE)
SetWindowLong LhWnd, GWL_EXSTYLE, lOldStyle Or WS_EX_LAYERED
SetLayeredWindowAttributes LhWnd, 0, bLevel, LWA_ALPHA
End If
LhWnd = FindWindow("BaseBar", vbNullString)
If (LhWnd <> 0) Then
lOldStyle = GetWindowLong(LhWnd, GWL_EXSTYLE)
SetWindowLong LhWnd, GWL_EXSTYLE, lOldStyle Or WS_EX_LAYERED
SetLayeredWindowAttributes LhWnd, 0, bLevel, LWA_ALPHA

End If

End Sub




حالا برنامه را اجرا كرده و اسكرول hscroll1 را تغيير دهيد مي بينيد كه مقدار شفافيت تسك بار كم و

زيا د مي شود



پايان



چطور يك برنامه جستجو گر فايل ها را طراحي و كد نويسي كنيم منظورم اين كه يك برنامه بنويسيم كه

مثلا تمامي فايل هاي عكس موجود در درايو ها را براي ما پيدا كند وبه نمايش در اورد و يا هر نوع فايل ديگر

كه مي خاهيد

اين پروژه يك برنامه كاملا كاربردي بوده و حتما شما به اين نوع برنامه ها نياز داريد


براي شروع ابزار زير را روي فرم بگزاريد

combobox
commandButoon
listBox
textbox
picturebox
پس ابزار كامند يا دكمه و يك ليست باكس و يك تكست بوكس و يك كوكبو بوكس روي فرم بگزاريد

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




حالا مي رسيم به كد نويسي كد هاي زير را به فرم پيست كنيد




Private Sub Command1_Click()
On Error GoTo ErrorHandler

Dim SearchPath As String, FindStr As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Screen.MousePointer = vbHourglass
List1.Clear

SearchPath = Text1.Text
FindStr = Combo1.Text
FileSize = FindFiles(SearchPath, FindStr, NumFiles, NumDirs)


Screen.MousePointer = vbDefault
ErrorHandler:
End Sub

Function FindFiles(path As String, SearchStr As String, _
FileCount As Integer, DirCount As Integer)
Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
On Error GoTo sysFileERR
If Right(path, 1) <> "\" Then path = path & "\"
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden)
Do While Len(DirName) > 0
If (DirName <> ".") And (DirName <> "..") Then
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
sysFileERRCont:
End If
DirName = Dir()
Loop
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
Or vbReadOnly)
While Len(FileName) <> 0
FindFiles = FindFiles + FileLen(path & FileName)
FileCount = FileCount + 1
List1.AddItem path & FileName
FileName = Dir()
Wend
If nDir > 0 Then
For i = 0 To nDir - 1
FindFiles = FindFiles + FindFiles(path & dirNames(i) & "\", _
SearchStr, FileCount, DirCount)
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont
Else
MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
"Unexpected Error"
Resume AbortFunction
End If
End Function

Private Sub Form_Load()
Text1.Text = "c:\"
Combo1.AddItem ("*.jpg")
End Sub

Private Sub List1_Click()
Image1.Picture = LoadPicture(List1.List(List1.ListIndex))
End Sub







تعجب نكنيد كل كد همين بود حالا بعد از اجراي نرم افزار روي دكمه جستجو كليك كنيد

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

در ليست باكس اضافه مي شود





پايان

;ويژال بيسيك 6

خالي كردن سطل اشغال با استفاده از ويژال بيسيك
در شروع يك فرم جديد ايجاد كرده و يك كامند يا دكمه نيز روي ان قرار دهيد
حالا كد زير را به فرم تون اضافه كنيد
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
كليك كنيد و يك عكس را فرا خاني كنيد مي بينيد كه اطلاعاتي در باره اون عكس در تكست باكس نوشته شده