Neue Seite 1



' **************************************************************
'  Modul:  Form1  Typ = Userform
' **************************************************************

Option Explicit

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub Form_Activate()
    Beep
    SetWindowPos Me.hwnd, HWND_TOPMOST, 0&, 0&, 0&, 0&, _
        SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE Or SWP_SHOWWINDOW
    DoEvents
End Sub



' **************************************************************
'  Modul:   basBrowse  Typ = Allgemeines Modul
' **************************************************************

Option Explicit

Private Function fncGetFolder( _
    Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
    Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
    Optional ByVal sPath As String = "C:\") As String
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
    sBrowseInitDir = sPath
    With xl
        .hwnd = FindWindow("XLMAIN", vbNullString)
        .Root = 0
        .Title = lstrcat(sMsg, "")
        .Flags = lFlag
        .FName = FuncCallback(AddressOf BrowseCallback)
    End With
    IDList = SHBrowseForFolder(xl)
    If IDList <> 0 Then
        FolderName = Space(256)
        RVal = SHGetPathFromIDList(IDList, FolderName)
        CoTaskMemFree (IDList)
        FolderName = Trim$(FolderName)
        FolderName = Left$(FolderName, Len(FolderName) - 1)
    End If
    fncGetFolder = FolderName
End Function

Private Function BrowseCallback( _
    ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    If uMsg = BFFM_INITIALIZED Then
        Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal sBrowseInitDir)
        Call CenterDialog(hwnd)
    End If
    BrowseCallback = 0
End Function

Private Function FuncCallback(ByVal nParam As Long) As Long
    FuncCallback = nParam
End Function

Private Sub CenterDialog(hwnd As Long)
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
    Dim DlgWidth As Integer, DlgHeight As Integer
    GetWindowRect hwnd, WinRect
    DlgWidth = WinRect.Right - WinRect.Left
    DlgHeight = WinRect.Bottom - WinRect.Top
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub

Public Sub prcBrowse(sFolder As String)
    Const sPreselect As String = "C:\"
    MakeSureDirectoryPathExists sPreselect
    sFolder = Trim$(fncGetFolder(, BIF_RETURNONLYFSDIRS, sPreselect))
End Sub



' **************************************************************
'  Modul:   basStart  Typ = Allgemeines Modul
' **************************************************************

Option Explicit

Private Sub Main()
    Dim sFolder As String
    Call prcBrowse(sFolder)
    If sFolder <> "" Then
        Call prcGetFilesInFolder(sFolder & "\", "*.jpg")
        Form1.Show vbModal
    End If
    End
End Sub



' **************************************************************
'  Modul:   basDeclaration  Typ = Allgemeines Modul
' **************************************************************

Option Explicit

Public Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long
Public Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
Public Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long
Public Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" ( _
    ByRef lpbi As InfoT) As Long
Public Declare Function CoTaskMemFree Lib "ole32.dll" ( _
    ByVal hMem As Long) As Long
Public Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long
Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    ByRef wParam As Any, _
    ByRef lParam As Any) As Long
Public Declare Function GetFileTime Lib "kernel32.dll" ( _
    ByVal hFile As Long, _
    ByRef lpCreationTime As FILETIME, _
    ByRef lpLastAccessTime As FILETIME, _
    ByRef lpLastWriteTime As FILETIME) As Long
Public Declare Function SetFileTime Lib "kernel32.dll" ( _
    ByVal hFile As Long, _
    ByRef lpCreationTime As FILETIME, _
    ByRef lpLastAccessTime As FILETIME, _
    ByRef lpLastWriteTime As FILETIME) As Long
Public Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByRef lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long
Public Declare Function SystemTimeToFileTime Lib "kernel32.dll" ( _
    ByRef lpSystemTime As SYSTEMTIME, _
    ByRef lpFileTime As FILETIME) As Long
Public Declare Function LocalFileTimeToFileTime Lib "kernel32.dll" ( _
    ByRef lpLocalFileTime As FILETIME, _
    ByRef lpFileTime As FILETIME) As Long
Public Declare Function CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As Long) As Long
Public Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindClose Lib "kernel32.dll" ( _
    ByVal hFindFile As Long) As Long
Public Declare Function SetWindowPos Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal wFlags As Long) As Long

Public Const HWND_TOPMOST = -1
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40

Public Const SM_CXFULLSCREEN = &H10
Public Const SM_CYFULLSCREEN = &H11

Public Const GENERIC_WRITE = &H40000000
Public Const OPEN_EXISTING = 3&
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2

