Add 3D Line Under The Menu

'Add 1 Frame and 1 Menu to your Form.
'Insert the following code to your form:
Private Sub Form_Load()
Frame1.Caption = ""
Frame1.Height = 30
Frame1.Width = Screen.Width + 100
Frame1.Move -50, 0
End Sub

Readmore...

Disable Text Box Pop Up Menu

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Text Box to your form.
'Insert this code to the module :
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = -4
Public Const WM_RBUTTONUP = &H205
Public lpPrevWndProc As Long
Private lngHWnd As Long

Public Sub Hook(hWnd As Long)
lngHWnd = hWnd
lpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, _
AddressOf WindowProc)
End Sub

Public Sub UnHook()
Dim lngReturnValue As Long
lngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub

Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam _
As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_RBUTTONUP
'You can put here your own popup menu.
Case Else
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Select
End Function

'Insert the following code to your form:
Private Sub Form_Load()
'Replace 'Text1' with the name of your Text Box
Call Hook(Text1.hWnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call UnHook
End Sub

Readmore...

Add Pop Up Menu To Text Box

'Add 1 Text Box to your form. Add 1 Menu (Name it MyMenu) and at least 1 Sub Menu.
'Insert the following code to your form:
Private Const WM_RBUTTONDOWN = &H204
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Sub OpenContextMenu(FormName As Form, MenuName As Menu)
Call SendMessage(FormName.hwnd, WM_RBUTTONDOWN, 0, 0&)
FormName.PopupMenu MenuName
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Replace 'MyMenu' with the menu you want to pop up.
If Button = vbRightButton Then Call OpenContextMenu(Me, Me.MyMenu)
End Sub

Readmore...

Align Menu To Right

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Command Button and 1 Menu to your form.
'Insert this code to the module :
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Public Const MIIM_TYPE = &H10
Public Const MFT_RIGHTJUSTIFY = &H4000
Public Const MFT_STRING = &H0&
Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" _
(ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo _
As MENUITEMINFO) As Long
Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" _
(ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, _
lpcMenuItemInfo As MENUITEMINFO) As Long
Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type

'Insert this code to your form:
Private Sub Command1_Click()
Dim MnuInfo As MENUITEMINFO
mnuH& = GetMenu(Me.hwnd)
MnuInfo.cbSize = Len(MnuInfo)
MnuInfo.fMask = MIIM_TYPE
'If you want to align to right only few menus, and leave the rest in left side,
'Replace the '0' below and the '0' two lines above the 'End Sub' with the number
'of menus you want to leave in the left side.
myTemp& = GetMenuItemInfo(mnuH&, 0, True, MnuInfo)
MnuInfo.fType = MFT_RIGHTJUSTIFY Or MFT_STRING
'Replace all 'MenuCaption' below with the caption of the first menu from left.
MnuInfo.cch = Len("MenuCaption")
MnuInfo.dwTypeData = "MenuCaption"
MnuInfo.cbSize = Len(MnuInfo)
myTemp& = SetMenuItemInfo(mnuH&, 0, True, MnuInfo)
myTemp& = DrawMenuBar(Me.hwnd)
End Sub

Readmore...

Add PopUp Menu To TreeView

'Add 1 TreeView to your form. Add few nodes to the treeview.
'Add 1 Menu (Named MyMenu) and few Sub Menus.
'When you will click on the right mouse button the menu will popup.
'Insert the following code to your form:

Private Sub TreeView1_Mousedown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim nod As Node
If Button = vbRightButton Then
Set nod = TreeView1.HitTest(x, y)
On Error GoTo EmptyNode
nod.Selected = True
On Error GoTo 0
Me.PopupMenu MyMenu
EmptyNode:
On Error GoTo 0
End If
End Sub

Readmore...

Put Split In Menu

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add menu to your form. Add 4 Sub Menus to this menu.
'Insert this code to the module :
Public Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Public Declare Function GetMenu Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) As Long
Public Declare Function GetSubMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function GetMenuItemInfo Lib "user32" _
Alias "GetMenuItemInfoA" _
(ByVal hMenu As Long, ByVal un As Long, _
ByVal b As Boolean, lpmii As MENUITEMINFO) As Long
Public Declare Function SetMenuItemInfo Lib "user32" _
Alias "SetMenuItemInfoA" _
(ByVal hMenu As Long, ByVal uItem As Long, _
ByVal fByPosition As Long, lpmii As MENUITEMINFO) As Long
Public Const MIIM_STATE = &H1
Public Const MIIM_ID = &H2
Public Const MIIM_SUBMENU = &H4
Public Const MIIM_CHECKMARKS = &H8
Public Const MIIM_TYPE = &H10
Public Const MIIM_DATA = &H20
Public Const MFT_RADIOCHECK = &H200&
Public Const MFT_STRING = &H0&
Public Const RGB_STARTNEWCOLUMNWITHVERTBAR = &H20&
Public Const RGB_STARTNEWCOLUMN = &H40&
Public Const RGB_EMPTY = &H100&
Public Const RGB_VERTICALBARBREAK = &H160&
Public Const RGB_SEPARATOR = &H800&

