sendto context menu

How to display and give the functionality of the sendto context menu along with the icons in a VB application
venuvrkAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

shijaz_aCommented:
The send to menu is located at C:\WINDOWS\SendTo
All shortcuts placed here appear in the context menu.

All you have to do is use an API to find the Windows directory. For this u need to add the foll declaration in a module:

Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Put this in the form

    Dim x As Long
    Dim Buffer As String
    Buffer = Space(255)
   
    x = GetWindowsDirectory(Buffer, Len(Buffer))
    'remove trailing null char '\0'
    Buffer = Left(Buffer, Len(Buffer) - 1)
    Label1.Caption = Buffer

Label1 will contain windows directory.

Now you can get the SendTo directory:
    Dim SendToPath as String
    SendToPath = Label1.Caption & "\SendTo"

Now u can access these shortcuts and use them anyway you like or put them in ur own menu.
0
DocMCommented:
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwnd As Long, ByVal nFolder As Long, Pidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal Pidl As Long, ByVal FolderPath As String) As Long

Private Const CSIDL_SENDTO = &H9
Private Const MAX_PATH = 260

Private Function SendToPath() As String

    Dim Pidl As Long
    Dim sFolderPath As String
    If SHGetSpecialFolderLocation(0, CSIDL_SENDTO, Pidl) = 0 Then
        sFolderPath = String(MAX_PATH, 0)
        If SHGetPathFromIDList(Pidl, ByVal sFolderPath) Then
            SendToPath = Left(sFolderPath, InStr(1, sFolderPath, Chr(0)) - 1)
        End If
    End If
End Function

Private Sub Command1_Click()
   
File1.Path = SendToPath

End Sub
0
venuvrkAuthor Commented:
thanks shijaz_a  and DocM  but that does not help me out... i need to show the menu with icons and functionality ...

 i have a app which has the functionality  of sending files to mydocument or desktop .. or any thing whihc is under sendto folder....

 so i need to build a menu and display it...
please help me out it very urgent
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

thaiminCommented:
The following code will generate a menu that has the names of all the files in the send to folder. When you click on one of the menu items, a message box pops up with the full file name. You could make it run a Shell(file) to run that file. It assumes no file there has more then one "." in the name, and the every file name excluding the extension is unique.

To use this script you need:
  a menu
  a submenu of that menu called SendToFile with an index of 0, visible, and not enabled.

Option Explicit

Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwnd As Long, ByVal nFolder As Long, Pidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal Pidl As Long, ByVal FolderPath As String) As Long

Private Const CSIDL_SENDTO = &H9
Private Const MAX_PATH = 260