Public Const BFFM_SETSELECTION = &H466
Public Const BFFM_INITIALIZED = &H1

Public Const MAX_PATH = 260&
Public Const INVALID_HANDLE_VALUE = -1&

Public Enum FILE_ATTRIBUTE
    FILE_ATTRIBUTE_READONLY = &H1
    FILE_ATTRIBUTE_HIDDEN = &H2
    FILE_ATTRIBUTE_SYSTEM = &H4
    FILE_ATTRIBUTE_DIRECTORY = &H10
    FILE_ATTRIBUTE_ARCHIVE = &H20
    FILE_ATTRIBUTE_NORMAL = &H80
    FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum

Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Public Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Public Type InfoT
    hwnd As Long
    Root As Long
    DisplayName As Long
    Title As Long
    Flags As Long
    FName As Long
    lParam As Long
    Image As Long
End Type

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Enum BIF_Flag
    BIF_RETURNONLYFSDIRS = &H1
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_RETURNFSANCESTORS = &H8
    BIF_EDITBOX = &H10
    BIF_VALIDATE = &H20
    BIF_NEWDIALOGSTYLE = &H40
    BIF_BROWSEINCLUDEURLS = &H80
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
    BIF_BROWSEINCLUDEFILES = &H4000
    BIF_SHAREABLE = &H8000
End Enum

Public sBrowseInitDir As String



' **************************************************************
'  Modul:   ChangeFiledate  Typ = Allgemeines Modul
' **************************************************************

Option Explicit

Public Sub prcChangeFiletime(strFilename As String, strFoldername As String)
    Dim udtFileTime1 As FILETIME, udtFileTime2 As FILETIME
    Dim udtFileTime3 As FILETIME, udtFileTimeNew As FILETIME
    Dim udtLocalTime As FILETIME, udtSystemTime As SYSTEMTIME
    Dim dtmNewFiletime As Date, lngHandle As Long
    Dim dtmDate As Date, dmtTime As Date
    Dim strTempDate As String, strTempTime As String
    On Error GoTo err_exit
    strTempDate = Mid$(strFilename, InStr(strFilename, "'") + 1)
    strTempDate = Left$(strTempDate, InStr(strTempDate, " ") - 1)
    dtmDate = CDate(Right$(strTempDate, 2) & "." & _
        Mid$(strTempDate, 5, 2) & "." & Left$(strTempDate, 4))
    strTempTime = Mid$(strFilename, InStr(strFilename, " ") + 1)
    strTempTime = Left$(strTempTime, 8)
    strTempTime = Replace(strTempTime, ".", ":")
    dmtTime = CDate(strTempTime)
    dtmNewFiletime = dtmDate + dmtTime
    udtSystemTime.wYear = Year(dtmNewFiletime)
    udtSystemTime.wMonth = Month(dtmNewFiletime)
    udtSystemTime.wDay = Day(dtmNewFiletime)
    udtSystemTime.wDayOfWeek = Weekday(dtmNewFiletime)
    udtSystemTime.wHour = Hour(dtmNewFiletime)
    udtSystemTime.wMinute = Minute(dtmNewFiletime)
    udtSystemTime.wSecond = Second(dtmNewFiletime)
    udtSystemTime.wMilliseconds = 0
    SystemTimeToFileTime udtSystemTime, udtLocalTime
    LocalFileTimeToFileTime udtLocalTime, udtFileTimeNew
    lngHandle = CreateFile(strFoldername & strFilename _
        , GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, _
        ByVal 0&, OPEN_EXISTING, 0&, 0&)
    SetFileTime lngHandle, udtFileTimeNew, udtFileTimeNew, udtFileTimeNew
    CloseHandle lngHandle
err_exit:
End Sub



' **************************************************************
'  Modul:   GetFile  Typ = Allgemeines Modul
' **************************************************************

Option Explicit

Public Sub prcGetFilesInFolder(ByRef strFolderPath As String, ByRef strSearch As String)
    Dim udtWFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    lngSearch = FindFirstFile(strFolderPath & strSearch, udtWFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
                FILE_ATTRIBUTE_DIRECTORY Then
                Call prcChangeFiletime(Left$(udtWFD.cFileName, _
                    InStr(udtWFD.cFileName, Chr(0)) - 1), strFolderPath)
            End If
        Loop While FindNextFile(lngSearch, udtWFD)
        FindClose lngSearch
    End If
End Sub

Code eingefügt mit: VisualBasic Code Jeanie