Private Declare Function SHGetSpecialFolderPathW Lib "shell32.dll" ( _
    ByVal hwndOwner As Long, _
    ByVal lpszPath As Long, _
    ByVal nFolder As Long, _
    ByVal fCreate As Long) As Boolean

Private Const MD As Long = &H5
    
Public Function My_Documents() As String
    
    Dim Folders(512) As Byte
    
    My_Documents = vbNullString
    
    If SHGetSpecialFolderPathW(0&, _
        ByVal VarPtr(Folders(0)), _
            MD, 0&) Then
        My_Documents = Left$(Folders, InStr(Folders, Chr$(0)) - 1)
    End If
    
    Erase Folders
    
End Function

Private Sub ParseName(ByVal strInput, ByRef strFirstName, ByRef strLastName)
        Try
            ' Split the string into it's constituent words
            Dim strSplitName1() As String = strInput.Split(New Char() {" "})

            ' Ensure any leading or trailing spaces are trimmed within each word
            Dim intIndex As Integer = 0
            For intIndex = 0 To strSplitName1.Length - 1
                strSplitName1(intIndex) = strSplitName1(intIndex).Trim
            Next

            ' If only one word was found, treat it as a last name, with no first name
            If (strSplitName1.Length <= 1) Then
                strFirstName = ""
                strLastName = strSplitName1(0)
                Return
            End If

            ' Check the first word for a title
            If ( _
                (String.Compare(strSplitName1(0), "Mr", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Mr.", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Mister", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Mrs", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Ms", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Ms.", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Miss", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Dr", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Dr.", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Sir", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Professor", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Prof", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Lord", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Lady", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Rev", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Rev.", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Reverend", True) = 0) OrElse _
                (String.Compare(strSplitName1(0), "Judge", True) = 0) OrElse _
                False _
                ) Then

                ' A title was found, so the second and last words should be first and last name respectively
                If (strSplitName1.Length > 2) Then
                    strFirstName = strSplitName1(1)
                    strLastName = strSplitName1(strSplitName1.Length - 1)
                Else
                    ' Only a title and one other word was found, so treat the other word as a last name
                    strLastName = strSplitName1(1)
                End If
            ElseIf (strSplitName1(0).Length = 1) Then
                ' The first word is likely an initial, so use the first non-length-of-1 word as the last name
                strFirstName = strSplitName1(0)
                For Each strWord As String In strSplitName1
                    If (strWord.Length > 1) Then
                        strLastName = strWord
                    End If
                Next
            ElseIf (strSplitName1(0).Contains(",")) Then
                ' Check the first word for a comma, if it contains one, it's likely to be 'Last, First' format
                strFirstName = strSplitName1(0).Replace(",", "").Trim()
                strLastName = strSplitName1(1)
            Else
                ' It's most likely to be a "First (Middle(s)) Last" format, so simply use the first and last words
                strFirstName = strSplitName1(0)
                strLastName = strSplitName1(strSplitName1.Length - 1)
            End If
        Catch ex As Exception
            'EventLogger.LogException(ex)
        End Try
    End Sub

Sub CascadingActionEntry()
    CascadingAction "Stamm-Produkte", "Art-Nr", "1014"
End Sub


Sub CascadingAction(tabellenName As String, field As String, value As String)

' für alle referenzierenden datensätze (objekte) rekursiv CascadingBackup
' durchführen
Dim rel As Relation
Dim rs As Recordset
Dim sqlQuery As String

'+------Parent------------+                   +----Child-------------------------+
'| Table , Fields(0).Name | ----Relation------|ForeignTable,Fields(0).ForeignName|
'+------------------------+                   +----------------------------------+

