| Вопрос: Создание ярлыков повсюду... | Добавлено: 21.06.06 13:58 |
Автор вопроса:  Wolf4D | Web-сайт: www.madnesstudio.ru
|
|
Обращаюсь с просьбой к знающим людям.
Кто знает, как создать ярлыки в меню "Пуск", на Рабочем Столе, в Быстром Запуске для Windows XP? Неплохо было-бы, если кто-нть выложил бы код для этого. Да, кстати, код желательно на Visual Basic. |
| Ответы | Всего ответов: 3 |
|
Номер ответа: 1 Автор ответа:  Серёга ICQ: 262809473 Вопросов: 17 Ответов: 561 |
Web-сайт: Профиль | | #1 | Добавлено: 21.06.06 22:56 |
|
код модуля:
______________________ Option Explicit Public Declare Sub OleInitialize Lib "ole32.dll" (pvReserved As Any) Public Declare Sub OleUninitialize Lib "ole32.dll" () Public Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As String, pclsid As modOLECommon.Guid) As Long Public Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As String, lpiid As modOLECommon.Guid) As Long Public Declare Function CoCreateInstance Lib "ole32.dll" (rclsid As modOLECommon.Guid, ByVal pUnkOuter As Long, ByVal dwClsContext As Long, riid As modOLECommon.Guid, ppv As Any) As Long Private 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 Private Declare Function PutMem2 Lib "msvbvm60" (ByVal pWORDDst As Long, ByVal NewValue As Long) As Long Private Declare Function PutMem4 Lib "msvbvm60" (ByVal pDWORDDst As Long, ByVal NewValue As Long) As Long Private Declare Function GetMem4 Lib "msvbvm60" (ByVal pDWORDSrc As Long, ByVal pDWORDDst As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Private Const GMEM_FIXED As Long = &H0 Private Const asmPUSH_imm32 As Byte = &H68 Private Const asmRET_imm16 As Byte = &HC2 Private Const asmCALL_rel32 As Byte = &HE8 Public Type Guid  ata1 As Long
ata2 As Integer
ata3 As Integer
ata4(0 To 7) As Byte
End Type Public Const unk_QueryInterface As Long = 0 Public Const unk_AddRef As Long = 1 Public Const unk_Release As Long = 2 Public Function CallInterface(ByVal pInterface As Long, ByVal Member As Long, ByVal ParamsCount As Long, Optional ByVal p1 As Long = 0, Optional ByVal p2 As Long = 0, Optional ByVal p3 As Long = 0, Optional ByVal p4 As Long = 0, Optional ByVal p5 As Long = 0, Optional ByVal p6 As Long = 0, Optional ByVal p7 As Long = 0, Optional ByVal p8 As Long = 0, Optional ByVal p9 As Long = 0, Optional ByVal p10 As Long = 0) As Long im i As Long, t As Long
im hGlobal As Long, hGlobalOffset As Long
If ParamsCount < 0 Then Err.Raise 5 'invalid call If pInterface = 0 Then Err.Raise 5 '5 байт для запихивания каждого параметра в стек '5 байт - PUSH this '5 байт - вызов мембера '3 байта - ret 0x0010, выпихивая при этом и параметры CallWindowProc '1 байт - выравнивание, поскольку последний PutMem4 требует 4 байта. hGlobal = GlobalAlloc(GMEM_FIXED, 5 * ParamsCount + 5 + 5 + 3 + 1) If hGlobal = 0 Then Err.Raise 7 'insuff. memory hGlobalOffset = hGlobal If ParamsCount > 0 Then t = VarPtr(p1) For i = ParamsCount - 1 To 0 Step -1 PutMem2 hGlobalOffset, asmPUSH_imm32 hGlobalOffset = hGlobalOffset + 1 GetMem4 t + i * 4, hGlobalOffset hGlobalOffset = hGlobalOffset + 4 Next End If 'Первый параметр любого интерфейсного метода - this. Делаем... PutMem2 hGlobalOffset, asmPUSH_imm32 hGlobalOffset = hGlobalOffset + 1 PutMem4 hGlobalOffset, pInterface hGlobalOffset = hGlobalOffset + 4 'Вызов мембера интерфейса PutMem2 hGlobalOffset, asmCALL_rel32 hGlobalOffset = hGlobalOffset + 1 GetMem4 pInterface, VarPtr(t) 'дереференс: находим положение vTable GetMem4 t + Member * 4, VarPtr(t) 'смещение по vTable, после чего дереференс оного PutMem4 hGlobalOffset, t - hGlobalOffset - 4 hGlobalOffset = hGlobalOffset + 4 'Интерфейсы stdcall. Поэтому не будем cdecl учитывать. PutMem4 hGlobalOffset, &H10C2& 'ret 0x0010 CallInterface = CallWindowProc(hGlobal, 0, 0, 0, 0) GlobalFree hGlobal End Function Public Sub CreateLink(CommandLine As String, WorkDir As String, LinkFileName As String) im a As ShellLink, t As Long, s As String
Set a = New ShellLink a.Path = CommandLine 'адрес вызываемой программы a.WorkingDirectory = WorkDir 'всплывающая подсказка a.Load LinkFileName 'имя ярлыка a.SetIconInfo CommandLine, 0 'контейнер иконок и номер иконки a.Save ' команда -создать Set a = Nothing End Sub ____________________ Применение на форме: ____________________ Private Sub Form_load() modOLECommon.OleInitialize ByVal 0& 'once for process End Sub Private Sub Form_Unload(Cancel As Integer) modOLECommon.OleUninitialize 'once for each OleInitialize End Sub Private Sub Command1_Click() CreateLink "c:\file.txt", "c:\", "d:\text.lnk" End Sub _____________ При нажатии на Command1 по адресу d:\ создается ярлык с именем text.lnk для файла c:\file.txt |
||
|
Номер ответа: 2 Автор ответа: HACKER Разработчик Offline Client Вопросов: 236 Ответов: 8362 |
Профиль | | #2 | Добавлено: 21.06.06 23:48 |
и незнал  да извращение сильная штука...
Enum ShortCutDest eskTop
Programs StartMenu StartUp End Enum Public Function CreateLink(dest As ShortCutDest, ByVal sName As String, ByVal sPath As String, Optional HotKey As String = "", Optional sIcon As String = "", Optional sWorkingDirectory As String = "", Optional sSubFolder As String = "", Optional WinStyle As Integer = vbNormalFocus) Dim WshShell As Object Dim oShellLink As Object Dim sLinkPath As String Set WshShell = CreateObject("WScript.Shell" 
Select Case dest Case DeskTop sLinkPath = WshShell.SpecialFolders(" esktop"
Case StartMenu sLinkPath = WshShell.SpecialFolders("StartMenu"
Case StartUp sLinkPath = WshShell.SpecialFolders("StartUp"
Case Programs sLinkPath = WshShell.SpecialFolders("Programs"
End Select On Error Resume Next If sSubFolder <> "" Then sLinkPath = sLinkPath & "\" & sSubFolder If Dir(sLinkPath) = "" Then MkDir sLinkPath End If On Error GoTo 0 Set oShellLink = WshShell.CreateShortCut(sLinkPath & "\" & sName & ".lnk"
oShellLink.WindowStyle = WinStyle oShellLink.HotKey = sHotKey oShellLink.TargetPath = sPath oShellLink.IconLocation = sIcon oShellLink.Description = sName oShellLink.WorkingDirectory = sWorkingDirectory oShellLink.Save Set oShellLink = Nothing Set WshShell = Nothing End Function CreateLink DeskTop, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
|
||
|
Номер ответа: 3 Автор ответа: Wolf4DВопросов: 20 Ответов: 131 |
Web-сайт: Профиль | | #3 | Добавлено: 22.06.06 19:02 |
|
Hacker, спасибо!
Правда, я уже задействовал ТОТ ЖЕ САМЫЙ код, поискав после задания вопроса с полдня, нашёл точно этот код. Взял я его с http://nickeater.narod.ru/Download/link.zip Но всё равно спасибо! P.S. Ежели кому надо, напишу код для VB4 и для VB5: нашёл в ходе поисков. В VB6 работает, но ТАК ГЛЮЧИТ!...... |
||
Страница: 1 |