---

EditMacro.zip

Hallo Leut',

kürzlich hab ich mit dem Macro-Rekorder eine längere Prozedur aufgenommen.
Anschliessend, beim Betrachten des Makros, hat mich genervt, dass jede zweite Zeile eine Dim-Anweisung enthielt.
Die Folge war, dass ich ein Progrämmchen erstellt habe, das die Dims alle nach vorne stellt(.zip anbei).

Code der Start-Routine(Form_Load):

Code:

---

'---------------------------------------------------------------------------------------
' App      : EditMacro
' Author    : jherzog
' Date      : 13.12.2014
' Purpose  : Edit _recorded_ single sub catscript macros;
'          : regroup and sort dim-statements;
' Remarks  : Just drop one or more files on the '.exe'; command line also possible.
'          : This app accepts multi-sel files.
'          : Blanks in file name will lead to error and failure.
'---------------------------------------------------------------------------------------

Option Explicit

Private Sub Form_Load()
  Dim arrCmd() As String
  Dim n As Integer
 
  If Command$ > "" Then
      arrCmd = Split(Command$, " ")
     
      For n = 0 To UBound(arrCmd)
        If InStr(UCase(arrCmd(n)), "CATSCRIPT") Then
            EditScript arrCmd(n)
        Else
            MsgBox "Not a CatScript! Exiting ...", vbOKOnly, App.Title & " " & App.Major _
              & "." & App.Minor & "." & App.Revision
            Unload Me
        End If
      Next
  End If

  Unload Me
End Sub

---

... und der zwei aufgerufenen Subs:

Code:

---

Option Explicit

' QuickSort-Algorithmus
' Autor:  Dieter Otter
' www.tools4vb.de
'
' vSort() : zu sortierendes Array
' lngStart, lngEnd: zu sortierender Bereich
' ==========================================
Public Sub QuickSort(vSort As Variant, _
  Optional ByVal lngStart As Variant, _
  Optional ByVal lngEnd As Variant)

  ' Wird die Bereichsgrenze nicht angegeben,
  ' so wird das gesamte Array sortiert

  If IsMissing(lngStart) Then lngStart = LBound(vSort)
  If IsMissing(lngEnd) Then lngEnd = UBound(vSort)

  Dim i As Long
  Dim j As Long
  Dim h As Variant
  Dim x As Variant

  i = lngStart: j = lngEnd
  x = vSort((lngStart + lngEnd) / 2)

  ' Array aufteilen
  Do

    While (vSort(i) < x): i = i + 1: Wend
    While (vSort(j) > x): j = j - 1: Wend

    If (i <= j) Then
      ' Wertepaare miteinander tauschen
      h = vSort(i)
      vSort(i) = vSort(j)
      vSort(j) = h
      i = i + 1: j = j - 1
    End If
  Loop Until (i > j)

  ' Rekursion (Funktion ruft sich selbst auf)
  If (lngStart < j) Then QuickSort vSort, lngStart, j
  If (i < lngEnd) Then QuickSort vSort, i, lngEnd
End Sub

---

Code:

---

'---------------------------------------------------------------------------------------
' Procedure : EditScript
' Author    : jherzog
' Date      : 13.12.2014
' Time      : 15:48
' Languages : VB6 Pro SP6
' V5-Release: V5R19/21
' Purpose  : Group sorted Dims infront of code
' Parms    : strInFile:  The input file
' Ret. Value: -
'
' Syntax    : EditScript strInFile
'
' Prereqs  : -
' Remarks  : The routine looks for 'CATMAIN' and 'SUB ' tokens. If neither is found,
'          : the code is just regrouped, dims first.
'---------------------------------------------------------------------------------------
'
Public Sub EditScript(strInFile As String)
  Dim strOutFile As String                                'name of edited macro
  Dim fso As Object                                        'file system object
  Dim oTxtStr As Object                                    'text stream
  Const ForReading = 1
  Const ForWriting = 2
  Const ForAppending = 3
  Const TristateFalse = 0
  Dim strTxt As String                                    'text read from text stream
  Dim arrTxt() As String                                  'text array
  Dim arrDims() As String                                  'dims array
  Dim arrCode() As String                                  'code array
  Dim n As Integer
  Dim m As Integer
  Dim d As Integer
  Dim c As Integer

  On Error GoTo EditScript_Error
