fExcel贴数

1
Sub 粘贴格式文本(control As IRibbonControl)
2
    Set xl = GetObject(, "excel.application")
3
    xlr = xl.Selection.Rows.Count
4
    xlc = xl.Selection.Columns.Count
5
    With Selection
6
        wdc = .Information(16)
7
        wdr = .Information(13)
8
        rangeselect wdr, wdc, xlr, xlc
9
        ReDim arr(1 To 1)
10
        For Each sht In .Cells
11
            i = i + 1
12
            ReDim Preserve arr(1 To i)
13
            arr(i) = sht.Range.Font.Underline
14
        Next
15
        .CopyFormat
16
        .PasteAndFormat (wdFormatSurroundingFormattingWithEmphasis)
17
        .PasteFormat
18
        With .Find
19
            .Text = " "
20
            .Replacement.Text = ""
21
            .Forward = True
22
            .Wrap = wdFindStop
23
            .Execute Replace:=wdReplaceAll
24
        End With
25
        rangeselect wdr, wdc, xlr, xlc
26
        For Each sht In .Cells
27
            j = j + 1
28
            sht.Range.Font.Underline = arr(j)
29
        Next
30
    End With
31

32
End Sub
33
Sub 双下划线(control As IRibbonControl)
34
    If Selection.Font.Underline = wdUnderlineDouble Then
35
        Selection.Font.Underline = wdUnderlineNone
36
    ElseIf Selection.Font.Underline = wdUnderlineNone Then
37
        Selection.Font.Underline = wdUnderlineDouble
38
    End If
39
End Sub
40
Sub 单下划线(control As IRibbonControl)
41
    If Selection.Font.Underline = wdUnderlineSingle Then
42
        Selection.Font.Underline = wdUnderlineNone
43
    ElseIf Selection.Font.Underline = wdUnderlineNone Then
44
        Selection.Font.Underline = wdUnderlineSingle
45
    End If
46
End Sub
47
Function rangeselect(wdr, wdc, xlr, xlc)
48
    With Selection
49
        .Tables(1).Cell(wdr, wdc).Select
50
        .Collapse wdCollapseStart
51
        st = .Start
52
        .Tables(1).Cell(wdr + xlr - 1, wdc + xlc - 1).Select
53
        .Collapse wdCollapseEnd
54
        ed = .End
55
        ActiveDocument.Range(st, ed).Select
56
    End With
57
End Function