VBNet - Форум - Перенос ярлычка Windows на форму

Вопрос: Перенос ярлычка Windows на форму Добавлено: 02.02.05 14:52

Автор вопроса: Nord

Помогите плиз мне онень нуно что бы моно было перетаскивать ярлычок любой проги с рабочего стола на мою форму. Чтоб так простенько моно было мышкой хватить и перетащить на форму а с ctrl ярлычок копировался бы. КАК ???
Ответить

Ответы Всего ответов: 10

Номер ответа: 1 Автор ответа: *CyRax* Разработчик Offline Client ICQ: 204447456 Вопросов: 180 Ответов: 4229	Web-сайт: basicproduction.nm.ru Профиль \| \| #1	Добавлено: 02.02.05 15:08
	Поищи в форме процедуру. Sub Form_ПолучитьЯрлычок(Optional НеЖелаетеЛиСкопировать As Boolean = False) Или поищи событие ПриПеретаскиванииЯрлычка() Шучу Ответить

Номер ответа: 2 Автор ответа: Nord Вопросов: 15 Ответов: 28	Профиль \| \| #2	Добавлено: 02.02.05 17:25
	ГЫ-ГЫ Не знаешь так и скажи Ответить

Номер ответа: 3 Автор ответа: *CyRax* Разработчик Offline Client ICQ: 204447456 Вопросов: 180 Ответов: 4229	Web-сайт: basicproduction.nm.ru Профиль \| \| #3	Добавлено: 02.02.05 17:31
	Разве что примерно. Там в форме есть события DDE. На них можно разве что реагировать. И то получишь не ярлык, а путь. А чтобы ярлык, да на форму, по моему это слишком сложно. Ответить

Номер ответа: 4 Автор ответа: Nash Bridges Вопросов: 5 Ответов: 139	Профиль \| \| #4	Добавлено: 02.02.05 20:37
	Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Debug.Print "Form_OLEDragDrop" End Sub Private Sub Form_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) Debug.Print "Form_OLEDragOver" End Sub Form.OLEDropMode = 1 Ответить

Номер ответа: 5 Автор ответа: Black Dragon ICQ: 321186096 Вопросов: 30 Ответов: 347	Web-сайт: в разработке Профиль \| \| #5	Добавлено: 02.02.05 21:41
	2Nash Bridges, а дальше слабо ? Ответить

