ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE
Diese Seite wurde zuletzt aktualisiert am 10.04.2001

Diese Seite wurde zuletzt aktualisiert am 10.04.2001
Aktuell im ABOUT Visual Basic-MagazinGrundlagenwissen und TechnologienKnow How, Tipps und Tricks rund um Visual BasicActiveX-Komponenten, Controls, Klassen und mehr...AddIns für VB, VBA und OfficeVBA-Programmierung in MS-Office und anderen AnwendungenScripting-Praxis für den Windows Scripting Host und das Scripting-ControlTools, Komponenten und Dienstleistungen des MarktesRessourcen für Programmierer (Bücher, Job-Börse)Dies&Das...

Themen und Stichwörter im ABOUT Visual Basic-Magazin
Code, Beispiele, Komponenten, Tools im Überblick, Shareware, Freeware
Ihre Service-Seite, Termine, Job-Börse
Melden Sie sich an, um in den vollen Genuss des ABOUT Visual Basic-Magazins zu kommen!
Informationen zum ABOUT Visual Basic-Magazin, Kontakt und Impressum

Zurück...

Quick-Ins

Zurück...


Anzeige

(-hg) mailto:hg_adiquickins@aboutvb.de

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.


Modul modDirectWindowHelper (modDirectWindowHelper.zip - ca. 4 KB)



AddIn-Übersicht


Zum Seitenanfang

Copyright © 1999 - 2017 Harald M. Genauck, ip-pro gmbh  /  Impressum

Zum Seitenanfang

Zurück...

Zurück...

Download Internet Explorer