Attribute VB_Name = "FF"
'Tipos, constantes y funciones para FileExist
Const MAX_PATH = 260
Const INVALID_HANDLE_VALUE = -1

Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400

Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOW = 5
Public Const SW_RESTORE = 9

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (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

Private Type FILETIME
        dwLowDateTime       As Long
        dwHighDateTime      As Long
End Type

Private 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 Enum Parte
    DIRECTORIO = 0
    ARCHIVO = 1
End Enum

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
    (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
    (ByVal hFindFile As Long) As Long

'Las declaraciones
Private Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, lpExitCode As Long) As Long

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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

Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Global Const gintMAX_SIZE% = 255                        'Maximum buffer size

'Valores de retorno de GetDriveType
Public Const DRIVE_REMOVABLE = 2
Public Const DRIVE_FIXED = 3
Public Const DRIVE_REMOTE = 4
'Estos tipos no están en el fichero de las declaraciones del API de 16 bits
Public Const DRIVE_CDROM = 5
Public Const DRIVE_RAMDISK = 6

Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Function comillas(strData) As String
'Función: devuelve un string entre comillas
comillas = Chr(34) & strData & Chr(34)
End Function

Function reempEnvironVar(strC As String, Optional Inicio As Integer = 1) As String
Dim limits(1) As Integer
Dim e As Integer
Dim Exp As String
For i = Inicio To Len(strC)
    If Mid(strC, i, 1) = "%" Then
    limits(e) = i + 1
        If e = 1 Then
        Exp = Mid(strC, limits(0), limits(1) - limits(0) - 1)
        StringInsert strC, Environ(Exp), "%" & Exp & "%"
        reempEnvironVar strC, i + 1
        End If
        e = e + 1
    End If
Next i
reempEnvironVar = strC
End Function

Function getCDROMPath() As String
For i = 68 To 90
    If GetDriveType(Chr(i) & ":\") = DRIVE_CDROM Then
        getCDROMPath = Chr(i) & ":\"
        Exit For
    End If
Next i
End Function

Function getHardDiskPath() As String
For i = 67 To 90
    If GetDriveType(Chr(i) & ":\") = DRIVE_FIXED Then
        getHardDiskPath = Chr(i) & ":\"
        Exit For
    End If
Next i
End Function

Function getVolumeDrive(DrivePath As String) As String
Dim lVSN As Long, n As Long, s1 As String, s2 As String, l As Integer
s1 = Space(255) 'String$(255, Chr$(0))
s2 = Space(255) 'String$(255, Chr$(0))
l = GetVolumeInformation(DrivePath, s1, Len(s1), lVSN, 0, 0, s2, Len(s2))
If Trim(s1) <> "" Then getVolumeDrive = Left(Trim(s1), Len(Trim(s1)) - 1)
End Function

'-----------------------------------------------------------
' FUNCTION: StripTerminator
'
' Returns a string without any zero terminator.  Typically,
' this was a string returned by a Windows API call.
'
' IN: [strString] - String to remove terminator from
'
' Returns: The value of the string passed in minus any
'          terminating zero.
'-----------------------------------------------------------
'
Function StripTerminator(ByVal strString As String) As String
    Dim intZeroPos As Integer

    intZeroPos = InStr(strString, Chr$(0))
    If intZeroPos > 0 Then
        StripTerminator = Left$(strString, intZeroPos - 1)
    Else
        StripTerminator = strString
    End If
End Function

Function GetWindowsSysDir() As String
    Dim strBuf As String

    strBuf = Space$(gintMAX_SIZE)

    '
    'Get the system directory and then trim the buffer to the exact length
    'returned and add a dir sep (backslash) if the API didn't return one
    '
    If GetSystemDirectory(strBuf, gintMAX_SIZE) > 0 Then
        strBuf = StripTerminator(strBuf)
        GetWindowsSysDir = strBuf
    Else
        GetWindowsSysDir = vbNullString
    End If
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' PrintPictureToFitPage
'    - Prints a Picture object as big as possible.
'
' Prn
'    - Destination Printer object.
'
' Pic
'    - Source Picture object.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Sub PrintPictureToFitPage(Prn As Printer, pic As Picture)
    
    Const vbHiMetric As Integer = 8
    Dim PicRatio As Double
    Dim PrnWidth As Double
    Dim PrnHeight As Double
    Dim PrnRatio As Double
    Dim PrnPicWidth As Double
    Dim PrnPicHeight As Double
    
    ' Determine if picture should be printed in landscape or portrait
    ' and set the orientation.
    If pic.Height >= pic.Width Then
        Prn.Orientation = vbPRORPortrait   ' Taller than wide.
    Else
        Prn.Orientation = vbPRORLandscape  ' Wider than tall.
    End If
    
    ' Calculate device independent Width-to-Height ratio for picture.
    PicRatio = pic.Width / pic.Height
    
    ' Calculate the dimentions of the printable area in HiMetric.
    PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)
    PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)
    ' Calculate device independent Width to Height ratio for printer.
    PrnRatio = PrnWidth / PrnHeight
    
    ' Scale the output to the printable area.
    If PicRatio >= PrnRatio Then
        ' Scale picture to fit full width of printable area.
        PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
        PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.ScaleMode)
    Else
        ' Scale picture to fit full height of printable area.
        PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
        PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, Prn.ScaleMode)
    End If
    
    ' Print the picture using the PaintPicture method.
    Prn.PaintPicture pic, 0, 0, PrnPicWidth, PrnPicHeight
