Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
convert the with statement in VBA into QM code
#1
hello everyone,
I found a piece of VBA code that can convert the with statement in VBA into QM code

Step 1: create a new macro in word, and then replace it with the following VBA code VbaWith2Qm
Step 2: Prepare the code that needs processed, copy to the word document
Step 3: run the macro VbaWith2Qm, and the code in the document will be processed

In addition, some modification skills are still needed, which I will add later
enjoy
Smile

Sample code I tested:

Code1:
Code:
Copy      Help
 
Sub InsertFormatText()
    Dim rngFormat As Range
    Set rngFormat = ActiveDocument.Range(Start:=0, End:=0)
    With rngFormat
        .InsertAfter Text:="Title"
        .InsertParagraphAfter
        With .Font
            .Name = "Tahoma"
            .Size = 24
            .Bold = True
        End With
    End With
    With ActiveDocument.Paragraphs(1)
        .Alignment = wdAlignParagraphCenter
        .SpaceAfter = InchesToPoints(0.5)
    End With
End Sub

Code2:
Code:
Copy      Help
 
Sub FormatRange()
    Dim rngFormat As Range
    Set rngFormat = ActiveDocument.Range( _
        Start:=ActiveDocument.Paragraphs(1).Range.Start, _
        End:=ActiveDocument.Paragraphs(3).Range.End)
    With rngFormat
        .Font.Name = "Arial"
        .ParagraphFormat.Alignment = wdAlignParagraphJustify
    End With
End Sub

Code3:
Code:
Copy      Help
 
Sub ToggleParagraphSpace()
    With Selection.Paragraphs(1)
        If .SpaceBefore <> 0 Then
            .SpaceBefore = 0
        Else
            .SpaceBefore = 6
        End If
    End With
End Sub

Code4:
Code:
Copy      Help
 
Sub FormatMargins()
    With ActiveDocument.PageSetup
        .LeftMargin = .LeftMargin + InchesToPoints(0.5)
        .RightMargin = .RightMargin + InchesToPoints(0.5)
    End With
End Sub

_____________________________________________________________________________________________________________________________________________________
VBA Macros VbaWith2Qm
Code:
Copy      Help
 
Sub VbaWith2Qm()
    Dim pa As Paragraph, re As Object
    ActiveDocument.Range.Find.Execute "_^13", , , 2, , , , 0, 0, "", 2  'The first 2 decides whether to pass through, and the second decides whether to replace all
    Set re = CreateObject("vbscript.regexp")
    re.Global = 1
    For Each pa In ActiveDocument.Paragraphs
        If InStr(pa.Range, ":=") > 0 Then
            re.Pattern = "\w+:=.+?(?=,)|\w+:=.+(?=\))|\w+:=.+?(?=\r)"
            For Each ma In re.Execute(pa.Range)
                s1 = Split(ma, ":=")(0)
                s2 = Split(ma, ":=")(1)
                
                If ch13 = 0 Then
                    ch13 = ch13 + 1
                    pa.Range.InsertBefore Chr(13)
                End If
                ma = Replace(Replace(ma, "(", "\("), ")", "\)")
                ActiveDocument.Range(pa.Range.Previous.End - 1, pa.Range.Previous.End - 1).InsertAfter "VARIANT " & s1 & "=" & s2 & Chr(13)
                If InStr(pa.Range, "(") > 0 Then
                    pa.Range.Find.Execute "\(" & ma, MatchWildcards:=1, replacewith:="(" & s1, Replace:=1
                    pa.Range.Find.Execute "[ \,]{1,}" & ma, MatchWildcards:=1, replacewith:=" " & s1, Replace:=1
                    pa.Range.Find.Execute ma, replacewith:=s1, Replace:=1
                    If UBound(Split(pa.Range, ":=")) = 0 And pa.Range.Characters.Last.Previous <> ")" Then pa.Range.Characters.Last.Previous.InsertAfter ")"
                ElseIf UBound(Split(pa.Range, ":=")) > 1 Then
                    pa.Range.Find.Execute "[ ,]{1,}" & ma, MatchWildcards:=1, replacewith:="(" & s1, Replace:=1
                Else
                    pa.Range.Find.Execute " " & ma, replacewith:="(" & s1 & ")", Replace:=1
                End If
            Next
            ch13 = 0
        End If
        fi = Split(Trim(pa.Range.Text), " ")(0)
        re.Pattern = "\.\w+\r"
        If re.test(pa.Range) And InStr(pa.Range, "With") = 0 Then
            pa.Range = Replace(pa.Range, Chr(13), "") & "()" & Chr(13)
        ElseIf fi = "With" Then
            tf = tf + 1
            strB = strB & Replace(Split(Trim(pa.Range.Text), " ")(1), Chr(13), "") & "@"
            pa.Range = ""
        ElseIf fi = "Set" Then
            re.Pattern = "\.(\w+)\("
            Set sm = re.Execute(pa.Range)
            strA = sm(0).submatches(0)
            pa.Range.Find.Execute findtext:=fi, replacewith:="word." & strA
        ElseIf Left(Trim(pa.Range), 1) = "." Then
            pa.Range = Replace(strB, "@", "") & Trim(pa.Range)
        ElseIf InStr(pa.Range.Text, " .") > 0 Then
            re.Pattern = "\s\."
            If re.test(pa.Range) Then
                st = re.Execute(pa.Range)(0).firstindex
                ActiveDocument.Range(pa.Range.Start + st + 1, pa.Range.Start + st + 1).InsertAfter Replace(strB, "@", "")
            End If
        ElseIf Replace(Trim(pa.Range), Chr(13), "") = "End With" Then
            tf = tf - 1
            strB = Left(strB, InStrRev(strB, "@", Len(strB) - 2))
            pa.Range = ""
        End If
    Next
    re.MultiLine = 1
    re.ignorecase = 1
    re.Pattern = "^\s+|Then|End If|End Sub"      '|^Sub.+$^\s*Dim.+$"
    Debug.Print re.test(ActiveDocument.Range)
    ActiveDocument.Range = re.Replace(ActiveDocument.Range, "")
