• Vui lòng đọc nội qui diễn đàn để tránh bị xóa bài viết
  • Tìm kiếm trước khi đặt câu hỏi

Kéo thả File vào TextBox có Unicode

Các thủ thuật liên quan đến việc xử lý ứng dụng, biểu mẫu và control
Hình đại diện của người dùng
Sweet Love
Thành viên tích cực
Thành viên tích cực
Bài viết: 159
Ngày tham gia: T.Bảy 06/06/2009 1:37 pm
Đến từ: Xuân Dương - Triệu Trung - Triệu Phong - Quảng Trị
Liên hệ:

Kéo thả File vào TextBox có Unicode

Gửi bàigửi bởi Sweet Love » T.Bảy 12/09/2009 5:59 pm

Thủ thuật: Kéo thả File vào TextBox có Unicode
Tác giả: Sưu tầm
Mô tả: Kéo thả File vào TextBox có Unicode



Tạo Form1 có 1 textbox, name: text1, multiLine=true, OLEDropMode = 0 (default)
paste vào form1

Mã: Chọn hết

 Option Explicit
 Private Sub Form_Load()
 DragAcceptFiles Text1.hWnd, True
Call Hook(Text1.hWnd)
End Sub

 Private Sub Form_Unload(Cancel As Integer)
 Call UnHook
 End Sub  


Paste vào Module1

Mã: Chọn hết

 Option Explicit
  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 Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 Public Declare Sub DragAcceptFiles Lib "shell32" (ByVal hWnd As Long, ByVal fAccept As Long)
 Public Declare Function DragQueryFile Lib "shell32" Alias "DragQueryFileW" (ByVal HDROP As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
 Public Const GWL_WNDPROC = -4
Public lpPrevWndProc As Long
 Public Const WM_DROPFILES As Long = &H233
Private lngHWnd As Long
 Public Sub Hook(hWnd As Long)
 lngHWnd = hWnd
lpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
  Public Sub UnHook()
Dim lngReturnValue As Long
lngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, lpPrevWndProc)
 End Sub

 Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 Select Case uMsg
 Case WM_DROPFILES
  Dim nFiles As Long, Files() As String, i As Long
Dim FileName As String
 nFiles = DragQueryFile(wParam, -1, "", 0)
ReDim Files(0 To nFiles - 1) As String
 FileName = Space(256)

 For i = 0 To nFiles - 1
DragQueryFile wParam, i, FileName, Len(FileName)
Files(i) = TrimNull(StrConv(FileName, vbFromUnicode))
 Next i

 Set_Text hWnd, Join(Files, vbCrLf)
  Case Else: WindowProc = CallWindowProc(lpPrevWndProc, hWnd, uMsg, wParam, lParam)
End Select
  End Function

  Private Function TrimNull(ByVal StrIn As String) As String
Dim nul As Long
' nul = InStr(StrIn, vbNullChar)
Select Case nul
 Case Is > 1
 TrimNull = Left(StrIn, nul - 1)
 Case 1
TrimNull = ""
Case 0
TrimNull = Trim(StrIn)
End Select
End Function  


paste vào module2

Mã: Chọn hết

 Option Explicit
 Private Const CF_UNICODETEXT As Long = 13 Private Const GMEM_MOVEABLE As Long = &H2 Private Const GMEM_ZEROINIT As Long = &H40
  Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
 Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
 Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
 Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
 Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
 Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Const WM_COPY As Long = &H301
 Private Const WM_PASTE As Long = &H302  

Private Function Get_clipboard() As String
 Dim myStrPtr As Long, myLen As Long, myLock As Long, myData As String
 OpenClipboard 0&
  If IsClipboardFormatAvailable(CF_UNICODETEXT) = 0 Then
 MsgBox "Clipboard Text is not available now"
 Exit Function
 myStrPtr = GetClipboardData(CF_UNICODETEXT)
  If myStrPtr = 0 Then
 MsgBox "Failed to get Clipboard Text"
 Else
 myLock = GlobalLock(myStrPtr)
 myLen = GlobalSize(myStrPtr)
myData = String$(myLen \ 2 - 1, vbNullChar)
 lstrcpy StrPtr(myData), myLock GlobalUnlock myStrPtr
End If  
CloseClipboard
  Get_clipboard = myData
 End Function

 Private Sub Set_clipboard(s As String)
Dim myStrPtr As Long, myLen As Long, myLock As Long
 OpenClipboard 0&
EmptyClipboard
  myLen = LenB(s) + 2
myStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, myLen)
 myLock = GlobalLock(myStrPtr) lstrcpy myLock, StrPtr(s) GlobalUnlock myStrPtr
 SetClipboardData CF_UNICODETEXT, myStrPtr
 If IsClipboardFormatAvailable(CF_UNICODETEXT) = 0 Then MsgBox "Failed to set Clipboard Text" CloseClipboard
 End Sub

 Public Sub Set_Text(hWnd As Long, sUni As String)
 Set_clipboard sUni SendMessage hWnd, WM_PASTE, 0, 0 End Sub
  Public Function Get_Text(TextBoxVB As TextBox) As String
 Dim i As Integer
With TextBoxVB
 i = .SelStart
.SelStart = 0
.SelLength = Len(.Text)
SendMessage .hWnd, WM_COPY, 0, 0
.SelStart = i
Get_Text = Get_clipboard
End With
 End Function  
Sửa lần cuối bởi truongphu vào ngày T.Hai 14/12/2009 9:42 am với 1 lần sửa.
Lý do: định dạng phù hợp mẫu


Nguyễn Xuân Khánh
Lớp 11B1 trường THPT Nguyễn Huệ thị xã Quảng Trị

Quay về “[VB] Ứng dụng - Form và Control”

Đang trực tuyến

Đang xem chuyên mục này: Không có thành viên nào trực tuyến.0 khách