漢字字源教學測試頁排版置入內容 vbscript 

                  Sub 漢字字源教學測試頁排版置入內容()
'要先輸入好字頭，並且將插入點置於字頭內容段落內
Dim d字源圖片 As Document, theD As Document, d1 As Document
Dim p As Paragraph, rng As Range, inlsp As InlineShape
Dim x As String
Set d字源圖片 = Documents("!!!@@@＃＃＃字源圖片.docx")
Set theD = ActiveDocument
Set d1 = Documents(1) '原字源檔
With theD.ActiveWindow.Selection.Paragraphs(1).Range
    x = .Characters(1)
    With .Characters(3)
        .Text = x
        .Select
        Application.WordBasic.toolsTcScTranslate Direction:=0, Varients:=0, Translatecommon:=0
    End With
    .Characters(8).Text = VBA.IIf(注音拼音.漢字轉拼音(x) = Null, "", 注音拼音.漢字轉拼音(x))
    .Characters(6).Text = VBA.IIf(注音拼音.漢字轉注音(x) = Null, "", 注音拼音.漢字轉注音(x))
End With
theD.ActiveWindow.Selection.MoveDown
For Each p In d1.Paragraphs
    If p.Range.Characters.Count > 3 Then
        If p.Range.Characters(3).Font.Size = 14 Then
            Set rng = p.Range
            rng.SetRange p.Range.Characters(1).Start, p.Range.Characters(p.Range.Characters.Count - 1).End
            rng.Copy
            '先選好要覆蓋過去的段落
            With theD.ActiveWindow.Selection
                .Paragraphs(1).Range.Select
                .MoveLeft wdCharacter, 1, wdExtend
                .Paste
                .MoveDown
            End With
            If p.Next.Range.Text Like "　　以下是「*" Then Exit For
        End If
    End If
Next
'調整靜態筆順圖大小及「」內的字
Dim np As Paragraph
Set np = theD.ActiveWindow.Selection.Paragraphs(1)
Do
    If InStr(np.Range.Text, "」字書寫的筆順是") > 0 Then
        np.Range.Characters(4) = x 'theD.Tables(1).Rows(2).Cells(6).Range.Characters(1)
        If np.Range.InlineShapes.Count = 0 Then '插入靜態筆順圖
            If Dir("E:\@@@華語文工具及資料@@@\!!@詞典附檔@!\筆順圖形\*" & x & "*.jpg") <> "" Then
                np.Range.Characters(13).InlineShapes.AddPicture _
                    "E:\@@@華語文工具及資料@@@\!!@詞典附檔@!\筆順圖形\" & _
                    Dir("E:\@@@華語文工具及資料@@@\!!@詞典附檔@!\筆順圖形\*" & x & "*.jpg")
            End If
        End If
        For Each inlsp In np.Range.InlineShapes
            inlsp.LockAspectRatio = msoTrue
            inlsp.Height = 20.65
        Next
        np.Next.Range.Select
        Exit Do
    End If
    Set np = np.Next
Loop
''處理表格內的字圖
Dim c As Cell, ri As Long, ci As Byte, tb As Table
Set tb = theD.ActiveWindow.Selection.Tables(1)
For Each c In d字源圖片.Tables(1).Columns(1).Cells
    If InStr(c.Range, x) > 0 Then
        ri = c.RowIndex
'        c.Next.Select
'        d字源圖片.
        Exit For
    End If
Next
If ri = 0 Then 'd字源圖片沒有的話
        For Each c In d1.Tables(1).Rows(2).Cells
            ci = ci + 1
            If c.Range.InlineShapes.Count > 0 Then
                c.Range.InlineShapes(1).Range.Select
                d1.ActiveWindow.Selection.Copy
                With tb.Cell(2, ci).Range
                    If .InlineShapes.Count > 0 Then
                        .InlineShapes(1).Range.Select
                    Else
                        .Characters(1).Select
                    End If
                    .Paste
                    With .InlineShapes(1)
                        .LockAspectRatio = msoTrue
                        Select Case ci
                            Case 1  '甲骨文
                                .Height = 27.2
                            Case 2
                                .Height = 30
                            Case 3
                                
                            Case 4
                            Case 5 '行書
                                .Height = 37.7
                        End Select
                    End With
                End With
            Else '結果沒圖
                'c.Range.Characters(1).Copy
                tb.Cell(2, ci).Range.Text = Replace(Replace(c.Range.Text, Chr(13), ""), Chr(7), "")
            End If
    Next

Else
    For Each c In d字源圖片.Tables(1).Rows(ri).Cells
        If c.ColumnIndex > 7 Then Exit For '到楷書為止
        If c.ColumnIndex > 1 Then
            ci = ci + 1
            If c.Range.InlineShapes.Count > 0 Then
                c.Range.InlineShapes(1).Range.Select
                d字源圖片.ActiveWindow.Selection.Copy
                With tb.Cell(2, ci).Range
                    If .InlineShapes.Count > 0 Then
                        .InlineShapes(1).Range.Select
                    Else
                        .Characters(1).Select
                    End If
                    .Paste
                    With .InlineShapes(1)
                        .LockAspectRatio = msoTrue
                        Select Case ci
                            Case 1  '甲骨文
                                .Height = 27.2
                            Case 2
                                .Height = 30
                            Case 3
                                
                            Case 4
                            Case 5 '行書
                                .Height = 37.7
                        End Select
                    End With
                End With
            Else '結果沒圖
                'c.Range.Characters(1).Copy
                tb.Cell(2, ci).Range.Text = Replace(Replace(c.Range.Text, Chr(13), ""), Chr(7), "")
            End If
        End If
    Next
    tb.Cell(2, ci + 1).Range.Text = Replace(Replace(tb.Cell(2, ci).Range.Text, Chr(13), ""), Chr(7), "")
    tb.Cell(2, ci + 1).Range.Characters(1).Select
    Application.WordBasic.toolsTcScTranslate Direction:=0, Varients:=0, Translatecommon:=0
End If
' 插入原有字源解說大圖
With d1.InlineShapes(d1.InlineShapes.Count)
    If .Height > 70 Then
        .Range.Select
        d1.ActiveWindow.Selection.Copy
        With theD.ActiveWindow.Selection
            '.MoveDown , 3
            .MoveUntil Chr(12)
            .Paste
'            .Paragraphs(1).LineSpacingRule = wdLineSpaceSingle
        End With
    End If
End With
With theD.ActiveWindow
    .Activate
    If .Selection.Sections(1).Range.Paragraphs(2).Range.Font.Size <> 14 Then .Selection.Sections(1).Range.Paragraphs(2).Range.Font.Size = 14
End With
If tb.Cell(2, ci + 1).Range.Text <> tb.Cell(2, ci).Range.Text Then MsgBox "請插入簡化字靜態筆順！", vbExclamation
End Sub
View Oscar's Profile