Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
?
Solved

sendto context menu

Posted on 2003-03-12
11
Medium Priority
?
562 Views
Last Modified: 2010-08-05
How to display and give the functionality of the sendto context menu along with the icons in a VB application
0
Comment
Question by:venuvrk
10 Comments
 

Expert Comment

by:shijaz_a
ID: 8120481
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
 
LVL 3

Expert Comment

by:DocM
ID: 8121537
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
 

Author Comment

by:venuvrk
ID: 8149807
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
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 
LVL 1

Accepted Solution

by:
thaimin earned 800 total points
ID: 8316155
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
 
LVL 1

Expert Comment

by:thaimin
ID: 8316165
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
 
LVL 1

Expert Comment

by:thaimin
ID: 8317126
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
 

Author Comment

by:venuvrk
ID: 8317363
  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
 

Expert Comment

by:CleanupPing
ID: 9056410
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
 
LVL 1

Expert Comment

by:thaimin
ID: 9163568
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
 
LVL 49

Expert Comment

by:DanRollins
ID: 9664469
Moderator, my recommended disposition is:

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

DanRollins -- EE database cleanup volunteer
0

Featured Post

Receive 1:1 tech help

Solve your biggest tech problems alongside global tech experts with 1:1 help.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Suggested Courses

580 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question