Option Explicit
Option Private Module
' ---------------------------------------------------------
' Funktion ShortPath
' Eingestellt von: Andre Schau
' Datum: 2011-09-10
' Kommentar:
' Parameter: String strPath, Länge lWidth
' Rückgabe: gekuerzter String
' weitere benoetigte Programme und Funktionen
' API-Funktion: PathCompactPath, GetDC
' Aufruf:
' Sub call_ShortPath()
' MsgBox shortpath("D:\Test\Ordner1\Ordner2\Ordner3\O2", 150)
' End Sub
 
' Deklarierung der API-Funktion
Private Declare Function PathCompactPath Lib "shlwapi" _
  Alias "PathCompactPathA" ( _
  ByVal hdc As Long, _
  ByVal lpszPath As String, _
  ByVal dx As Long) As Long

' API zur Ermittlung des hdc
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

'Aufruf
Sub call_ShortPath()
  MsgBox shortpath("D:\Test\Ordner1\Ordner2\Ordner3\O2", 150)
End Sub

Private Function shortpath(ByVal strPath As String, lWidth As Long) As String
'Variablendeklaration
'Long
Dim hdc As Long
  ' API-Funktion zur Ermittlung von hdc
  ' API-Parameter handle der Anwendung / des Objekts
  hdc = GetDC(Application.hwnd)
  ' API-Funktion zum autom. Kuerzen des Pfades aufrufen
  ' API-Parameter hdc, Pfad, Laenge
  PathCompactPath hdc, strPath, lWidth
  ' Rueckgabewert uebernehmen
  shortpath = strPath
End Function