End Sub
'-------------------------------------------------------------------

Sub printPicture(objPicture As IPictureDisp)
If objPicture <> 0 Then
   If MsgBox("¿Desea realmente imprimir la imágen?", vbQuestion + vbYesNo) = vbYes Then
      PrintPictureToFitPage Printer, objPicture
      Printer.EndDoc
   End If
   Exit Sub
Else
      MsgBox "No hay imágen para imprimir!", vbExclamation
End If
End Sub

'Un procedimiento para ejecutar y esperar a que termine
Public Sub waitShell(szCmdLine As String, Optional wsWindowsStyles As VbAppWinStyle = vbNormalFocus, Optional waitClose As Boolean = True)
    'Esperar a que un proceso termine,
    'la ventana se mostrará minimizada sin foco
    Dim hProcess As Long
    Dim RetVal As Long
    Dim hWnd As Long
    hWnd = Shell(szCmdLine, wsWindowsStyles)
    If Not waitClose Then Exit Sub
    'The next line launches CmdLine as icon,
    'captures process ID
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hWnd)
    Do
        'Get the status of the process
        GetExitCodeProcess hProcess, RetVal
        'Sleep command recommended as well
        'as DoEvents
        DoEvents
        'Sleep 100
    'Loop while the process is active
    Loop While RetVal = STILL_ACTIVE
End Sub

Public Function FileExist(ByVal sFile As String) As Boolean
    'comprobar si existe este fichero
    Dim WFD As WIN32_FIND_DATA
    Dim hFindFile As Long

    hFindFile = FindFirstFile(sFile, WFD)
    'Si no se ha encontrado
    If hFindFile = INVALID_HANDLE_VALUE Then
        FileExist = False
    Else
        FileExist = True
        'Cerrar el handle de FindFirst
        hFindFile = FindClose(hFindFile)
    End If
End Function

Function desglosarRuta(ruta As String, iParte As Parte) As String
'Desglosa una ruta (C:\directorio\Directorio\hola.txt)
'Parte = 0 then es directorio ("C:\Directorio\directorio")
'Parte = 1 then es nombre de archivo ("hola.txt")
Dim limite As Integer
For i = Len(ruta) To 1 Step -1
    If Mid(ruta, i, 1) = "\" Or Mid(ruta, i, 1) = "/" Then
    limite = i
    Exit For
    End If
Next i
If iParte = 0 Then
    desglosarRuta = Mid(ruta, 1, limite)
