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.
Public Function heredoc( _ ByVal iModulName As String, _ ByVal iName As String, _ Optional ByVal iClearCache As Boolean = False _ ) As String
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r()
Für den Test_3 verwende ich noch [VBA] sprintf(), vsprintf() um die Möglichekit zu zeigen, mit Platzhalter zu arbeiten
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;
Die Ausgabe
<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'
'------------------------------------------------------------------------------- '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