Change Color Of Pixel In PictureBox

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 CommandButton (named Command1) to your form, And 1 PictureBox
'(Named Picture1). If you want You can put picture in the picturebox. Set the
'PictureBox AutoRedraw property to True.
'Insert this code to the module :

Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, _
ByVal Y As Long, ByVal crColor As Long) As Long

'Insert the following code to your form:

Private Sub Command1_Click()
Dim s As Long
'Replace the '10,10' below with the position of the pixel you want to change its color.
'Replace the RGB(255, 0, 0) with the color you want to assign to this pixel.
'RGB(255, 0, 0) is red color.
s = SetPixel(Picture1.hdc, 10, 10, RGB(255, 0, 0))
Picture1.Refresh
End Sub

Make 3D Rotating Cube

'Add 1 Picture Box and 1 Timer Control to your form.
'At Run-Time, Move the mouse to change the rotation speed and direction..
'Insert the following code to your form:

Private X(8) As Integer
Private y(8) As Integer
'Integer arrays that hold the actual 2D coordinates of the
'8 corners of the cube.These are the values used to plot
'the cube on the form after the X,Y,Z coordinates of each cube
'corner have been converted to 2 dimensinal X and Y coordinates.
Private Const Pi = 3.14159265358979
'Constant used to convert degrees to radians
Private CenterX As Integer
Private CenterY As Integer
'The center of the 3 dimensional plane,where it's
'X=0 , Y=0 , Z=0
Private Const SIZE = 250
'The length of the cube achmes,therefore also adjusts the overall size.
Private Radius As Integer
'The radius of the rotation.Each one of the 8 corners of the cube
'rotates around the vertical Y axis with the same angular speed and radius
'of rotation.
Private Angle As Integer
'The value of this variable loops from 0 to 360 and it is passed
'as an argument to the COS and SIN functions (sine and cosine)
'that return the changing Z and X coordinates of each corner
'as the cube rotates around the Y axis
Private CurX As Integer
Private CurY As Integer
'Variables that hold the current mouse position on the form.
Private CubeCorners(1 To 8, 1 To 3) As Integer
'The array that holds the X,Y and Z coordinates of the 8 corners
'The center of the 3D plane is right on the center of the cube.
'So ,if SIZE the length of one achmes,it's:
'CenterCube(1,1) = SIZE/2 ' X coordinate of 1st corner
'CenterCube(1,2) = SIZE/2 ' Y coordinate
'CenterCube(1,3) = SIZE/2 ' Z coordinate
'Actually,we only need to give a value for the Y coordinates
'of each corner since that will never change during the rotation
'as all corners rotate around the Y axis ,with only their Z and X
'coordinates changing periodically.
Private Sub Form_Load()
Me.ScaleMode = 3
Picture1.ScaleMode = 3
Timer1.Interval = 1
'Set here the cube Width and color.
Me.ForeColor = vbBlue
Me.DrawWidth = 3
Picture1.AutoRedraw = True
Show
Picture1.Height = Picture1.Width
Picture1.Move ScaleWidth / 2 - Picture1.ScaleWidth / 2, Picture1.Height
CenterX = ScaleWidth / 2
CenterY = ScaleHeight / 2
'Set the center of the 3D plane to reflect the center of the form.
Angle = 0
Radius = Sqr(2 * (SIZE / 2) ^ 2)
'Give a value to the radius of the rotation.This is
'the Pythagorean theorem that returns the length of the
'hypotenuse of a right triangle as the square root
'of the sum of the other two sides raised to the 2nd power.
CubeCorners(1, 2) = SIZE / 2
CubeCorners(2, 2) = SIZE / 2
CubeCorners(3, 2) = -SIZE / 2
CubeCorners(4, 2) = -SIZE / 2
CubeCorners(5, 2) = SIZE / 2
CubeCorners(6, 2) = SIZE / 2
CubeCorners(7, 2) = -SIZE / 2
CubeCorners(8, 2) = -SIZE / 2
'Assign a value to the Y coordinates of each cube.This
'will never change through out the rotation since the cube
'rotates around the Y axis.Play around with these if you like
'but the 3D prism will no longer resemble a cube...
End Sub

Private Sub DrawCube()
Cls
For i = 1 To 8
X(i) = CenterX + CubeCorners(i, 1) + CubeCorners(i, 3) / 8
y(i) = CenterY + CubeCorners(i, 2) + Sgn(CubeCorners(i, 2)) * CubeCorners(i, 3) / 8
'These two lines contain the algorith that converts the
'coordinates of a point on the 3D plane (x,y,z) ,into 2
'dimensional X and Y coordinates that can be used to plot
'a point on the form.Play around with the 8's and see what happens...
Next
Line (X(3), y(3))-(X(4), y(4))
Line (X(4), y(4))-(X(8), y(8))
Line (X(3), y(3))-(X(7), y(7))
Line (X(7), y(7))-(X(8), y(8))
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(8), y(8))
Line (X(2), y(2))-(X(4), y(4))
Line (X(2), y(2))-(X(6), y(6))
Line (X(1), y(1))-(X(4), y(4))
Line (X(2), y(2))-(X(3), y(3))
Line (X(4), y(4))-(X(8), y(8))
Line (X(3), y(3))-(X(7), y(7))
'The plotting of the cube onto the form.
'We have to draw each achmes seperately and then
' "connect" the bottom square with the top square.
DoEvents
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
CurX = X
CurY = y
'Store the current position of the mouse cursor into
'the variable CurX,CurY.
End Sub

