Attribute VB_Name = "mdlBuscador"
Option Explicit
'Declaro las llamadas a la API
 
Public Declare Function BringWindowToTop Lib "user32" (ByVal hWnd 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

Public Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

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 flgs As Long) As Long

Public Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal wIndx As Long) As Long

Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpSting As String, ByVal nMaxCount As Long) As Long

Public Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long

Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

Public Declare Function ReleaseCapture Lib "user32" () As Long

Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Public Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long

Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Public Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

Public Declare Function Shell_NotifyIcon Lib "Shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Public Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" _
    (ByVal nBufferLength As Long, _
     ByVal lpBuffer As String) As Long

Public Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" _
    (ByVal wDeviceID As Long, _
    ByVal uMessage As Long, _
    ByVal dwParam1 As Long, _
    ByRef dwParam2 As Any) As Long

Public Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" _
    (ByVal dwError As Long, _
    ByVal lpstrBuffer As String, _
    ByVal uLength As Long) As Long

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Declare Sub mouse_event Lib "user32" (ByVal dwflags As Long, ByVal dx As Long, ByVal dy As Long, _
            ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Public 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

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 MoveWindow Lib "user32" _
                       (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

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                        (ByVal hWnd As Long, ByVal wMsg As Long, _
                         ByVal wParam As Long, lParam As Any) As Long

Declare Function GetLogicalDrives Lib "kernel32" () As Long

Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long

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

Public Const INVALID_HANDLE_VALUE = -1

Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
                        (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long

'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------

Const SW_HIDE As Long = 0
Const SW_SHOWNORMAL As Long = 1
Const SW_SHOWMINIMIZED As Long = 2
Const SW_SHOWMAXIMIZED As Long = 3
Const SW_SHOWNOACTIVATE As Long = 4
Const SW_SHOW As Long = 5
Const SW_MINIMIZE As Long = 6
Const SW_SHOWMINNOACTIVE As Long = 7
Const SW_SHOWNA As Long = 8
Const SW_RESTORE As Long = 9
Const SW_SHOWDEFAULT As Long = 10
Const WM_USER = &H400
Const CCM_FIRST = &H2000&
Const CCM_SETBKCOLOR = (CCM_FIRST + 1)
Const PBM_SETBKCOLOR = CCM_SETBKCOLOR
Const PBM_SETBARCOLOR = (WM_USER + 9)
Const GW_HWNDFIRST = 0
Const GW_HWNDNEXT = 2
Const GWL_STYLE = (-16)
Const WS_MINIMIZE = &H20000000
Const HWND_TOP = 0
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_SHOWWINDOW = &H40

Public Const RGN_OR = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
Public Const MF_BYPOSITION = &H400&
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const LB_INITSTORAGE = &H1A8
Public Const conSwNormal = 1
Public Const MOUSEEVENTF_MOVE = &H1 '  movimiento del mouse
Public Const MOUSEEVENTF_LEFTDOWN = &H2 '  botón izquierdo presionado
Public Const MOUSEEVENTF_LEFTUP = &H4 '  botón izquierdo soltado
Public Const MOUSEEVENTF_RIGHTDOWN = &H8 '  botón derecho presionado
Public Const MOUSEEVENTF_RIGHTUP = &H10 '  botón derecho soltado
Public Const MOUSEEVENTF_MIDDLEDOWN = &H20 '  botón central presionado
Public Const MOUSEEVENTF_MIDDLEUP = &H40 ' botón central soltado
Public Const MOUSEEVENTF_ABSOLUTE = &H8000 '  movimiento absoluto
Public Const LB_ADDSTRING = &H180
Public Const WM_SETREDRAW = &HB
Public Const WM_VSCROLL = &H115
Public Const SB_BOTTOM = 7
Public Const MaxLFNPath = 260
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOACTIVATE = &H10
Public Const DRIVE_CDROM = 5
Public Const MCI_CLOSE = &H804
Public Const MCI_OPEN = &H803
Public Const MCI_OPEN_ELEMENT = &H200&
Public Const MCI_OPEN_SHAREABLE = &H100&
Public Const MCI_OPEN_TYPE = &H2000&
Public Const MCI_SET = &H80D
Public Const MCI_SET_DOOR_OPEN = &H100&
Public Const MCI_SET_DOOR_CLOSED = &H200&
Public Const MMSYSERR_NOERROR = 0

Public TituloCd As String
Public AgrandA, Hasta As Integer
Public ExtencionInvalida As Boolean
Public m_lDeviceID, Search123, IsTask, HwndProg As Long
Public NoHayCD, EstaGuardado As Boolean
Public t As NOTIFYICONDATA
Public Primer As Integer
Public NombreCd As String
Public Counter22, Counter23, Counter24, Counter25, Counter26 As Integer
Public Cancelar%

Dim Excel As Excel.Application ' This is the excel program
Dim ExcelWBk As Excel.Workbook ' This is the work book
Dim ExcelWS As Excel.Worksheet ' This is the sheet
Dim Direc1, CdNum1, Format1, Path1 As String
Dim BuscaSigno As String * 1
Dim LargoFile As Integer
Dim PrincFormato As Integer
Dim Lcode As Long
Dim SinExt As Boolean
Dim Xlm
'---------------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------------
Public Type NOTIFYICONDATA
    cbSize As Long
    hWnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

Public Type MCI_OPEN_PARMS
    dwCallback As Long
    wDeviceID As Long
    lpstrDeviceType As String
    lpstrElementName As String
    lpstrAlias As String
End Type



Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

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 * MaxLFNPath
        cShortFileName As String * 14
End Type

Public Type POINTAPI
        X As Long
        Y As Long
End Type
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Function AllwaysOnTop()
  SetWindowPos Form1.hWnd, -1, Form1.Left / 15, _
                        Form1.Top / 15, Form1.Width / 15, _
                        Form1.Height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDOW


End Function

Public Function AllwaysNonOnTop()
  SetWindowPos Form1.hWnd, -2, Form1.Left / 15, _
                       Form1.Top / 15, Form1.Width / 15, _
                        Form1.Height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDOW
End Function


Public Function MakeMeFlash(hWnd As Long)

Form1.Timer1.Enabled = True

End Function

Public Function YaEstaElCDROM()
'HACERRRRRRR!!!!!!!!!

End Function

Public Function GetCDInfo(drive As String)

Dim root As String
Dim volume_name As String
Dim serial_number, ttt As Long
Dim max_component_length As Long
Dim file_system_flags As Long
Dim file_system_name As String
Dim pos As Integer
    
    root = drive
    volume_name = Space$(1024)
    file_system_name = Space$(1024)

    If GetVolumeInformation(root, volume_name, _
        Len(volume_name), serial_number, _
        max_component_length, file_system_flags, _
        file_system_name, Len(file_system_name)) = 0 _
    Then
      GoTo Endel

    End If

    pos = InStr(volume_name, Chr$(0))
    volume_name = Left$(volume_name, pos - 1)
    Form1.txtvolumename.Text = volume_name

    Form1.lblSerialNumber.Caption = Format$(serial_number)

    Form1.lblMaxComponentLength.Caption = Format$(max_component_length)

    pos = InStr(file_system_name, Chr$(0))
    file_system_name = Left$(file_system_name, pos - 1)
    Form1.lblFileSystem.Caption = file_system_name

    Form1.lblFlags.Caption = "&&H" & Hex$(file_system_flags)

Endel:

End Function

Public Function HazmeAncho()

Hasta = 10700
AgrandA = Form1.Width
Form1.Timer2.Enabled = True

End Function

Public Function MostrarOpcionesLista(X As Single, Y As Single)

Form1.PopupMenu Form1.mnuOpcionesLista

End Function

Public Function OpenCdDevice(drive As String) As Boolean

On Error GoTo ErrHandler
    
    Dim Lcode As Long
    Dim mciOpenParms As MCI_OPEN_PARMS
    Dim sBuffer As String * 128

    mciOpenParms.lpstrDeviceType = "cdaudio"
    mciOpenParms.lpstrElementName = Left(drive, 2)

    Lcode = mciSendCommand(0, MCI_OPEN, (MCI_OPEN_TYPE Or MCI_OPEN_ELEMENT Or MCI_OPEN_SHAREABLE), mciOpenParms)

    If Lcode <> MMSYSERR_NOERROR Then GoTo ErrHandler
      m_lDeviceID = mciOpenParms.wDeviceID
    
      OpenCdDevice = True
    
    Exit Function

ErrHandler:
    ' This is to show how to read lCode for error messages
mciGetErrorString Lcode, sBuffer, 128
OpenCdDevice = False

End Function

Public Function CloseCdDevice()
    
    mciSendCommand m_lDeviceID, MCI_CLOSE, 0, 0
    m_lDeviceID = -1

End Function

Public Function AbrirCDROM(CDAbrir As String)
    
    m_lDeviceID = -1

    If OpenCdDevice(CDAbrir) Then
        Lcode = mciSendCommand(m_lDeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0)
        CloseCdDevice
    End If

End Function

Public Function CerrarCDROM(CDCerrar As String)
    
    Dim Lcode As Long
    
    m_lDeviceID = -1
    
    If OpenCdDevice(CDCerrar) Then
        Lcode = mciSendCommand(m_lDeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0)
        
        CloseCdDevice
    End If

End Function

Public Function EncuentraUnidadesDeCDROM() As Integer

Dim EsONoEs, Recorre As Integer
Dim CDROMDrive As String * 2

Form4.Combo1.Clear

For Recorre = 0 To Form3.Drive1.ListCount - 1
  EsONoEs = GetDriveType(Form3.Drive1.List(Recorre))
  If EsONoEs = 5 Then Form4.Combo1.AddItem Form3.Drive1.List(Recorre)
Next

If Form4.Combo1.ListCount > 0 Then
  EncuentraUnidadesDeCDROM = Form4.Combo1.ListCount
Else
  EncuentraUnidadesDeCDROM = 0
End If

End Function

Public Function TieneCDROM(drive As String)

Dim Button, boton As Integer

On Error GoTo Reintentar
Form3.Drive1.drive = drive
Call GetCDInfo(drive)
NombreCd = InputBox("Ingrese el nombre del grupo con el que desea realizar la busqueda", "Ingrese el titulo del grupo de archivos en busqueda", Form1.txtvolumename.Text)
If Len(NombreCd) > 0 And Trim$(NombreCd) <> "" Then
  Form1.txtvolumename.Text = NombreCd
Else
  boton = MsgBox("Debe escribir un nombre.¿Desea cancelar la busqueda?", vbYesNo, "Cancelacion de Busqueda")
If boton = 6 Then Exit Function
Form1.txtvolumename.Text = "NO ESPECIFICADO"
NombreCd = "NO ESPECIFICADO"
End If
Form1.Command1.Value = 1
Exit Function

Reintentar:

Select Case Err.Number
Case 68
    Call AbrirCDROM(drive)
  Button = MsgBox("Por Favor Inserte un CD en la unidad, pero sin cerrarla, el programa lo hará por Usted ", vbOKCancel, "No hay CD en la bandeja")
If Button = 1 Then
  CerrarCDROM (drive)
  Call TieneCDROM(drive)
Else
  CerrarCDROM (drive)
End If
Case 0
Case Else
  MsgBox "Ha ocurrido un error desconocido nro. " & CStr(Err.Number), vbOKOnly, "Error Desconocido"
End Select

End Function

Public Function ValidaUnidad(drive As String) As Boolean

On Error GoTo PathInvalido
Form3.Drive1.drive = drive
ValidaUnidad = True
Exit Function
PathInvalido:
ValidaUnidad = False

End Function
Public Function MostrarIcono()
    
    t.cbSize = Len(t)
    t.hWnd = Form12.pichook.hWnd
    t.uID = 1&
    t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    t.uCallbackMessage = WM_MOUSEMOVE
    t.hIcon = Form1.Icon
    t.szTip = "Shell_NotifyIcon ..." & Chr$(0)
    Shell_NotifyIcon NIM_ADD, t
    App.TaskVisible = False

End Function

Public Function EliminarIcono()
    
    t.cbSize = Len(t)
    t.hWnd = Form12.pichook.hWnd
    t.uID = CLng(2)
    Shell_NotifyIcon NIM_DELETE, t

End Function


Public Function SearchFirstEmptyCol() As Integer

Primer = 1
Do While Primer < 2000
  If ExcelWS.Cells(Primer, 1) = "" Then
    SearchFirstEmptyCol = Primer
    ExcelWS.Cells(Primer, 1) = "NOMBRE TEMA"
    ExcelWS.Cells(Primer, 2) = "DIRECCION"
    ExcelWS.Cells(Primer, 3) = "TITULO CD"
    ExcelWS.Cells(Primer, 4) = "FORMATO"
    Primer = Primer + 1
    Exit Function
  End If
  Primer = Primer + 1
Loop

End Function

Public Function SeparaDatos(PathEntero As String)

LargoFile = Len(PathEntero)
Dim MyObj1 As Object
'me fijo si el archivo tiene extención
Set MyObj1 = CreateObject("Scripting.FileSystemObject")

If MyObj1.fileexists(PathEntero) = False Then Exit Function

While LargoFile >= 1
  If Mid(PathEntero, LargoFile, 1) <> "\" Then
    If Mid(PathEntero, LargoFile, 1) = "." Then
      PrincFormato = Len(PathEntero) - LargoFile
      Format1 = UCase(Right(PathEntero, PrincFormato))
      PathEntero = Left(PathEntero, Len(PathEntero) - Len(Format1) - 1)
      GoTo BuscaBeginPath
    End If
  Else
    Format1 = "ARCHIVO"
    GoTo BuscaBeginPath
  End If
  LargoFile = LargoFile - 1
Wend


BuscaBeginPath:

LargoFile = Len(PathEntero)

While LargoFile >= 2
  If Mid(PathEntero, LargoFile, 1) = "\" Then
      Path1 = Right(PathEntero, Len(PathEntero) - LargoFile)
      PathEntero = Left(PathEntero, LargoFile)
      Direc1 = Right(PathEntero, Len(PathEntero) - 2)
      If Len(Direc1) < 2 Then Direc1 = "DIRECTORIO PRINCIPAL"
      GoTo YaEsta
  End If
LargoFile = LargoFile - 1
Wend

YaEsta:
   Set Xlm = Form1.ListView1.ListItems.Add(1, , Path1)
   Xlm.SubItems(1) = Direc1
   Xlm.SubItems(2) = NombreCd
   Xlm.SubItems(3) = Format1
   Xlm.SubItems(4) = Left(PathEntero, 2)

Form1.Label2.Caption = "La lista contiene " & Form1.ListView1.ListItems.Count & " archivos actualmente"

End Function

Public Function CorroboraExt()

Dim GoGo As Integer
Dim compara As String * 1
Dim EsPosible As Boolean

GoGo = Len(Form3.Combo1.Text)
EsPosible = False
ExtencionInvalida = False

Do While GoGo >= 1
  compara = Mid(Form3.Combo1.Text, GoGo, 1)
  If compara = "." Then
    EsPosible = True
    Exit Function
  End If
  GoGo = GoGo - 1
Loop
 
 Form3.Combo1.Text = "*.mp3"
 MsgBox "Extencion Invalida, la extencion se restaurara a *.mp3", vbOKOnly, "Extencion Invalida"
 ExtencionInvalida = True

End Function

Public Function ReproducirFile()

Dim PathEntero As String

On Error Resume Next

If Form1.ListView1.ListItems.Count > 0 Then
  PathEntero = MakeFullPath(Form1.ListView1, Form1.ListView1.SelectedItem.Index)
  ShellExecute Form1.hWnd, "open", PathEntero, vbNullString, vbNullString, conSwNormal
  Exit Function
End If

End Function

Public Function AgregarAListaMp3()

Dim PathEntero As String
Dim Search123 As Long

For Search123 = 1 To Form1.ListView1.ListItems.Count
    If Form1.ListView1.ListItems.Item(Search123).Selected = True Then
          PathEntero = MakeFullPath(Form1.ListView1, Search123)
          ShellExecute Form1.hWnd, "Enqueue", PathEntero, vbNullString, vbNullString, conSwNormal
    End If
Next

End Function

Public Function ConfiguraAbrir() As String
    
    Dim MiObjeto As Object
    Dim Extencion As String * 4
    
    Set MiObjeto = CreateObject("Scripting.filesystemobject")
    
    Form5.CommonDialog1.Filter = "Archivos de Excel y Access (*.xls:*.mdb)|*.xls;*.mdb|Archivos de Excel (*.xls)|*.xls|Archivos de Access(*.mdb)|*.mdb"
    Form5.CommonDialog1.CancelError = True
    Form5.CommonDialog1.Flags = &H5504&
    Form5.CommonDialog1.DialogTitle = "Seleccione la base de datos a abrir"
TryAgain:
    On Error GoTo ErrHandler
    Form5.CommonDialog1.ShowOpen
    ConfiguraAbrir = Form5.CommonDialog1.FileName
    Extencion = Right(ConfiguraAbrir, 4)

    If UCase(Extencion) <> UCase(".xls") And UCase(Extencion) <> UCase(".mdb") Then ConfiguraAbrir = ConfiguraAbrir & ".mdb"
    If MiObjeto.fileexists(ConfiguraAbrir) = False Then
      On Error Resume Next
      MiObjeto.Close
      GoTo TryAgain
    End If
    Exit Function

ErrHandler:

EscribirTexto "No se abrira ninguna base de datos", 5000, vbYellow
ConfiguraAbrir = ""

End Function

Public Function ConfiguraGuardar(Title As String) As String
    
    Dim boton As Integer
    Dim Extencion As String * 4
    
    Form5.CommonDialog1.Filter = "Archivo de Excel o Access (*.xls:*.mdb)|*.xls;*.mdb|Archivos de Excel (*.xls)|*.xls|Archivos de Access(*.mdb)|*.mdb"
    Form5.CommonDialog1.CancelError = True
    On Error GoTo ErrHandler
    Form5.CommonDialog1.Flags = &H4502&
    Form5.CommonDialog1.DialogTitle = Title
    Form5.CommonDialog1.ShowSave
    ConfiguraGuardar = Form5.CommonDialog1.FileName
    On Error Resume Next
    Extencion = Right(ConfiguraGuardar, 4)
    If UCase(Extencion) <> UCase(".mdb") And UCase(Extencion) <> UCase(".xls") Then
      ConfiguraGuardar = ConfiguraGuardar & ".mdb"
    Else
       
    End If
    Exit Function

ErrHandler:

EscribirTexto "La lista no se guardará", 5000, vbYellow
ConfiguraGuardar = ""

End Function

Public Function LeerExcelDataBase(ByVal PathRead As String)

Dim AppWorld As Excel.Application
Dim WbWorld As Excel.Workbook
Dim ShtContinent As Excel.Worksheet
Dim RngFeatureList As Excel.Range
Dim NombreHoja, Name11, MiString As String
Dim Start, Start01, Varia, Anterior, Ultima, Cantidad, CantidadEsperada, Maiz, Vacios As Long
Dim LoEncontre As Boolean
Dim Xlm
Dim MiArreglo, MiArbol As Range
Dim X, Y As Long
Dim ObjGen As Object

Cancelar = False

Set ObjGen = CreateObject("Scripting.FileSystemObject")

On Error Resume Next 'ignorar errores

Set AppWorld = GetObject(, "Excel.Application") 'buscar una copia de Excel en ejecución

If Err.Number <> 0 Then 'Si no se ejecuta Excel
  Set AppWorld = CreateObject("Excel.Application") 'ejcutarlo
End If

Err.Clear

If ObjGen.fileexists(PathRead) = True Then
  On Error GoTo OfficeNotInstalled
  Set WbWorld = AppWorld.Workbooks.Open(PathRead)
Else
  Exit Function
End If

NombreHoja = WbWorld.Sheets(1).Name
Form7.TxtNameXls.Text = NombreHoja
EscribirTexto "Comprobando formato " & NombreHoja & "...", 10000, vbWhite

Set ShtContinent = WbWorld.Sheets(NombreHoja)
Set RngFeatureList = ShtContinent.Rows(1)
EscribirTexto "El formato de la base es correcto, buscando el final de " & NombreHoja & ".Por favor Espere...", 32000, vbWhite
 Start = 2
CantidadEsperada = ShtContinent.UsedRange.Rows.Count - 2
Cantidad = 0
'Form1.ListView1.Enabled = False
Maiz = 1
Form1.ProgressBar1.Visible = True
Form1.ProgressBar1.Max = Abs(CantidadEsperada)
For Start01 = Start To ShtContinent.UsedRange.Rows.Count
  DoEvents
  If Cancelar% Then GoTo HaSidoCancelada
  If RngFeatureList.Cells(Start01, 1) <> "" Then
    Form1.ProgressBar1.Value = Cantidad
    Cantidad = Cantidad + 1
    EscribirTexto "Se estan agregando " & CStr(Cantidad) & " archivos desde " & PathRead, 12000, vbWhite
    Set Xlm = Form1.ListView1.ListItems.Add(1, , RngFeatureList.Cells(Start01, 1))
    Xlm.SubItems(1) = RngFeatureList.Cells(Start01, 2)
    Xlm.SubItems(2) = RngFeatureList.Cells(Start01, 3)
    Xlm.SubItems(3) = RngFeatureList.Cells(Start01, 4)
    Xlm.SubItems(4) = "NN"
  End If
Next Start01
EscribirTexto "Se han agregado " & CStr(Cantidad) & " archivos desde " & PathRead, 12000, vbWhite
Form1.Label2.Caption = "La lista contiene " & Form1.ListView1.ListItems.Count & " archivos actualmente"
Form1.ProgressBar1.Visible = False
Exit Function

HaSidoCancelada:

On Error Resume Next
Set RngFeatureList = Nothing
Set ShtContinent = Nothing
AppWorld.quit
EscribirTexto "CANCELADA...Agregados " & CStr(Cantidad) & " archivos desde " & PathRead, 12000, vbRed
Form1.LblInfo.Refresh
Form1.Label2.Caption = "La lista contiene " & Form1.ListView1.ListItems.Count & " archivos actualmente"
Form1.ProgressBar1.Visible = False
Exit Function

OfficeNotInstalled:

On Error Resume Next

AppWorld.quit
MsgBox "Microsoft Office 97 no se encuentra instalado,o su instalación es incorrecta o la versión no es compatible con el programa.", vbOKOnly, "Error al leer archivo"
EscribirTexto "No se puede acceder al archivo " & PathRead & ". Version de Office Incompatible", 10000, vbRed
WriteLogError ("Office 97 incorrecto, mal instalado o sin instalar." & "%" & PathRead & "%Read")

End Function


Public Function LeerAccessDataBase(ByVal PathRead As String)

Dim WrkPredeterminado As Workspace
Dim DbsNeptuno As Database
Dim Tabla1 As TableDef
Dim Record1 As Recordset
Dim Recorre As Long

On Error GoTo ICant

Cancelar = False

Set WrkPredeterminado = DBEngine.Workspaces(0)
Set DbsNeptuno = OpenDatabase(PathRead, False, True)
Set Tabla1 = DbsNeptuno.TableDefs(0)
Set Record1 = Tabla1.OpenRecordset(dbOpenDynaset, dbConsistent)

On Error Resume Next

Form1.ProgressBar1.Max = Tabla1.RecordCount
Form1.ProgressBar1.Value = 1
Form1.ProgressBar1.Visible = True
Record1.MoveLast
Recorre = 1

Do While Not Record1.BOF

DoEvents
If Cancelar = True Then GoTo HaSidoCancelada
Set Xlm = Form1.ListView1.ListItems.Add(1, , Record1.Fields(0).Value)
    Xlm.SubItems(1) = Record1.Fields(1).Value
    Xlm.SubItems(2) = Record1.Fields(2).Value
    Xlm.SubItems(3) = Record1.Fields(3).Value
    Xlm.SubItems(4) = "NN"

Recorre = Recorre + 1
Record1.MovePrevious
Form1.ProgressBar1.Value = Recorre

Loop

Record1.Close
DbsNeptuno.Close
WrkPredeterminado.Close
EscribirTexto "Se han agregado " & CStr(Recorre - 1) & " archivos desde " & PathRead, 12000, vbWhite
Form1.Label2.Caption = "La lista contiene " & Form1.ListView1.ListItems.Count & " archivos actualmente"
Form1.ProgressBar1.Visible = False
Exit Function

HaSidoCancelada:

Record1.Close
DbsNeptuno.Close
WrkPredeterminado.Close
EscribirTexto "CANCELADA...Agregados " & CStr(Recorre - 1) & " archivos desde " & PathRead, 12000, vbRed
Form1.Label2.Caption = "La lista contiene " & Form1.ListView1.ListItems.Count & " archivos actualmente"
Form1.ProgressBar1.Visible = False
Form1.ProgressBar1.Visible = False
Exit Function

ICant:

EscribirTexto "Imposible Acceder a " & PathRead, 7000, vbRed

End Function

Public Function GuardarDataBase(ByVal PathLista As String)

Dim BuscaTipo As String * 3

BuscaTipo = UCase(Right(PathLista, 3))

Select Case BuscaTipo

Case UCase("mdb")
GuardaAccessFile PathLista

Case UCase("xls")
GuardaExcelFile PathLista

End Select

End Function



Public Function GuardaExcelFile(Path As String)
    
    Dim mobjExcel As Excel.Application
    Dim lngTempCounter, MenuPositions As Long
    Dim objWorkbook As Excel.Workbook
    Dim objExcelSheet   As Excel.Worksheet
    Dim ObjGen As Object
    Dim Msg As Integer
    
    Cancelar = False
    On Error Resume Next
    
    Set ObjGen = CreateObject("Scripting.FileSystemObject")
    If ObjGen.fileexists(Path) Then Kill (Path)
      
    Set mobjExcel = GetObject(, "Excel.Application") 'buscar una copia de Excel en ejecución
    If Err.Number <> 0 Then 'Si no se ejecuta Excel
      Set mobjExcel = CreateObject("Excel.Application") 'ejcutarlo
    End If
      Err.Clear   ' Borrar el objeto Err si se produce un error.
      
      On Error GoTo OfficeNotInstalled
      
      Set objWorkbook = mobjExcel.Workbooks.Add
      Set objExcelSheet = mobjExcel.ActiveWorkbook.ActiveSheet
      
      Form1.ProgressBar1.Max = Form1.ListView1.ListItems.Count
      Form1.ProgressBar1.Visible = True
      
      On Error Resume Next
      
      With objExcelSheet
        .Name = Form7.TxtNameXls.Text
        .Cells(1, 1) = Form1.ListView1.ColumnHeaders.Item(1).Text
        .Cells(1, 2) = Form1.ListView1.ColumnHeaders.Item(2).Text
        .Cells(1, 3) = Form1.ListView1.ColumnHeaders.Item(3).Text
        .Cells(1, 4) = Form1.ListView1.ColumnHeaders.Item(4).Text
       End With
       
        Form1.ListView1.Enabled = False
        
        For lngTempCounter = 3 To Form1.ListView1.ListItems.Count + 2
          DoEvents
          If Cancelar = True Then GoTo HaSidoCancelada
            Form1.ProgressBar1.Value = lngTempCounter - 2
              objExcelSheet.Cells(lngTempCounter, 1) = Form1.ListView1.ListItems.Item(lngTempCounter - 2).Text
              objExcelSheet.Cells(lngTempCounter, 2) = Form1.ListView1.ListItems.Item(lngTempCounter - 2).ListSubItems(1).Text
              objExcelSheet.Cells(lngTempCounter, 3) = Form1.ListView1.ListItems.Item(lngTempCounter - 2).ListSubItems(2).Text
              objExcelSheet.Cells(lngTempCounter, 4) = Form1.ListView1.ListItems.Item(lngTempCounter - 2).ListSubItems(3).Text
        Next lngTempCounter
    
    'salvar proyecto y definir configuraciones de hoja
    If Form5.ChkExcConfg.Value = 1 Then
      objExcelSheet.UsedRange.Interior.Color = Form7.TxtcolorRelleno.BackColor
      objExcelSheet.UsedRange.Borders.Color = Form7.TxtColorborder.BackColor
      objExcelSheet.UsedRange.Font.Name = Form7.Text1.Font.Name
      objExcelSheet.UsedRange.Font.Size = Form7.Text1.Font.Size
      objExcelSheet.UsedRange.Font.Bold = Form7.Text1.Font.Bold
      objExcelSheet.UsedRange.Font.Italic = Form7.Text1.Font.Italic
      objExcelSheet.UsedRange.Font.Underline = Form7.Text1.Font.Underline
      objExcelSheet.UsedRange.Font.Color = Form7.Text1.ForeColor
      objExcelSheet.UsedRange.Borders.LineStyle = Form7.TxtBorStyle.Text
      objExcelSheet.UsedRange.Borders.Weight = Form7.TxtBorWidth.Text
    End If
    
   On Error GoTo ICant
   
   objWorkbook.SaveAs (Path)
   objWorkbook.Close
   mobjExcel.quit
   
   Set objExcelSheet = Nothing
   Set objWorkbook = Nothing
   Set mobjExcel = Nothing
   
   Form1.ProgressBar1.Visible = False
   EscribirTexto "Agregados " & CStr(lngTempCounter - 3) & " archivos a la base de datos.", 15000, vbWhite
   Form1.ListView1.Enabled = True

Exit Function

HaSidoCancelada:
objWorkbook.SaveAs (Path)
objWorkbook.Close
mobjExcel.quit

Set objExcelSheet = Nothing
Set objWorkbook = Nothing
Set mobjExcel = Nothing

Form1.ProgressBar1.Visible = False
EscribirTexto "CANCELADA...Se ha agregado " & CStr(lngTempCounter - 3) & " archivos a la base de datos.", 15000, vbRed
Form1.ListView1.Enabled = True

Exit Function

ICant:

On Error Resume Next

objWorkbook.Close
mobjExcel.quit

Set objWorkbook = Nothing
Set objExcelSheet = Nothing
Set mobjExcel = Nothing

Form1.ProgressBar1.Visible = False
EscribirTexto "No se puede acceder al archivo " & Path & " Compruebe que el archivo exista y no sea de solo lectura", 10000, vbRed
Form1.ListView1.Enabled = True

Exit Function

OfficeNotInstalled:

On Error Resume Next

mobjExcel.quit
MsgBox "Microsoft Office 97 no se encuentra instalado,o su instalación no es correcta o la versión  es anterior al la 97", vbOKOnly, "Error al guardar archivo"
EscribirTexto "No se puede acceder al archivo " & Path & "Version de Office Incompatible", 10000, vbRed
WriteLogError ("Office 97 incorrecto, mal instalado o sin instalar." & "%" & Path & "%Write")

End Function



Public Function GuardaAccessFile(Path As String)

Dim Record1 As Recordset
Dim WrkPredeterminado As Workspace
Dim DbsNeptuno As Database
Dim Tabla1 As TableDef
Dim Myobj As Object
Dim Recorre As Long

On Error Resume Next

Cancelar = False

Set Myobj = CreateObject("scripting.filesystemobject")
If Myobj.fileexists(Path) = True Then Kill (Path)

Set WrkPredeterminado = DBEngine.Workspaces(0)
On Error GoTo ICant
Set DbsNeptuno = WrkPredeterminado.CreateDatabase(Path, dbLangGeneral, dbEncrypt)
On Error Resume Next
Set Tabla1 = DbsNeptuno.CreateTableDef("Catalogo", dbAutoIncrField)

With Tabla1
.Fields.Append .CreateField(Form1.ListView1.ColumnHeaders.Item(1).Text, dbText)
.Fields.Append .CreateField(Form1.ListView1.ColumnHeaders.Item(2).Text, dbText)
.Fields.Append .CreateField(Form1.ListView1.ColumnHeaders.Item(3).Text, dbText)
.Fields.Append .CreateField(Form1.ListView1.ColumnHeaders.Item(4).Text, dbText)
End With

DbsNeptuno.TableDefs.Append Tabla1

If Form1.ListView1.ListItems.Count > 0 Then
  Form1.ListView1.Enabled = False
  Set Record1 = Tabla1.OpenRecordset(dbOpenDynaset, dbConsistent)
  Form1.ProgressBar1.Max = Form1.ListView1.ListItems.Count
  Form1.ProgressBar1.Value = 1
  Form1.ProgressBar1.Visible = True
 
    For Recorre = 1 To Form1.ListView1.ListItems.Count
      DoEvents
      Form1.ProgressBar1.Value = Recorre
      Record1.AddNew
      If Cancelar = True Then GoTo PresionoCancelar
      Record1.Fields(0).Value = Form1.ListView1.ListItems.Item(Recorre).Text
      Record1.Fields(1).Value = Form1.ListView1.ListItems.Item(Recorre).ListSubItems.Item(1).Text
      Record1.Fields(2).Value = Form1.ListView1.ListItems.Item(Recorre).ListSubItems.Item(2).Text
      Record1.Fields(3).Value = Form1.ListView1.ListItems.Item(Recorre).ListSubItems.Item(3).Text
      Record1.Update
    Next
    
    Record1.Close
    DbsNeptuno.Close
    WrkPredeterminado.Close
    Form1.ProgressBar1.Visible = False
    EscribirTexto "Agregados " & CStr(Recorre - 1) & " archivos a la base de datos.", 15000, vbWhite
    Form1.ListView1.Enabled = True
    Exit Function
    
PresionoCancelar:
    
    Record1.Update
    Record1.Close
    DbsNeptuno.Close
    WrkPredeterminado.Close
    EscribirTexto "CANCELADA...Se ha agregado " & CStr(Recorre) & " archivos a la base de datos.", 15000, vbRed
    Form1.ProgressBar1.Visible = False
    Form1.ListView1.Enabled = True
    Exit Function
End If

DbsNeptuno.Close

Exit Function

ICant:

EscribirTexto "No se puede acceder al archivo " & Path & " Compruebe que el archivo exista y no sea de solo lectura", 10000, vbRed

End Function


Public Function MakeRegion(picSkin As PictureBox) As Long
    
   
    Dim X As Long, Y As Long, StartLineX As Long
    Dim FullRegion As Long, LineRegion As Long
    Dim TransparentColor As Long
    Dim InFirstRegion As Boolean
    Dim InLine As Boolean
    Dim hdc As Long
    Dim PicWidth As Long
    Dim PicHeight As Long
    
    hdc = picSkin.hdc
    PicWidth = picSkin.ScaleWidth
    PicHeight = picSkin.ScaleHeight
    
    InFirstRegion = True: InLine = False
    X = Y = StartLineX = 0
    
    TransparentColor = GetPixel(hdc, 0, 0)
    
    For Y = 0 To PicHeight - 1
        For X = 0 To PicWidth - 1
            
            If GetPixel(hdc, X, Y) = TransparentColor Or X = PicWidth Then
                If InLine Then
                    InLine = False
                    LineRegion = CreateRectRgn(StartLineX, Y, X, Y + 1)
                    
                    If InFirstRegion Then
                        FullRegion = LineRegion
                        InFirstRegion = False
                    Else
                        CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
                        DeleteObject LineRegion
                    End If
                End If
            Else
                If Not InLine Then
                    InLine = True
                    StartLineX = X
                End If
            End If
        Next
    Next
    
    MakeRegion = FullRegion
End Function

Public Function EjecBoton1()

Form3.Show

End Function

Public Function EjecBoton2()

Form5.Show
Call ExplodeForm(Form5, 300)
MoveWindow Form5.hWnd, (Form5.Left / Screen.TwipsPerPixelX), (Form5.Top / Screen.TwipsPerPixelY), (Form5.Width / Screen.TwipsPerPixelX), (Form5.Height / Screen.TwipsPerPixelY), 1

End Function

Public Function EjecBoton3()

Form1.ListView1.ListItems.Clear
End

End Function

Public Function EjecBoton4()

Form1.Show

End Function

Public Function EjecBoton5()

Form6.Show
End Function

Public Function Change_pb_ForeColor(ByVal hWnd As Long, _
                                    ByVal lColor As Long)
          SendMessage hWnd, PBM_SETBARCOLOR, 0, ByVal lColor
End Function


Public Function Change_pb_Color(ByVal hWnd As Long, _
                                ByVal lColor As Long)
           SendMessage hWnd, PBM_SETBKCOLOR, 0, ByVal lColor
End Function


Public Function EscribirTexto(Texto As String, MiliSegundos As Integer, Color As Long)

Form1.Timer3.Enabled = False
Form1.Timer3.Interval = MiliSegundos
Form1.LblInfo.Caption = Texto
Form1.LblInfo.ForeColor = Color
Form1.Timer3.Enabled = True
End Function


Public Function TaskWindow(hwCurr As Long) As Long

Dim lngStyle As Long

lngStyle = GetWindowLong(hwCurr, GWL_STYLE)
If (lngStyle And IsTask) = IsTask Then TaskWindow = True

End Function

Public Function WarningRepeat()
'cambio el foco a la ventana del programa ya ejecutado
Dim hWnd As Long    ' handle to window
Dim X As Long          ' work area
Dim lngWW As Long      ' Window Style bits

hWnd = HwndProg
'hWnd = lstapp.ItemData(lstapp.ListIndex)
               ' Get style bits for window
lngWW = GetWindowLong(hWnd, GWL_STYLE)
               ' If minimized do a restore
If lngWW And WS_MINIMIZE Then
  X = ShowWindow(hWnd, SW_RESTORE)
End If
               ' Move window to top of z-order/activate; no move/resize
               X = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _
                       SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW)
End

End Function

Public Function EliminaMp3Seleccionados()

Dim Howev, Search123 As Long

If Form1.ListView1.ListItems.Count > 0 Then
    Form1.ListView1.Enabled = False
    Search123 = 1
    While Search123 <= Form1.ListView1.ListItems.Count
        If Form1.ListView1.ListItems.Item(Search123).Selected = True Then
            Form1.ListView1.ListItems.Remove (Search123)
            Howev = Howev + 1
        Else
            Search123 = Search123 + 1
        End If
    Wend
    If Howev > 1 Then
      Form1.ListView1.Enabled = True
      EscribirTexto "Han sido eliminados " & CStr(Howev) & " archivos de la lista", 5000, vbBlue
      Form1.Label2.Caption = "La lista contiene " & Form1.ListView1.ListItems.Count & " archivos actualmente"
    Else
      Form1.ListView1.Enabled = True
      EscribirTexto "Ha sido eliminado " & CStr(Howev) & " archivo de la lista", 5000, vbBlue
      Form1.Label2.Caption = "La lista contiene " & Form1.ListView1.ListItems.Count & " archivo actualmente"
    End If
Else
  EscribirTexto "ADVERTENCIA: No se pueden eliminar archivos de una lista vacia!", 10000, vbRed
  Form1.Label2.Caption = "La lista esta vacia"
End If

End Function


Public Function GetMove(Objeto As ListView, boton As Integer, X As Single, Y As Single)

Dim MyRect As RECT
Dim LstAncho As Long

If boton = 1 Then
  If Form1.Edit.Checked = True Then
    If X / Screen.TwipsPerPixelX < Objeto.Width / 2 Then
      If Y / Screen.TwipsPerPixelY < Objeto.Height / 2 Then
        SendMessage Objeto.hWnd, &HA1, 13, 0&
        GetWindowRect Objeto.hWnd, MyRect
        LstAncho = MyRect.Right - MyRect.Left
        Objeto.ColumnHeaders.Item(1).Width = LstAncho / 4
        Objeto.ColumnHeaders.Item(2).Width = LstAncho / 4
        Objeto.ColumnHeaders.Item(3).Width = LstAncho / 4
        Objeto.ColumnHeaders.Item(4).Width = LstAncho / 4
      Else
        SendMessage Objeto.hWnd, &HA1, 16, 0&
      End If
    Else
      If Y / Screen.TwipsPerPixelY < Objeto.Height / 2 Then
        SendMessage Objeto.hWnd, &HA1, 14, 0&
      Else
        SendMessage Objeto.hWnd, &HA1, 17, 0&
      End If
    End If
  End If
  If Form1.Mover.Checked = True Then
    SendMessage Objeto.hWnd, &HA1, 2, 0&
  End If
End If

End Function

Public Function LeerDataBase(Path As String)

Dim Extencion As String * 3

Extencion = UCase(Right(Path, 3))

Select Case Extencion
Case UCase("xls")
  LeerExcelDataBase Path
Case UCase("mdb")
  LeerAccessDataBase Path
End Select

End Function
