Attribute VB_Name = "Module2"
'***************************************************
Option Explicit

Public Declare Function InitCommonControls Lib "comctl32.dll" () As Long 'XP theme

Public Const CSIDL_DRIVES = &H11

Public Const BIF_EDITBOX = &H10
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_CREATEFOLDER = &H40

Public Const BFFM_ENABLEOK = &H465
Public Const BFFM_SETSELECTION = &H466
Public Const BFFM_SETSTATUSTEXT = &H464
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SELCHANGED = 2
Public Const BFFM_VALIDATEFAILED = 3

Public m_strCurrentPath As String

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

Public Type BROWSEINFO
    hwndOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Type FILETIME
    dwLowDate  As Long
    dwHighDate As Long
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
    wMillisecs As Integer
End Type
  
Public Declare Function CreateFile Lib "kernel32" Alias _
   "CreateFileA" (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   ByVal lpSecurityAttributes As Long, _
   ByVal dwCreationDisposition As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal hTemplateFile As Long) _
   As Long

Public Declare Function LocalFileTimeToFileTime Lib _
     "kernel32" (lpLocalFileTime As FILETIME, _
      lpFileTime As FILETIME) As Long

Public Declare Function SetFileTime Lib "kernel32" _
   (ByVal hFile As Long, ByVal MullP As Long, _
    ByVal NullP2 As Long, lpLastWriteTime _
    As FILETIME) As Long

Public Declare Function SystemTimeToFileTime Lib _
    "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime _
    As FILETIME) As Long
    
Public Declare Function CloseHandle Lib "kernel32" _
   (ByVal hObject As Long) As Long

Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
    (ByVal hwndOwner As Long, _
    ByVal nFolder As Long, ppidl As Long) As Long

Public Declare Function SendMessage Lib "user32.dll" Alias _
    "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, _
    wParam As Any, lParam As Any) As Long

Public Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" _
    (lpbi As BROWSEINFO) As Long

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
    "SHGetPathFromIDListA" _
    (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
'***************************************************

Public Declare Function GetDiskFreeSpaceEx Lib "kernel32" _
    Alias "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _
    lpFreeBytesAvailableToCaller As Currency, _
    lpTotalNumberOfBytes As Currency, _
    lpTotalNumberOfFreeBytes As Currency) As Long
    
' File Copy

Public Type SHFILEOPSTRUCT
     hwnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Integer
     fAnyOperationsAborted As Boolean
     hNameMappings As Long
     lpszProgressTitle As String
End Type

Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Public Const FO_COPY = &H2
Public Const FO_DELETE = &H3
Public Const FO_MOVE = &H1
Public Const FO_RENAME = &H4
Public Const FOF_ALLOWUNDO = &H40
Public Const FOF_CONFIRMMOUSE = &H2
Public Const FOF_FILESONLY = &H80                  '  en *.*, sólo archivos
Public Const FOF_MULTIDESTFILES = &H1
Public Const FOF_NOCONFIRMATION = &H10             '  No pedir confirmación al usuario.
Public Const FOF_NOCONFIRMMKDIR = &H200            '  no confirmar al crear directorios necesarios
Public Const FOF_RENAMEONCOLLISION = &H8
Public Const FOF_SILENT = &H4                      '  no crear avance/informe
Public Const FOF_WANTMAPPINGHANDLE = &H20          '  Llenar SHFILEOPSTRUCT.hNameMappings
Public Const FOF_SIMPLEPROGRESS = &H100            '  significa no mostrar nombres de archivos

'***************************************************

Public Declare Function GetTickCount Lib "kernel32" () As Long

'***************************************************

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'***************************************************
Public Const WM_CLOSE = &H10

Public Declare Function FindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Public Declare Sub Sleep Lib "kernel32" _
    (ByVal dwMilliseconds As Long)
'************************** open file dialog
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_EXPLORER = &H80000                         '  nueva apariencia de commdlg
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_LONGNAMES = &H200000                       '  exige nombres largos para módulos 3.x
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_NOLONGNAMES = &H40000                      '  exige nombre no largos para módulos 4.x
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_READONLY = &H1
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0
Public Const OFN_SHOWHELP = &H10
Public Const OFS_MAXPATHNAME = 128

'**************************************************