Private Sub Timer1_Timer()
Select Case CurX
Case Is > ScaleWidth / 2
Angle = Angle + Abs(CurX - ScaleWidth / 2) / 20
If Angle = 360 Then Angle = 0
Case Else
Angle = Angle - Abs(CurX - ScaleWidth / 2) / 20
If Angle = 0 Then Angle = 360
End Select
'Change the direction and the angular speed of the rotation
'according to the position of the mouse cursor.If it's near
'the left edge of the form then the rotation will be
'anti-clockwise ,it's near the right edge it will be
'clockwise. The closer to the center of the form the
'cursor is,the slower the cube rotates.
'The angular speed of the rotation is controlled by the
'pace at which 'Angle' (the value that we pass to the
'(COS and SIN functions) increases or decreases (increases
'for anti-clockwise rotation and decreases for clockwise rotation).
For i = 1 To 3 Step 2
CubeCorners(i, 3) = Radius * Cos((Angle) * Pi / 180)
CubeCorners(i, 1) = Radius * Sin((Angle) * Pi / 180)
Next
For i = 2 To 4 Step 2
CubeCorners(i, 3) = Radius * Cos((Angle + 2 * 45) * Pi / 180)
CubeCorners(i, 1) = Radius * Sin((Angle + 2 * 45) * Pi / 180)
Next
For i = 5 To 7 Step 2
CubeCorners(i, 3) = Radius * Cos((Angle + 6 * 45) * Pi / 180)
CubeCorners(i, 1) = Radius * Sin((Angle + 6 * 45) * Pi / 180)
Next
For i = 6 To 8 Step 2
CubeCorners(i, 3) = Radius * Cos((Angle + 4 * 45) * Pi / 180)
CubeCorners(i, 1) = Radius * Sin((Angle + 4 * 45) * Pi / 180)
Next
'Give the new values to the X and Z coordinates of each one
'of the 8 cube corners by using the COS and SIN mathematical
'functions.Notice that corners 1 and 3 always have the same
'X and Z coordinates, as well as 2 and 4, 5 and 7,6 & 8.
'Take a look at the little scetch on the top of the form
'to see how this is explained (imagine the cube rotating
'around the Y axis)
DrawCube
End Sub

Draw 3D Text On Form

Preparations
Add 1 Command Button to your form.
Press the button to draw the text.

Form Code

Private Sub Command1_Click()

Me.AutoRedraw = True
' you can change the font size and type.
Me.FontSize = 30
Dim ShadowX
Dim ShadowY
ScaleMode = 3
ForeColor = "&H808080"
ShadowY = 5
ShadowX = 5
For i = 0 To 5
CurrentX = ShadowX + i
CurrentY = ShadowY + i
If i = 5 Then Form1.ForeColor = vbWhite
Form1.Print "VBTown!!!"
Next

End Sub

Extract Associated Icon From EXE File

'This example will show you how to extract icon from EXE file. The file has to be file that
'his associate files (the files that opens with him) got his icon. For example the file
'winamp.exe that when it's installed in your computer, all the mp3 files will get his icon.
'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 PictureBox (named Picture1) to your form.
'Insert this code to the module :

Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As _
Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal _
hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

'Insert this code to your form:

Private Sub Form_Load()
Dim Path As String, strSave As String
Dim returnl As Long, return2 As Long
strSave = String(200, Chr$(0))
Picture1.AutoRedraw = True
'Replace 'c:\windows\regedit.exe' with the name of the file that
'you want to extract his icon.
return1 = ExtractIcon(Me.hWnd, "c:\windows\regedit.exe", 2)
return2 = DrawIcon(Picture1.hdc, 0, 0, return1)
End Sub

Capture Screen Image

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 CommandButton (named Command1) to your form.
'Add 1 PictureBox (named Picture1) to your form. Enlarge the PictureBox and make it wide.
'When you will press the button, the program will capture the screen image, and draw
'it in the PictureBox.
'Insert the following code to the module :

Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Integer, ByVal x As _
Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, _
ByVal hSrcDC As Integer, ByVal xSrc As Integer, ByVal ySrc As Integer, _
ByVal dwRop As Long) As Integer
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Const SRCCOPY = &HCC0020
Public Const SRCAND = &H8800C6
Public Const SRCINVERT = &H660046

'Insert the following code to your form:

Private Sub Command1_Click()
Dim DeskhWnd As Long, DeskDC As Long
DeskhWnd& = GetDesktopWindow()
DeskDC& = GetDC(DeskhWnd&)
'If you want to draw the captured image on the form rather than the PictureBox,
'replace the 'Picture1' below with the name of the form.
BitBlt Picture1.hDC, 0&, 0&, Screen.Width, Screen.Height, DeskDC&, 0&, 0&, SRCCOPY
End Sub

Drag Picture File To Picture Box And Display The Picture

If you will drag the file mypic.gif from Windows to the picture box, the picture will be displayed within the picture box.

Preparations
Add 1 Picture Box to your form.
Set the Picture Box OLEDropMode Property to 1 - manual.

