Tập thiết kế một chương trình phức hợp thao tác với Word và PowerPoint

[tuhocvba]

Trong topic này tôi sẽ trình bày các bước để các bạn làm quen dần với thiết kế Tool.
Mục đích Tool lần này là chuyển nội dung từ Word vào File Form PowerPoint đã được thiết kế sẵn.

Như vậy từ mục đích yêu cầu của bài toán, tôi sẽ cần hai nút bấm để chọn file.

Bạn cần đăng nhập để thấy đính kèm

Đoạn code để chọn file có thể tham khảo code dưới đây:

Function select_file(ByVal tieude As String) As String
'    Dim fso As Object
'    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fd As Office.FileDialog

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

   With fd

      .AllowMultiSelect = False

      ' Set the title of the dialog box.
      .Title = tieude

      ' Clear out the current filters, and add our own.
      .Filters.Clear
      .Filters.Add "Excel File", "*.xls?"
      '.Filters.Add "All Files", "*.*"

      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least one file. If the .Show method returns
      ' False, the user clicked Cancel.
      If .Show = True Then
        select_file = .SelectedItems(1) 'replace txtFileName with your textbox

      End If
   End With
   Set fd = Nothing
End Function

Vì lần này select file .ppt và .doc nên trong code trên ta cần chỉnh lại phần định dạng file.

Để không làm thay đổi nội dung file ban đầu, chúng ta nên

Bạn cần đăng nhập để thấy link

ra một bản sao, trước khi tiến hành thay đổi nội dung.
Code tham khảo:

Sub test68()
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ''Copy file C:\Work\Book1.xlsx cất vào thư mục C:\Tmp
    FSO.GetFile("C:\Work\Book1.xlsx").Copy "C:\Tmp\"
    ''Copy file C:\Work\Book1.xlsx cho vào thư mục
    '' và đổi tên file là Report.xlsx
    FSO.GetFile("C:\Work\Book1.xlsx").Copy "C:\Tmp\Report.xlsx"
    Set FSO = Nothing
End Sub

Việc copy file gốc không phải là nội dung bắt buộc trong thiết kế một chương trình. Tùy vào mức độ quan trọng của file mình thao tác mà đưa vào. Thao tác cũng không có khó khăn gì nên tôi lựa chọn copy file.

Bạn cần đăng nhập để thấy đính kèm

Tên file sẽ thay đổi một chút, ví dụ có thể thêm _tmp tuy nhiên nếu tool chạy đi chạy lại nhiều lần thì vô tình sẽ tạo ra các file có tên giống nhau. Do đó ta sẽ dựa vào thời gian để đưa thêm vào tên file cho phù hợp. Tôi thường sử dụng đoạn code này:

strDate = Format(Now, "ddmmyyhmmss")

Chúng ta nối strDate vào tên file ban đầu là được.

 

[tuhocvba]

Tiếp theo tới vấn đề mở một file word, ta có code tham khảo như sau:

Sub openfileword()
    Dim objword As Object, wdDoc As Object
    Dim Target  As String
    
    Set objword = CreateObject("Word.Application")
    objword.Visible = True
    objword.DisplayAlerts = False
    Target = "D:\Python_AI\TaiLieuPyThon\N1\01\001_KJ - Copy.docx"
    '===========================================================================
    Set wdDoc = objword.Documents.Open(Target) '(Target, ReadOnly:=True)
    '===========================================================================
    objword.ActiveWindow.ActivePane.View.ShowAll = True
End Sub

Tiếp theo tôi sẽ mở file ppt và thử tác động thay đổi màu nền ở phương án cũng như thêm nội dung câu hỏi vào form có sẵn.

Bạn cần đăng nhập để thấy đính kèm

Sub openfileppt()
    Dim PPTApplication   As Object, ppt    As Object
    Dim lk  As String
    lk = "D:\Python_AI\TaiLieuPyThon\N1\02\1.pptx"
    Set PPTApplication = CreateObject("PowerPoint.Application")
    Set ppt = PPTApplication.Presentations.Open(lk) ', ReadOnly:=msoTrue
    With ppt.Slides(7).Shapes("#sl-pollquestion()")
        .TextFrame.TextRange.Text = "abc"
    End With
    'To mau nen
    With ppt.Slides(7).Shapes("Answer C")
        .Fill.ForeColor.RGB = RGB(0, 176, 80)
        .Fill.BackColor.RGB = RGB(0, 176, 80)
    End With
End Sub

Theo hình dung của tôi thì dòng code số 12 là đủ rồi. Tuy nhiên khi thực hiện thì không thành công, cho nên tôi thêm dòng code số 13. Tôi thực sự chưa rõ nguyên nhân thực sự tại sao, tạm thời thì output đã ra đúng ý đồ của tôi.

 

[tuhocvba]

Trong dự án lần này, mục đích của tôi là chuyển các câu trắc nghiệm tiếng nhật từ word vào powerpoint.
Form word có thể nói là có hai loại.
Loại 1, đó là không có đáp án.

Bạn cần đăng nhập để thấy đính kèm

Loại thứ hai là có đáp án được lưu trong table.

Bạn cần đăng nhập để thấy đính kèm

Như vậy công việc của chúng ta là cần kiểm tra file word có chứa table hay không, nếu có thì đọc dữ liệu trong table này lưu vào mảng. Sau đó xóa table này đi để không gây nhiễu ở phần câu hỏi.
Đây là các phần không khó nên tôi không trình bày code tham khảo.
Tuy nhiên nhìn vào đáp án ở trên, chúng ta phát sinh công việc đó là cần xác định đáp án đúng. Việc này chỉ có thể thực hiện được nếu ta đọc được ký tự có font màu đỏ.

Sub vidu()
    Dim n   As Long, i As Long, x As Long
    Dim tbl As Table, rng   As Range
    Dim arr()
    
    Set tbl = ActiveDocument.Tables(1)
    n = tbl.Rows.Count
    x = 0
    For i = 1 To n Step 1
        Set rng = tbl.Cell(i, 1).Range
        Call timkiem(rng, arr, x)
        
    Next i
    Set rng = Nothing
    Set tbl = Nothing
End Sub
Sub timkiem(ByRef rng As Range, ByRef arr As Variant, ByRef x As Long)
    Dim n1   As Long, n2    As Long
    n1 = rng.Start
    n2 = rng.End
 
    rng.Find.ClearFormatting 'Khong can thiet
    rng.Find.Font.Color = wdColorRed
    rng.Find.Replacement.ClearFormatting 'khong can thiet
    With rng.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
        Do While .Execute
            If rng.End > n2 Or rng.Start < n1 Then Exit Sub
            x = x + 1
            If x = 1 Then
                ReDim arr(1 To x)
            Else
                ReDim Preserve arr(1 To x)
            End If
            arr(x) = rng.Text
        Loop
    End With
 
End Sub

Bạn cần đăng nhập để thấy đính kèm

 

[tuhocvba]

Trong một shape, nếu muốn gạch chân một số chữ.
Chả hạn nội dung bên trong shape:
abcdef
Ta chỉ muốn gạch chân chữ cd thôi.

With ppt.Slides(cnt + 2).Shapes("#sl-pollquestion()")
    .TextFrame.TextRange.Characters(3, 2).Font.Underline = 1
End with

Thì 3 là ký tự bắt đầu, 2 là số lượng ký tự muốn gạch chân.