Put Bitmaps On Menu

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Command Button And 2 Picture Boxes to your form.
'Set Picture Boxes AutoSize property to True. Add pictures to the Picture Boxes.
'When the menu will be enabled, the picture in Picture1 will be displayed near him.
'When the menu will be disabled, the picture in Picture2 will be displayed near him.
'The pictures should not be bigger than 13x13.
'Add menu to your form, Add 1 sub menu to the menu and name it MyMenu.
'When you run this program, press on the button to enable\disable menu.
'Insert this code to the module :
Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal _
nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal _
nPos As Long) As Long
Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal _
nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal _
hBitmapChecked As Long) As Long
Public Const MF_BITMAP = &H4&

'Insert this code to your form:
Private Sub Command1_Click()
MyMenu.Enabled = Not MyMenu.Enabled
End Sub

Private Sub Form_Load()
'Replace 'Form1' with the name of your form
hMenu& = GetMenu(Form1.hWnd)
'Replace '0' with the menu position. '0' means the first menu from left.
'If it was the second from left, you should been place there '1'.
hSubMenu& = GetSubMenu(hMenu&, 0)
'Replace '0' with the sub menu position. '0' means the upper sub menu.
'If it was the second from top, you should been place there '1'.
hID& = GetMenuItemID(hSubMenu&, 0)
SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, Picture1.Picture, Picture2.Picture
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...

Convert Menu 'V' Checkmark To Circle

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add menu to your form. Add 2 Sub Menus to this menu. Name them both MySubMenu.
'Set the first sub menu index property to '0'. Set the second sub menu index property to '1'.
'After you run the program, press on one of the sub menus and you will see that he has
'circle checkmarks.
'Insert this code to the module :
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 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 SetMenuItemInfo Lib "user32" Alias _
"SetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal _
fByPosition As Long, lpmii As MENUITEMINFO) As Long
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal _
hMenu As Long, ByVal nPos As Long) As Long

'Insert the following code to your form:

Private Sub SetRadioMenuChecks(Mnu As Menu, ByVal mnuItem As Long)
Dim hMenu 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 change his checkmark is the first menu from the left. If the menu position was the 'second from the left, you've should been put there '1'.
hMenu& = GetSubMenu(GetMenu(Mnu.Parent.hwnd), 0)
With mInfo
.cbSize = Len(mInfo)
.fType = MFT_RADIOCHECK
.fMask = MIIM_TYPE
.dwTypeData = Mnu.Caption & Chr$(0)
End With
SetMenuItemInfo hMenu&, mnuItem&, 1, mInfo
End Sub

Private Sub Form_Load()
'Replace the 'MySubMenu(0)' below with the name of the sub menu that you want to change
'his checkmark. Replace the '0' below (that found after the comma) with the position
'of the sub menu that you want to change his checkmark. In this case we put '0' because
'the 'MySubMenu(0)' sub menu is the top sub menu. if the sub menu position was the
'second from top, you've should put there '1'.
SetRadioMenuChecks MySubMenu(0), 0
SetRadioMenuChecks MySubMenu(1), 1
End Sub

Private Sub MySubMenu_Click(Index As Integer)
Static prevSelection As Integer
MySubMenu(prevSelection).Checked = False
MySubMenu(Index).Checked = True
prevSelection = Index
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...