Form Code

Private Sub Picture1_OLEDragDrop(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo Err
Picture1.Picture = LoadPicture(Data.Files(1))
Exit Sub
Err:
MsgBox "The Picture you dragged could not be loaded"
End Sub

Get Image Dimensions

Get the dimensions of any image file that can be loaded into an Image box.

Preparations
Add 1 Image Box to your form.
Set the Image Box Stretch property to false and the Visible property to false.

Form Code

Private Sub Form_Load()
Image1.Picture = LoadPicture("c:\mypic.gif")
'You will get the image dimensions in pixels. to get them in Twips scale, remove
' the "/ Screen.TwipsPerPixelY" and "/ Screen.TwipsPerPixelX" below.
MsgBox "Image Height: " & Image1.Height / Screen.TwipsPerPixelY & _ " Image width: " & Image1.Width / Screen.TwipsPerPixelX
End Sub

Export BMP File To Icon File

Preparations
Add 1 ImageList Control to your form.

Form Code
Private Sub Form_Load()
' Load the picture into the ImageList. replace "d:\myDir\File.bmp"
' with the BMP file name you want to export.
ImageList1.ListImages.Add , , LoadPicture("d:\myDir\File.bmp")
' Save the icon file. replace "d:\myDir2\File2.ico" with the new Icon
' file you want to create.
SavePicture ImageList1.ListImages(1).ExtractIcon, "d:\myDir2\File2.ico"
End Sub

Make A Pop Up Color Selector

Preparations

Add 1 Common Dialog Control to your form (From VB menu choose Project->Components..., then mark the Microsoft Common Dialog Control check box, and press OK. Now drag the new control to your form).

Form Code

Private Sub Command1_Click()
' The following line says: if the user will press the cancel Button,
' treat it like if an error occurred in the program.
CommonDialog1.CancelError = True
' If an error occurred in the program, jump to the
' CancelPressed part of the program, below.
On Error GoTo CancelPressed
' Pop up the Color Selector
CommonDialog1.ShowColor
' Paint the from with the chosen color.
' CommonDialog1.Color holds the color that the user has selected.
Form1.BackColor = CommonDialog1.Color
' exit the Command1_Click() sub
Exit Sub
CancelPressed:
' If the user pressed the cancel button an error was occurred, and
' the program had jumped to here.
' if the user didn't press the cancel button, the program doesn't apply this
' lines because it already has exited this sub from the "Exit Sub" line above
MsgBox "You pressed Cancel"
End Sub

Copy List Box Content To Another List Box\Combo Box

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 2 List Boxes, 1 Combo Box and 2 Command Buttons to your form.
'Add few Items to List1. At Run-Time press the first button to copy List1 content to List2.
'And press The second button to copy List1 content to Combo1.

'Insert the following code to your module:

Public Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As String) As Long

Public Declare Function SendMessageLong Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

'Insert the following code to your form:

Private Sub Command1_Click()
Dim success As Long
success = CopyListToList(List1, List2)
End Sub

Private Sub Command2_Click()
Dim success As Long
success = CopyListToCombo(List1, Combo1)
If success Then Combo1.ListIndex = 0
End Sub

Private Function CopyListToList(source As ListBox, target As ListBox) As Long
Dim c As Long
Const LB_GETCOUNT = &H18B
Const LB_GETTEXT = &H189
Const LB_ADDSTRING = &H180

'get the number of items in the list

Dim numitems As Long
Dim sItemText As String * 255

'get the number of items in the source list

numitems = SendMessageLong(source.hWnd, LB_GETCOUNT, 0&, 0&)

'if it has contents, copy the items

If numitems > 0 Then
For c = 0 To numitems - 1
Call SendMessageStr(source.hWnd, LB_GETTEXT, c, ByVal sItemText)
Call SendMessageStr(target.hWnd, LB_ADDSTRING, 0&, ByVal sItemText)
Next
End If

'get the number of items in the target list and return that as the function value

numitems = SendMessageLong(target.hWnd, LB_GETCOUNT, 0&, 0&)
CopyListToList = numitems
End Function

Private Function CopyListToCombo(source As ListBox, target As ComboBox) As Long
Dim c As Long
Const LB_GETCOUNT = &H18B
Const LB_GETTEXT = &H189
Const CB_GETCOUNT = &H146
Const CB_ADDSTRING = &H143

'get the number of items in the list

Dim numitems As Long
Dim sItemText As String * 255

'get the number of items in the source list

numitems = SendMessageLong(source.hWnd, LB_GETCOUNT, 0&, 0&)

'if it has contents, copy the items

If numitems > 0 Then
For c = 0 To numitems - 1
Call SendMessageStr(source.hWnd, LB_GETTEXT, c, ByVal sItemText)
Call SendMessageStr(target.hWnd, CB_ADDSTRING, 0&, ByVal sItemText)
Next
End If

'get the number of items in the target combo and return that as the function value

numitems = SendMessageLong(target.hWnd, CB_GETCOUNT, 0&, 0&)
CopyListToCombo = numitems
End Function

Make Editable List Box

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Command Button, 1 List Box and 1 Text Box to your form.
'Insert the following code to your module:

Option Explicit
DefLng A-Z

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

