Maika8008
Thành viên gạo cội
- Tham gia
- 12/6/20
- Bài viết
- 4,762
- Được thích
- 5,716
- Donate (Momo)
- Giới tính
- Nam
Tôi đang có việc luôn phải chép code VBA đến trang văn bản Word và tất nhiên phải trình bày thụt lề các khối mã With... End With, For...Next, If...Else...End If v.v... cho dễ đọc cho giống như vẫn phải làm (và thấy) trong cửa sổ VB Editor.
Do khối lượng việc này quá nhiều cần tiết kiệm công sức, mà sẵn vừa dịch xong cuốn Lập trình VBA cho MS Word cũng cần nghiên cứu áp dụng thứ gì đó, nên tôi cũng gắng viết đoạn code để làm việc này xem sao.
Dù biết chẳng mấy ai làm cái việc như mình, nhưng tôi cũng chia sẻ ra đây cho ai tình cờ cần đến:
Dưới đây là file Word, trong đó có mã VBA để chạy thử.
CÁCH DÙNG: quét chọn đoạn mã cần định dạng rồi chạy code. Muốn chạy nhanh hơn chút thì cho khả dụng 2 dòng WordApp.Application.ScreenUpdating = False và WordApp.Application.ScreenUpdating = True trong code.
P/S: Code để trong file Excel và mở sẵn file Word có mã cần định dạng.
Do khối lượng việc này quá nhiều cần tiết kiệm công sức, mà sẵn vừa dịch xong cuốn Lập trình VBA cho MS Word cũng cần nghiên cứu áp dụng thứ gì đó, nên tôi cũng gắng viết đoạn code để làm việc này xem sao.
Dù biết chẳng mấy ai làm cái việc như mình, nhưng tôi cũng chia sẻ ra đây cho ai tình cờ cần đến:
Rich (BB code):
'Trình bày doan ma VBA trong file Word => Quét chon doan ma truoc khi chay Code
'wdCharacter = 1, wdWord = 2, wdLine = 5, wdExtend = 1, wdMove = 0
Sub FormatCodeVBAWord()
Dim WordApp As Object, myDoc As Object, MySlt As Object, rng As Object, currentWord As Object
Dim iPara&, i&, Sch$, sKT$, sKey$, bCase As Boolean, bThen As Boolean, tmr
On Error GoTo Thoat
tmr = Timer
Set WordApp = GetObject(, "Word.Application")
On Error GoTo 0
'WordApp.Application.ScreenUpdating = False
With WordApp.Selection
Set myDoc = WordApp.ActiveDocument
Set MySlt = .Range
MySlt.Style = myDoc.Styles("Subtitle")
iPara = MySlt.Paragraphs.Count
Sch = Sch & vbTab
'Xoa setting trong hop thoai Find & Replace de tim chu "Then " khong bi loi
ClearFindAndReplaceParameters WordApp
For i = 1 To iPara
MySlt.Paragraphs(i).Range.Select
'Code tìm THEN nhung khong có END IF
With .Find
.Text = "Then "
.Execute
End With
If UCase(.Range) = "THEN " Then
.MoveRight Unit:=1, Extend:=1
If Right(.Range, 1) <> " " Then
bThen = True 'Tìm duoc THEN khong có END IF thì bThen = True
End If
End If
.HomeKey Unit:=5
'Xoa tab va khoang trang dau dong
Do
.MoveRight Unit:=2, Extend:=1
sKT = Trim(.Range)
Loop Until sKT <> "" And Right(sKT, 1) <> vbTab
.MoveLeft Unit:=2, Extend:=1
If Left(.Range, 1) = " " Or Left(.Range, 1) = vbTab Then .Delete
'Code chính
St: .MoveRight Unit:=2, Extend:=1
sKey = UCase(Trim(.Range))
'Các tu khóa bat dau vòng lap
If sKey = "SUB" Or sKey = "FOR" Or sKey = "IF" Or sKey = "WITH" Or sKey = "FUNCTION" _
Or sKey = "PRIVATE" Or sKey = "PUBLIC" Or sKey = "DO" Or sKey = "SELECT" Or sKey = "WHILE" Then
.HomeKey Unit:=5 'Thuc hien go phím Tab
.TypeText Text:=Sch
If bThen = False Then 'Neu THEN có END IF thì them vbTab
Sch = Sch & vbTab
Else
bThen = False 'THEN không có END IF thì reset bien bThen cho dòng lenh sau
End If
ElseIf .Range = " " Then 'Xu ly truong hop có 1 khoang trang dau dong code
.HomeKey Unit:=5
.Delete Unit:=1, Count:=1
GoTo St
ElseIf InStr(1, .Range, " ") Then 'Xu ly truong hop có nhieu khoang trang dau dong code
.HomeKey Unit:=5
.MoveRight Unit:=2, Count:=1, Extend:=1
.Delete Unit:=1, Count:=1
GoTo St
ElseIf sKey = "CASE" Then 'Truong hop tu khóa là CASE
.HomeKey Unit:=5
If bCase = False Then
bCase = True 'Xác dinh dúng là CASE de thut le cho các dòng duói
Else
Sch = Left(Sch, Len(Sch) - 1) 'Neu khong phai CASE thì bót di 1 phím Tab
End If
.TypeText Text:=Sch 'Thuc hien go phím
Sch = Sch & vbTab
ElseIf sKey = "NEXT" Or sKey = "LOOP" Or sKey = "WEND" Then 'Truong hop ket thúc vòng lap
.HomeKey Unit:=5
Sch = Left(Sch, Len(Sch) - 1)
.TypeText Text:=Sch
ElseIf sKey = "ELSE" Or sKey = "ELSEIF" Then 'Truong hop gap Else hoac ElseIf
.HomeKey Unit:=5
Sch = Left(Sch, Len(Sch) - 1)
.TypeText Text:=Sch
Sch = Sch & vbTab
ElseIf sKey = "END" Then 'Khi gap tu khóa END
.MoveRight Unit:=2, Count:=1, Extend:=1
If UCase(Trim(.Range)) = "END SELECT" Then
Sch = Left(Sch, Len(Sch) - 2) 'Neu End Select thì bót di 2 phím Tab
Else
Sch = Left(Sch, Len(Sch) - 1) 'Neu chi là End thì bót di 1 phím Tab
End If
.HomeKey Unit:=5 'Go phím
.TypeText Text:=Sch
Else 'Truong hop không phai là dòng có các tu khóa dac biet
.HomeKey Unit:=5 'Go phím
.TypeText Text:=Sch
.MoveRight Unit:=1, Count:=1, Extend:=1
'Xác dinh dieu kien de to màu Green cho các dòng ghi chú
If Trim(.Range) = vbTab Then 'Neu có phím Tab truoc ký tu "'" hoac "‘"
.MoveRight Unit:=2, Count:=1
.MoveRight Unit:=1, Count:=1, Extend:=1
If .Range = "'" Or .Range = "‘" Then
.EndKey Unit:=5, Extend:=1
.Font.Color = 4825600
End If
Else 'Neu không có phím Tab truoc ký tu "'" hoac "‘"
If .Range = "'" Or .Range = "‘" Then
.EndKey Unit:=5, Extend:=1
.Font.Color = 4825600
End If
End If
End If
Next
End With
Set myDoc = Nothing
'WordApp.Application.ScreenUpdating = True
Set WordApp = Nothing
Debug.Print Timer - tmr & " giay"
Exit Sub
Thoat:
MsgBox "Khong co file Word nao dang mo."
End Sub
'Xoa cac thong tin trong hop thoai Find and Repace
Sub ClearFindAndReplaceParameters(WordApp As Object)
With WordApp.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = 0 'wdFindStop = 0
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End SubDưới đây là file Word, trong đó có mã VBA để chạy thử.
CÁCH DÙNG: quét chọn đoạn mã cần định dạng rồi chạy code. Muốn chạy nhanh hơn chút thì cho khả dụng 2 dòng WordApp.Application.ScreenUpdating = False và WordApp.Application.ScreenUpdating = True trong code.
P/S: Code để trong file Excel và mở sẵn file Word có mã cần định dạng.
Lần chỉnh sửa cuối:
