Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SHFileOperationW Lib "shell32" ( _
lpFileOp As SHFILEOPSTRUCT _
) As Long
Private Type SHFILEOPSTRUCT
hWnd As LongPtr
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As LongPtr
lpszProgressTitle As String
End Type
#End If
Private Const ERROR_SUCCESS As Long = 0
Private Const FO_MOVE As Long = &H1
Private Const FO_COPY As Long = &H2
Private Const FO_DELETE As Long = &H3
Private Const FO_RENAME As Long = &H4
Private Const FOF_NOCONFIRMATION As Long = &H10
Private Const FOF_ALLOWUNDO As Long = &H40
Private Const FOF_NOERRORUI As Long = &H400
Private Const DE_SAMEFILE As Long = &H71
Private Const DE_DIFFDIR As Long = &H73
Private Const DE_ROOTDIR As Long = &H74
Private Const DE_OPCANCELLED As Long = &H75
Private Const DE_DESTSUBTREE As Long = &H76
Private Const DE_ACCESSDENIEDSRC As Long = &H78
Private Const DE_PATHTOODEEP As Long = &H79
Private Const DE_MANYDEST As Long = &H7A
Private Const DE_INVALIDFILES As Long = &H7C
Private Const DE_DESTSAMETREE As Long = &H7D
Private Const DE_FLDDESTISFILE As Long = &H7E
Private Const DE_FILEDESTISFLD As Long = &H80
Private Const DE_FILENAMETOOLONG As Long = &H81
Private Const DE_ERROR_MAX As Long = &HB7
Private Const DE_UNKNOWN As Long = &H402
Private Const ERRORONDEST As Long = &H10000
Private Const DE_ISROOTDIR As Long = DE_ROOTDIR Or ERRORONDEST
Public Sub Demo_Move()
Dim strPath As String
Dim strPathNew As String
With Worksheets("Tabelle1")
strPath = StrConv("D:\" & .Range("B3") & "\", vbUnicode)
strPathNew = StrConv("D:\" & .Range("B3") & "_2018\", vbUnicode)
End With
If Not SHFileFolderRenameW(strPath, strPathNew) Then
Call MsgBox("Umbenennen fehlgeschalgen.", vbCritical)
End If
End Sub
Public Function SHFileFolderRenameW(ByVal Path As String, ByVal PathNew As String) As Boolean
Const PROC_NAME As String = "SHFileFolderRenameW"
Dim retVal As Long
Dim udtSHFO As SHFILEOPSTRUCT
With udtSHFO
.wFunc = FO_RENAME
.fFlags = FOF_NOERRORUI Or FOF_NOCONFIRMATION
.pFrom = Path & String$(2, vbNullChar)
.pTo = PathNew & String$(2, vbNullChar)
End With
retVal = SHFileOperationW(udtSHFO)
Debug.Print Format$(Time, "\#hh:mm:ss\#"); Spc(1); PROC_NAME; Spc(1);
Select Case retVal
Case Else: Debug.Print "returned 0x" & Hex$(retVal)
End Select
SHFileFolderRenameW = (retVal = ERROR_SUCCESS)
End Function