Office中国论坛/Access中国论坛

标题: 如何实现复制、粘贴功能 [打印本页]

作者: linjingdr 时间: 2009-4-9 00:03
标题: 如何实现复制、粘贴功能
本帖最后由 linjingdr 于 2009-4-9 00:16 编辑

如图：
想实现把某个文本框里的文本复制后，在另一处粘贴。已录屏成GIF图片（已在论坛里搜索并试验过了，没有成功）请别只回答在论坛里搜索。这个功能对我真的很重要。谢谢！

作者: 82077802 时间: 2009-4-9 06:39
Dim mbCut As
Boolean

Dim mRng As Range

Sub InitCutCopy()

'设定/初此化快捷键

With Application

'CTRL+X

.OnKey "^x", "DoCut"

.OnKey "^X", "DoCut"

.OnKey "+{DEL}", "DoCut"

'CTRL+C

.OnKey "^c", "DoCopy"

.OnKey "^C", "DoCopy"

.OnKey "^{INSERT}", "DoCopy"

'CTRL+V

.OnKey "^v", "DoPaste"

.OnKey "^V", "DoPaste"

.OnKey "+{INSERT}", "DoPaste"

'关掉单元格的拖动功能，你也可以不<SPAN class=t_tag onclick=tagshow(event) href="tag.php?name=%C9%E8%D6%C3">设置</SPAN>

.CellDragAndDrop = False

End
With

End
Sub

Sub DoCut()

If
TypeOf Selection Is Range Then

      mbCut = True

Set mRng = Selection

'复制到剪切板上

      Selection.Copy

Else

      mRng = Nothing

'剪切到剪切板上

      Selection.Cut

End
If

End
Sub

Sub DoCopy()

If
TypeOf Selection Is Range Then

      mbCut = False

Set mRng = Selection

Else

      mRng = Nothing

End
If

'复制到剪切板上

      Selection.Copy

End
Sub

Sub DoPaste()

If Application.CutCopyMode And
Not (mRng Is
Nothing) Then

'贴为数值

Selection.PasteSpecial xlValue

'如果是CUT模式，清除旧数据

If mbCut Then mRng.ClearContents

Set mRng = Nothing

Else

'如果不是RANGE对象，直接粘贴

If Application.CutCopyMode Then ActiveSheet.Paste

End
If

'清空剪切板

Application.CutCopyMode = False

End
Sub

作者: linjingdr 时间: 2009-4-9 17:10
试了一下，还是没有成功，能不能帮我做一个例子看一下，好吗？

作者: chaojianan 时间: 2009-4-9 18:16
看看可以否。

作者: koutx 时间: 2009-4-9 18:18
本帖最后由 koutx 于 2009-4-9 18:21 编辑

帮助医生我高兴。
给你一个不用粘贴的办法，勾选几个字段后关闭其窗口，就自动添进去了。

作者: koutx 时间: 2009-4-9 18:54
又彻底完善了一下，再发一个新的。在选择字段窗体中勾选完需勾选的字段后，点其窗体右上角的“X”关闭即可。[attach]37213[/attach]

作者: linjingdr 时间: 2009-4-9 21:28
你们好，谢谢大家的帮助。chaojianan的方法是在原文本的最后，添加了新选择的文本。koutx 的方法则是直接替换了原来的文本。我的设想是这样，把选择的文本复制进剪贴板，然后在原文本的任意位置从剪贴板中粘贴进去。（根据我的体会，医师在写病历时，如果频繁调用文本，会影响思路。如果可以在完成初步的病历后，在适当位置插入常用字段，如难以输入的检验报告结果，应该是比较好的方法）
大家再帮帮我吧！

作者: linjingdr 时间: 2009-4-9 21:29
如果用SENDKEYS不知道是否可以实现这个功能（代替CTRL+C和CTRL+V)，但我不会用

作者: koutx 时间: 2009-4-9 22:22
本帖最后由 koutx 于 2009-4-9 22:25 编辑

如果用SENDKEYS不知道是否可以实现这个功能（代替CTRL+C和CTRL+V)，但我不会用
linjingdr 发表于 2009-4-9 21:29

试试看。在欲插入点单击，再点右键即可贴进去。[attach]37218[/attach]

作者: linjingdr 时间: 2009-4-9 23:35
本帖最后由 linjingdr 于 2009-4-10 10:22 编辑

谢谢koutx的热心帮助，用你的方法通过右键功能可以实现这个功能了。
我从别处找了一个API的代码，放在楼下，可以用在ACCESS中来实现复制和粘贴功能，可是我不知道如何应用，大家可以看一看，发表一下看法。

作者: linjingdr 时间: 2009-4-10 01:07
有谁能够给这段代码做个详细的解释吗？能给出一个简单的调用例子吗？
VBA中用API操作剪贴板