Else
    desglosarRuta = Mid(ruta, limite + 1, Len(ruta) - limite)
End If
End Function

Function comprobarRuta(ruta As String) As Integer
On Error Resume Next
'Devuelve:  0 archivo
'               1 directorio
'               -1 si la ruta no es válida o no existe
    comprobarRuta = -1
If Dir(ruta, vbArchive + vbHidden) <> "" And Not Len(ruta) = 3 Then  'Es archivo
    comprobarRuta = 0
ElseIf Dir(ruta, vbDirectory + vbHidden) <> "" Or Len(ruta) = 3 Then  'Es directorio
    comprobarRuta = 1
End If
End Function

Function GetAttrEx(ruta As String) As VbFileAttribute
ChDir desglosarRuta(ruta, DIRECTORIO)
Dim item As String, findName As String
findName = desglosarRuta(ruta, ARCHIVO)
item = Dir$("*.*")
While item <> "" And item <> findName
    item = Dir$
    DoEvents
Wend
If item = findName Then GetAttrEx = GetAttr(item)
End Function

Function IsHiddenFile(ruta As String) As Boolean
On Error GoTo etErr
Dim iAtt As VbFileAttribute, a As Variant, s As Integer
iAtt = GetAttr(ruta)
If IsDirectory(ruta) Then iAtt = iAtt - vbDirectory
a = Array(vbArchive, vbSystem, vbHidden)
For i = 0 To UBound(a)
    If iAtt >= a(i) Then
    iAtt = iAtt - a(i)
        If i = UBound(a) Then IsHiddenFile = True
    End If
Next i
Exit Function
etErr:
IsHiddenFile = False
End Function

Function IsDirectory(ruta As String) As Boolean
On Error GoTo etErr
Dim iAtt As VbFileAttribute, a As Variant, s As Integer
iAtt = GetAttr(ruta)
a = Array(vbArchive, vbDirectory, vbSystem, vbHidden, vbReadOnly)
For i = 0 To UBound(a)
    If iAtt >= a(i) Then
    iAtt = iAtt - a(i)
        If i = 1 Then
            IsDirectory = True
            Exit For
        End If
    End If
Next i
Exit Function
etErr:
IsDirectory = False
End Function

Sub soloNumeros(ByRef KeyAscii As Integer)
'Poner en KeyPress:
'soloNumeros KeyAscii
If Not IsNumeric(Chr(KeyAscii)) And Not KeyAscii = vbKeyBack And Not KeyAscii = vbKeyDelete Then KeyAscii = 0
End Sub

Sub Wait(ByVal nSec As Integer)
    'Esperar un número de segundos
    Dim t1 As Date, t2 As Date

    t1 = Second(Now)
    t2 = t1 + nSec
    Do
        DoEvents
    Loop While t2 > Second(Now)
End Sub

Function getDecPart(Variable As String, Optional iLength As Integer) As String
'Extrae la parte decimal de un Double
'iLength :Longitud del decimal (Si es 0 o no se especifíca, se pondrán todos los decimales)
If Not isDec(Variable) Then
    getDecPart = 0
    Exit Function
End If
For i = 1 To Len(Variable)
    If Mid(Variable, i, 1) = "," Then
        If iLength = 0 Then
            getDecPart = Right(Variable, Len(Variable) - i)
        Else
            getDecPart = Mid(Variable, i + 1, iLength)
        End If
    Exit Function
    End If
Next i
End Function

Function isDec(Variable) As Boolean
isDec = False
If IsNumeric(Variable) Then
For i = 1 To Len(Variable)
    If Mid(Variable, i, 1) = "," Then
    isDec = True
    Exit Function
    End If
Next i
End If
End Function

