回 帖 发 新 帖 刷新版面

主题:富文本框一拖即开、一拖即存以及拖放编辑的代码

富文本框一拖即开、一拖即存以及拖放编辑的代码


本代码有3个功能:
1.一拖即开:可以将rtf文件、txt文本以及其它文本文件拖放到文本框并打开,如果是多个文本文件,就进行文本合并。操作时会出现一个带加号的小框。
2.一拖即存:用鼠标选定一段文本,先按住【Ctrl】键,再用鼠标按住按选定的文本拖至窗口外,该段文本保存到桌面上为一个txt文件(文件名后面有可以连续递增的序数,让用户可以保存多个这样的小文本文件)。代码中用到了一个检测鼠标位置的API函数 GetCursorPos。该函数只有一个参数,即POINTAPI结构,它用于检测选中的文本是否拖出了窗体。
3.拖放编辑:相当于将“剪切”和“粘贴”两个编辑功能合并了,并且不但能在本窗口内拖放字符串文本,还能将别的程序窗口中的文本拖到本窗口来。操作时先选定一段文本,用鼠标按住在窗口内移动,鼠标尖处会出现一个虚线长方框,移动到位松开鼠标即可。


新建一个窗体,在窗体上添加一个富文本框(RichTextBox控件),一个按纽和一个计时器。
属性设置:
富文本框:ScrollBars=2,MultiLine=True
计时器:Enabled=False,Interval=200
按纽:Caption=“拖放模式”


代码如下:


Option Explicit

Private Type POINTAPI
  x As Long
  y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Dim dropMode As Boolean '拖放模式:0-拖放编辑,1-拖放文件
Dim fName As String     '文件名
Dim st1 As String, fNum As Integer


Private Sub Form_Load()
RichTextBox1.OLEDropMode = 2
Command1.ToolTipText = "拖放编辑"
End Sub


Private Sub Command1_Click()
dropMode = Not dropMode
Command1.ToolTipText = IIf(dropMode, "拖放文件", "拖放编辑")
RichTextBox1.OLEDropMode = IIf(dropMode, 1, 2)
RichTextBox1.SetFocus
End Sub


Private Sub RichTextBox1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Shift = 2 Then Timer1.Enabled = True
End Sub


Private Sub RichTextBox1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Timer1.Enabled = False
End Sub


Private Sub RichTextBox1_OLEDragOver(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
On Error GoTo 100
Effect = IIf(InStr("RTF,TXT,LOG,HTM,INI,REG", Right(UCase(Data.Files.Item(1)), 3)), 1, 0) '文件后缀是例举的就显示可以放下的带加号图标,否则显示不可放下的圆圈加斜线的图标
100
End Sub


Private Sub RichTextBox1_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo 100
Effect = 1
fName = Data.Files.Item(1)
If UCase(Right(fName, 3)) = "RTF" Then
  RichTextBox1.LoadFile fName
Else
  Dim st2 As String, z As String, i As Integer
  For i = 1 To Data.Files.Count
    st1 = ""
    fName = Data.Files.Item(i)
    Open fName For Input As #1
    Do Until EOF(1)
      Line Input #1, z
      st1 = st1 & z & vbCrLf
    Loop
    Close #1
    st2 = st2 & st1
  Next
  RichTextBox1.Text = st2
End If
100
End Sub


Private Sub Timer1_Timer()
Dim PO As POINTAPI, Ws
GetCursorPos PO '检测鼠标位置
If (PO.x < Left \ 15 Or PO.x > (Left + Width) \ 15 Or PO.y < Top \ 15 Or PO.y > (Top + Height) \ 15) And RichTextBox1.SelLength > 0 Then  '如果剪贴板不为空,并且鼠标移出窗体外
  Set Ws = CreateObject("WScript.Shell")
  st1 = Ws.SpecialFolders("Desktop") '获取桌面路径
  Set Ws = Nothing
  fNum = fNum + 1: fName = st1 & "\快存(" & Format(fNum, "00") & ").txt" '添加序号作为新文件名
  Open fName For Output As #2
  Print #2, RichTextBox1.SelText
  Close #2
  Timer1.Enabled = False
End If
End Sub


简要分析:
1.操作
程序开始时,默认为拖放编辑,点击按纽就改变为一拖即开。一拖即存与按纽的拖放模式无关。


2.事件
以上代码中,富文本框的OLEDragOver事件和OLEDragDrop事件处理一拖即开,鼠标事件和计时器事件处理一拖即存。其中:
OLEDragOver事件判断拖来的文件是否rtf文件、txt文件或其它文本文件。
OLEDragDrop事件将文件打开,如果是文本文件就进行合并(rtf文件也可进行合并,但处理起来较复杂,本文不赘述)。
Timer1_Timer事件判断如果鼠标移出窗口,就将选定文本保存。其中的有关数据除以15的目的是保持计量单位的统一(API函数用“像素”,VB默认用“缇”,1像素=15缇)。


3.参数
富文本框OLEDragOver事件和OLEDragDrop事件中的Effect参数有3个值:
0—不接受数据,常用。
1—接受数据,且初始数据没有被拖放操作改动,常用。
2—接受数据,但拖动后,拖放源要被删去数据,极少使用。


4.属性
富文本框的OLEDropMode属性决定了是拖放编辑还是一拖即开,它有3个值:
0—不接受任何拖放操作。
1—允许用代码处理拖放操作,一拖即开必须设置为此值。
2—自动接受拖放操作,允许窗口内的数据移动,拖放编辑必须设置为此值。


如果你想坐享其成,可以去163信箱下载实例,帐号:vb62013,密码:vb620132013。

回复列表 (共1个回复)

沙发








我来回复

您尚未登录,请登录后再回复。点此登录或注册