Номер ответа: 6 Автор ответа: sne Разработчик Offline Client ICQ: 233286456 Вопросов: 34 Ответов: 5445	Web-сайт: hw.t-k.ru Профиль \| \| #6	Добавлено: 02.02.05 22:34
	В файл модуля: Attribute VB_Name = "mSubclassing" Option Explicit Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long) '-------------------------------------------------------------------------------- ' Модуль : mFormSubclass ' Проект : OfflineClient ' ' Описание : Просто удобно реализованный сабклассинг ' ' Изменяли : sne, '-------------------------------------------------------------------------------- Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function CallWindowProc Lib "user32.dll" 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 Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long) Private Type gbFrmSbg old_adrfn As Long new_adrfn As Long hwnd As Long End Type Private Const WM_USER As Long = &H400 Private OldWndArray() As gbFrmSbg '-------------------------------------------------------------------------------- ' Проект : OfflineClient ' Процедура : StartFormSubclass ' Описание : Начать сабклассинг окна/контрола ' Кем создан : SNE ' Дата-Время : 14.11.2004-15:35:23 ' ' Параметры : hWindow - Хэндл окна ' adrfn - Адрес функции для подмены оконной процедуры '-------------------------------------------------------------------------------- Public Sub StartFormSubclass(ByVal hWindow As Long, ByVal adrfn As Long) Dim cnt As Long cnt = UBoundFS(OldWndArray) For cnt = 0& To cnt If OldWndArray(cnt).hwnd = hWindow Then Exit Sub Next ReDim Preserve OldWndArray(cnt) OldWndArray(cnt).new_adrfn = adrfn OldWndArray(cnt).hwnd = hWindow OldWndArray(cnt).old_adrfn = SetWindowLong(hWindow, &HFFFC, AddressOf prFrmSbcls) End Sub '-------------------------------------------------------------------------------- ' Проект : OfflineClient ' Процедура : StopFormSubclass ' Описание : Остановить сабклассмнг окна/контрола ' Кем создан : SNE ' Дата-Время : 14.11.2004-15:36:59 ' ' Параметры : hWindow - Хэндл окна '-------------------------------------------------------------------------------- Public Sub StopFormSubclass(ByVal hWindow) Dim iIndex As Long, ub As Long iIndex = hWnd2Index(hWindow) ub = UBoundFS(OldWndArray) If iIndex = &HFFFF Then Exit Sub Call SetWindowLong(hWindow, &HFFFC, OldWndArray(iIndex).old_adrfn) ' ----------- If Not ub = 0 And Not ub = &HFFFF Then If Not iIndex = ub Then Call CopyMemory(OldWndArray(iIndex), OldWndArray(iIndex + vbNull), Len(OldWndArray(iIndex)) * (ub - iIndex)) ReDim Preserve OldWndArray(ub - vbNull) Else Erase OldWndArray End If End Sub Private Function UBoundFS(ByRef lngArray() As gbFrmSbg) On Error Resume Next UBoundFS = &HFFFF UBoundFS = UBound(lngArray) End Function Private Function hWnd2Index(ByVal hWindow As Long) As Long Dim i As Long hWnd2Index = &HFFFF For i = 0 To UBoundFS(OldWndArray) If OldWndArray(i).hwnd = hWindow Then hWnd2Index = i: Exit For Next End Function Private Function prFrmSbcls(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim iIndex As Long iIndex = hWnd2Index(hwnd) If iIndex = &HFFFF Then Exit Function prFrmSbcls = CallWindowProc(OldWndArray(iIndex).new_adrfn, hwnd, uMsg, wParam, lParam) If prFrmSbcls = WM_USER + vbNull Then _ prFrmSbcls = CallWindowProc(OldWndArray(iIndex).old_adrfn, hwnd, uMsg, wParam, lParam) End Function Public Function frmSbclss(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If uMsg = &H233 Then Call frmMain.Drag(wParam) ' Кривой способ, так никогда не делайте End If ' но т.к. это всего-лишь вспомогательная фишка, позволю себе frmSbclss = WM_USER + vbNull End Function А это вроде как форма: VERSION 5.00 Begin VB.Form frmMain BorderStyle = 1 'Fixed Single Caption = "Тащить сюда!" ClientHeight = 4500 ClientLeft = 45 ClientTop = 330 ClientWidth = 4680 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False OLEDropMode = 1 'Manual ScaleHeight = 4500 ScaleWidth = 4680 StartUpPosition = 3 'Windows Default Begin VB.TextBox txtOut Height = 3000 Left = 75 MultiLine = -1 'True ScrollBars = 3 'Both TabIndex = 0 Top = 1455 Width = 4545 End Begin VB.Label Label1 BackStyle = 0 'Transparent Caption = $"frmMain.frx":0000 Height = 1260 Left = 90 TabIndex = 1 Top = 105 Width = 4545 End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long) Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long) Private Declare Function DragQueryFile Lib "shell32.dll" Alias "ragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long Private Sub Form_Load() Call mSubclassing.StartFormSubclass(Me.hwnd, AddressOf frmSbclss) Call DragAcceptFiles(Me.hwnd, True) End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Call mSubclassing.StopFormSubclass(Me.hwnd) Call DragAcceptFiles(Me.hwnd, False) End Sub Public Sub Drag(ByVal lParam As Long) Dim iCnt As Long, sBuffer As String, nf As Integer iCnt = DragQueryFile(lParam, &HFFFF, 0&, 0& ' Count of files For iCnt = 0 To iCnt - vbNull sBuffer = String$(DragQueryFile(lParam, iCnt, 0&, 0& + vbNull, 0& Call DragQueryFile(lParam, iCnt, sBuffer, Len(sBuffer)) sBuffer = Left$(sBuffer, Len(sBuffer) - vbNull) txtOut.Text = txtOut.Text & "file: " & sBuffer & vbCrLf & "-----------------------------------" & vbCrLf & vbCrLf nf = VBA.FreeFile Open sBuffer For Binary Access Read Lock Write As nf sBuffer = String$(LOF(nf), 0& Get nf, vbNull, sBuffer Close nf txtOut.Text = "bla-bla-bla" & vbCrLf & vbCrLf & "-----------------------------------" & vbCrLf Next Call DragFinish(lParam) End Sub Ответить

Номер ответа: 7 Автор ответа: LamerOnLine ICQ: 334781088 Вопросов: 108 Ответов: 2822	Профиль \| \| #7	Добавлено: 03.02.05 10:26
	Может проще через DrawIcon? Ответить

Номер ответа: 8 Автор ответа: sne Разработчик Offline Client ICQ: 233286456 Вопросов: 34 Ответов: 5445	Web-сайт: hw.t-k.ru Профиль \| \| #8	Добавлено: 03.02.05 11:12
	Ну не знаю что тут имелось ввиду, но я увидел DragAndDrop, и шмякнул сюда код Ответить

Номер ответа: 9 Автор ответа: Александр Разработчик Offline Client ICQ: 204034 Вопросов: 106 Ответов: 1919	Профиль \| \| #9	Добавлено: 03.02.05 18:17
	Ну или так (вырезка из моей программы). Можно еще сделать проверку на количество файлов в _OLEDragOver, но это ты уже сам сможешь по этому коду: Private Sub txtMain_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) On Error GoTo erra Dim sf As String If (Data.GetFormat(vbCFFiles)) Then If (Data.Files.Count = 1) Then sf = Data.Files(1) mnuFileNew_Click txtMain.LoadFile sf, vbCFText dlgCommonDialog.fileName = sf add_menu Me.Caption = "Easy Note - [" & Trim(Mid(sf, InStrRev(sf, "\" + 1)) & "]" trMain.RefreshIcon Icon, Caption End If End If erra: If Err.number = 75 Then Exit Sub End Sub Private Sub txtMain_OLEDragOver(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) If (Data.GetFormat(vbCFFiles)) Then Effect = vbDropEffectCopy Else Effect = vbDropEffectNone End If End Sub Ответить

Номер ответа: 10 Автор ответа: Nord Вопросов: 15 Ответов: 28	Профиль \| \| #10	Добавлено: 04.02.05 10:15
	Пасибки всем на выходных посмотрю Ответить

Страница: 1 |