Type SIZE
cx As Long
cy As Long
End Type

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Declare Function GetTextExtentPoint32 Lib "gdi32" Alias _
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal _
cbString As Long, lpSize As SIZE) As Long
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
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
ByVal hdc As Long) As Long

Public Const WM_SETREDRAW = &HB&
Public Const WM_SETFONT = &H30
Public Const WM_GETFONT = &H31
Public Const LB_GETITEMRECT = &H198
Public Const LB_ERR = (-1)
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOZORDER = &H4
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_FRAMECHANGED = &H20
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOOWNERZORDER = &H200
Public Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Public Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SM_CXEDGE = 45
Public Const SM_CYEDGE = 46
Public Function Max(ByVal param1 As Long, ByVal param2 As Long) As Long
If param1 > param2 Then Max = param1 Else Max = param2
End Function

'Insert the following code to your form:
Option Explicit
DefLng A-Z
Private m_bEditing As Boolean
Private m_lngCurrIndex As Long

Private Sub Command1_Click()
If Not m_bEditing Then Editing = True
End Sub

Private Sub Form_Load()
Me.ScaleMode = 3
Text1.Visible = False
Text1.Appearance = 0
Command1.Caption = "Press F2 to edit"
Dim a%
For a% = 1 To 10
List1.AddItem "Item number " & a%
Next a%
Set Text1.Font = List1.Font
End Sub

Private Sub List1_KeyUp(KeyCode As Integer, Shift As Integer)
If ((KeyCode = vbKeyF2) And (Shift = 0)) Then
If (Not m_bEditing) Then Editing = True
End If
End Sub

Private Sub Text1_LostFocus()
'If the textbox looses focus and we're editing, restore the text
'and cancel the edit
If m_bEditing = True Then
List1.List(m_lngCurrIndex) = Text1.Tag
Editing = False
End If
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim strText As String
If KeyAscii = 10 Or KeyAscii = 13 Then
If Len(Trim$(Text1.Text)) = 0 Then
List1.List(m_lngCurrIndex) = Text1.Tag
Else
strText = Text1.Text
'assign the new text to the item
List1.List(m_lngCurrIndex) = strText
End If
Editing = False 'return to the old state
KeyAscii = 0 'avoid a beep

ElseIf KeyAscii = 27 Then 'pressed Esc to cancel the edit
List1.List(m_lngCurrIndex) = Text1.Tag 'restore the original text
Editing = False
KeyAscii = 0 'avoid a beep
End If
End Sub

Private Sub Text1_GotFocus()
'select all the text
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub

Private Sub Text1_Change()
Dim lpSize As SIZE
Dim phDC As Long

'adjust the size of the textbox depending on the calculated
'size of the text it contains (or 50 pixels, whatever is greater)
'note that the extent calculation fails (for some reason) when the
'font is over 14 points, but if you have a listbox with a 14 point
'font then you need some redesign there

phDC = GetDC(Text1.hwnd)
If GetTextExtentPoint32(phDC, Text1.Text, Len(Text1.Text), lpSize) = 1 Then
Text1.Width = Max(50, lpSize.cx)
End If
Call ReleaseDC(Text1.hwnd, phDC)
End Sub

Private Property Let Editing(vData As Boolean)
Dim rcItem As RECT 'RECT of the item being edited
Dim strText As String 'text of the item beign edited
Dim lpSize As SIZE 'uset to calculate the size of the textbox
Dim phDC As Long 'hDC of the listbox
On Error Resume Next

'Get the current index...

m_lngCurrIndex = List1.ListIndex

'...and split if there's no index

If m_lngCurrIndex = -1 Then Beep: Exit Property

'are we starting an edit?

If vData = True Then
strText = List1.List(m_lngCurrIndex)
If Len(strText) = 0 Then Beep: Exit Property

'try to get the RECT of the item within the list

If SendMessage(List1.hwnd, LB_GETITEMRECT, ByVal m_lngCurrIndex, rcItem) _
<> LB_ERR Then

'adjust the RECT to makeup. Note that these are client window coordinates
'That is, the RECT is in relation to the list's parent window.
'We also take into consideration the 3-D border, so remove the call to
'GetSystemMetrics() if the listbox's appearance is "flat"

With rcItem
.Left = .Left + List1.Left + GetSystemMetrics(SM_CXEDGE)
.Top = List1.Top + .Top

'why not a call to GetSysMetrics and the SM_CYEDGE?
'because we want the textbox to pop up centered over
'the list item, not flush with the top.

'Get the DC of the listbox and calculate the height and width of the
'Note that the extent calculation fails (for some reason) when the
'font is over 14 points.

phDC = GetDC(Text1.hwnd)
Call GetTextExtentPoint32(phDC, strText, Len(strText), lpSize)
Call ReleaseDC(Text1.hwnd, phDC)

'position and show the textbox, bring it to the top of the Z order.

Call SetWindowPos(Text1.hwnd, HWND_TOP, .Left, .Top, Max(50, lpSize.cx), _
lpSize.cy + 2, SWP_SHOWWINDOW Or SWP_NOREDRAW)
End With

'setting the List property of the listbox causes too
'much flashing, so turn off redrawing

Call SendMessage(List1.hwnd, WM_SETREDRAW, 0, ByVal 0&)
List1.List(m_lngCurrIndex) = ""

'save the item's text and set the focus to the textbox