Public Function BrowseForFolder(hwnd As Long, strTitle As String) As String
    Dim hBrowseInfo As BROWSEINFO
    Dim dwShellReturn As Long
    Dim dwReturn As Long
    
    With hBrowseInfo
        .hwndOwner = hwnd
        .pszDisplayName = Space(260)
        .lpszTitle = strTitle
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_CREATEFOLDER
        .lpfn = DummyFunc(AddressOf BrowseCallbackProc)
        .lParam = 0
        .iImage = 0
    End With
    
    dwReturn = SHGetSpecialFolderLocation(hwnd, CSIDL_DRIVES, _
        hBrowseInfo.pidlRoot)
    
    dwShellReturn = SHBrowseForFolder(hBrowseInfo)
    
    If dwShellReturn <> 0 Then
       
        hBrowseInfo.pszDisplayName = Left$(hBrowseInfo.pszDisplayName, _
            InStr(hBrowseInfo.pszDisplayName, vbNullChar) - 1)
        
        m_strCurrentPath = Space(260)
        dwReturn = SHGetPathFromIDList(dwShellReturn, m_strCurrentPath)
        
        If dwReturn = 0 Then
            m_strCurrentPath = vbNullString
        Else
            m_strCurrentPath = Left(m_strCurrentPath, _
                InStr(m_strCurrentPath, vbNullChar) - 1)
        End If
        
        Call CoTaskMemFree(dwShellReturn)
    Else
        m_strCurrentPath = ""
    End If
    
    Call CoTaskMemFree(hBrowseInfo.pidlRoot)
    BrowseForFolder = m_strCurrentPath
End Function

Public Function BrowseForFile(ByVal hwnd As Long, strTitle As String, strFilter As String) As String
    Dim ofn As OPENFILENAME
    With ofn
        .lStructSize = Len(ofn)
        .hwndOwner = hwnd
        .hInstance = App.hInstance
        .lpstrFilter = strFilter
        .lpstrFile = Space$(254)
        .nMaxFile = 255
        .lpstrFileTitle = Space$(254)
        .nMaxFileTitle = 255
        .lpstrInitialDir = CurDir
        .lpstrTitle = strTitle
        .flags = OFN_HIDEREADONLY
    End With
        Dim a
        Dim FilePath As String
        a = GetOpenFileName(ofn)

        If (a) Then
                FilePath = Trim$(ofn.lpstrFile)
        Else
                FilePath = ""
        End If
        
        BrowseForFile = FilePath
End Function

Public Function DummyFunc(ByVal lParam As Long) As Long
    DummyFunc = lParam
End Function

Public Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, _
    ByVal lParam As Long, ByVal lpData As Long) As Long

    Select Case uMsg
        Case BFFM_INITIALIZED
            Call SendMessage(hwnd, BFFM_SETSELECTION, _
                ByVal CLng(1), ByVal m_strCurrentPath)
    End Select
    
    BrowseCallbackProc = 0
End Function

Public Function CopyFileWindowsWay(ByVal SourceFile As String, ByVal DestinationFile As String) As Boolean

     Dim lngReturn As Long
     Dim typFileOperation As SHFILEOPSTRUCT

     With typFileOperation
        .hwnd = 0
        .wFunc = FO_COPY
        '.pFrom = SourceFile & vbNullChar & vbNullChar 'source file
        .pFrom = SourceFile & vbNullChar 'source file
        .pTo = DestinationFile & vbNullChar & vbNullChar 'destination file
        .fFlags = FOF_ALLOWUNDO
     End With

     lngReturn = SHFileOperation(typFileOperation)

     If lngReturn <> 0 Then 'Operation failed
          'MsgBox Err.LastDllError, vbCritical Or vbOKOnly
     Else 'Aborted
          If typFileOperation.fAnyOperationsAborted = True Then
               MsgBox "Operation Failed", vbCritical Or vbOKOnly
          End If
     End If
CopyFileWindowsWay = True
End Function