'durch alle Relationen loopen (etwas umständlich)
For Each rel In CurrentDb.Relations
    'falls Relation mit dieser Tabelle
    If (rel.table = tabellenName) Then
        ' Alle kind objekte des gegenwärtigen Datensatzes (Objekt) über diese Relation (Kante) suchen
        'sqlQuery = "SELECT * FROM " & rel.ForeignTable & " WHERE " & rel.Fields(0).ForeignName & " = '" & value & "'"
        sqlQuery = getSelectString(rel.ForeignTable, rel.Fields(0).ForeignName, value)
        Set rs = CurrentDb.OpenRecordset(sqlQuery)
        Do While (Not rs.EOF)
            ' Für alle referenzierenden Objekte Aktion durchführen
            CascadingAction rel.ForeignTable, rel.Fields(0).ForeignName, rs(rel.Fields(0).Name)
            rs.MoveNext
        Loop
   End If
Next
'jetzt die eigentliche Aktion durchführen
'DELETE FROM tabellenName WHERE field = value
'MsgBox (tabellenName & " : " & value)
doBackup tabellenName, field, value
End Sub


Private Function getSelectString(table As String, field As String, value As String)
Dim sqlQuery As String
'falls der FK vom DatenType Text ist
If (CurrentDb.TableDefs(table).Fields(field).Type = dbText) Then
 sqlQuery = "SELECT * FROM [" & table & "] WHERE [" & field & "] = '" & value & "'"

Else
 sqlQuery = "SELECT * FROM [" & table & "] WHERE [" & field & "] = " & value
End If

 getSelectString = sqlQuery
End Function



Sub doBackup(tabellenName As String, field As String, value As String)

'falls Backup Tabelle nicht existiert
If (Not tableExists(tabellenName & "_archiv")) Then
    'kopie erstellen
    DoCmd.CopyObject , tabellenName & "_archiv", acTable, tabellenName
    CurrentDb.Execute ("DELETE FROM [" & tabellenName & "_archiv]")
End If

Dim sqlInsert As String
Dim sqlDelete As String
Dim sqlFields1 As String
Dim sqlFields2 As String

sqlFields1 = ""
sqlFields2 = ""
Dim i As Integer
Debug.Print (CurrentDb.TableDefs(tabellenName).Fields(1).Name)

For i = 0 To CurrentDb.TableDefs(tabellenName).Fields.Count - 2
'For Each f In CurrentDb.TableDefs(tabellenName).Fields
    sqlFields1 = sqlFields1 & " [" & CurrentDb.TableDefs(tabellenName).Fields(i).Name & "], "
    sqlFields2 = sqlFields2 & "[" & tabellenName & "].[" & CurrentDb.TableDefs(tabellenName).Fields(i).Name & "], "
Next i
sqlFields1 = sqlFields1 & "[" & CurrentDb.TableDefs(tabellenName).Fields(CurrentDb.TableDefs(tabellenName).Fields.Count - 1).Name & "]"
sqlFields2 = sqlFields2 & "[" & tabellenName & "].[" & CurrentDb.TableDefs(tabellenName).Fields(CurrentDb.TableDefs(tabellenName).Fields.Count - 1).Name & "]"

'falls das Feld vom DatenType Text ist
If (CurrentDb.TableDefs(tabellenName).Fields(field).Type = dbText) Then
sqlInsert = "INSERT  INTO [" & tabellenName & "_archiv] (" & sqlFields1 & ") SELECT " & sqlFields2 & " FROM [" & tabellenName & "] WHERE [" & tabellenName & "].[" & field & "]='" & value & "'"
sqlDelete = "DELETE FROM [" & tabellenName & "] WHERE [" & tabellenName & "].[" & field & "] ='" & value & "'"

Else
sqlInsert = "INSERT  INTO [" & tabellenName & "_archiv] (" & sqlFields1 & ") SELECT " & sqlFields2 & " FROM [" & tabellenName & "] WHERE [" & tabellenName & "].[" & field & "]=" & value
sqlDelete = "DELETE FROM [" & tabellenName & "] WHERE [" & tabellenName & "].[" & field & "] =" & value

End If

Debug.Print sqlDelete


CurrentDb.Execute (sqlInsert)
CurrentDb.Execute (sqlDelete)
'falls der FK vom DatenType Text ist


End Sub


