|
Dass Sie öffentliche Prozeduren und Funktionen eines Standard-Moduls eines geladenen Projekts im Direkt-Fenster der Entwicklungsumgebung aufrufen und sofort ausführen können, wissen Sie sicher schon längst. Falls nicht - nun, dann wissen Sie es jetzt und können es gleich einmal ausprobieren. Geben Sie die folgende Prozedur in ein Standard-Modul ein:
Public Sub Hallo()
Debug.Print "Hallo Direkt-Fenster!"
End Sub
Dann tippen Sie im Direkt-Fenster (das Sie schnell mit der Tastenkombination Strg+D erreichen)
Hallo
ein, betätigen dann die Eingabe-Taste - und lassen sich überraschen...
Sie werden sicher ganz schnell darauf gekommen sein, dass Sie auf diese Weise Funktionen separat und vorab testen können, ohne das Projekt starten und den Punkt erreichen zu müssen, an dem eine der Prozeduren oder Funktionen Ihrer Standard-Module aufgerufen werden. Natürlich hat diese Testmöglichkeit ihre Grenzen: Sie können so nur Dinge ausprobieren, die nicht von einem zur Laufzeit erreichten Zustand Ihrer Anwendung abhängen - etwa von bestimmten Werten in globalen Variablen, geladenen Forms und dergleichen mehr.
Doch nicht nur zum Testen von Bestandteilen Ihrer Anwendungen ist die Ausführung im Direkt-Fenster nützlich. Sie können dort auch Prozeduren und Funktionen ausführen, die Sie beim Schreiben von Code unterstützen. Schauen wir uns einmal ein kleines, sicher noch nicht sonderlich nützliches Beispiel an.
Angenommen, Sie benötigen eine Zeile in Ihrem Code mehrfach und nur leicht variiert - etwa so, dass in jeder Zeile an einer bestimmten Stelle eine Nummer hochgezählt werden soll. Geben Sie beispielsweise eine Zeile wie die folgende in irgendeinem Code-Modul ein:
ListBox1.AddItem "Item#"
Hier soll nun beispielsweise das "#"-Zeichen von 2 bis 20 in Zweierschritten hochgezählt werden.
Eine Prozedur, die dies erledigt, ist folgende:
Public Sub ßMultiLines(Optional ByVal Count As Integer = 2, _
Optional Var As String, Optional ByVal First As Long, _
Optional ByVal Interval As Long)
Dim nLine As String
Dim nPos As Integer
Dim nResult As String
Dim i As Integer
Dim nVar As Long
With Clipboard
If .GetFormat(vbCFText) Then
nLine = .GetText(vbCFText)
nPos = InStr(nLine, vbCrLf)
If nPos Then
nLine = Left$(nLine, nPos - 1)
End If
If StrPtr(Var) <> 0 Then
nVar = First
For i = 1 To Count
nResult = nResult & Replace(nLine, Var, CStr(nVar)) _
& vbCrLf
nVar = nVar + Steps
Next 'i
Else
For i = 1 To Count
nResult = nResult & nLine & vbCrLf
Next 'i
End If
.Clear
.SetText nResult
Else
MsgBox "Kein Text in der Zwischenablage", vbCritical, "DWH"
End If
End With
End Sub
Kopieren Sie die zu vervielfältigende Zeile in die Zwischenablage und geben Sie den Prozedurnamen in eine leere Zeile im Direkt-Fenster ein. Sie sehen, dass wie gewohnt die Parameter der Prozedur angezeigt werden. Setzen Sie die gewünschten Werte ein:
ßMultiLines 11, "#", 2, 10
und betätigen Sie die Eingabe-Taste. Offensichtlich passiert nichts - doch wenn Sie nun den Inhalt der Zwischenablage anstelle der ursprünglichen Zeile einfügen... Praktisch, nicht wahr?
Der Name der Prozedur beginnt übrigens bewusst mit einem "ß" (oder mit einem beliebigen anderen "exotischen" Zeichen, das von VB in Prozedurnamen akzeptiert wird), damit sie nicht mit anderenfalls zufällig gleich lautenden Prozeduren Ihrer Anwendung in Konflikt geraten kann. Sie können das Standard-Modul, in dem Sie solche Hilfsprozeduren unterbringen, speichern und in jedes beliebige Projekt aufgenommen lassen, so lange Sie noch daran arbeiten. Es genügt, das Modul vor dem endgültigen Kompilieren gegebenenfalls zu entfernen.
Wenn Ihnen die Tipperei eines sooo langen Prozedurnamens zu umständlich erscheint, dann kürzen Sie ihn doch einfach ab. Oder legen Sie in dem Modul eine weitere Prozedur mit einem kürzeren Namen an, in der die oben stehende Prozedur mit Übergabe aller Parameter aufgerufen wird:
Public Sub ßML(Optional ByVal Count As Integer = 2, _
Optional Var As String, _
Optional ByVal First As Long, _
Optional ByVal Steps As Long)
ßMultiLines Count, Var, First, Steps
End Sub
Dies hat den Vorteil, dass Sie gegebenenfalls auch den Namen des Hilfs-Moduls und einen Punkt dahinter im Direkt-Fenster eingeben können. Die IntelliSense-Technik zeigt Ihnen alle Prozeduren des Moduls zur Auswahl. Die langen, "sprechenden" Prozedurnamen sind hier ganz praktisch als Gedächtnisstütze - die kryptischen Abkürzungen sind dagegen schneller getippt.
Vielleicht fragen Sie sich nun, warum dieser Artikel in der Rubrik "AddIns" zu finden ist. Nun, irgendwie ist ein solches Hilfs-Modul ja ein "AddIn", obwohl es nicht als COM-AddIn über die AddIn-Schnittstelle der Entwicklungsumgebung geladen wird und auch keinen Zugriff auf das Objekt-Modell der Entwicklungsumgebung hat. Gegenüber einem COM-AddIn hat es einen interessanten Vorteil: Sie können jederzeit "mal eben" neue Hilfsprozeduren anlegen und jederzeit wiederverwenden. Und Sie können jederzeit an eine bestimmte Aufgabenstellung angepasste Varianten solcher Hilfs-Prozeduren erstellen - und ebenfalls immer wieder verwenden. Wie praktisch dieses Pseudo-AddIn also sein kann, zeige ich Ihnen im Folgenden anhand einiger weiterer nützlicher Hilfs-Prozeduren.
Bei der Verwendung von Enumerationen ist folgende Prozedur ganz hilfreich. Sie kopieren die Zeilen eine Enumeration in die Zwischenablage - und die Prozedur bereitet daraus eine Select Case...-Verzweigung zu, die Sie an der gewünschten Stelle in Ihren Code einfügen können:
Public Sub ßSelCaseFromEnum()
Dim nEnum() As String
Dim i As Integer
Dim nRetEnum As String
Dim nOK As Boolean
Dim nMax As Integer
With Clipboard
If .GetFormat(vbCFText) Then
nEnum = Split(.GetText(vbCFText), vbCrLf)
If UBound(nEnum) >= 0 Then
If InStr(nEnum(0), "Enum") Then
For i = UBound(nEnum) To 1 Step -1
If Trim$(nEnum(i)) = "End Enum" Then
nMax = i - 1
nOK = True
Exit For
End If
Next 'i
If nOK Then
nRetEnum = "Select Case" & vbCrLf
For i = 1 To nMax
nRetEnum = nRetEnum & vbTab & "Case " & _
Trim$(nEnum(i)) & vbCrLf
Next 'i
nRetEnum = nRetEnum & "End Select" & vbCrLf
.Clear
.SetText nRetEnum, vbCFText
Exit Sub
End If
End If
End If
End If
End With
MsgBox "Keine gültige Enumeration in der Zwischenablage", _
vbCritical, "DWH"
End Sub
So wird aus:
Public Enum ABCConstants
abc123
abc456
abc789
End Enum
im Handumdrehen die Verzweigung generiert:
Select Case
Case abc123
Case abc456
Case abc789
End Select
In Eigenschaften-Prozeduren können Sie eine Select Case...-Verzweigung ganz gut brauchen, um als Eigenschaftswert nur Werte der Enumeration zuzulassen. Die folgende Prozedur packt die Elemente einer Prozedur in eine einzige Case-Zeile und fügt optional den Select Case-Rahmen (Parameter AddSelect) und auch optional einen Case Else-Zweig (Parameter AddCaseElse) hinzu:
Public Sub ßCaseFromEnum _
(Optional ByVal AddSelect As Boolean = True, _
Optional ByVal AddCaseElse As Boolean)
Dim nEnum() As String
Dim i As Integer
Dim nRetEnum As String
Dim nOK As Boolean
Dim nMax As Integer
Dim nTab As String
With Clipboard
If .GetFormat(vbCFText) Then
nEnum = Split(.GetText(vbCFText), vbCrLf)
If UBound(nEnum) >= 0 Then
If InStr(nEnum(0), "Enum") Then
For i = UBound(nEnum) To 1 Step -1
If Trim$(nEnum(i)) = "End Enum" Then
nMax = i - 1
nOK = True
Exit For
End If
Next 'i
If nOK Then
If AddSelect Then
nTab = vbTab
nRetEnum = "Select Case" & vbCrLf
End If
nRetEnum = nRetEnum & nTab & "Case "
For i = 1 To nMax - 1
nRetEnum = nRetEnum & Trim$(nEnum(i)) & ", "
Next 'i
nRetEnum = nRetEnum & Trim$(nEnum(nMax)) & vbCrLf
If AddCaseElse Then
nRetEnum = nRetEnum & nTab & "Case Else" & vbCrLf
End If
If AddSelect Then
nRetEnum = nRetEnum & "End Select" & vbCrLf
End If
.Clear
.SetText nRetEnum, vbCFText
Exit Sub
End If
End If
End If
End If
End With
MsgBox "Keine gültige Enumeration in der Zwischenablage", _
vbCritical, "DWH"
End Sub
Aus der oben stehenden Enumeration ABCConstants wird:
Select Case
Case abc123, abc456, abc789
Case Else
End Select
Stört auch Sie der Bug in der Entwicklungsumgebung, dass Namen von Elementen einer Enumeration ihre Groß-/Kleinschreibweise verlieren, wenn Sie im Code den Namen anders schreiben? Ein kleiner Trick sorgt für eine Beibehaltung der Schreibweise:
Public Enum ABCConstants
abc123
abc456
abc789
End Enum
#If False Then
Public abc123
Public abc456
Public abc789
#End If
Die Compiler-Anweisungen "#..." sorgen dafür, dass die darin eingeschlossenen Zeilen nicht mit kompiliert werden, während diese Zeilen zur Entwicklungszeit für die Beibehaltung der Schreibweise verantwortlich sind.
Da das Hinzufügen dieser Zeilen eine stupide Arbeit ist, überlassen Sie sie der folgenden Prozedur:
Public Sub ßEnforceCaseFromEnum()
Dim nEnum() As String
Dim i As Integer
Dim nRetEnum As String
Dim nOK As Boolean
Dim nMax As Integer
With Clipboard
If .GetFormat(vbCFText) Then
nRetEnum = .GetText(vbCFText)
nEnum = Split(nRetEnum, vbCrLf)
If UBound(nEnum) >= 0 Then
If InStr(nEnum(0), "Enum") Then
For i = UBound(nEnum) To 1 Step -1
If Trim$(nEnum(i)) = "End Enum" Then
nMax = i - 1
nOK = True
Exit For
End If
Next 'i
If nOK Then
Do While Right$(nRetEnum, 2) = vbCrLf
nRetEnum = Left$(nRetEnum, Len(nRetEnum) - 2)
Loop
nRetEnum = nRetEnum & vbCrLf & "#If False Then" _
& vbCrLf
For i = 1 To nMax
nRetEnum = nRetEnum & vbTab & "Public " & _
Trim$(nEnum(i)) & vbCrLf
Next 'i
nRetEnum = nRetEnum & "#End If" & vbCrLf
.Clear
.SetText nRetEnum, vbCFText
Exit Sub
End If
End If
End If
End If
End With
MsgBox "Keine gültige Enumeration in der Zwischenablage", _
vbCritical, "DWH"
End Sub
Sie benötigen hin und wieder GUIDs? Auch kein Problem - die nächste Prozedur erzeugt jedes Mal einen neuen (siehe auch: "GUIDs für jeden Zweck"khwcreateguid.htm), wahlweise ins Direkt-Fenster ausgegeben oder in die Zwischenablage kopiert:
Public Sub ßGUID(Optional ByVal Copy As Boolean = True)
Dim nTemp As String
Dim nGUID As GUID
Dim nLength As Long
Dim nGUIDStr As String
nTemp = Space$(78)
CoCreateGuid nGUID
nLength = StringFromGUID2(nGUID, nTemp, Len(nTemp))
nGUIDStr = Left$(StrConv(nTemp, vbFromUnicode), nLength - 1)
If Copy Then
With Clipboard
.Clear
.SetText nGUIDStr, vbCFText
End With
Else
Debug.Print nGUIDStr
End If
End Sub
Das sei alles nur Spielerei, sagen Sie? Gut, dann höre ich damit auf und zeige Ihnen eine wirklich praktische Sache - eine Prozedur, die den etwas starren und eigensinnigen Eigenschaftenprozeduren-Assistenten ersetzen dürfte:
Private Const kPropertyPrefix = "m_"
Private Const kDefaultPrefix = "mdef_"
Public Enum dwhPropertyScopeConstants
dwhPropPublic
dwhPropFriend
dwhPropPrivate
End Enum
Public Enum dwhPropertyVarTypeConstants
dwhPVTObject
dwhPVTBoolean
dwhPVTByte
dwhPVTCurrency
dwhPVTDate
dwhPVTDouble
dwhPVTInteger
dwhPVTLong
dwhPVTSingle
dwhPVTString
dwhPVTVariant
dwhPVTOLE_COLOR
dwhPVTStdPicture
dwhPVTStdFont
End Enum
Public Enum dwhClassTypeConstants
dwhCTNone
dwhCTForm
dwhCTClass
dwhCTUserControl
dwhCTUserDocument
End Enum
Public Sub ßMakeProperty(PropName As String, _
Optional ByVal Scope As dwhPropertyScopeConstants = dwhPropPublic, _
Optional ByVal VarType As dwhPropertyVarTypeConstants = _
dwhPVTObject, _
Optional ObjType As String, Optional DefaultValue As Variant, _
Optional ByVal ReadOnly As Boolean, _
Optional ByVal PropBag As Boolean)
Dim nProp As String
Dim nScope As String
Dim nVarType As String
Dim nDefaultValue As String
Dim nSet As String
Const kSet = "Set "
If Len(PropName) Then
Select Case Scope
Case dwhPropPublic
nScope = "Public "
Case dwhPropFriend
nScope = "Friend "
Case dwhPropPrivate
nScope = "Private "
End Select
Select Case VarType
Case dwhPVTObject
If Len(ObjType) Then
nVarType = ObjType
Else
nVarType = InputBox("Objekt-Typ:", "DWH.MakeProperty")
If StrPtr(nVarType) = 0 Then
Exit Sub
End If
End If
nSet = kSet
Case dwhPVTBoolean
nVarType = "Boolean"
Case dwhPVTByte
nVarType = "Byte"
Case dwhPVTCurrency
nVarType = "Currency"
Case dwhPVTDate
nVarType = "Date"
Case dwhPVTDouble
nVarType = "Double"
Case dwhPVTInteger
nVarType = "Integer"
Case dwhPVTLong
nVarType = "Long"
Case dwhPVTSingle
nVarType = "Single"
Case dwhPVTString
nVarType = "String"
Case dwhPVTVariant
nVarType = "Variant"
Case dwhPVTOLE_COLOR
nVarType = "OLE_COLOR"
Case dwhPVTStdPicture
nVarType = "StdPicture"
nSet = kSet
Case dwhPVTStdFont
nVarType = "StdFont"
nSet = kSet
End Select
nProp = nScope & "Property Get " & PropName & "() As " _
& nVarType & vbCrLf
nProp = nProp & vbTab & nSet & PropName & " = " _
& kPropertyPrefix & PropName & vbCrLf
nProp = nProp & "End Property" & vbCrLf & vbCrLf
If ReadOnly Then
nProp = nProp & "'M§Private " & kPropertyPrefix & PropName _
& " As " & nVarType & vbCrLf
If Not IsMissing(DefaultValue) Then
If Len(nSet) = 0 Then
Select Case VBA.VarType(DefaultValue)
Case vbString
nDefaultValue = Chr$(34) & CStr(DefaultValue) _
& Chr$(34)
Case vbBoolean
If CBool(DefaultValue) Then
nDefaultValue = "True"
Else
nDefaultValue = "False"
End If
Case Else
nDefaultValue = CStr(DefaultValue)
End Select
nProp = nProp & "'D§" & "Private Const " & _
kDefaultPrefix & PropName & " = " & nDefaultValue & vbCrLf
nProp = nProp & "'I§" & kPropertyPrefix & PropName _
& " = " & kDefaultPrefix & PropName & vbCrLf
End If
End If
If PropBag Then
nProp = nProp & "'R§" & nSet & kPropertyPrefix & PropName _
& " = PropBag.ReadProperty(" & Chr$(34) & PropName _
& Chr$(34) & ")" & vbCrLf
End If
nProp = nProp & vbCrLf
With Clipboard
.Clear
.SetText nProp, vbCFText
End With
Exit Sub
End If
nProp = nProp & nScope & "Property Let " & PropName _
& "(New_" & PropName & " As " & nVarType & ")" & vbCrLf
nProp = nProp & vbTab & nSet & kPropertyPrefix & PropName _
& " = New_" & PropName & vbCrLf
If PropBag Then
nProp = nProp & vbTab & "PropertyChanged " & Chr$(34) _
& PropName & Chr$(34) & vbCrLf
End If
nProp = nProp & "End Property" & vbCrLf
nProp = nProp & "'M§Private " & kPropertyPrefix & PropName _
& " As " & nVarType & vbCrLf
If Not IsMissing(DefaultValue) Then
If Len(nSet) = 0 Then
Select Case VBA.VarType(DefaultValue)
Case vbString
nDefaultValue = Chr$(34) & CStr(DefaultValue) & Chr$(34)
Case vbBoolean
If CBool(DefaultValue) Then
nDefaultValue = "True"
Else
nDefaultValue = "False"
End If
Case Else
nDefaultValue = CStr(DefaultValue)
End Select
nProp = nProp & "'D§" & "Private Const " & kDefaultPrefix _
& PropName & " = " & nDefaultValue & vbCrLf
nProp = nProp & "'I§" & kPropertyPrefix & PropName & " = " _
& kDefaultPrefix & PropName & vbCrLf
End If
End If
If PropBag Then
nProp = nProp & "'R§" & nSet & kPropertyPrefix & PropName _
& " = PropBag.ReadProperty(" & Chr$(34) & PropName _
& Chr$(34) & ")" & vbCrLf
nProp = nProp & "'W§" & "PropBag.WriteProperty " & Chr$(34) _
& PropName & Chr$(34) & ", " & kPropertyPrefix & PropName _
& vbCrLf
End If
nProp = nProp & vbCrLf
With Clipboard
.Clear
.SetText nProp, vbCFText
End With
Else
MsgBox "Kein Name für Eigenschaft angegeben", vbCritical, _
"DWH"
End If
End Sub
Hübsch, nicht wahr? Sie übergeben den Namen der Eigenschaft, wählen komfortabel den Gültigkeitsbereich aus (Scope) und picken den gewünschten Datentyp (VarType) der Eigenschaft heraus. Sogar den Namen eines Objekt-Typs können Sie im nächsten Parameter einsetzen, wenn Sie zuvor als VarType dwhPVTObject ausgesucht haben. Ebenso können Sie im Parameter DefaultValue einen Initialisierungswert für die Eigenschaft vorgeben - True oder False, einen nummerischen Wert oder einen String (allerdings wird nicht geprüft, ob dieser Wert und der zuvor gewählte Datentyp zusammenpassen - das zu einzubauen überlasse ich Ihrer eigenen Kreativität). Wenn Sie nur eine ReadOnly-Eigenschaft anlegen wollen, setzen Sie den Parameter ReadOnly auf True. Und wenn Sie die Eigenschaft in ein Objekt-Modul einsetzen wollen, das die Serialisierung in ein PropertyBag erlaubt (Class, UserControl, UserDocument), setzen Sie den letzten Parameter PropBag auf True.
Das folgende Eingabe-Beispiel im Direkt-Fenster
ßMakeProperty "Test", dwhPropPublic, dwhPVTString, , "Hallo", _
, True
produziert fertig zum Einfügen in das Code-Modul eines UserControls folgenden Code:
Public Property Get Test() As String
Test = m_Test
End Property
Public Property Let Test(New_Test As String)
m_Test = New_Test
PropertyChanged "Test"
End Property
'M§Private m_Test As String
'D§Private Const mdef_Test = "Hallo"
'I§m_Test = mdef_Test
'R§m_Test = PropBag.ReadProperty("Test")
'W§PropBag.WriteProperty "Test", m_Test
Sie wundern sich über die etwas seltsam erscheinenden auskommentierten letzten Zeilen? Warten Sie noch einen Moment und produzieren Sie erst noch folgende Eigenschaft als weiteres Beispiel und fügen Sie sie ins gleiche UserControl-Modul ein:
ßMakeProperty "Wert", dwhPropPublic, dwhPVTBoolean, , True, _
, True
Das Ergebnis hier, das Sie ebenfalls in das UserControl-Modul einfügen:
Public Property Get Wert() As Boolean
Wert = m_Wert
End Property
Public Property Let Wert(New_Wert As Boolean)
m_Wert = New_Wert
PropertyChanged "Wert"
End Property
'M§Private m_Wert As Boolean
'D§Private Const mdef_Wert = True
'I§m_Wert = mdef_Wert
'R§m_Wert = PropBag.ReadProperty("Wert")
'W§PropBag.WriteProperty "Wert", m_Wert
Kopieren Sie nun den gesamten Inhalt des UserControl-Moduls, führen Sie die nun folgende Prozedur aus, und ersetzen Sie dann den Inhalt des UserControl-Moduls durch den neuen Inhalt der Zwischenablage.
Public Sub ßPropCollect()
Dim nCode As String
Dim nLines() As String
Dim i As Integer
Dim nDims As String
Dim nDefaults As String
Dim nInits As String
Dim nClassType As String
Dim nCheckClassType As Boolean
Dim nReadProps As String
Dim nWriteProps As String
Dim nNewCode As String
Dim nOK As Boolean
Const kClassPrompt = _
"OK zum Übernehmen oder Leertaste+OK für weitere Auswahl:"
With Clipboard
If .GetFormat(vbCFText) Then
nCode = .GetText(vbCFText)
nLines = Split(nCode, vbCrLf)
If UBound(nLines) >= 0 Then
For i = 0 To UBound(nLines)
Select Case Left$(nLines(i), 3)
Case "'M§"
nDims = nDims & Mid$(nLines(i), 4) & vbCrLf
Case "'D§"
nDefaults = nDefaults & Mid$(nLines(i), 4) & vbCrLf
Case "'I§"
nInits = nInits & vbTab & Mid$(nLines(i), 4) & vbCrLf
nCheckClassType = True
Case "'R§"
nReadProps = nReadProps & vbTab & Mid$(nLines(i), 4) _
& vbCrLf
nCheckClassType = True
Case "'W§"
nWriteProps = nWriteProps & vbTab & Mid$(nLines(i), 4) _
& vbCrLf
nCheckClassType = True
Case Else
nNewCode = nNewCode & nLines(i) & vbCrLf
End Select
Next 'i
Do Until Right$(nNewCode, 2) <> vbCrLf
nNewCode = Left$(nNewCode, Len(nNewCode) - 2)
Loop
nNewCode = nNewCode & vbCrLf & vbCrLf
If nCheckClassType Then
nClassType = InputBox(kClassPrompt, "DWH.PropCollect", _
"Class")
If Len(Trim$(nClassType)) = 0 Then
nClassType = InputBox(kClassPrompt, "DWH.PropCollect", _
"Form")
If Len(Trim$(nClassType)) = 0 Then
nClassType = InputBox(kClassPrompt, _
"DWH.PropCollect", "UserControl")
If Len(Trim$(nClassType)) = 0 Then
nClassType = InputBox(kClassPrompt, _
"DWH.PropCollect", "UserDocument")
If Len(Trim$(nClassType)) = 0 Then
Exit Sub
End If
End If
End If
End If
End If
If Len(nInits) Then
nInits = "Private Sub " & nClassType & "_Initialize()" _
& vbCrLf & nInits
nInits = nInits & "End Sub" & vbCrLf & vbCrLf
nNewCode = nNewCode & nInits
nOK = True
End If
If Len(nReadProps) Then
nReadProps = "Private Sub " & nClassType _
& "_ReadProperties(PropBag As PropertyBag)" & vbCrLf _
& nReadProps
nReadProps = nReadProps & "End Sub" & vbCrLf & vbCrLf
nNewCode = nNewCode & nReadProps
nOK = True
End If
If Len(nWriteProps) Then
nWriteProps = "Private Sub " & nClassType _
& "_WriteProperties(PropBag As PropertyBag)" & vbCrLf _
& nWriteProps
nWriteProps = nWriteProps & "End Sub" & vbCrLf & vbCrLf
nNewCode = nNewCode & nWriteProps
nOK = True
End If
If Len(nDims) Then
nNewCode = nNewCode & nDims & vbCrLf
nOK = True
End If
If Len(nDefaults) Then
nNewCode = nNewCode & nDefaults
nOK = True
End If
If nOK Then
Do Until Right$(nNewCode, 2) <> vbCrLf
nNewCode = Left$(nNewCode, Len(nNewCode) - 2)
Loop
nNewCode = nNewCode & vbCrLf & vbCrLf
.Clear
.SetText nNewCode, vbCFText
Exit Sub
End If
End If
End If
End With
MsgBox "Kein (gültiger) Text in der Zwischenablage", _
vbCritical, "DWH"
End Sub
Das Ergebnis sieht dann schon ziemlich "reif" aus, oder?
Option Explicit
Public Property Get Test() As String
Test = m_Test
End Property
Public Property Let Test(New_Test As String)
m_Test = New_Test
PropertyChanged "Test"
End Property
Public Property Get Wert() As Boolean
Wert = m_Wert
End Property
Public Property Let Wert(New_Wert As Boolean)
m_Wert = New_Wert
PropertyChanged "Wert"
End Property
Private Sub UserControl_Initialize()
m_Test = mdef_Test
m_Wert = mdef_Wert
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_Test = PropBag.ReadProperty("Test")
m_Wert = PropBag.ReadProperty("Wert")
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "Test", m_Test
PropBag.WriteProperty "Wert", m_Wert
End Sub
Private m_Test As String
Private m_Wert As Boolean
Private Const mdef_Test = "Hallo"
Private Const mdef_Wert = True
Da ich Ihnen nicht vorschreiben möchte, wie Sie den Deklarationsteil (Allgemein-Teil) Ihrer Module strukturieren, stehen die Deklarationen für die privaten Eigenschaften-Variablen und Default-Wert-Konstanten am Ende des Moduls. Sie brauchen Sie nur noch auszuschneiden und in den Deklarations-Teil des Moduls einzufügen. Sie können die Prozedur natürlich auch so ändern, dass dies gleich dort erledigt wird - ganz nach Ihren Vorstellungen.
Wie schon erwähnt, können Sie den Aufruf auch abkürzen:
Public Sub ßP(PropName As String, _
Optional ByVal Scope As dwhPropertyScopeConstants = _
dwhPropPublic, _
Optional ByVal VarType As dwhPropertyVarTypeConstants = _
dwhPVTObject, Optional ObjType As String, _
Optional DefaultValue As Variant, _
Optional ByVal ReadOnly As Boolean, _
Optional ByVal PropBag As Boolean)
ßMakeProperty PropName, Scope, VarType, ObjType, _
DefaultValue, ReadOnly, PropBag
End Sub
Und Sie können die Abkürzungen spezialisieren.
Für einen Objekt-Datentyp:
Public Sub ßPO(PropName As String, _
Optional ByVal Scope As dwhPropertyScopeConstants, _
Optional ObjType As String, _
Optional ByVal ReadOnly As Boolean, _
Optional ByVal PropBag As Boolean)
ßMakeProperty PropName, Scope, dwhPVTObject, ObjType, _
ReadOnly, PropBag
End Sub
Für einen Objekt-Daten in einem UserControl:
Public Sub ßPOU(PropName As String, _
Optional ByVal Scope As dwhPropertyScopeConstants, _
Optional ObjType As String, _
Optional ByVal ReadOnly As Boolean, _
Optional ByVal PropBag As Boolean)
ßMakeProperty PropName, Scope, dwhPVTObject, ObjType, _
ReadOnly, True
End Sub
Für einen beliebigen Datentyp in einem UserControl:
Public Sub ßPU(PropName As String, _
Optional ByVal Scope As dwhPropertyScopeConstants = dwhPropPublic, _
Optional ByVal VarType As dwhPropertyVarTypeConstants = _
dwhPVTObject, _
Optional ObjType As String, _
Optional DefaultValue As Variant, _
Optional ByVal ReadOnly As Boolean, _
Optional ByVal PropBag As Boolean)
ßMakeProperty PropName, Scope, VarType, ObjType, DefaultValue, _
ReadOnly, True
End Sub
Und schließlich die Prozedur, die für das letzte "Finishing" sorgte, auch noch im Schnellzugriff:
Public Sub ßPC()
ßPropCollect
End Sub
Ach ja, ehe ich es vergesse: Das Ganze funktioniert übrigens genau so prächtig auch in der VBA-Entwicklungsumgebung.
|