Yaslaw.Info

This page is read only. You can view the source, but not change it. Ask your administrator if you think this is wrong.
====== [VBA] heredoc() ======
In VBA ist es leider fast nicht möglich, einen längeren fixen Text in eine Variable zu drücken ohne ihn unlesbar zu machen. heredoc() ist mein Versuch das zu vereinfachen. Dabei wird ein Text in der heredoc-Formatierung als Kommentar erfasst. heredoc() liest diesen dann aus und gibt ihn als String zurück.

Die ausgelesenen Strings werden in einem Dictionary gecached. Wenn derselbe String nochmals abgefragt wird, muss so nicht mehr der VB-Code durchsucht werden.

> Das ganze ist zu aufwendig. Ich selber verwedne es nur sehr selten. Aber der Ansatz finde ich interessant.

{{:vba:functions:udf_heredoc.bas|download udf_heredoc.bas}}

===== Definitionen =====
<code vb>Public Function heredoc( _
        ByVal iModulName As String, _
        ByVal iName As String, _
        Optional ByVal iClearCache As Boolean = False _
) As String</code>
  ***iModulName** Name des Moduls
  ***iName** Name der Variable
  ***iClearCache** Angabe, ob der Objektcache geleert werden soll

===== Beispiel =====
> Für die Ausgabe der Resultate verwendete ich die Funktion [[vba:functions:print_r:index]]
> Für den Test_3 verwende ich noch [[vba:functions:printf:index]] um die Möglichekit zu zeigen, mit Platzhalter zu arbeiten

<code vb funcTest.bas>Option Explicit

'text_1 = <<<TXT
'   Ein Text am Anfang
'TXT;

    'text_2 = <<<TXT
    'und noch einer
    'am Anfang
    'TXT;


Const C_MODULE_NAME = "funcTest"

Public Sub testHeredoc()
'text_3 = <<<TXT
'   Innerhalb einer Funktion
'   Der Sieger im Jahr %d heisst %s
'TXT;

    print_r heredoc(C_MODULE_NAME, "text_1"), prShowType + prStringSingleQuotes
    print_r heredoc(C_MODULE_NAME, "text_2"), prShowType + prStringSingleQuotes
    print_r heredoc(C_MODULE_NAME, "text_3"), prShowType + prStringSingleQuotes
    print_r sPrintF(heredoc(C_MODULE_NAME, "text_3"), 2014, "Yaslaw"), prShowType + prStringSingleQuotes
    print_r heredoc(C_MODULE_NAME, "text_4"), prShowType + prStringSingleQuotes

End Sub

'text_4 = <<<SUFFIX
'   Der Text darf auch am
'           Ende des Moduls stehen
'SUFFIX;
</code>
Die Ausgabe
<code><String> '   Ein Text am Anfang'
<String> 'und noch einer
am Anfang'
<String> '   Innerhalb einer Funktion
   Der Sieger im Jahr %d heisst %s'
<String> '   Innerhalb einer Funktion
   Der Sieger im Jahr 2014 heisst Yaslaw'
<String> '   Der Text darf auch am
           Ende des Moduls stehen'</code>
           
===== Code =====
<code vb udf_heredoc.bas>'-------------------------------------------------------------------------------
'File         : udf_heredoc.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki
'Environment  : VBA 2007 +
'Version      : 1.0.1
'Name         : heredoc
'Author       : Stefan Erb (ERS)
'History      : 14.07.2014 - ERS - Creation
'               14.07.2014 - ERS - Kleine Anpassungen
'-------------------------------------------------------------------------------
Option Explicit

'text = <<<TXT
'   Hallo2
'   Welt
'
'TXT;

Private rxText As Object
Private rxRemoveSingleQuotes As Object
Private vbProj As VBProject
Private cache As Object

'/**
' * List ein String aus aus einem Comment aus, der in der heredoc-Syntax steht.
' *
' *     text = heredoc(modulName, name [,clearCache]])
' *
' * @param  String      Name des Moduls
' * @param  String      Name der Variable
' * @param  Boolean     Angabe, ob der Objektcache geleert werden soll
' * @return String      Ausgelesener Text ohne führende '
' */
Public Function heredoc( _
        ByVal iModulName As String, _
        ByVal iName As String, _
        Optional ByVal iClearCache As Boolean = False _
) As String
    Dim key As String: key = iModulName & "#" & iName
    'Cahce anlegen
    If cache Is Nothing Or iClearCache Then
        Set cache = CreateObject("scripting.Dictionary")
    End If
    'Prüfen ob der Text schon mal abgefragt wurde. Wenn ja, aus dem Cache abrufen.
    If cache.exists(key) And Not iClearCache Then
        'Text aus dem Cache laden
        heredoc = cache(key)
        Exit Function
    End If
    
    'Je nach Microsoft-Programm muss das VBProject anderst ausgelesen werden
    If vbProj Is Nothing Or iClearCache Then
        Select Case Application.Name
            Case "Microsoft Access": Set vbProj = Application.VBE.VBProjects(1)
            Case "Microsoft Excel": Set vbProj = ThisWorkbook.VBProject
        End Select
    End If
    Dim vbCodeMod As CodeModule: Set vbCodeMod = vbProj.VBComponents(iModulName).CodeModule
    
    'RegExp anlegen
    'RegExp um eine heredoc-Format aus einem Modul auszulesen
    If rxText Is Nothing Or iClearCache Then
        Set rxText = CreateObject("VBScript.RegExp")
        rxText.pattern = "'" & iName & "\s*=\s*<<<(\w+)([\s\S]*?)[\r\n]\s*'\1;"
        rxText.Global = True
    End If
    'RegExp um die führenden ' zu entfernen
    If rxRemoveSingleQuotes Is Nothing Or iClearCache Then
        Set rxRemoveSingleQuotes = CreateObject("VBScript.RegExp")
        rxRemoveSingleQuotes.pattern = "^\s*'"
        rxRemoveSingleQuotes.Multiline = True
        rxRemoveSingleQuotes.Global = True
    End If
    
    Dim codeText As String: codeText = vbCodeMod.Lines(1, vbCodeMod.CountOfLines)
    If Not rxText.Test(codeText) Then Err.Raise 461     'Method or data member not found
    Dim mc As MatchCollection: Set mc = rxText.Execute(codeText)
    heredoc = rxRemoveSingleQuotes.Replace(mc(0).SubMatches(1), "")
    cache(key) = heredoc
    
Exit_Hanldler:
On Error Resume Next
    Set mc = Nothing
    Set vbCodeMod = Nothing
End Function</code>
Yaslaw.Info

User Tools

Site Tools

Page Tools