Private Function tableExists(e As String) As Boolean
Dim i
Dim contains As Boolean
contains = False
For Each i In CurrentDb.TableDefs
    If i.Name = e Then
        contains = True
    End If
Next
tableExists = contains
End Function

' under Tools-References add "Microsoft Visual Basic for Applications Extensibility 5.3" as a reference
Sub ExportAllVBA()

Dim VBComp As VBIDE.VBComponent
Dim Sfx As String
For Each VBComp In ActiveWorkbook.VBProject.VBComponents
    Select Case VBComp.Type
        Case vbext_ct_ClassModule, vbext_ct_Document
           Sfx = ".cls"
        Case vbext_ct_MSForm
           Sfx = ".frm"
        Case vbext_ct_StdModule
           Sfx = ".bas"
        Case Else
           Sfx = ""
    End Select
    If Sfx <> "" Then
       VBComp.Export _
          fileName:=ActiveWorkbook.path & "\" & VBComp.name & Sfx
    End If
Next VBComp
End Sub

Public Function FileExists(sFilePath As String) As Boolean
 
    If Trim(sFilePath) = "" Then Exit Function
    If Right(sFilePath, 1) = "\" Then Exit Function
'// ------------------------------------------------------------------------
'// Fehlerhandling einschalten, um VB-Meldung abzufangen
'// ------------------------------------------------------------------------
    On Error Resume Next
    FileExists = Dir(sFilePath) <> ""
    FileExists = FileExists And Err.Number = 0
'// ------------------------------------------------------------------------
'// Fehlerhandling wieder auschalten
'// ------------------------------------------------------------------------
    On Error GoTo 0
 
End Function

set app = createobject("Excel.Application")
app.Visible = true
set oClientBook=app.Workbooks.Open("Datei.xls")
app.Run "PB_SmokeTest.testMengen","20" & "", optionenString & ""
oClientBook.Worksheets("Deckblatt").range("D28").value = "Lief" & i & " " & teststring
oClientBook.save()
oClientBook.close(true

Set CN = CreateObject("ADODB.Connection")
 	CN.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data source=Build\Ftkomponenten.mdb"
 	CN.execute("Delete * from Properties")
 	CN.execute("Insert into Properties VALUES ('" & text  & "','1.0." & revision & "')")
 	CN.Close

Sub createAutoIncrField()

    Dim Fld As DAO.Field

    Set Fld = CurrentDb.TableDefs("deineTabelle"). _
                   CreateField("deinFeldname", dbLong)
    Fld.Attributes = dbAutoIncrField
    CurrentDb.TableDefs("deineTabelle").Fields.Append Fld

End Sub

Public Function Kalenderwoche(Datum As Date)
 
    Kalenderwoche = Format(Datum, "ww", 2, 2)
    wochentag = weekday([datum])
 
End Function

'' im Bericht:
'' =ErsterWert(DatTeil("ww";[Datum];2;2))

Const ForReading = 1
Const adVarChar = 200
Const MaxCharacters = 255
Const adDouble = 5

Set DataList = CreateObject("ADOR.Recordset")
DataList.Fields.Append "Player", _
  adVarChar, MaxCharacters
DataList.Fields.Append "HomeRuns", adDouble
DataList.Open

Set objFSO = _
  CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile _
  ("C:\Scripts\Test.txt", ForReading)

objFile.SkipLine

Do Until objFile.AtEndOfStream
    strStats = objFile.ReadLine
    arrStats = Split(strStats, vbTab)

    DataList.AddNew
    DataList("Player") = arrStats(0)
    DataList("HomeRuns") = arrStats(1)
    DataList.Update
Loop

objFile.Close

DataList.MoveFirst

Do Until DataList.EOF
    Wscript.Echo _
        DataList.Fields.Item("Player") & _
        vbTab & _
        DataList.Fields.Item("HomeRuns")
    DataList.MoveNext
Loop

=IIf(RowNumber(Nothing) mod 2 = 0, "Beige", Nothing)