Excel VBA将单元格内容复制到InkEdit文本框中，并保留包括颜色/粗体等的格式
我有一个表单，其中一些单元格有多彩的文本，并以粗体/下划线/斜体显示。
我需要能够拉单元格的内容，并在窗体上显示相同格式的信息。
我遇到了支持RichText的InkEdit控件，但我无法从单元格复制到此框。
请帮助
问题似乎是，Excel对象模型深深地埋藏了单元格内容的RTF格式，并没有提供简单的方法来提取它。
这似乎是一种工作：
Sub CopyRichText(source As Range, target As InkEdit) Dim i As Long, n As Long target.Text = source.Text n = Len(target.Text) For i = 1 To n target.SelStart = i - 1 target.SelLength = 1 target.SelBold = source.Characters(i, 1).Font.Bold target.SelColor = source.Characters(i, 1).Font.Color target.SelFontName = source.Characters(i, 1).Font.FontStyle target.SelFontSize = source.Characters(i, 1).Font.Size target.SelItalic = source.Characters(i, 1).Font.Italic 'target.SelUnderline = source.Characters(i, 1).Font.Underline '-- doesn't work as expected! Next i target.SelStart = n target.SelLength = 0 End Sub 像这样使用：
Private Sub UserForm_Initialize() CopyRichText Range("A1"), Me.InkEdit1 End Sub
例如，在A1中我有：
然后当我显示用户窗体看起来像：
似乎在inkedit的SelUnderline方法中有一个彻底的错误。 取消该行看到我的意思。 也许有一些解决方法。
我怀疑上面有些脆弱。 我没有testing过那么多。 如果它适合你（也许适当调整） – 好。 如果不是的话，我怀疑使用剪贴板有一个很深的魔法。 InkEdit控件没有粘贴方法 – 但它有一个Hwnd方法，听起来好像它可以提供一个窗口的粘贴目标。
InkEdit控件支持粘贴富文本，所以您只需复制Range ，然后将其粘贴到控件中即可。 由于该控件暴露了.hWnd ，所以您只需使用SendMessage API函数发送WM_PASTE消息：
'UserForm1 Option Explicit Private Declare Function SendMessage Lib "user32" Alias _ "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) As Long Private Const WM_PASTE = &H302 Private Sub UserForm_Initialize() RangeToInkEdit ActiveSheet.Cells(1, 1), InkEdit1 Application.CutCopyMode = False End Sub Sub RangeToInkEdit(source As Range, target As InkEdit) source.Copy SendMessage InkEdit1.hwnd, WM_PASTE, 0&, 0& End Sub Private Sub CommandButton1_Click() Unload Me End Sub
请注意，这也有一个类似于@ JohnColeman的方法的轻微问题 – 在拾取颜色方面做得不是很好。 这似乎是Excel在RTF编码中发送到剪贴板的问题，而不是InkEdit控件本身的问题（您可以通过复制并粘贴到写字板中，这基本上是一个RTF编辑器）来确认。 一些颜色可以工作，其他颜色则不会 – 所有颜色的颜色深度都会减less到基本上与RTF支持的最接近的颜色。
我提供了两个function来使用InkEdit控件。
- PasteToControl：使用API调用将数据从ClipBoard粘贴到InkEdit控件中
- PutInClipBoard：这将文本复制到剪贴板。 这个function是必需的，因为如果你设置InkEdit文本属性（例如InkEdit.Text = InkEdit.Text＆“Hello！”），你将失去所有的格式。 InkEdit.TextRTF也不起作用。
Private Declare Function PasteToControl Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, Optional ByVal wMsg As Long = &H302, Optional ByVal wParam As Long = 0, Optional lParam As Any = 0&) As Long 'http://www.devx.com/vb2themax/Tip/18632 Private Sub UserForm_Layout() InkEdit1.Text = vbCrLf Range("A6").Copy PasteToControl InkEdit1.hWnd PutInClipBoard vbCrLf & "How about Range?" & vbCrLf PasteToControl InkEdit1.hWnd Range("A2:G4").Copy PasteToControl InkEdit1.hWnd PutInClipBoard vbCrLf & "Can we do Tables?" & vbCrLf PasteToControl InkEdit1.hWnd Sheet4.ListObjects("Orders").Range.Copy PasteToControl InkEdit1.hWnd PutInClipBoard vbCrLf & "Pictures?" PasteToControl InkEdit1.hWnd Sheet4.Shapes("Picture 1").Copy PasteToControl InkEdit1.hWnd PutInClipBoard vbCrLf & "Charts?" PasteToControl InkEdit1.hWnd Sheet4.ChartObjects("Chart 4").Copy PasteToControl InkEdit1.hWnd PutInClipBoard vbCrLf & "Can we take a snapshot of a Range?" & vbCrLf PasteToControl InkEdit1.hWnd Range("A6:I12").CopyPicture PasteToControl InkEdit1.hWnd End Sub Sub PutInClipBoard(Text As String) Dim clip As DataObject Set clip = New DataObject clip.SetText Text clip.PutInClipBoard End Sub
你需要能够编辑文本？ 如果没有，那么我会尝试复制范围并粘贴它作为UserForm中的图片。 检查Stephen Bullen的PastePicture示例代码。