Public Function SendFileToRecycleBin(ByVal FileName As String, Optional Papelera As Boolean = True) As Boolean
    Dim lngReturn As Long
    Dim FileOp As SHFILEOPSTRUCT

    'fills the file operation structure
    With FileOp
        .wFunc = FO_DELETE
        .pFrom = FileName
        If Papelera Then .fFlags = FOF_ALLOWUNDO
        'If Not Confirm Then .fFlags = .fFlags + FOF_NOCONFIRMATION
        'If Silent Then .fFlags = .fFlags + FOF_SILENT
    End With
    lngReturn = SHFileOperation(FileOp)

    If lngReturn <> 0 Then 'Operation failed
          'MsgBox Err.LastDllError, vbCritical Or vbOKOnly
    Else 'Aborted
        If FileOp.fAnyOperationsAborted = True Then
            MsgBox "Operation Failed", vbCritical Or vbOKOnly
        End If
    End If
SendFileToRecycleBin = True
End Function

Public Sub Delay(nSegons As Long)
  Dim TimeOut As Long
    
  'Calcula el temps en segons
  TimeOut = (GetTickCount / 1000) + nSegons
    
  Do
    DoEvents

  Loop Until TimeOut < (GetTickCount / 1000)
End Sub

Public Function TotalSpace(path As String) As Currency
    Dim Status As Long
    Dim TotalBytes, TempTotalBytes As Currency
    Dim FreeBytes, TempFreeBytes As Currency
    Dim BytesAvailableToCaller As Currency
'    Dim TotalSpaceValue, FreeSpaceValue As String
    
    TempTotalBytes = 0
    TempFreeBytes = 0
    TotalBytes = 0
    FreeBytes = 0
    
    Status = GetDiskFreeSpaceEx(path, BytesAvailableToCaller, TotalBytes, FreeBytes)
    
    TotalSpace = TotalBytes
End Function

Public Function FreeSpace(path As String) As Currency
    Dim Status As Long
    Dim TotalBytes, TempTotalBytes As Currency
    Dim FreeBytes, TempFreeBytes As Currency
    Dim BytesAvailableToCaller As Currency
    Dim TotalSpaceValue, FreeSpaceValue As String
    
    TempTotalBytes = 0
    TempFreeBytes = 0
    TotalBytes = 0
    FreeBytes = 0
    
    Status = GetDiskFreeSpaceEx(path, BytesAvailableToCaller, TotalBytes, FreeBytes)
    
    FreeSpace = FreeBytes
End Function

Public Sub CheckForOtherInstances(appCaption As String)
    Dim lhWnd       As Long
    Dim lretval     As Long
    Dim i           As Integer
    '--------------------------------------
    On Error GoTo errCheckForOtherInstances
    'Me.Caption = "xxxxxxxxxxxxx"
    lhWnd = FindWindow(vbNullString, appCaption)
    If lhWnd <> 0 Then
        lretval = SendMessage(lhWnd, WM_CLOSE, 0&, 0&)
        For i = 1 To 3
            Call Sleep(50)
            DoEvents
        Next i
    End If
    'Me.Caption = PREVIEWCAPTION
Exit Sub
errCheckForOtherInstances:
    Resume Next
End Sub

Public Function SetFileDateTime(ByVal FileName As String, _
  ByVal TheDate As String) As Boolean
'************************************************
'PURPOSE:    Set File Date (and optionally time)
'            for a given file)
'PARAMETERS: TheDate -- Date to Set File's Modified Date/Time
'            FileName -- The File Name
'Returns:    True if successful, false otherwise
'************************************************
    If Dir(FileName) = "" Then Exit Function
    If Not IsDate(TheDate) Then Exit Function
    
    Dim lFileHnd As Long
    Dim lRet As Long
    
    Dim typFileTime As FILETIME
    Dim typLocalTime As FILETIME
    Dim typSystemTime As SYSTEMTIME
    
    With typSystemTime
        .wYear = Year(TheDate)
        .wMonth = Month(TheDate)
        .wDay = Day(TheDate)
        .wDayOfWeek = Weekday(TheDate) - 1
        .wHour = Hour(TheDate)
        .wMinute = Minute(TheDate)
        .wSecond = Second(TheDate)
    End With
    
    lRet = SystemTimeToFileTime(typSystemTime, typLocalTime)
    lRet = LocalFileTimeToFileTime(typLocalTime, typFileTime)
    
    lFileHnd = CreateFile(FileName, GENERIC_WRITE, _
        FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, _
        OPEN_EXISTING, 0, 0)
        
    lRet = SetFileTime(lFileHnd, ByVal 0&, ByVal 0&, _
             typFileTime)
    
    CloseHandle lFileHnd
    SetFileDateTime = lRet > 0
End Function