Function StringInsert(ByRef szString As String, Optional szStringInsert As String, Optional szSign As String = "@!", Optional stepCrecient As Boolean = True) As Boolean
'Función: Inserta un troso de texto en un string
'szString: El String al cual se le desea insertar un texto
'szStringInsert: Texto que se quiere insertar a szString
'szSign: Signo que hay que buscar en el string para reemplazarlo por el szStringInsert
StringInsert = False
For i = IIf(stepCrecient, 1, Len(szString)) To IIf(Not stepCrecient, 1, Len(szString)) Step (-1 + -CInt(stepCrecient) * 2)
    If Mid(szString, i, Len(szSign)) = szSign Then
    szString = Left(szString, i - 1) & szStringInsert & Right(szString, Len(szString) - i - Len(szSign) + 1)
    StringInsert = True
    Exit Function
    End If
Next i
End Function

Function StringInsertEx(ByRef szString As String, Optional szStringInsert As String, Optional szSign As String = "@!", Optional stepCrecient As Boolean = True, Optional Inicio As Integer = 1) As Boolean
'Función: Inserta un troso de texto en un string, en todas las posiciones indicadas
'szString: El String al cual se le desea insertar un texto
'szStringInsert: Texto que se quiere insertar a szString
'szSign: Signo que hay que buscar en el string para reemplazarlo por el szStringInsert
StringInsertEx = False
For i = IIf(stepCrecient, Inicio, Len(szString)) To IIf(Not stepCrecient, Inicio, Len(szString)) Step (-1 + -CInt(stepCrecient) * 2)
    If Mid(szString, i, Len(szSign)) = szSign Then
    szString = Left(szString, i - 1) & szStringInsert & Right(szString, Len(szString) - i - Len(szSign) + 1)
        If StringInsertEx(szString, szStringInsert, szSign, , i + Len(szStringInsert)) Then
        End If
    StringInsertEx = True
    Exit Function
    End If
Next i
End Function

Function findText(TextoABuscar As String, TextoEnDondeBuscar As String) As Integer
'Función: Busca un texto dentro de otro
'Devuelve: El indice del inicio del texto encontrado
'   si no se encuentra devuelve 0, de lo contrario un numero > 0
For i = 1 To Len(TextoEnDondeBuscar)
    If TextoABuscar = Mid(TextoEnDondeBuscar, i, Len(TextoABuscar)) Then findText = i
Next i
End Function

Function IsObjArray(objCtrl) As Boolean
IsObjArray = False
On Error Resume Next
IsObjArray = (objCtrl.UBound <> "")
IsObjArray = (objCtrl.Index <> "")
End Function

Sub Centrar(frmForm As Form)
frmForm.Move Screen.Width / 2 - frmForm.Width / 2, Screen.Height / 2 - frmForm.Height / 2
End Sub

Function getTextualTime(szDate As String, Optional onlyDayAndTime As Boolean = False, Optional dayLen As Integer = 2) As String
Dim szTmpRes As String, szTotal As String, dtVar As String, i As Integer, i2 As Integer
If Not onlyDayAndTime Then
    For i = 0 To 5
    If i < 3 Then
    szTmpRes = sDateValue(szDate)
    Else
    szTmpRes = sTimeValue(szDate)
    End If
        dtVar = getsDateFunc(i, szTmpRes)
    If CInt(dtVar) <> 0 Then
    dtVar = dtVar & Space(1) & getsDateFunc(i, szTmpRes, True) & ", "
    Else
    dtVar = ""
    End If
    szTotal = szTotal & dtVar
    Next i
Else
szTmpRes = Left(szDate, dayLen)
    szTotal = IIf(CLng(szTmpRes) = 0, "", szTmpRes & " Dia" & IIf(CLng(szTmpRes) > 1, "s", "") & ", ") & getTextualTime("00/00/0000 " & sTimeValue(szDate))
End If
If Not StringInsert(szTotal, " y ", " y ", False) Then
    StringInsert szTotal, "", ", ", False
    StringInsert szTotal, " y ", ", ", False
End If
    getTextualTime = szTotal
End Function

Function sHour(sTime As String)
sHour = Left(sTime, Len(sTime) - 6)
End Function

Function sMin(sTime As String)
sMin = Mid(sTime, Len(sTime) - 4, 2)
End Function