'Insert the following code to your form:
Private Sub Form_Load()
Dim r As Long
Dim hSubMenu As Long
Dim mnuItemCount As Long
Dim mInfo As MENUITEMINFO
'Replace the '0' below with the menu position. In this case put 0 because the menu that you
'want to put split on it is the first menu from the left. If the menu position was the second from 'the left, you've should been put there '1'.
hSubMenu = GetSubMenu(GetMenu(Me.hwnd), 0)
mnuItemCount = GetMenuItemCount(hSubMenu)
mInfo.cbSize = Len(mInfo)
mInfo.fMask = MIIM_TYPE
mInfo.fType = MFT_STRING
mInfo.dwTypeData = Space$(256)
mInfo.cch = Len(mInfo.dwTypeData)
'Replace the '1' below with your desirable split position. Put '1' to enter the split after
'the first sub menu, put '1' to put it after the second sub menu and so on.
'If you want to put the split before the last sub menu, put there 'mnuItemCount - 1'.
'If you want to put it before 2 sub menus from the last, put there 'mnuItemCount - 1'.
'If you replace the '1' Don't forget to replace also the '1' in the line above the 'End Sub'
r = GetMenuItemInfo(hSubMenu,1, True, mInfo)
mInfo.fType = RGB_STARTNEWCOLUMNWITHVERTBAR
mInfo.fMask = MIIM_TYPE
'If you Replaced the '1' three lines above, replace the '1' below with the same number.
r = SetMenuItemInfo(hSubMenu,1, True, mInfo)
End Subm

Readmore...

Add New Menu Item To The Form's Sytem Menu

The system menu is the default pop up menu (with Restore, Move, Minimize, Maximize, etc.) that pops up when you right clicking on the title bar, or when you right clicking on the task bar.

Note: to perform this task, the code below uses subclassing. that's mean that if you won't close your program properly, it may cause your Visual Basic Environment to crash.
You can close your program by pressing Alt +F4, clicking the form X button, or any other way, but don't close the program by pressing the Visual Basic Stop button.

Module Code

Option Explicit Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As _
Long, ByVal lpNewItem As String) As Long

Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As _
Long, ByVal bRevert As Long) As Long

Public Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal _
dwNewLong As Long) As Long

Public Declare Function CallWindowProc Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal ByteLen As Long)

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

Public Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As _
Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const SC_NEWMENU = 2
Public Const SC_MINIMIZE = &HF020
Public Const WM_SYSCOMMAND = &H112
Public Const WM_INITMENUPOPUP = &H117
Public Const BITMASK = &HFFFF0000
Public Const MF_STRING = &H0&
Public Const MF_SEPARATOR = &H800&
Public Const MF_GREYED = &H1&

Public Function FrmProc(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
   
    'this allows each form to have its own window proc
    'and hence to be able to access its own properties in the Win Proc
    FrmProc = FrmFromHwnd(hwnd).WindowProc(hwnd, Msg, wParam, lParam)
   
End Function
Private Function FrmFromHwnd(hwnd As Long) As Object
   
    Dim lo_Form As Object
    Dim ll_Pointer As Long
   
    'make function point to our subclassed form
    ll_Pointer = GetWindowLong(hwnd, GWL_USERDATA)
    CopyMemory lo_Form, ll_Pointer, 4
    Set FrmFromHwnd = lo_Form
   
    'don't forget to clean up afterwards!
    CopyMemory lo_Form, 0&, 4
   
End Function

Form Code

Option Explicit
Private ml_OldWinProc As Long Private Sub Form_Load()
   
    AddAboutMenu
    SubClass
       
End Sub
Private Sub Form_Unload(Cancel As Integer)
    UnSubClass
   
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim ll_SysMenu As Long
    Select Case Msg
   
        Case WM_SYSCOMMAND
     
            'the user clicked on the new menu item
            If wParam = SC_NEWMENU Then
            ' you can put here whatever you want to run when the menu is clicked
                MsgBox "You've clicked the new item"
            End If
           
        Case WM_INITMENUPOPUP
       
            'disable the menu option if the form is minimized. If you want
            'that it will be enabled, remove the lines below from "If lParam ..."
            'till "End If" that found 1 line above the "End Select"
            If lParam And BITMASK Then
                ll_SysMenu = GetSystemMenu(hwnd, 0)
                If wParam = ll_SysMenu Then
                    EnableMenuItem ll_SysMenu, SC_NEWMENU, ByVal _
                       IIf(WindowState = vbMinimized, MF_GREYED, 0)
                End If
            End If
    End Select
   
    WindowProc = CallWindowProc(ml_OldWinProc, hwnd, Msg, wParam, lParam)
   
End Function
Private Sub SubClass()
    'store object refernce so we can check its properties later
    SetWindowLong Me.hwnd, GWL_USERDATA, ObjPtr(Me)   
    ml_OldWinProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf FrmProc)
