[Tool Ex Test]Quản lý file Tex bằng VBA từ đó tạo ra đề thi trắc nghiệm tự động
- Thread starter tuhocvba
- Ngày gửi
1. Code #41 vẫn có chỗ có thể cải thiện. Nếu tìm không thấy từ khóa \choice thì thoát, không làm việc làm gì nữa.
2. Về cơ bản thuật toán không có gì khác với các cách nghĩ ad đã trình bày trong topic này, nhưng kỹ thuật xử lý có khác.
Thuật toán vẫn là đếm dấu { và }. Vì nội dung văn bản có quá nhiều dấu này, nên cần dò tìm liên tục bằng hàm Instr. Cần thay đổi vị trí bắt đầu tìm kiếm cho hàm Instr, do đó Do ~ Loop đã thực hiện liên tục việc tìm kiếm cho tới khi k = 0 (số lượng dấu { = số lượng dấu } ).
3. Ở bước tiếp theo, tôi rất tâm đắc với việc bạn tìm ra quy luật (để nhìn rõ, tôi sử dụng dấu cách, thực tế là chỉ có { và }:
Code của ad có một hạn chế là tách ra từng dòng để xử lý. Việc này chỉ phù hợp cho việc dọn dẹp rác trước khi vào xử lý chính. Vì đã tách ra từng dòng nên việc đếm ký tự, vòng lặp cũng xử lý khó khăn hơn. Có lẽ ngay từ đầu đã không nắm được các trường hợp có thể xảy ra trong Latex. Trong topic ad cũng liên tục tưởng tượng ra các tình huống và tự mình giải quyết, nếu như tìm hiểu cho kỹ các tình huống rồi mới bắt tay vào code thì sẽ đơn giản hơn.
Vì code #41 cũng đã hay rồi, nên tôi không đưa code của mình lên nữa. Để thuận tiện cho mọi người theo dõi, tôi đưa ra những hình ảnh phân tích, mục đích để mọi người nhìn vào code #41 thấy dễ hiểu hơn.
2. Về cơ bản thuật toán không có gì khác với các cách nghĩ ad đã trình bày trong topic này, nhưng kỹ thuật xử lý có khác.
Thuật toán vẫn là đếm dấu { và }. Vì nội dung văn bản có quá nhiều dấu này, nên cần dò tìm liên tục bằng hàm Instr. Cần thay đổi vị trí bắt đầu tìm kiếm cho hàm Instr, do đó Do ~ Loop đã thực hiện liên tục việc tìm kiếm cho tới khi k = 0 (số lượng dấu { = số lượng dấu } ).
3. Ở bước tiếp theo, tôi rất tâm đắc với việc bạn tìm ra quy luật (để nhìn rõ, tôi sử dụng dấu cách, thực tế là chỉ có { và }:
Mã:
{ { } } { } { }Vì code #41 cũng đã hay rồi, nên tôi không đưa code của mình lên nữa. Để thuận tiện cho mọi người theo dõi, tôi đưa ra những hình ảnh phân tích, mục đích để mọi người nhìn vào code #41 thấy dễ hiểu hơn.
Bạn cần đăng nhập để thấy đính kèm
Cảm ơn @Euler , mình sửa lại code như sau:
Trong code này mình khai báo biến đối tượng Regexp là static để tránh việc khởi tạo đối tượng nhiều lần, đưa các thuộc tính chỉ gán 1 lần (Global, Pattern) vào khối lệnh kiểm tra regexp đã tồn tại chưa để tăng tốc độ. Các lần gọi hàm Tach từ lần 2 trở đi không cần khởi tạo đối tượng nữa.
Trong hình vẽ ở bài 43 của @Euler thì biến PrevI của mình ở đây là vị trí của "{" bắt đầu của đáp án, đầu tiên i=PrevI, mỗi vòng lặp ta tăng i lên 1 đến khi k=0, lúc này số "{" và "}" bằng nhau và i là vị trí kết thúc đáp án, sau vòng lặp thì i được tăng 1 nên số dấu "}' = (i-prveI)/2. Cả i và prevI đều là vị trí ký tự trên chuỗi s1, có lẽ đặt tên PrevI không hợp lý lắm, đặt là BeginCurrentAnswer thì rõ hơn.
Mã:
Function Tach(ByVal s As String, Optional ByVal slda As Integer = 4)
Const Key As String = "\choice"
Const cm As String = "%"
Const c1 As String = "{"
Const c2 As String = "}"
Const dhkt As String = "\"
Const loigiai As String = "\loigiai"
Dim da, CountAns&, s1$
Dim StartSearchingPos&, k&, n&, i&, j&, PrevI&
Static RegExp As Object
Tach = s
If InStr(s, Key) = 0 Then Exit Function
StartSearchingPos = InStr(s, Key) + Len(Key)
If InStr(s, loigiai) > 0 Then
n = InStr(s, loigiai) - 1
Else
n = Len(s)
End If
s1 = Mid(s, StartSearchingPos, n - StartSearchingPos + 1)
If RegExp Is Nothing Then
Set RegExp = CreateObject("VBScript.RegExp")
RegExp .Global = True
RegExp .Pattern = "[^{}]"
End If
s1 = RegExp.Replace(s1, "")
n = Len(s1)
i = 1
PrevI = 1
CountAns = 0
da = s
Do While CountAns < slda And i <= n
If Mid(s1, i, 1) = c2 Then Exit Do
k = 1
i = i + 1
Do While k > 0 And i <= n
If Mid(s1, i, 1) = c2 Then
k = k - 1
Else
k = k + 1
End If
i = i + 1
Loop
If k > 0 Then Exit Do
CountAns = CountAns + 1
If CountAns = 1 Then
ReDim da(1 To 3, 1 To CountAns)
Else
ReDim Preserve da(1 To 3, 1 To CountAns)
End If
da(2, CountAns) = InStr(StartSearchingPos, s, c1)
For j = 1 To (i - PrevI) / 2
StartSearchingPos = InStr(StartSearchingPos, s, c2) + 1
Next
da(3, CountAns) = StartSearchingPos - 1
da(1, CountAns) = Mid(s, da(2, CountAns), StartSearchingPos - da(2, CountAns))
PrevI = i
Loop
Tach = da
End FunctionTrong hình vẽ ở bài 43 của @Euler thì biến PrevI của mình ở đây là vị trí của "{" bắt đầu của đáp án, đầu tiên i=PrevI, mỗi vòng lặp ta tăng i lên 1 đến khi k=0, lúc này số "{" và "}" bằng nhau và i là vị trí kết thúc đáp án, sau vòng lặp thì i được tăng 1 nên số dấu "}' = (i-prveI)/2. Cả i và prevI đều là vị trí ký tự trên chuỗi s1, có lẽ đặt tên PrevI không hợp lý lắm, đặt là BeginCurrentAnswer thì rõ hơn.
Sửa lần cuối:
Chỗ này nếu mà số lượng đáp án lấy ra không đủ thì phải gán Tach = s. Ví dụ:
Số lượng đáp án đang được quy định là 4 mà chỉ nhặt ra được ít hơn 4 là phải gán Tach = s.
Mã:
\begin{ex}
Gọi $z_1,z_2$ là nghiệm của phương trình $z^2+2z+3=0$. Giá trị của biểu thức $\left| z_1 \right|^2+\left| z_2 \right|^2$ bằng
\choice
{$2$}
{$\sqrt3$}
{\True $6$}
\loigiai{
}
\end{ex}Code thế này cho ăn chắc:
Mã:
Function tachlayloigiai(ByRef s As String, Optional ByVal slda As Integer = 4)
Const Key As String = "\choice"
Const cm As String = "%"
Const c1 As String = "{"
Const c2 As String = "}"
Const dhkt As String = "\"
Const loigiai As String = "\loigiai"
Dim da, CountAns&, s1$
Dim StartSearchingPos&, k&, n&, i&, j&, PrevI&
Const THAYTHEPHANTRAM As String = "@~"
Const KYTUGAYNHIEU As String = "\%"
Static RegExp As Object
On Error GoTo thoat
tachlayloigiai = s
Call chuanhoacauhoi(s) 'Loai bo comment %...
If InStr(s, Key) = 0 Then Exit Function
StartSearchingPos = InStr(s, Key) + Len(Key)
If InStr(s, loigiai) > 0 Then
n = InStr(s, loigiai) - 1
Else
n = Len(s)
End If
s1 = Mid(s, StartSearchingPos, n - StartSearchingPos + 1)
If RegExp Is Nothing Then
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.Pattern = "[^{}]"
End If
s1 = RegExp.Replace(s1, "")
n = Len(s1)
i = 1
PrevI = 1
CountAns = 0
da = s
Do While CountAns < slda And i <= n
If Mid(s1, i, 1) = c2 Then Exit Do
k = 1
i = i + 1
Do While k > 0 And i <= n
If Mid(s1, i, 1) = c2 Then
k = k - 1
Else
k = k + 1
End If
i = i + 1
Loop
If k > 0 Then Exit Do
CountAns = CountAns + 1
If CountAns = 1 Then
ReDim da(1 To 3, 1 To CountAns)
Else
ReDim Preserve da(1 To 3, 1 To CountAns)
End If
da(2, CountAns) = InStr(StartSearchingPos, s, c1)
For j = 1 To (i - PrevI) / 2
StartSearchingPos = InStr(StartSearchingPos, s, c2) + 1
Next
da(3, CountAns) = StartSearchingPos - 1
da(1, CountAns) = Mid(s, da(2, CountAns), StartSearchingPos - da(2, CountAns))
PrevI = i
Loop
s = Replace(s, THAYTHEPHANTRAM, KYTUGAYNHIEU, , , vbTextCompare) 'Tra ve ky tu ban dau @~ => \%
If IsNumeric(CStr(da(2, CountAns))) = False Or IsNumeric(CStr(da(3, CountAns))) = False Then
tachlayloigiai = s
Exit Function
End If
If CountAns = slda Then
For i = LBound(da, 2) To UBound(da, 2) Step 1
da(1, i) = Replace(CStr(da(1, i)), THAYTHEPHANTRAM, KYTUGAYNHIEU, , , vbTextCompare)
Next i
tachlayloigiai = da
End If
thoat:
End Function
Mã:
'Loai bo comment.
'\% => @~
Sub chuanhoacauhoi(ByRef s As String)
Dim i As Long
Dim arr
Dim stemp As String
Dim optemp As String
Dim vt As Long
Const cm As String = "%"
Const THAYTHEPHANTRAM As String = "@~"
Const KYTUGAYNHIEU As String = "\%"
If s = "" Then Exit Sub
s = Replace(s, KYTUGAYNHIEU, THAYTHEPHANTRAM, , , vbTextCompare)
arr = Split(s, Chr(10))
For i = LBound(arr, 1) To UBound(arr, 1) Step 1
stemp = CStr(arr(i))
If stemp = "" Then GoTo tiep
vt = InStr(1, stemp, cm, vbTextCompare)
If vt > 0 Then
stemp = Left(stemp, vt - 1)
End If
optemp = optemp & Chr(10) & stemp
tiep:
Next i
If optemp <> "" Then
s = optemp
Else
vt = InStr(1, s, cm, vbTextCompare)
If vt > 0 Then
s = Left(s, vt - 1)
End If
End If
End SubChính tôi mới là người cần nói lời cảm ơn bạn. Thật may mắn vì diễn đàn đã có một Smod xuất sắc về thuật toán.
Convert ID Word (Replace trực tiếp trong s nguồn), Xử lý cả ID của BT Pro
Mã:
'\d: so
'\d{1,2}: so co 1 chu so hoac 2 chu so
'\w :A-Z
'[1D3-2.4-3]: ??i s? 11 ch??ng 3. bai 2. d?ng 4. m?c ?? 3 h?
'1D3K2-4
'2.4 => 2-4
'1=>Y
'2=>B
'3=>K
'4=>G
'5=>T
'INPUT: [1D3-2.4-3]
'OUTPUT: [1D3K2-4], dong thoi thay doi input
'OUTPUT: ?
'Da chuyen ca ID cua BT PRo
Sub abb()
Dim s As String, x As String
s = "aaa[HH12.C8.6.D1.b]aaa" '2H1K3-8
's = "aaaa[HH12.C8.6.D1.b]aaaa" '2H8K6-1
x = chuyenidword(s)
MsgBox x
End Sub
Function chuyenidword(ByRef s As String) As String
Dim kq1 As String, kq As String
chuyenidword = "?"
kq1 = idwbt(s)
If kq1 = "" Then GoTo thoat
kq = chuyenidw(kq1)
If kq = "" Then GoTo thoat
kq = chuyenidw6(kq)
If kq = "" Then GoTo thoat
kq = "[" & kq & "]"
s = Replace(s, kq1, kq, , , vbTextCompare)
chuyenidword = " % " & kq
Exit Function
'BT PRO
thoat:
chuyenidword = " % " & cidbt(s)
End Function
Private Function idwbt(ByVal str As String) As String
Dim reg As Object
Dim s As String
Dim Match, Matches
idwbt = ""
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = "(\[\d{1})([A-Z])([A-Z,0-9])(-)([A-Z,0-9])(\.)([A-Z,0-9])(-)([A-Z,0-9]\])"
.IgnoreCase = False
.Global = True
End With
Set Matches = reg.Execute(str)
s = ""
For Each Match In Matches
s = Match.Value
If s = "" Then Exit Function
idwbt = s
Exit Function
Next Match
idwbt = s
Set reg = Nothing
End Function
Private Function chuyenidw6(ByVal s As String) As String
Dim vt1 As Integer, vt2 As Integer
Dim s1 As String, s2 As String
Dim mucdo As String
Const c As String = "-"
On Error GoTo thoat
s1 = Left(s, 3) '1D3-2.4-3 => 1D3
s2 = Right(s, 1)
chuyenidw6 = ""
Select Case s2
Case "1"
mucdo = "Y"
Case "2"
mucdo = "B"
Case "3"
mucdo = "K"
Case "4"
mucdo = "G"
Case "5"
mucdo = "T"
End Select
vt1 = InStr(1, s, c, vbTextCompare)
If vt1 = 0 Then GoTo thoat
vt2 = InStrRev(s, c, , vbTextCompare)
s2 = ""
If vt1 < vt2 Then
s2 = Mid(s, vt1 + 1, vt2 - 5)
s2 = Replace(s2, ".", c, , , vbTextCompare)
Else
GoTo thoat
End If
chuyenidw6 = s1 & mucdo & s2
thoat:
Err.Clear
End Function
'INPUT: abc[123]
'OUTPUT:123
Private Function chuyenidw(ByVal s As String) As String
On Error GoTo thoat
Dim vt1 As Integer, vt2 As Integer
Dim kq As String
Const c1 As String = "["
Const c2 As String = "]"
chuyenidw = ""
If s = "" Then Exit Function
vt1 = InStr(1, s, c1, vbTextCompare)
If vt1 = 0 Then Exit Function
vt2 = InStr(vt1, s, c2, vbTextCompare)
If vt2 > vt1 Then
kq = Mid(s, vt1 + 1, vt2 - vt1 - 1)
End If
thoat:
Err.Clear
chuyenidw = kq
End Function
Private Function cidbt(ByRef s As String) As String
Dim kq As String, kq2 As String
kq = ""
kq = idwbt2(s)
kq2 = cidwbt(kq)
If kq2 = "" Then
cidbt = "?"
Else
kq2 = "[" & kq2 & "]"
s = Replace(s, kq, kq2, , , vbTextCompare)
cidbt = kq2
End If
End Function
Private Function idwbt2(ByVal str As String) As String
Dim reg As Object
Dim s As String
Dim Match, Matches
idwbt2 = ""
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = "\[[A-Z]{2}\d{2}\.[A-Z]\d{1,2}\.\d{1,2}\.[A-Z]\d{1,2}\.[a-z]\]"
.IgnoreCase = False
.Global = True
End With
Set Matches = reg.Execute(str)
s = ""
For Each Match In Matches
s = Match.Value
If s = "" Then Exit Function
idwbt2 = s
Exit Function
Next Match
idwbt2 = s
Set reg = Nothing
End Function
Private Function cidwbt(ByVal s2 As String) As String
Dim arr
Dim kq As String
Dim s As String
Dim i As Integer
Dim mon As String
Dim monx As String 'C, D, H
Dim lop As String '10: HO10
Dim lopx As String
Dim chuong As String
Dim bai As String
Dim dang As String
Dim md As String
Dim mdx As String
cidwbt = ""
s = Replace(s2, "[", "")
s = Replace(s, "]", "")
kq = ""
On Error GoTo thoat
arr = Split(s, ".")
'Mon: HO = C, DS = D, HH = H
mon = Left(CStr(arr(0)), 2)
Select Case mon
Case "DS"
monx = "D"
Case "HH"
monx = "H"
Case "HO"
monx = "C"
Case Else
GoTo thoat
End Select
lop = Right(CStr(arr(0)), 2)
Select Case lop
Case "10"
lopx = "0"
Case "11"
lopx = "1"
Case "12"
lopx = "2"
Case Else
GoTo thoat
End Select
chuong = UCase(CStr(arr(1)))
chuong = Right(chuong, Len(chuong) - 1)
If IsNumeric(chuong) = True Then
If Val(chuong) < 10 Then
chuong = CStr(Val(chuong))
Else
chuong = Chr(Val(chuong) + 55)
End If
Else
GoTo thoat
End If
bai = CStr(arr(2))
bai = CStr(Val(bai))
If IsNumeric(bai) = True Then
If Val(bai) < 10 Then
bai = CStr(Val(bai))
Else
bai = Chr(Val(bai) + 55)
End If
Else
GoTo thoat
End If
dang = UCase(CStr(arr(3)))
dang = Right(dang, Len(dang) - 1)
If IsNumeric(dang) = True Then
If Val(dang) < 10 Then
dang = CStr(Val(dang))
Else
dang = Chr(Val(dang) + 55)
End If
Else
GoTo thoat
End If
md = CStr(arr(4))
md = LCase(md)
Select Case md
Case "a"
mdx = "B"
Case "b"
mdx = "K"
Case "c"
mdx = "G"
Case "d"
mdx = "T"
Case Else
GoTo thoat
End Select
cidwbt = lopx & monx & chuong & mdx & bai & "-" & dang
Exit Function
thoat:
cidwbt = ""
End Function
Mã:
Sub test102021()
Dim s As String, x As String
s = "aaa[1D3K2-4]"
x = nhandienid(s, "")
MsgBox x
End Sub
'Thay ID_OLD thanh ID_NEW
'Neu snew = "" : ReadOnly
'INPUT: [1D3K2-4], snew: 1D3K5-4
'OUTPUT: thay [1D3K5-4] vao s, ket qua cua ham la : 1D3K2-4
Function nhandienid(ByRef str As String, ByVal snew As String) As String
Dim reg As Object
Dim s As String, kq As String
Dim Match, Matches
kq = str
nhandienid = "?"
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = "(\[\d{1})([A-Z])([A-Z,0-9])([A-Z])([A-Z,0-9])(-)([A-Z,0-9])(\])"
.IgnoreCase = False
.Global = True
End With
Set Matches = reg.Execute(str)
s = ""
For Each Match In Matches
s = Match.Value
If s <> "" Then
If snew <> "" Then
kq = Replace(kq, s, "[" & snew & "]", , , vbTextCompare)
End If
nhandienid = s
End If
Next Match
str = kq
Set reg = Nothing
nhandienid = Replace(nhandienid, "[", "", , , vbTextCompare)
nhandienid = Replace(nhandienid, "]", "", , , vbTextCompare)
End Function