@106
תנסה את זה
Sub MarkdownMaster_Smart_Final()
Dim para As Paragraph
Dim r As Range
Dim IsSingleStarBold As Boolean
IsSingleStarBold = True
If MsgBox("להתחיל בעיבוד? (הוגדר: כוכבית אחת = " & IIf(IsSingleStarBold, "מודגש", "נטוי") & ")", vbOKCancel) = vbCancel Then Exit Sub
Application.ScreenUpdating = False
CleanBrowserArtifacts
For Each para In ActiveDocument.Paragraphs
Set r = para.Range
If Len(r.Text) > 2 Then
HandleHeadingsAndQuotes r
FormatByPattern r, "\*\*\?([!\*]@)\*\*\?", True, False
FormatByPattern r, "([! \*\^13])\*([!\*]@)\*", IsSingleStarBold, Not IsSingleStarBold
FormatByPattern r, "\~\~([!\~]@)\~\~", False, False, True
FormatByPattern r, "\`([!\`]@)\`"
End If
Next para
Application.ScreenUpdating = True
MsgBox "הסתיים בהצלחה!", vbInformation
End Sub
Sub FormatByPattern(rng As Range, pattern As String, Optional bBold As Boolean = False, Optional bItalic As Boolean = False, Optional bStrike As Boolean = False)
Dim findRng As Range
Set findRng = rng.Duplicate
With findRng.Find
.ClearFormatting
.Text = pattern
.MatchWildcards = True
Do While .Execute
If Not findRng.InRange(rng.Paragraphs(1).Range) Then Exit Do
If bBold Then findRng.Font.Bold = True
If bItalic Then findRng.Font.Italic = True
If bStrike Then findRng.Font.StrikeThrough = True
If pattern Like "*\`*" Then
findRng.Font.Name = "Courier New"
findRng.Font.ColorIndex = wdRed
End If
RemoveSymbolsFromRange findRng, pattern
findRng.Collapse wdCollapseEnd
Loop
End With
End Sub
Sub RemoveSymbolsFromRange(r As Range, pattern As String)
Dim txt As String, firstChar As String, lastChar As String
txt = r.Text
If Left(pattern, 2) = "\*" Or Left(pattern, 2) = "\~" Or Left(pattern, 2) = "\_" Then
If Left(r.Text, 2) = "**" Or Left(r.Text, 2) = "~~" Then
r.Text = Mid(txt, 3, Len(txt) - 4)
Else
r.Text = Mid(txt, 2, Len(txt) - 2)
End If
Else
Dim content As String
content = Mid(txt, 3, Len(txt) - 3)
r.Text = Left(txt, 1) & content
End If
End Sub
Sub CleanBrowserArtifacts()
Dim v As Variant
For Each v In Array(8203, 8204, 8205)
With ActiveDocument.Content.Find
.Text = ChrW(v): .Replacement.Text = "": .Execute Replace:=wdReplaceAll
End With
Next v
End Sub
Sub HandleHeadingsAndQuotes(r As Range)
Dim t As String: t = Trim(r.Text)
If Left(t, 1) = "#" Then
If Left(t, 3) = "###" Then r.Style = wdStyleHeading3: r.Start = r.Start + 4
If Left(t, 2) = "##" Then r.Style = wdStyleHeading2: r.Start = r.Start + 3
If Left(t, 1) = "#" Then r.Style = wdStyleHeading1: r.Start = r.Start + 2
ElseIf Left(t, 1) = ">" Then
r.Style = wdStyleQuote: r.Start = r.Start + 2
End If
End Sub
לא בטוח שזה טוב תבדוק ותעדכן