With Text1
.Enabled = True
.Tag = strText
.Text = strText
.SetFocus
End With
End If
Else

'set the redraw flag so that the listbox updates itself

Call SendMessage(List1.hwnd, WM_SETREDRAW, 1, ByVal 0&)

'Get rid of the textbox and clear it

With Text1
.Enabled = False
.Visible = False
.Move 800, 800
.Text = ""
.Tag = ""
End With
m_lngCurrIndex = -1 'invalidate this for next time
End If

'save the current state

m_bEditing = vData
End Property

Scan ListBox For The Text In TextBox

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Text Box and 1 List Box to your form. Add few items to the List Box.
'If you will type 'a' in the Text Box, the first item beginning with 'a' will be marked.

'Insert this code to the module :

Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As _
Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Public Const LB_FINDSTRING = &H18F

'Insert this code to your form:

Private Sub Text1_Change()
List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, ByVal CStr(Text1.Text))
End Sub

Quick Select/UnSelect All Items In List Box

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 List Box and 2 Command Buttons to your form.
'Set List1 MultiSelect property to 1-Simple.
'Insert the following code to your module:

Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const LB_SETSEL = &H185&

'Insert the following code to your form:

Private Sub Command1_Click()
Call SendMessageLong(List1.hwnd, LB_SETSEL, True, -1)
End Sub

Private Sub Command2_Click()
Call SendMessageLong(List1.hwnd, LB_SETSEL, False, -1)
End Sub

Sub Form_Load()
'add this code to the form load to fill
'List1 with some (15) of the system's
'screen fonts.
Dim i As Integer
Dim max As Integer
max = Screen.FontCount
If max > 15 Then max = 15
For i = 1 To max
List1.AddItem Screen.Fonts(i)
Next
End Sub

Move Multiple Items From One List Box To Other List Box/Combo Box

Preparations

Add 2 List Boxes and 1 Command Button to your form.
Set List1 MultiSelect property to 1 - Simple.

Form Code

Private Sub Command1_Click()
'if List1 is empty - exit, to avoid error
If List1.ListCount = 0 Then Exit Sub
Dim CurItem As Integer
CurItem = 0
Do
'if the item is selected
If List1.Selected(CurItem) Then
'add it to the second List Box. If you want to add it to Combo Box,
'change the "List2" below with your combo Box name
'for example: Combo1.AddItem List1.List(CurItem)
List2.AddItem List1.List(CurItem)
'and delete it from List1 List Box
List1.RemoveItem (CurItem)
Else
CurItem = CurItem + 1
End If
Loop Until CurItem = List1.ListCount
End Sub
Private Sub Form_Load()
'add few items to the List Box
For i = 1 To 10
List1.AddItem "Item " & i
Next
End Sub

Ask For Confirmation Before Exit Progarm

When the user will try to end this program by clicking the X button, by pressing Alt + F4, or by any other way, a message box will pop up and will ask him for confirmation.

Form Code

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim Answer As Integer
Answer = MsgBox("Are you sure you want to exit this program?", _
vbQuestion + vbYesNo, "Confirmation")
If Answer = vbNo Then Cancel = -1
End Sub

Launch URL With Default Browser

'Add 1 CommandButton to your form (named Command1),'To launch URL with default browser press the button.'Insert the following code to your form:

Private Sub Command1_Click()
'Replace http://www.yahoo.com with the URL you want to launch.
'You can replace 'vbHide' with following settings, according to in which state
'you want to open the browser :
'vbHide ; vbMaximizedFocus ; vbMinimizedFocus ;vbMinimizedNoFocus ;
'vbNormalFocus ; vbNormalNoFocus
RetVal = SHELL("Start.exe http://www.yahoo.com", vbHide)
End Sub

Print File

Preparations

Add 1 Text Box to your form. Set the Text Box's MultiLine property to True, and the Text Box's Visible property to False.

Form Code

Private Sub Form_Load()
Dim file As String

'Replace 'c:\autoexec.bat' with the file you want to print
file = "c:\autoexec.bat"
Open file For Input As #1
Text1.Text = Input(LOF(1), #1)
Close
Printer.Print Text1.Text
Printer.EndDoc

End Sub

Browse And Preview Installed Fonts

'Add 1 List Box to your form. The List Box will be populated with all installed fonts.
'When you click on one of the fonts, the List Box will change its font to the clicked font.

'Insert this code to your form:

Private Sub Form_Load()
Dim counter As Integer
For counter = 0 To Screen.FontCount - 1
List1.AddItem Screen.Fonts(counter)
Next
End Sub

Private Sub List1_Click()
Static tempheight As Single
If tempheight = 0 Then tempheight = List1.Height
List1.Font.Name = List1.List(List1.ListIndex)
List1.Height = tempheight
End Sub

Add New Font Temporary

Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
Add 1 Command Button to your form.

Insert this code to the module :

Declare Function AddFontResource& Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String)
Declare Function RemoveFontResource& Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String)

'Insert this code to your form:

Private Sub Command1_Click()
Dim retvalue As Long
'Replace all 'MyFont' below with your font file.
retvalue = RemoveFontResource("c:\MyFont.ttf")
Command1.Caption = "uninstall"
End Sub
Private Sub Form_Load()
Dim retvalue As Long
Command1.Caption = "uninstall"
retvalue = AddFontResource("c:\MyFont.ttf")
Command1.FontName = "MyFont"
End Sub