End Sub
Private Sub UnSubClass()
    If ml_OldWinProc Then
        Call SetWindowLong(Me.hwnd, GWL_WNDPROC, ml_OldWinProc)
    End If
End Sub
Private Sub AddAboutMenu()
    Dim ll_OwnerWindowHandle As Long
    Dim ll_MenuHandle As Long
   
    ll_OwnerWindowHandle = Me.hwnd
    'Get system menu
    ll_MenuHandle = GetSystemMenu(ll_OwnerWindowHandle, False)
    'Add new menu item
    Call AppendMenu(ll_MenuHandle, MF_SEPARATOR, 0&, 0&)
    'replace the "New Item" below with the text you want to appear on the new
    'menu item
    Call AppendMenu(ll_MenuHandle, MF_STRING, SC_NEWMENU, "&New Item")
   
End Sub

Readmore...

Copy The Content Of One Tree View To Another

'Add 2 Tree View Controls to your form, and 1 Command Button.
'Insert the following code to your form:
Private Sub Command1_Click()
'The Command below will copy the content of TreeView1 to Treeview2
CopyTreeview TreeView1, TreeView2
End Sub

Private Sub CopyTreeview(objTVSrc As TreeView, objTVDest As TreeView)
Dim nodeRoot As Node
objTVDest.Nodes.Clear
For Each nodeRoot In objTVSrc.Nodes
If (nodeRoot.Parent Is Nothing) Then
Call CopyTVParentNode(nodeRoot, objTVDest.Nodes)
End If
Next
End Sub

Private Sub CopyTVParentNode(nodeParent As Node, nodesDest As Nodes)
Dim nodeDummy As Node
Dim nodeChild As Node
Set nodeDummy = CopyNode(nodeParent, nodesDest)
Set nodeChild = nodeParent.Child
Do While Not (nodeChild Is Nothing)
If nodeChild.Children Then
Call CopyTVParentNode(nodeChild, nodesDest)
Else
Set nodeDummy = CopyNode(nodeChild, nodesDest)
End If
Set nodeChild = nodeChild.Next
Loop
End Sub

Private Function CopyNode(nodeSrc As Node, nodesDest As Nodes) As Node
With nodeSrc
If (.Parent Is Nothing) Then
Set CopyNode = nodesDest.Add(, , .Key, .Text, .Image, .SelectedImage)
CopyNode.Expanded = True
Else
Set CopyNode = nodesDest.Add(.Parent.Index, _
tvwChild, .Key, .Text, .Image, .SelectedImage)
CopyNode.Expanded = True
End If
End With
End Function

Private Sub Form_Load()
TreeView1.Nodes.Add , , "Sample", "Primary"
TreeView1.Nodes.Add , , "Sample2", "Primary2"
TreeView1.Nodes.Add "Sample", tvwChild, "Sample3", "Child"
End Sub

Readmore...

Implement Drag and Drop in TreeView Control

Drag and drop one node to another. This sample code will pop up message box with the name of the node that been dragged.
This implemention don't let the user drag a parent node.

Preparations

Add 1 TreeView Control.
Set the TreeView's OLEDragMode property to 1 - ccOLEDragAutomation,
OLEDropMode property to 1 - ccOLEDropManual, LineStyle property to 1 -tvwRootLines.

Form Code

Option Explicit
Public dragNode As Node, hilitNode As Node


Private Sub Form_Load()
'the following code lines will populate the TreeView control   TreeView1.Nodes.Add , , "First", "First"
   TreeView1.Nodes.Add , , "Second", "Second"
   TreeView1.Nodes.Add "First", tvwChild, "Child", "Child"
   TreeView1.Nodes.Add "Child", tvwChild, "Child2", "Child2"
End Sub Private Sub TreeView1_MouseDown(Button As Integer, Shift As Integer, _
     x As Single, y As Single)
   Set dragNode = TreeView1.HitTest(x, y)
End Sub
Private Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
   If Not dragNode Is Nothing Then MsgBox (dragNode.Text)
End Sub
Private Sub TreeView1_OLEStartDrag(Data As MSComctlLib.DataObject, _
     AllowedEffects As Long)