Function sSeg(sTime As String)
sSeg = Right(sTime, 2)
End Function

Function sDay(sDate As String)
sDay = Left(sDate, 2)
End Function

Function sMonth(sDate As String)
sMonth = Mid(sDate, 4, 2)
End Function

Function sYear(sDate As String)
sYear = Mid(sDate, 7, 4)
End Function

Function sDateValue(sDate As String)
sDateValue = Left(sDate, 10)
End Function

Function sTimeValue(sDate As String)
sTimeValue = Right(sDate, 8)
End Function

Function getsDateFunc(FuncNum As Integer, sString As String, Optional getName As Boolean = False)
Select Case FuncNum
    Case 0
        If getName Then
        getsDateFunc = "Dia" & IIf(sDay(sString) <> "01", "s", "")
        Else
        getsDateFunc = sDay(sString)
        End If
    Case 1
        If getName Then
        getsDateFunc = "Mes" & IIf(sMonth(sString) <> "01", "es", "")
        Else
        getsDateFunc = sMonth(sString)
        End If
    Case 2
        If getName Then
        getsDateFunc = "Año" & IIf(sYear(sString) <> "01", "s", "")
        Else
        getsDateFunc = sYear(sString)
        End If
    Case 3
        If getName Then
        getsDateFunc = "Hora" & IIf(sHour(sString) <> "01", "s", "")
        Else
        getsDateFunc = sHour(sString)
        End If
    Case 4
        If getName Then
        getsDateFunc = "Minuto" & IIf(sMin(sString) <> "01", "s", "")
        Else
        getsDateFunc = sMin(sString)
        End If
    Case 5
        If getName Then
        getsDateFunc = "Segundo" & IIf(sSeg(sString) <> "01", "s", "")
        Else
        getsDateFunc = sSeg(sString)
        End If
End Select
End Function

Function combineRute(szRuta As String, Optional szFile As String) As String
 combineRute = szRuta & IIf((Right(szRuta, 1) = "\"), "", "\") & szFile
End Function

Function subFolderContain(szDir As String) As String
Dim n As String
Dir$ combineRute(szDir, "*.*"), vbDirectory
Dir$
n = Dir$
If n <> "" Then subFolderContain = n
End Function

Sub delDir(szDir As String)
Shell "command.com /C del C:\b /q /f /s"
DD2 szDir
End Sub

Sub DD2(szDir As String)
Dim OriginalDir, fileName, allFiles As String, NextDir As String
OriginalDir = CurDir$
ChDir szDir
'Borramos los directorios
    'Comprobamos si hay más directorios
    NextDir = subFolderContain(szDir)
    If NextDir <> "" Then
        DoEvents
        DD2 combineRute(szDir, NextDir)
    Else
        RmDir szDir
    End If
ChDir OriginalDir
End Sub

Function getUpRoute(szDir As String) As String
Dim l As Integer
l = Len(szDir)
    For i = l To 1 Step -1
        If Mid(szDir, i, 1) = "\" And i < l Then
        getUpRoute = Left(szDir, i - 1 * -CInt(Not i <= 3))
        Exit For
        End If
    Next i
End Function

Function getSelect(op) As Integer
For i = 0 To op.Count - 1
    If op(i).Value Then
    getSelect = i
    Exit For
    End If
Next i
End Function

Sub resetOP(op)
For i = 0 To op.Count - 1
    op(i).Value = False
Next i
End Sub

Function isValidFileName(fileName As String) As Boolean
Dim noChrs As Variant
noChrs = Array("\", "/", ":", "*", "?", Chr(34), "<", ">", "|")
isValidFileName = True
For i = 1 To Len(fileName)
    For a = 0 To UBound(noChrs)
        If Mid(fileName, i, 1) = noChrs(a) Then
            isValidFileName = False
            Exit For
        End If
    Next a
Next i
End Function

Sub cNumber(t As TextBox)
If t = "" Then t = 0
End Sub
