Сформировать табличку в Clipboard

[Andrey Fedorov]

Кто нибудь знает простейший способ сформировать табличку в Clipboard, чтобы потом ее можно вставить по Ctrl+V в Word? Интересует именно самый простой вариант...

[Amed]

Прямо объектной моделью ворда..?
Создать документ, создать/заполнить табличку, вырезать ее из документа, закрыть документ.

В буфере табличка останется

[Andrey Fedorov]

Прямо объектной моделью ворда..?

Чур меня!

Я вот так уже сделал:

Код: Выделить всё

Public Sub SetClipboardTableRTF(r As ADODB.Recordset, _
                        Optional WidthCols As String = vbNullString, _
                        Optional FormatCols As String = vbNullString)

    Dim ColW() As Integer, ColF() As String
    Dim sb As New StringBuilder, f As ADODB.Field, sr As String, v As Variant, _
        s As String, ss As String, b As Boolean, sf As String, i As Long, _
        n As Integer, j As Integer

    ' Ширина колонок
    ReDim ColW(r.Fields.Count - 1)
    If Len(WidthCols) Then
        v = Split(WidthCols, ";")
        n = UBound(v)
        If n > UBound(ColW) Then n = UBound(ColW)
        On Error Resume Next
        For n = 0 To n
            If IsNumeric(v(n)) Then
                j = v(n)
                If Err.Number Then
                    Err.Clear
                Else
                    If j > 0 Then ColW(n) = j
                End If
            End If
        Next n
        On Error GoTo 0
    Else
        For Each f In r.Fields
            Select Case f.Type
                Case adCurrency
                    i = 1500
                Case adTinyInt, adSmallInt, adInteger
                    i = 1200
                Case adSingle, adDouble
                    i = 1500
                Case adDate, adDBTimeStamp
                    i = 1500
                Case adBoolean
                    i = 700
                Case Else
                    i = 3000
            End Select
            ColW(n) = i
            n = n + 1
        Next f
    End If
    i = 0
    For n = 0 To UBound(ColW)
        If ColW(n) > 0 Then
            i = i + ColW(n)
            ColW(n) = i
        End If
    Next n

    ' Формат колонок
    ReDim ColF(r.Fields.Count - 1): n = 0
    For Each f In r.Fields
        Select Case f.Type
            Case adCurrency
                s = "r": sf = "#,##0.00"
            Case adTinyInt, adSmallInt, adInteger
                s = "r": sf = "#,##0"
            Case adSingle, adDouble
                s = "r": sf = "#,##0.000"
            Case adDate, adDBTimeStamp
                s = "c": sf = "Short Date"
            Case adBoolean
                s = "c": sf = "b"
            Case Else
                s = "l": sf = vbNullString
        End Select
        ColF(n) = s & sf
        n = n + 1
    Next f
    If Len(FormatCols) Then
        v = Split(FormatCols, ";")
        n = UBound(v)
        If n > UBound(ColF) Then n = UBound(ColF)
        On Error Resume Next
        For n = 0 To n
            s = Trim$(v(n))
            If Len(s) Then ColF(n) = Left$(ColF(n), 1) & s
        Next n
    End If

    ' Формирование строки RTF
    sb.AppendLine "{\rtf1\par "
    For n = 0 To UBound(ColW)
        If ColW(n) > 0 Then sr = sr & "\cellx" & ColW(n)
    Next n
    sr = "\trowd \trgaph30\trleft-30\trrh262" & sr & " "
    Do Until r.EOF
        sb.AppendLine sr
        b = True: n = 0
        For Each f In r.Fields
            If ColW(n) > 0 Then
                s = Left$(ColF(n), 1)
                sf = Mid$(ColF(n), 2)
                If IsNull(f) Then
                    ss = "\cell"
                Else
                    If Len(sf) Then
                        If sf = "b" Then
                            ss = IIf(f, "Да", "Нет") & "\cell"
                        Else
                            ss = Replace(Format$(f, sf), "", "") & "\cell"
                        End If
                    Else
                        ss = Replace(f, "", "") & "\cell"
                    End If
                End If
                If b Then
                    sb.Append "\intbl \q" & s & " \f0\fs20 \cf " & ss: b = False
                Else
                    sb.Append "\q" & s & " " & ss
                End If
            End If
            n = n + 1
        Next f
        sb.AppendLine " \intbl \row "
        r.MoveNext
    Loop
    sb.AppendLine "}"
   
    Debug.Print sb.Value
   
    Clipboard.Clear
    Clipboard.SetText sb.Value, vbCFRTF
End Sub

[EUGY]

надо написать метафайл

Код: Выделить всё


Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Declare Function PlayEnhMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hemf As Long, lpRect As RECT) As Long

'рисует на форме скопированную таблицу из EXCEL or WORD
Private Sub Form_Paint() 'autoredraw -false
Dim rc As RECT
    rc.Top = 0
    rc.Left = 0
    rc.Right = 1000
    rc.Bottom = 500
    PlayEnhMetaFile Me.hdc, Clipboard.GetData(vbCFEMetafile), rc
End Sub


[Andrey Fedorov]

надо написать метафайл

Мне такое точно не требовалось...

[EUGY]

я и не настаивал.
просто хотел сказать что это "родной" формат.
Границы, заливки, ширина столбцов...

Если без них то.

Clipboard.SetText r.GetString()