Private Sub Form_Load()
    Dim path As String
    Dim file As String
    Dim i As Integer
    path = SendToPath()
    i = 1
    file = path & "\" & Dir(path & "\*.*") 'get first file
    Do
        Load SendToFile(i) 'create new menu item
        SendToFile(i).Visible = True
        SendToFile(i).Checked = False
        SendToFile(i).Caption = FileName(file)
        i = i + 1
        file = path & "\" & Dir 'get next file
    Loop Until (file = path & "\")
    SendToFile(0).Visible = False 'hide the original which we copied
End Sub

'When the menu item is clicked
Private Sub SendToFile_Click(Index As Integer)
    If Index = 0 Then Exit Sub 'this is the dummy
    Dim file As String
    Dim path As String
    path = SendToPath()
    file = path & "\" & SendToFile(Index).Caption
    file = path & "\" & Dir(file & ".*") 'gets the extension
    MsgBox file
End Sub

'Gets SendTo path
Private Function SendToPath() As String
   Dim Pidl As Long
   Dim sFolderPath As String
   If SHGetSpecialFolderLocation(0, CSIDL_SENDTO, Pidl) = 0 Then
       sFolderPath = String(MAX_PATH, 0)
       If SHGetPathFromIDList(Pidl, ByVal sFolderPath) Then
           SendToPath = Left(sFolderPath, InStr(1, sFolderPath, Chr(0)) - 1)
       End If
   End If
End Function

'Gets the filename part of a full path
Private Function FileName(ByVal path As String) As String
    Dim slash As Integer
    Dim LastSlash As Integer
    slash = 0
Get_slash:
    slash = InStr(slash + 1, path, "\")
    If (slash <> 0) Then 'if there was another slash..
        LastSlash = slash
        GoTo Get_slash 'try again
    End If
    FileName = Mid(path, LastSlash + 1, InStr(1, path, ".") - LastSlash - 1)
End Function
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
thaiminCommented:
That code is missing the icon part, which I do not know how to do, but I will try to find out how to.
0
thaiminCommented:
This code will now generate the menu with all the icons. The menu also will popup when you right-click the background. A slight warning though is that this will look a lot worse then the Windows one becuase the one in Windows can use 16 x 16 pxl icons, where in Visual Basic, you can only use a 13 x 13 pxl icon. Also, on my computer at least, all drives are missing from the Send To list through this script becuase they are not actually in the SendTo folder, but instead are added later. If you want this script can be modified to include an a drive.

To use this script you need:
 a menu called FileMenu
 a submenu called SendTo
 a submenu of SendTo called SendToFile with an index of 0, visible, and not enabled.
 two picture boxes, with all default settings
 an imagelist (Microsoft Windows Common Controls 5.0 or higher)


'****Send To Menu Generator****
Option Explicit

Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwnd As Long, ByVal nFolder As Long, Pidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal Pidl As Long, ByVal FolderPath As String) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private 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
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Integer
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long

Private Const CSIDL_SENDTO = &H9
Private Const MAX_PATH = 260

Private Sub Form_Load()
    Dim path As String, file As String
    Dim hMenu As Long, hSubMenu As Long, hSendToMenu As Long, menuID As Long, retval As Long
    Dim i As Integer
    ImageList1.ImageHeight = 13 'setup imagelist
    ImageList1.ImageWidth = 13
    Picture1.Appearance = 0
    Picture1.BorderStyle = 0 'setup picture boxes
    Picture1.Visible = False
    Picture2.Appearance = 0
    Picture2.BorderStyle = 0
    Picture2.Visible = False
    hMenu = GetMenu(Me.hwnd) 'get all the menus
    hSubMenu = GetSubMenu(hMenu, 0)
    hSendToMenu = GetSubMenu(hSubMenu, 0)
    path = SendToPath()
    i = 1
    file = Dir(path & "\*.*") 'get first file
    Do
        Load SendToFile(i) 'create new menu item
        SendToFile(i).Visible = True
        SendToFile(i).Checked = False
        SendToFile(i).Caption = RemoveExt(file)
        GetIcon path & "\" & file, i 'Saves icon to the imagelist
        menuID = GetMenuItemID(hSendToMenu, i) 'get the item in the menu
        retval = SetMenuItemBitmaps(hMenu, menuID, 0, ImageList1.ListImages(i).Picture, ImageList1.ListImages(i).Picture) 'Pictures(i).Picture, Pictures(i).Picture) 'draw the icon
        i = i + 1
        file = Dir 'get next file
    Loop Until (file = "")
    SendToFile(0).Visible = False 'hide the original which we copied
End Sub

'When the menu item is clicked
Private Sub SendToFile_Click(index As Integer)
    If index = 0 Then Exit Sub 'this is the dummy menu item
    Dim file As String
    Dim path As String
    path = SendToPath()
    file = path & "\" & SendToFile(index).Caption
    file = path & "\" & Dir(file & ".*") 'gets the extension
    MsgBox file
End Sub

'Gets SendTo path
Private Function SendToPath() As String
   Dim Pidl As Long
   Dim sFolderPath As String
   If SHGetSpecialFolderLocation(0, CSIDL_SENDTO, Pidl) = 0 Then
       sFolderPath = String(MAX_PATH, 0)
       If SHGetPathFromIDList(Pidl, ByVal sFolderPath) Then
           SendToPath = Left(sFolderPath, InStr(1, sFolderPath, Chr(0)) - 1)
       End If
   End If
End Function

'Removes the extension part of a filename
Private Function RemoveExt(ByVal file As String) As String
    RemoveExt = Left(file, InStr(1, file, ".") - 1)
End Function

'Shows the menu on a left click
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Button = 2 Then
    PopupMenu FileMenu, 2, x, y
  End If
End Sub

'Gets the icon of a file and save it to ImageList1 at index
'Needs 2 hidden picture boxes, Picture1 and Picture2
Private Sub GetIcon(ByVal filePath As String, index As Integer)
    Dim iconH As Long, mIcon As Long
    Picture1.Height = 32 * Screen.TwipsPerPixelY 'Make the box the right size
    Picture1.Width = 32 * Screen.TwipsPerPixelX
    iconH = ExtractAssociatedIcon(App.hInstance, filePath, mIcon) 'Get the icon
    DrawIcon Picture1.hdc, 0, 0, iconH 'Draw using the icon handle
    DrawIcon Picture1.hdc, 0, 0, mIcon 'Draw the secondary icon handle
    DestroyIcon iconH 'Free memory
    Picture1.Refresh
    Picture2.Height = 13 * Screen.TwipsPerPixelY 'Make the box the right size
    Picture2.Width = 13 * Screen.TwipsPerPixelX
    Picture2.PaintPicture Picture1.Image, 0, 0, Picture2.Width, Picture2.Height 'Draw the icon at reduced size
    Picture2.Refresh
    Picture2.Picture = Picture2.Image 'Turn from image into bitmap
    ImageList1.ListImages.Add index, filePath, Picture2.Picture 'Make the new icon in the imagelist
End Sub
0
venuvrkAuthor Commented:
  Thank you thaimin for the answer.
   I have already got the solution in the same manner you have done it, anyway thanks a lot for your genuine help.
0
CleanupPingCommented:
venuvrk:
This old question needs to be finalized -- accept an answer, split points, or get a refund.  For information on your options, please click here-> http:/help/closing.jsp#1 
EXPERTS:
Post your closing recommendations!  No comment means you don't care.
0
thaiminCommented:
I think that I should get the points for being the one who actually answered the question, even though venuvrk achieved it in the same way.
0
DanRollinsCommented:
Moderator, my recommended disposition is:

    Accept thaimin's comment(s) as an answer.

DanRollins -- EE database cleanup volunteer
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.