'If you want to allow parent node dragging, delete the line below    If dragNode.Parent Is Nothing Then Set dragNode = Nothing
End Sub
Private Sub TreeView1_OLEDragOver(Data As MSComctlLib.DataObject, _
     Effect As Long, Button As Integer, Shift As Integer, _
     x As Single, y As Single, State As Integer)
    If Not dragNode Is Nothing Then
        TreeView1.DropHighlight = TreeView1.HitTest(x, y)
    End If
End Sub

Readmore...

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 form:
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

Readmore...

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

Readmore...

Play Avi File In Picture Box

Play an avi file inside a picture box. The AVI file will be resized to the size of the picture box.

Preparations

Add 1 Command Button (named Command1), and 1 Picture Box (named Picture1) to your form.

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 Declare Function mciGetErrorString Lib "winmm" Alias _
"mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, _
ByVal uLength As Long) As Long
Declare Function GetShortPathName Lib "kernel32" Alias _
"GetShortPathNameA" (ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Const WS_CHILD = &H40000000

Form Code

Sub PlayAVIPictureBox(FileName As String, ByVal Window As PictureBox)
Dim RetVal As Long
Dim CommandString As String
Dim ShortFileName As String * 260
Dim deviceIsOpen As Boolean
'Retrieve short file name format
RetVal = GetShortPathName(FileName, ShortFileName, Len(ShortFileName))
FileName = Left$(ShortFileName, RetVal)
'Open the device
CommandString = "Open " & FileName & " type AVIVideo alias AVIFile parent " _
& CStr(Window.hWnd) & " style " & CStr(WS_CHILD)
RetVal = mciSendString(CommandString, vbNullString, 0, 0&)
If RetVal Then GoTo error
'remember that the device is now opendeviceIsOpen = True
'Resize the movie to PictureBox size
CommandString = "put AVIFile window at 0 0 " & CStr(Window.ScaleWidth / _
Screen.TwipsPerPixelX) & " " & CStr(Window.ScaleHeight / _
Screen.TwipsPerPixelY)
RetVal = mciSendString(CommandString, vbNullString, 0, 0&)
If RetVal <> 0 Then GoTo error
'Play the file
CommandString = "Play AVIFile wait"
RetVal = mciSendString(CommandString, vbNullString, 0, 0&)
If RetVal <> 0 Then GoTo error
'Close the deviceCommandString = "Close AVIFile"
RetVal = mciSendString(CommandString, vbNullString, 0, 0&)
If RetVal <> 0 Then GoTo error
Exit Sub
error:
'An error occurred.
'Get the error description
Dim ErrorString As String
ErrorString = Space$(256)
mciGetErrorString RetVal, ErrorString, Len(ErrorString)
ErrorString = Left$(ErrorString, InStr(ErrorString, vbNullChar) - 1)
'close the device if necessary
If deviceIsOpen Then
CommandString = "Close AVIFile"
mciSendString CommandString, vbNullString, 0, 0&
End If
'raise a custom error, with the proper description
Err.Raise 999, , ErrorString
End Sub
Private Sub Command1_Click()
'replace 'c:\myfile.avi' with the name of the AVI file you want to play
    PlayAVIPictureBox "c:\myfile.avi", Picture1
End Sub

Readmore...

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

Readmore...

Play WAV File

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Insert this code to the module :
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

'Insert this code to your form:
Private Sub Form_Load()
'replace c:\music\myfile.wav with the WAV file you want to play
sndPlaySound "c:\music\myfile.wav", 1
'the '1' following the file means that the program should not stop to play the file.
'The sound will play and other events can be happening.
'If you want the whole program to stop while the sound is playing, just change the '1' to '0'.
End Sub

Readmore...

Play MP3 Files Using Windows Media Player

You can use Microsoft Windows Media Player in your VB application to play MP3 files.
To do that you must have Windows Media Player installed on your computer.

Preparations

Add Windows Media Player to your form:
From VB menu choose Project->Components... then mark the Windows Media Player check box and press OK. Now drag the Windows Media Player Control to your form.

If you want that Windows Media Player will be invisible, set its Visible property to False.

Add 3 Command Buttons to your form.
Press the first to play the MP3 file, press the second to stop it, and press the third to Pause/Resume.

Form Code

Private Sub Command1_Click()
' replace the "D:\MP3\MyFile.mp3" below with the Mp3 file
' you want to play
    MediaPlayer1.Open "D:\MP3\MyFile.mp3"
End Sub
Private Sub Command2_Click()
    MediaPlayer1.Stop
End Sub
Private Sub Command3_Click()
' if PlayState is 2: the file is currently playing.
' if PlayState is 1: the file is in pause mode.
    If MediaPlayer1.PlayState = 2 Then
        MediaPlayer1.Pause
    Else
        MediaPlayer1.Play
    End If
End Sub

Readmore...

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

Readmore...

Retrieve The Length Of WAV, AVI And MIDI Files

Know how much time run any WAV, AVI and MIDI file.

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

Readmore...