Get MP3 File Tag Info

'Insert the following code to your form:

Private Sub Form_Load()
Dim fNum As Integer
Dim sTagIdent As String * 3
Dim sTitle As String * 30
Dim sArtist As String * 30
Dim sAlbum As String * 30
Dim sYear As String * 4
Dim sComment As String * 30
fNum = FreeFile
'Replace 'c:\MySong.mp3' with the name of the MP3 file that you want to get its info.
Open "c:\MySong.mp3" For Binary As fNum
Seek #fNum, LOF(fNum) - 127
Get #fNum, , sTagIdent
If sTagIdent = "TAG" Then
Get #fNum, , sTitle
Get #fNum, , sArtist
Get #fNum, , sAlbum
Get #fNum, , sYear
Get #fNum, , sComment
End If
Close #fNum
MsgBox sTitle & "," & sArtist & "," & sAlbum & "," & sYear & "," & sComment
End Sub

Hide Your Program From The Ctrl-Alt-Del Process List

Add 2 Command Buttons to your form.Press the first to hide you program, and the second to show it again.

Module Code

Public Const RSP_SIMPLE_SERVICE = 1

Public Const RSP_UNREGISTER_SERVICE = 0
Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID _As Long, ByVal dwType As Long) As Long

Form Code

Public Sub HideApp(Hide As Boolean)
Dim ProcessID As Long
ProcessID = GetCurrentProcessId()
If Hide Then
retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)
Else
retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)
End If
End Sub

Private Sub Command1_Click()
HideApp (True)
End Sub

Private Sub Command2_Click()
HideApp (False)
End Sub

Detect If Sound Card Can Play Sound Files

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)

'Insert this code to the module :

Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long

'Insert this code to your form:

Private Sub Form_Load()

Dim I As Integer

I = waveOutGetNumDevs()

If I > 0 Then

MsgBox "Your system can play sound files."

Else

MsgBox "Your system can not play sound files."

End If

End Sub

Retrieve The Length Of WAV, AVI And MIDI Files

Module Code

Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" (ByVal _ lpstrCommand As String, ByVal lpstrReturnString As String, _ ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Form Code

Function GetMediaLength(FileName As String)
Dim MediaLength As Long
Dim RetString As String * 256
Dim CommandString As String

'open the media file
CommandString = "Open " & FileName & " alias MediaFile"
mciSendString CommandString, vbNullString, 0, 0&

'get the media file length
CommandString = "Set MediaFile time format milliseconds"
mciSendString CommandString, vbNullString, 0, 0&
CommandString = "Status MediaFile length"
mciSendString CommandString, RetString, Len(RetString), 0&
GetMediaLength = CLng(RetString)

'close the media file
CommandString = "Close MediaFile"
mciSendString CommandString, vbNullString, 0, 0&

End Function

Private Sub Form_Load()

Dim Seconds, Minutes As Integer
Dim MilliSeconds As Long
' replace "c:\my_media_file.wav" with the path to your media file
MilliSeconds = GetMediaLength("c:\my_media_file.wav")
' the function GetMediaLength return the media length in milliseconds,
' so we will calculate the total minutes and seconds
Seconds = Int(MilliSeconds / 1000) Mod 60
Minutes = Int(MilliSeconds / 60000)
MilliSeconds = MilliSeconds Mod 1000

TotalTime = Minutes & ":" & Seconds & ":" & MilliSeconds
MsgBox (TotalTime)

End Sub

Play AVI File

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open) Add 2 CommandButtons to your form (named Command1 and Command2). When you press the first button the AVI movie will start to play. Even after the AVI Finish playing, it is still takes memory. To remove it from the memory press the second button.

'Insert this code to the module :

Declare Function mciSendString Lib "winmm.dll" Alias _"mciSendStringA" (ByVal lpstrCommand As String, ByVal _lpstrReturnString As String, ByVal uReturnLength As Long, _ByVal hwndCallback As Long) As Long

'Insert the following code to your form:

Private Sub Command1_Click()
Dim returnstring As String
Dim FileName As String
returnstring = Space(127)
'Replace c:\MyMovie.avi with the AVI file you want to play
FileName = "c:\MyMovie.avi"
erg = mciSendString("open " & Chr$(34) & FileName & _
Chr$(34) & " type avivideo alias video", returnstring, 127, 0)
erg = mciSendString("set video time format ms", returnstring, 127, 0)
erg = mciSendString("play video from 0", returnstring, 127, 0)
End Sub

Private Sub Command2_Click()
erg = mciSendString("close video", returnstring, 127, 0)
End Sub

Play MIDI Files

Add a module to your project (In the menu choose Project -> Add Module, Then click Open) Add 2 CommandButtons to your form (named Command1 and Command2). When you press the first button the Midi File will start playing. When you press the second button the Midi File will stop playing.

Insert this code to the module :

Declare Function mciSendString Lib "winmm.dll" Alias _"mciSendStringA" (ByVal lpstrCommand As String, _ByVal lpstrReturnString As String, ByVal uReturnLength _As Long, ByVal hwndCallback As Long) As Long

Insert the following code to your form:

Public Sub StopMIDI(MidiFileName As String)
Call mciSendString("stop " + MidiFileName, 0&, 0, 0)
Call mciSendString("close " + MidiFileName, 0&, 0, 0)
End Sub

Function PlayMIDI(MidiFileName As String)
On Error Resume Next
Call mciSendString("open " + MidiFileName + " type sequencer", 0&, 0, 0)
If mciSendString("play " + MidiFileName + Flags, 0&, 0, 0) = 0 Then
PlayMIDI = 0
Else
PlayMIDI = 1
End If
End Function
Private Sub Command1_Click()
'Replace c:\mydir\song1.mid with the Midi file name you want to play
PlayMIDI ("c:\mydir\song1.mid")
End Sub

Private Sub Command2_Click()
'Replace c:\mydir\song1.mid with the Midi file name you want to stop
StopMIDI ("c:\mydir\song1.mid")
End Sub

Make a CD Player

'Add Class Module to your project (In the menu choose Project -> Add Class Module, Then click Open). Change the Class Module name to CDAudio (In the Project Explorer press on Class1 and press F4). Add 14 Command Buttons and 2 Text Boxes to your form. Insert into Text1 the track number to play. Insert into Text2 the Rewind\FastForward speed.

'Insert the following code to your Class Module :


Private Declare Function mciGetErrorString Lib "winmm.dll" Alias _
"mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, _
ByVal uLength As Long) As Long
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal _
uReturnLength As Long, ByVal hwndCallback As Long) As Long

Function StartPlay()
mciSendString "play cd", 0, 0, 0
End Function

Function SetTrack(Track%)
mciSendString "seek cd to " & Str(Track), 0, 0, 0
End Function

Function StopPlay()
mciSendString "stop cd wait", 0, 0, 0
End Function

Function PausePlay()
mciSendString "pause cd", 0, 0, 0
End Function

Function EjectCD()
mciSendString "set cd door open", 0, 0, 0
End Function

Function CloseCD()
mciSendString "set cd door closed", 0, 0, 0
End Function

Function UnloadAll()
mciSendString "close all", 0, 0, 0
End Function

Function SetCDPlayerReady()
mciSendString "open cdaudio alias cd wait shareable", 0, 0, 0
End Function

Function SetFormat_tmsf()
mciSendString "set cd time format tmsf wait", 0, 0, 0
End Function

Function SetFormat_milliseconds()
mciSendString "set cd time format milliseconds", 0, 0, 0
End Function

Function CheckCD$()
Dim s As String * 30
mciSendString "status cd media present", s, Len(s), 0
CheckCD = s
End Function

Function GetNumTracks%()
Dim s As String * 30
mciSendString "status cd number of tracks wait", s, Len(s), 0
GetNumTracks = CInt(Mid$(s, 1, 2))
End Function

Function GetCDLength$()
Dim s As String * 30
mciSendString "status cd length wait", s, Len(s), 0
GetCDLength = s
End Function

Function GetTrackLength$(TrackNum%)
Dim s As String * 30
mciSendString "status cd length track " & TrackNum, s, Len(s), 0
GetTrackLength = s
End Function

Function GetCDPosition$()
Dim s As String * 30
mciSendString "status cd position", s, Len(s), 0
GetCDPosition = s
End Function

Function CheckIfPlaying%()
CheckIfPlaying = 0
Dim s As String * 30
mciSendString "status cd mode", s, Len(s), 0
If Mid$(s, 1, 7) = "playing" Then CheckIfPlaying = 1
End Function

Function SeekCDtoX(Track%)
StopPlay
SetTrack Track
StartPlay
End Function

Function ReadyDevice()
UnloadAll
SetCDPlayerReady
SetFormat_tmsf
End Function

Function FastForward(Spd%)
Dim s As String * 40
SetFormat_milliseconds
mciSendString "status cd position wait", s, Len(s), 0
CheckIfPlaying%
If CheckIfPlaying = 1 Then
mciSendString "play cd from " & CStr(CLng(s) + Spd), 0, 0, 0
Else
mciSendString "seek cd to " & CStr(CLng(s) + Spd), 0, 0, 0
End If
SetFormat_tmsf
End Function

Function ReWind(Spd%)
Dim s As String * 40
SetFormat_milliseconds
mciSendString "status cd position wait", s, Len(s), 0
CheckIfPlaying%
If CheckIfPlaying = 1 Then
mciSendString "play cd from " & CStr(CLng(s) - Spd), 0, 0, 0
Else
mciSendString "seek cd to " & CStr(CLng(s) - Spd), 0, 0, 0
End If
SetFormat_tmsf
End Function


'Insert the following code to your Class Module :

Dim Snd As CDAudio
Private Sub Command1_Click()
Snd.SeekCDtoX Val(Text1)
End Sub

Private Sub Command10_Click()
MsgBox Snd.CheckIfPlaying
End Sub

Private Sub Command11_Click()
s = Snd.GetCDPosition
MsgBox "Track: " & CInt(Mid$(s, 1, 2)) & " Min: " & _
CInt(Mid$(s, 4, 2)) & " Sec: " & CInt(Mid$(s, 7, 2))
Track = CInt(Mid$(s, 1, 2))
Min = CInt(Mid$(s, 4, 2))
Sec = CInt(Mid$(s, 7, 2))
End Sub