End Sub
#2
The above implementation process is a bit cumbersome, If someone can implement the above VBA code function with QM regular expression, it would be great Smile

@Kevin
Can you give it a try?  I don't quite understand regular expressions at present
Do this in the following code



Macro Vba2Qm
Code:
Copy      Help
_s.getsel


;Using regular expressions to process such as with. if. statements
;It's like VBA Macros VbaWith2Qm


;Replace some keywords
_s.findreplace("True" "TRUE") ;;replace True
_s.findreplace("ActiveDocument" "doc") ;;replace ActiveDocument
_s.findreplace("Paragraphs(" "Paragraphs.Item(") ;;replace Paragraphs(
_s.findreplace("InchesToPoints(" "app.InchesToPoints(") ;;replace InchesToPoints(
_s.findreplace("If" "if") ;;replace If
_s.findreplace("Else" "else") ;;replace Else

;Add word app statement
str s=
;;/exe 1
;;Use /exe 1 to run the macro in separate process, as User. This macro may not work without it.
;typelib Word {00020905-0000-0000-C000-000000000046} 8.0
;Word.Application app._getactive
;app.Visible = TRUE
;Word.Document doc=app.ActiveDocument
s.addline(_s)
mes s

;Prompt for next step
int i=ListDialog("New macro file[]Save to clipboard" "How to operate?")
if i=1
,newitem("vba_macro" s "Macro" "" "" 4)
else if i=2
,s.setclip
#3
Now the operation is more convenient
However,
still need to open the word software,
create a new macro VbaWith2Qm,
Copy the code to be processed into the Word Client
,
finally execute macro9
_________________________________
In QM code: 
Clear lines beginning with Dim and Sub

 
Code:
Copy      Help
 
Sub VbaWith2Qm()
    Dim pa As Paragraph, re As Object
    ActiveDocument.Range.Find.Execute "_^13", , , 2, , , , 0, 0, "", 2  
    Set re = CreateObject("vbscript.regexp")
    re.Global = 1
    For Each pa In ActiveDocument.Paragraphs
        If InStr(pa.Range, ":=") > 0 Then
            re.Pattern = "\w+:=.+?(?=,)|\w+:=.+(?=\))|\w+:=.+?(?=\r)"
            For Each ma In re.Execute(pa.Range)
                s1 = Split(ma, ":=")(0)
                s2 = Split(ma, ":=")(1)
                
                If ch13 = 0 Then
                    ch13 = ch13 + 1
                    pa.Range.InsertBefore Chr(13)
                End If
                ma = Replace(Replace(ma, "(", "\("), ")", "\)")
                ActiveDocument.Range(pa.Range.Previous.End - 1, pa.Range.Previous.End - 1).InsertAfter "VARIANT " & s1 & "=" & s2 & Chr(13)
                If InStr(pa.Range, "(") > 0 Then
                    pa.Range.Find.Execute "\(" & ma, MatchWildcards:=1, replacewith:="(" & s1, Replace:=1
                    pa.Range.Find.Execute "[ \,]{1,}" & ma, MatchWildcards:=1, replacewith:=" " & s1, Replace:=1
                    pa.Range.Find.Execute ma, replacewith:=s1, Replace:=1
                    If UBound(Split(pa.Range, ":=")) = 0 And pa.Range.Characters.Last.Previous <> ")" Then pa.Range.Characters.Last.Previous.InsertAfter ")"
                ElseIf UBound(Split(pa.Range, ":=")) > 1 Then
                    pa.Range.Find.Execute "[ ,]{1,}" & ma, MatchWildcards:=1, replacewith:="(" & s1, Replace:=1
                Else
                    pa.Range.Find.Execute " " & ma, replacewith:="(" & s1 & ")", Replace:=1
                End If
            Next
            ch13 = 0
        End If
        fi = Split(Trim(pa.Range.Text), " ")(0)
        re.Pattern = "\.\w+\r"
        If re.test(pa.Range) And InStr(pa.Range, "With") = 0 Then
            pa.Range = Replace(pa.Range, Chr(13), "") & "()" & Chr(13)
        ElseIf fi = "With" Then
            tf = tf + 1
            strB = strB & Replace(Split(Trim(pa.Range.Text), " ")(1), Chr(13), "") & "@"
            pa.Range = ""
        ElseIf fi = "Set" Then
            re.Pattern = "\.(\w+)\("
            Set sm = re.Execute(pa.Range)
            strA = sm(0).submatches(0)
            pa.Range.Find.Execute findtext:=fi, replacewith:="word." & strA
        ElseIf Left(Trim(pa.Range), 1) = "." Then
            pa.Range = Replace(strB, "@", "") & Trim(pa.Range)
        ElseIf InStr(pa.Range.Text, " .") > 0 Then
            re.Pattern = "\s\."
            If re.test(pa.Range) Then
                st = re.Execute(pa.Range)(0).firstindex
                ActiveDocument.Range(pa.Range.Start + st + 1, pa.Range.Start + st + 1).InsertAfter Replace(strB, "@", "")
            End If
        ElseIf Replace(Trim(pa.Range), Chr(13), "") = "End With" Then
            tf = tf - 1
            strB = Left(strB, InStrRev(strB, "@", Len(strB) - 2))
            pa.Range = ""
        End If
    Next
    re.MultiLine = 1
    re.ignorecase = 1
    re.Pattern = "^\s+|Then|End If|End Sub"      '|^Sub.+$^\s*Dim.+$"
    Debug.Print re.test(ActiveDocument.Range)
    ActiveDocument.Range = re.Replace(ActiveDocument.Range, "")
    ActiveDocument.Content.Copy
End Sub

Macro Macro9
Code:
Copy      Help
;/exe 1
;Use /exe 1 to run the macro in separate process, as User. This macro may not work without it.
typelib Word {00020905-0000-0000-C000-000000000046} 8.0
Word.Application app._getactive
app.Visible = TRUE
Word.Document doc=app.ActiveDocument
app.Run("VbaWith2Qm")

_s.getclip

;Replace some keywords
_s.findreplace("True" "TRUE") ;;replace True
_s.findreplace("ActiveDocument" "doc") ;;replace ActiveDocument
_s.findreplace("Paragraphs(" "Paragraphs.Item(") ;;replace Paragraphs(
_s.findreplace("InchesToPoints(" "app.InchesToPoints(") ;;replace InchesToPoints(
_s.findreplace("If" "if") ;;replace If
_s.findreplace("Else" "else") ;;replace Else

;Add word app statement
str s=
;;/exe 1
;;Use /exe 1 to run the macro in separate process, as User. This macro may not work without it.
;typelib Word {00020905-0000-0000-C000-000000000046} 8.0
;Word.Application app._getactive
;app.Visible = TRUE
;Word.Document doc=app.ActiveDocument
s.addline(_s)
mes s "QM code has been put on the clipboard"
s.setclip


Forum Jump:


Users browsing this thread: 1 Guest(s)