uweziegenhagen.de

Option Compare Database
 
Function getDatabaseName(currentPath As String)
    ' Uwe Ziegenhagen, 2017-11-03
    ' Extrahiert den Namen der Datenbank aus dem Pfad,
    ' wertet dazu die Position des letzten "\" aus:
    ' von innen nach außen:
    ' kehre String um
    ' finde den letzten Backslash
    ' nimm den substring bis zum letzten Backslash
    ' reverse diesen Substring wieder
 
getDatabaseName = StrReverse(Left(StrReverse(currentPath), InStr(StrReverse(currentPath), "\") - 1))
 
End Function
 
Function GetFolder() As String
' https://stackoverflow.com/questions/26392482/vba-excel-to-prompt-user-response-to-select-folder-and-return-the-path-as-string
' based on https://www.ozgrid.com/forum/forum/help-forums/excel-general/126180-getfolder-function?t=182343
 
' requires references to Microsoft Office xx.0 Object library
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        '.InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
Sub verlinkeTabellenNeu()
' Uwe Ziegenhagen, 2017-11-03
' Ruft vom User einen Pfad ab und verlinkt alle Tabellen mit diesem Pfad neu
' based on code from https://stackoverflow.com/questions/4928134/changing-linked-table-location-programatically
 
ordnerNeu = GetFolder()
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Set dbs = CurrentDb()
 
    With dbs
        For Each tdf In .TableDefs
        'Is the table a linked table?
            If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then
                With tdf
                    oldPath = .Properties("Connect").Value
                    .Connect = ";DATABASE=" & ordnerNeu & "\" & getDatabaseName(.Properties("Connect").Value)
                    .RefreshLink
                    Debug.Print oldPath & "@@@" & .Properties("Connect").Value
                End With
            End If
        Next tdf
    End With
 
End Sub

Sub LinkedTableConnection()
' http://p2p.wrox.com/access-vba/37117-finding-linked-tables.html
   Dim dbs As DAO.Database
   Dim tdf As DAO.TableDef
 
   Set dbs = CurrentDb()
 
    With dbs
        For Each tdf In .TableDefs
        'Is the table a linked table?
            If tdf.Attributes And dbAttachedODBC Or tdf.Attributes And dbAttachedTable Then
                With tdf
                    ' Connect property contains path of link
                    ' Debug.Print "Connect Property of " & .Name & " is: " &  .Properties("Connect").Value
                    Debug.Print "kompletter Pfad: " & tdf.Connect
                    ' Debug.Print "Name der Datenbank: " & getDatabaseName(.Properties("Connect").Value)
                End With
            End If
        Next tdf
    End With
End Sub

import tkinter as tk
from tkinter import filedialog
 
# Make a top-level instance and hide since it is ugly and big.
root = tk.Tk()
root.withdraw()
 
# Make it almost invisible - no decorations, 0 size, top left corner.
root.overrideredirect(True)
root.geometry('0x0+0+0')
 
# Show window again and lift it to top so it can get focus,
# otherwise dialogs will end up behind the terminal.
root.deiconify()
root.lift()
root.focus_force()
 
filenames = filedialog.askopenfilenames(parent=root) # Or some other dialog
 
# Get rid of the top-level instance once to make it actually invisible.
root.destroy()

[String]$Ziel = "somelocalfile.txt"
 
Write-Host "Loesche die alte Datei"
Remove-Item -Path $Ziel
 
$FileExists = Test-Path $Ziel
If ($FileExists -eq $True) {
    Write-Host "Fehler: Datei noch vorhanden!"}
Else {
    Write-Host "OK: Alte Datei geloescht!"
}
 
Write-Host "Mounte Sharepoint als virtuelles Laufwerk..."
[String]$WebDAVShare = '\\some\unc\path\'
New-PSDrive -Name S -PSProvider FileSystem -Root $WebDAVShare
 
Write-Host "Kopiere ..."
Copy-Item "S:/someremotefile.xlsx" $Ziel
 
$FileExists = Test-Path $Ziel
 
If ($FileExists -eq $True) {
    Write-Host "OK: Neue Datei vorhanden!"}
Else {
    Write-Host "Fehler: Datei wurde nicht heruntergeladen!"
}
 
Write-Host "Press any key to continue ..."
$x = $host.UI.RawUI.ReadKey("NoEcho,IncludeKeyDown")

Sub clearthisSheet()
 With Sheets("Tabelle1")
      .Cells.Clear
End With

=WERT(WECHSELN(B4;LINKS(RECHTS(B4;6);2)&RECHTS(B4;4);"")&"."&LINKS(RECHTS(B4;6);2)&"."&RECHTS(B4;4))

Option Compare Database
 
' based on http://allenbrowne.com/func-06.html
' modified for the export of the information by Uwe Ziegenhagen
 
Sub exportTableInformation()
On Error GoTo TableInfoErr
   ' Purpose:   Display the field names, types, sizes and descriptions for a table.
   ' Argument:  Name of a table in the current database.
   Dim db As DAO.Database
   Dim tdf As DAO.TableDef
   Dim fld As DAO.Field
 
   Set db = CurrentDb()
 
    ' ask user for path of the output file
    ' https://support.office.com/de-de/article/InputBox-Funktion-Eingabefeld-17821927-28b7-4350-b7f1-4786575314d9
    Dim Message, Title, Default, MyValue
    Message = "File will be overwritten..."   ' Set prompt.
    Title = "Enter file of output file"     ' Set title.
    Default = "c:\somefile.csv"               ' Set default.
    ' Display message, title, and default value.
    outputfilePath = InputBox(Message, Title, Default)
 
    n = FreeFile()
    Open outputfilePath For Output As #n
    Print #n, "SOURCE;TABLE;FIELDNAME;FIELDTYPE;SIZE;DESCRIPTION"
   Set db = CurrentDb()
 
    Debug.Print
 
    For Each tdf In db.TableDefs
        ' ignore system and temporary tables
        If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*") Then
            For Each fld In tdf.Fields
                Debug.Print db.Name & ";" & tdf.Name & ";" & fld.Name & ";" & FieldTypeName(fld) & ";" & fld.Size & ";" & GetDescrip(fld)
                Print #n, db.Name & ";" & tdf.Name & ";" & fld.Name & ";" & FieldTypeName(fld) & ";" & fld.Size & ";" & GetDescrip(fld)
            Next
        End If
    Next
 
    Set tdf = Nothing
    Set db = Nothing
 
    Close #n
 
TableInfoExit:
   Set db = Nothing
   Exit Sub
 
TableInfoErr:
   Select Case Err
   Case 3265&  'Table name invalid
      MsgBox strTableName & " table doesn't exist"
   Case Else
      Debug.Print "TableInfo() Error " & Err & ": " & Error
   End Select
   Resume TableInfoExit
End Sub
 
Function GetDescrip(obj As Object) As String
' http://allenbrowne.com/func-06.html
    On Error Resume Next
 
    GetDescrip = obj.Properties("Description")
 
End Function
 
 
 
Function FieldTypeName(fld As DAO.Field) As String
    'http://allenbrowne.com/func-06.html
    'Purpose: Converts the numeric results of DAO Field.Type to text.
    Dim strReturn As String    'Name to return
 
    Select Case CLng(fld.Type) 'fld.Type is Integer, but constants are Long.
        Case dbBoolean: strReturn = "Yes/No"            ' 1
        Case dbByte: strReturn = "Byte"                 ' 2
        Case dbInteger: strReturn = "Integer"           ' 3
        Case dbLong                                     ' 4
            If (fld.Attributes And dbAutoIncrField) = 0& Then
                strReturn = "Long Integer"
            Else
                strReturn = "AutoNumber"
            End If
        Case dbCurrency: strReturn = "Currency"         ' 5
        Case dbSingle: strReturn = "Single"             ' 6
        Case dbDouble: strReturn = "Double"             ' 7
        Case dbDate: strReturn = "Date/Time"            ' 8
        Case dbBinary: strReturn = "Binary"             ' 9 (no interface)
        Case dbText                                     '10
            If (fld.Attributes And dbFixedField) = 0& Then
                strReturn = "Text"
            Else
                strReturn = "Text (fixed width)"        '(no interface)
            End If
        Case dbLongBinary: strReturn = "OLE Object"     '11
        Case dbMemo                                     '12
            If (fld.Attributes And dbHyperlinkField) = 0& Then
                strReturn = "Memo"
            Else
                strReturn = "Hyperlink"
            End If
        Case dbGUID: strReturn = "GUID"                 '15
 
        'Attached tables only: cannot create these in JET.
        Case dbBigInt: strReturn = "Big Integer"        '16
        Case dbVarBinary: strReturn = "VarBinary"       '17
        Case dbChar: strReturn = "Char"                 '18
        Case dbNumeric: strReturn = "Numeric"           '19
        Case dbDecimal: strReturn = "Decimal"           '20
        Case dbFloat: strReturn = "Float"               '21
        Case dbTime: strReturn = "Time"                 '22
        Case dbTimeStamp: strReturn = "Time Stamp"      '23
 
        'Constants for complex types don't work prior to Access 2007 and later.
        Case 101&: strReturn = "Attachment"         'dbAttachment
        Case 102&: strReturn = "Complex Byte"       'dbComplexByte
        Case 103&: strReturn = "Complex Integer"    'dbComplexInteger
        Case 104&: strReturn = "Complex Long"       'dbComplexLong
        Case 105&: strReturn = "Complex Single"     'dbComplexSingle
        Case 106&: strReturn = "Complex Double"     'dbComplexDouble
        Case 107&: strReturn = "Complex GUID"       'dbComplexGUID
        Case 108&: strReturn = "Complex Decimal"    'dbComplexDecimal
        Case 109&: strReturn = "Complex Text"       'dbComplexText
        Case Else: strReturn = "Field type " & fld.Type & " unknown"
    End Select
 
 
    FieldTypeName = strReturn
 
End Function

Option Explicit
 
Function Contains(needle As String, haystack As String, separator As String) As Boolean
 
Dim rv As Boolean, lb As Long, ub As Long, i As Long, field() As String
 
field = Split(haystack, separator)
 
    lb = LBound(field)
    ub = UBound(field)
    For i = lb To ub
        If field(i) = needle Then
            rv = True
            Exit For
        End If
    Next i
    Contains = rv
End Function

Function InRange(needle As Variant, haystack As Range) As Boolean
Dim rv As Boolean, cell As Range
 
    For Each cell In haystack
        If cell = needle Then
            rv = True
            Exit For
        End If
    Next cell
    InRange = rv
 
End Function

Function GetUsername()
     Set objAD = CreateObject("ADSystemInfo")
     Set objUser = GetObject("LDAP://" & objAD.UserName)
     GetUsername = objUser.DisplayName
End Function

Function getOrder()
    auswahl = Range("Auswahl")
    bestellstring = "* " & GetUsername() & ": "
    Order = 0
 
    For i = 1 To UBound(auswahl)
        If (auswahl(i, 3)) > 0 Then
            If Order > 0 Then
                bestellstring = bestellstring & ", "
            End If
            bestellstring = bestellstring & auswahl(i, 3) & " x " & auswahl(i, 1)
            Order = 1
        End If
    Next i
 
    Debug.Print bestellstring
    getOrder = bestellstring
 
End Function

Sub Mail_small_Text_Outlook()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    strbody = "Hier ist meine Bestellung:" & vbNewLine & vbNewLine & vbNewLine
 
 
    body = getOrder()
 
    If Len(Range("kommentar") > 0) Then
        body = body & vbNewLine & Range("kommentar")
    End If
 
 
 
    On Error Resume Next
    With OutMail
        .To = Range("receiver")
        .CC = ""
        .BCC = ""
        .Subject = Range("subject")
        .body = strbody & body
        .Display
    End With
    On Error GoTo 0
 
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

# -*- coding: utf-8 -*-
 
import logging # Logging
import time # Time
import sys
 
 
# Logger in Datei und auf die Konsole
logger = logging.getLogger("Logfile")
logger.propagate = False
logger.setLevel(logging.DEBUG)
 
 
fileHandler = logging.FileHandler(logger.name + ".log", mode='w')
fileHandler_format = logging.Formatter('%(asctime)s_%(levelname)s: %(message)s', datefmt='%H:%M:%S')
fileHandler.setFormatter(fileHandler_format)
 
consoleHandler = logging.StreamHandler(sys.stdout)
 
consoleHandler.setFormatter(fileHandler_format)
 
# Remove existing loggers
if logger.handlers:
    for handler in logger.handlers:
        logger.removeHandler(handler)
 
logger.addHandler(fileHandler)
logger.addHandler(consoleHandler)
 
 
logger.info('Hello')
logger.warning('World')
logger.error('Foobar')
 
logging.shutdown()