Private Sub Command12_Click()
s = Snd.GetCDPosition
MsgBox Snd.GetTrackLength(CInt(Mid$(s, 1, 2)))
End Sub

Private Sub Command13_Click()
Snd.PausePlay
End Sub

Private Sub Command14_Click()
Snd.StartPlay
End Sub

Private Sub Command2_Click()
s$ = Snd.GetCDLength
MsgBox "Total length of CD: " & s, , "CD len"
End Sub

Private Sub Command3_Click()
Snd.CloseCD
End Sub

Private Sub Command4_Click()
Snd.EjectCD
End Sub

Private Sub Command5_Click()
Snd.StopPlay
End Sub

Private Sub Command6_Click()
Snd.ReWind Val(Text2) * 1000
End Sub

Private Sub Command7_Click()
Snd.FastForward Val(Text2) * 1000
End Sub

Private Sub Command8_Click()
MsgBox Snd.CheckCD
End Sub

Private Sub Command9_Click()
MsgBox Snd.GetNumTracks
End Sub

Private Sub Form_Load()
Set Snd = New CDAudio
Snd.ReadyDevice
Command1.Caption = "Play track"
Command2.Caption = "Get CD Length"
Command3.Caption = "Close CD"
Command4.Caption = "Eject CD"
Command5.Caption = "Stop"
Command6.Caption = "Rewind"
Command7.Caption = "Fast Forward"
Command8.Caption = "Check if CD in drive"
Command9.Caption = "Get numbre of tracks"
Command10.Caption = "Check If Playing"
Command11.Caption = "Get CD Position"
Command12.Caption = "Get current track Length"
Command13.Caption = "Pause"
Command14.Caption = "Resume"
Text1.Text = "1"
Text2.Text = "5"
End Sub

Private Sub Form_Unload(Cancel As Integer)
Snd.StopPlay
Snd.UnloadAll
End Sub

Visual Basic

History of Visual Basic

Visual basic evolved from BASIC(Beginners' All-purpose Symbolic Instruction Code). The BASIC language was created by Professors John Kemeny and Thomas Kurtz of Dartmouth College in the mid 1960s(Deitel&Deitel, 1999) . It is a carefully constructed English-Like language basically used by the programmers to write simple computer programs. It served the purpose of educating laymen like we all the basic concepts of programming. From then on many versions of BASIC were developed to accommodate different computer platforms. Some of the versions are Microsoft QBASIC, QUICKBASIC, GWBASIC ,IBM BASICA, Apple BASIC and etc. Apple BASIC was developed by Steve Wozniak, a former employee of Hewlett-Packard and a good friend of steve Jobs(the founded of Apple Inc.). Steve Jobs had worked with Wozniak in the past (together they designed the arcade game "Breakout" for Atari). They pooled their financial resources together to have PC boards made, and on April 1st, 1976 they officially formed the Apple Computer Company.

The concept of computer programming

Before we begin programming, let us understand some basic concepts of programming. According to Webopedia, a computer program is an organized list of instructions that, when executed, causes the computer to behave in a predetermined manner. Without programs, computers are useless. Therefore, programming means designing or creating a set of instructions to ask the computer to carry out certain jobs which normally are very much faster than human beings can do. 　A lot of people think that computer CPU is a very intelligent thing, which in actual fact it is a dumb and inanimate object that can do nothing without human assistant. The microchips of a CPU can only understand two distinct electrical states, namely, the on and off states, or 0 and 1 codes in the binary system. So, the CPU only understands a combinations of 0 and 1 codes, a language which we called machine language. Machine language is extremely difficult to learn and it is not for us laymen to master it easily. Fortunately , we have many smart programmers who wrote interpreters and compilers that can translate human language-like programs such as BASIC into machine language so that the computer can carry out the instructions entered by the users. Machine language is known as the primitive language while Interpreters and compilers like Visual Basic are called high-level language. Some of the high level computer languages beside Visual Basic are Fortran, Cobol, Java, C, C++, Turbo Pascal, and etc . 　 FORTRAN stands for FORmula TRANslator and it was developed by IBM Inc. between 1954 and 1957 which was used specifically for scientific ad engineering applications. It is still widely used today in the engineering fields. COBOL stands for Common Business Oriented Language which was created by a group of computer manufacturers and industrial computer users in 1959. It was designed for commercial applications that required large amount of data processing. It is still being used today in the business fields. C was developed by Dennis Richie at Bell Laboratories in 1972. It is a system implementation language that was used to develop the UNIX operating system. C++ is an extension of C which was created by Bjarne Stroustrup in 1980's. It added the OOP (Object-Oriented Programming) feature to C and now it is the main systems implementation language (Deitel&Deitel, 1999) . PASCAL was created by Professor Nicklaus Wirth for teaching the concepts of structured programming. Its use is primarily confined to the academic world. JAVA is the latest but one of the hottest programming languages developed by the Sun Microsystems in 1995. It was actually an extension of C++ but it has included extensive libraries for doing multimedia, networking, multithreading , graphics, database access, GUI programming. Microsoft also come out with its own version of Javawhich is known as Visual J++. Other programming languages are Power Builder which was developed by Powersoft Corporation and Delphi which was developed by Borland Inc.

http://www.vbtutor.net/vbtutor.html