Public Const GHND = &H42
Public Const CF_TEXT = 1
Private Const CF_ANSIONLY = &H400&
Private Const CF_APPLY = &H200&
Private Const CF_BITMAP = 2
Private Const CF_DIB = 8
Private Const CF_DIF = 5
Private Const CF_DSPBITMAP = &H82
Private Const CF_DSPENHMETAFILE = &H8E
Private Const CF_DSPMETAFILEPICT = &H83
Private Const CF_DSPTEXT = &H81
Private Const CF_EFFECTS = &H100&
Private Const CF_ENABLEHOOK = &H8&
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLETEMPLATEHANDLE = &H20&
Private Const CF_ENHMETAFILE = 14
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_GDIOBJFIRST = &H300
Private Const CF_GDIOBJLAST = &H3FF
Private Const CF_HDROP = 15
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_LOCALE = 16
Private Const CF_MAX = 17
Private Const CF_METAFILEPICT = 3
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_NOSIZESEL = &H200000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS
Private Const CF_NOVERTFONTS = &H1000000
Private Const CF_OEMTEXT = 7
Private Const CF_OWNERDISPLAY = &H80
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_PRINTERFONTS = &H2
Private Const CF_PRIVATEFIRST = &H200
Private Const CF_PRIVATELAST = &H2FF
Private Const CF_RIFF = 11
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_SELECTSCRIPT. = &H400000
Private Const CF_SHOWHELP = &H4&
Private Const CF_SYLK = 4
Private Const CF_TIFF = 6
Private Const CF_TTONLY = &H40000
Private Const CF_UNICODETEXT = 13
Private Const CF_USESTYLE = &H80&
Private Const CF_WAVE = 12
Private Const CF_WYSIWYG = &H8000
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Sub ClearClipBoard()
OpenClipboard 0&
EmptyClipboard
CloseClipboard
End Sub
Function ClipBoard_SetText(strCopyString As String) As Boolean
Dim hGlobalMemory As Long
Dim lpGlobalMemory As Long
Dim hClipMemory As Long
Call ClearClipBoard
hGlobalMemory = GlobalAlloc(GHND, Round((Len(strCopyString) / 1024 + 0.5), 0) * 1024)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, strCopyString)
If GlobalUnlock(hGlobalMemory) = 0 Then
   If OpenClipboard(0&) <> 0 Then
      hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
      ClipBoard_SetText = CBool(CloseClipboard)
   End If
End If
End Function
Function ClipBoard_GetText() As String
Dim hClipMemory As Long
Dim lpClipMemory As Long
Dim strCBText As String
Dim RetVal As Long
Dim lngSize As Long
If OpenClipboard(0&) <> 0 Then
      hClipMemory = GetClipboardData(CF_TEXT)
      If hClipMemory <> 0 Then
         lpClipMemory = GlobalLock(hClipMemory)
         If lpClipMemory <> 0 Then
            lngSize = GlobalSize(lpClipMemory)
            strCBText = Space$(lngSize)
            RetVal = lstrcpy(strCBText, lpClipMemory)
            RetVal = GlobalUnlock(hClipMemory)
            strCBText = Left(strCBText, InStr(1, strCBText, Chr$(0), 0) - 1)
         Else
            MsgBox "Could not lock memory to copy string from."
         End If
      End If
      Call CloseClipboard
End If
ClipBoard_GetText = strCBText
End Function
Function CopyOlePiccy(Piccy As Object)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(Piccy) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, Piccy)
If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard."
End If
End Function

作者: linjingdr 时间: 2009-4-10 10:24
Private Const CF_SELECTSCRIPT. = &H400000
这一行中的“.”可能是多余的，在ACCESS中会提示出错

作者: todaynew 时间: 2009-4-10 16:40
本帖最后由 todaynew 于 2009-4-10 17:22 编辑

[attach]37231[/attach]

[attach]37232[/attach]

没有完全按你的思路来，以我的理解就是字符串连接的问题而已，于是乎便另建了一个主诉记录窗体。操作时，可连续在主诉字段中录入内容。当需使用常用词时，下拉组合框，找到常用字，双击之即可。

Private Sub Combo2_DblClick(Cancel As Integer)
Me.主诉.Value = Me.主诉.Value & Me.Combo2.Value
Me.主诉.SetFocus
Me.主诉.SelStart = Len(Nz(主诉, ""))
End Sub
Private Sub Form_Open(Cancel As Integer)
Me.主诉.SetFocus
Me.主诉.SelStart = Len(Nz(主诉, ""))
End Sub

如果确需打开一个常用词窗体的话，也可以用OpenArgs参数回写原窗体数据。总体说来，常用词的操作似乎并不需要用到剪贴板，也不需要那么多按钮。不应将简单问题复杂化。以上意见仅供参考。

作者: sgrshh29 时间: 2009-4-10 19:55
类似于点菜,在主窗体的任意文本框中的任意位置插入右边子窗体中任意文本框的字符串.不要调用剪贴板.

作者: linjingdr 时间: 2009-4-10 21:13

类似于点菜,在主窗体的任意文本框中的任意位置插入右边子窗体中任意文本框的字符串.不要调用剪贴板.
sgrshh29 发表于 2009-4-10 19:55

能详细说说吗？
其实我举的只是一个简单化的例子，本意是要在多个文本框中根据需要选择性的进行粘贴，所以想调用剪贴板。

作者: sgrshh29 时间: 2009-4-10 22:13

能详细说说吗？
其实我举的只是一个简单化的例子，本意是要在多个文本框中根据需要选择性的进行粘贴，所以想调用剪贴板。
linjingdr 发表于 2009-4-10 21:13

供你参考。

作者: chaojianan 时间: 2009-4-11 11:35
谢谢，学习了。

作者: linjingdr 时间: 2009-4-11 21:11

供你参考。
sgrshh29 发表于 2009-4-10 22:13

果然可以点菜，学到了好东东呀！

作者: t小宝 时间: 2009-4-11 22:42
关于复制粘贴，不必要用API，ACC中有内置命令：

DoCmd.RunCommand acCmdCopy
DoCmd.RunCommand acCmdPaste

作者: 13555609005 时间: 2009-4-11 23:55
学习学习

作者: yinghua05 时间: 2009-4-13 11:28
感谢帮助，这个帖子对我帮助很大

作者: lymin 时间: 2009-4-13 15:37
好例子

作者: chuang0321 时间: 2009-4-13 15:48
受益了

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)