'---------------------------------------------------------------------------------------
'open the file & get text
  Set fso = CreateObject("Scripting.FileSystemObject")    'filesysobject
  Set oTxtStr = fso.OpenTextFile(strInFile, ForReading, TristateFalse)
  strTxt = oTxtStr.ReadAll                                'read text
  arrTxt = Split(strTxt, vbLf)                            'split text
  oTxtStr.Close                                            'close text stream
'---------------------------------------------------------------------------------------
'split up dimms and code
  m = UBound(arrTxt)
  ReDim arrDims(m)                                        'predimension array
  ReDim arrCode(m)
 
  d = -1
  c = -1
  For n = 0 To m
      If Left(UCase(arrTxt(n)), 3) = "DIM" Then
        d = d + 1
        arrDims(d) = arrTxt(n)
      Else
        c = c + 1
        arrCode(c) = arrTxt(n)
      End If
  Next
'---------------------------------------------------------------------------------------
'sort dims
  If d >= 0 Then                                          'if at least one dim was found
      ReDim Preserve arrDims(d)
      QuickSort arrDims                                    'SortDims
  End If
  If c >= 0 Then ReDim Preserve arrCode(c)
'---------------------------------------------------------------------------------------
'Write back macro
  'create file
  strOutFile = Left(strInFile, InStr(UCase(strInFile), "CATSCRIPT") - 2) _
      & "_EDIT" & ".CATScript"
  Set oTxtStr = fso.CreateTextFile(strOutFile, True)      'create textstream

  'if used on recorded catscript files, only the first if-block is relevant
  If InStr(UCase(strTxt), "CATMAIN") > 0 Then              'if there is a catmain
      For c = 0 To UBound(arrCode)
        If InStr(UCase(arrCode(c)), "CATMAIN") > 0 Then    'this should only happen once
            oTxtStr.WriteLine (arrCode(c))
            If d >= 0 Then
              For d = 0 To UBound(arrDims)                'write in dims
                  oTxtStr.WriteLine (arrDims(d))
              Next
              oTxtStr.WriteLine ("'" & String$(80, "-"))
              oTxtStr.WriteLine ("'" & "End of Dims")
              oTxtStr.WriteLine ("'" & String$(80, "-"))
            End If
        Else
            oTxtStr.WriteLine (arrCode(c))
        End If
      Next
  ElseIf InStr(UCase(strTxt), "SUB ") > 0 Then            'no catmain, but sub?
      For c = 0 To UBound(arrCode)
        If InStr(UCase(arrCode(c)), "SUB ") > 0 Then      'this should only happen once
            oTxtStr.WriteLine (arrCode(c))
            If d >= 0 Then
              For d = 0 To UBound(arrDims)                'write in dims
                  oTxtStr.WriteLine (arrDims(d))
              Next
              oTxtStr.WriteLine ("'" & String$(80, "-"))
              oTxtStr.WriteLine ("'" & "End of Dims")
              oTxtStr.WriteLine ("'" & String$(80, "-"))
            End If
        Else
            oTxtStr.WriteLine (arrCode(c))
        End If
      Next
  Else                                                    'first dims, then code
      If d >= 0 Then
        For d = 0 To UBound(arrDims)                      'write in dims
            oTxtStr.WriteLine (arrDims(d))
        Next
        oTxtStr.WriteLine ("'" & String$(80, "-"))
        oTxtStr.WriteLine ("'" & "End of Dims")
        oTxtStr.WriteLine ("'" & String$(80, "-"))
      End If
      For c = 0 To UBound(arrCode)                          'write code
        oTxtStr.WriteLine (arrCode(c))
      Next
  End If
  oTxtStr.Close                                            'close text stream
Exit Sub
'---------------------------------------------------------------------------------------
EditScript_Error:
  Dim errMsg As String
  Dim errRet As VbMsgBoxResult

  Select Case Err.Number
'      Case 438
'      Case -2147467259
      Case Else
        errMsg = Err.Number & ": " & Err.Description & " in procedure EditScript of Modul modEditMacro"
        errRet = MsgBox(errMsg, vbOKOnly, "EditScript")
  End Select

  'Resume Next                                            'fall thru to quit sub
'---------------------------------------------------------------------------------------
End Sub

---

Wer's verwenden mag: Aufgenommene(s) Catscript(s) auf EditMacro.exe oder eine Verknüpfung droppen.
That's it.
Die erzeugte Datei hat den gleichen Stammnamen & '_EDIT'.

Nota: Nachdem die einzelnen Dateien per Leerzeichen unterschieden werden, darf kein Leerzeichen im Makronamen stehen.

Enjoy,
Joe

Tokens: Command, Quicksort, FileSystemObject, TextStream

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP