Attribute VB_Name = "APIS"
Option Explicit
Public LastDirExplore As String

Private Const LB_SETHORIZONTALEXTENT = &H194
Private Const FO_DELETE = &H3
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_ALLOWUNDO = &H40

Private Const FO_MOVE = &H1
Private Const FO_COPY = &H2

Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2 '

Private Const PROCESS_VM_READ As Long = (&H10)
Private Const PROCESS_QUERY_INFORMATION As Long = (&H400)
Private Const PROCESS_TERMINATE = &H1

Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPheaplist = &H1
Private Const TH32CS_SNAPthread = &H4
Private Const TH32CS_SNAPmodule = &H8
Private Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + TH32CS_SNAPthread + TH32CS_SNAPmodule

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 Type SHITEMID
cb As Long
abID As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

Private Type ChooseColor
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Type SHFILEOPTSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As Long
End Type

Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * 260
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OpenFileName) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessageByNum Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal WMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
Private 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
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPTSTRUCT) As Long
Private 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 Declare Function EnumProcesses Lib "PSAPI.DLL" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFilename As String, ByVal nSize As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long

Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

Public Function OpenFileDialog(Optional sFilter As String, Optional HwndPW As Long, Optional ByVal InitialDir As String, Optional DialogTitle As String, Optional MiltiSelect As Boolean, Optional Bufferlong As Integer, Optional InitialFile As String, Optional IniFilterIndex As Long) As String()
Dim OpenFile As OpenFileName, lReturn As Long, LenInitialFile As Long
Dim ListRet() As String, i As Integer, k As Integer
Dim SelList() As String

'Muestra el cuadro de diálogo "Abrir Archivo",
'devuelve una matriz 1xN con las rutas de los archivos seleccionados (donde N es el numero de archivos
'seleccionados)
'En caso de error ó de no haber seleccionado ningún archivo, devuelve una matriz cuyo único elemento
'es una cadena nula
'En indice inferior de la matriz devuelta es 1, el indice superior es N

ReDim ListRet(1 To 1)
OpenFileDialog = ListRet

If Bufferlong = 0 Then Bufferlong = 257
If IniFilterIndex = 0 Then IniFilterIndex = 1
If ScriptObj.ExisteCarpeta(InitialDir) = False Then InitialDir = ""
If InitialDir = "" Then InitialDir = LastDirExplore
If InitialDir = "" Then InitialDir = GetSpecialFolder(&H10)
LenInitialFile = Len(InitialFile)
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = HwndPW
OpenFile.hInstance = App.hInstance
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = IniFilterIndex
If LenInitialFile = 0 Then
OpenFile.lpstrFile = String(Bufferlong, 0)
Else
OpenFile.lpstrFile = InitialFile & String(Bufferlong - LenInitialFile, 0)
End If
OpenFile.nMaxFile = Bufferlong - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = InitialDir
OpenFile.lpstrTitle = DialogTitle
OpenFile.flags = &H80000 Or &H1000 Or &H4
If MiltiSelect = True Then OpenFile.flags = OpenFile.flags Or &H200

lReturn = GetOpenFileName(OpenFile)

If lReturn = 0 Then Exit Function

i = InStr(1, OpenFile.lpstrFile, Chr(0) & Chr(0))
OpenFile.lpstrFile = Left(OpenFile.lpstrFile, i - 1)
SelList = Split(OpenFile.lpstrFile, Chr(0))

If LBound(SelList) = UBound(SelList) Then
ReDim ListRet(1 To 1)
ListRet(1) = SelList(LBound(SelList))
Else
k = 1
ReDim ListRet(1 To UBound(SelList) - LBound(SelList))
For i = LBound(SelList) + 1 To UBound(SelList)
ListRet(k) = SelList(LBound(SelList)) & "\" & SelList(i)
k = k + 1
Next
End If

OpenFileDialog = ListRet
If ListRet(1) <> "" Then LastDirExplore = ScriptObj.DirectorioPadre(ListRet(1)) & "\"
End Function

Public Function SaveFileDialog(Optional DialogTitle As String, Optional ByVal InitialDir As String, Optional Filter As String, Optional InitialFilter As Long, Optional HwndPW As Long, Optional ReplaceConfirm As Boolean, Optional BufferLen As Integer) As String
Dim SFN As OpenFileName, Ret As Long, RutaRet As String
If InitialFilter = 0 Then InitialFilter = 1
If BufferLen = 0 Then BufferLen = 257
If ScriptObj.ExisteCarpeta(InitialDir) = False Then InitialDir = ""
If InitialDir = "" Then InitialDir = LastDirExplore
If InitialDir = "" Then InitialDir = GetSpecialFolder(&H10)

With SFN
.lStructSize = Len(SFN)
.hwndOwner = HwndPW
.hInstance = App.hInstance
.lpstrFilter = Filter
.nFilterIndex = InitialFilter
.lpstrFile = String(BufferLen, 0)
.lpstrInitialDir = InitialDir
.lpstrTitle = DialogTitle
.nMaxFile = BufferLen - 1
.flags = &H4 Or &H80000
If ReplaceConfirm Then .flags = .flags Or &H2
End With

Ret = GetSaveFileName(SFN)
If Ret <> 0 Then
RutaRet = Trim(Replace(SFN.lpstrFile, Chr(0), ""))
LastDirExplore = ScriptObj.DirectorioPadre(RutaRet)
SaveFileDialog = RutaRet
End If
End Function

Public Function GetSpecialFolder(CSIDL As Long) As String
Dim Ret As Long, IDL As ITEMIDLIST, Path As String
Ret = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If Ret = 0 Then
Path$ = Space$(512)
Ret = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
GetSpecialFolder = Left$(Path, InStr(Path, Chr$(0)) - 1)
Exit Function
End If
GetSpecialFolder = ""
End Function

Public Function AddHScroll_listbox(Control As ListBox, LWidth As Long)
SendMessageByNum Control.hWnd, LB_SETHORIZONTALEXTENT, LWidth, 0
End Function

Public Function ColorDialog(WindowHandle As Long, Optional CDFlags As Long, Optional InitialColor As Long = -1) As Long
Dim CC As ChooseColor, lngColDlgResult As Long, bytCustomColorsArray(0 To 16 * 4 - 1) As Byte
Dim intCounter As Integer, glngRGBValue As Long
For intCounter = LBound(bytCustomColorsArray) To UBound(bytCustomColorsArray)
bytCustomColorsArray(intCounter) = 0
Next intCounter
On Error GoTo ErrH
CC.flags = CDFlags
CC.hwndOwner = WindowHandle
CC.lStructSize = Len(CC)
CC.hInstance = 0
CC.lpCustColors = StrConv(bytCustomColorsArray, vbUnicode)
If InitialColor <> -1 Then CC.rgbResult = InitialColor
lngColDlgResult = ChooseColorAPI(CC)
If lngColDlgResult Then
ColorDialog = CC.rgbResult
glngRGBValue = CC.rgbResult
Else: ColorDialog = lngColDlgResult - 1
End If
Exit Function
ErrH:
ColorDialog = -2
End Function

Public Sub APIAbrirArchivo(Ruta As String, Optional hWnd As Long)
'Abre un archivo con su programa asociado
'El proceso es asincronico, la funcion no espera a que que cierre el archivo
Call ShellExecute(hWnd, "open", Ruta, vbNullString, vbNullString, 1)
End Sub

Public Function APIDeletePath(Ruta As String, Optional DelMode As Byte = 0, Optional ByRef Cancelado As Boolean) As Boolean
'Mode=0: Mandar a la papelera de reciclaje, confirmar eliminación y mostrar diálogo de progreso
'Mode=1: Mandar a la papelera de reciclcaje, no confirmar eliminación ni mostrar diálogo de progreso
'Mode=2: Eliminar el archivo, confirmar y mostrar progreso
'Mode=3: Eliminar el archivo, no confirmar ni mostrar progreso
Dim Ret As Long, Struct As SHFILEOPTSTRUCT
Struct.pFrom = Ruta
Struct.wFunc = FO_DELETE
Select Case DelMode
Case Is = 0: Struct.fFlags = FOF_ALLOWUNDO
Case Is = 1: Struct.fFlags = FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_ALLOWUNDO
Case Is = 2:
Case Is = 3: Struct.fFlags = FOF_SILENT Or FOF_NOCONFIRMATION
End Select
Ret = SHFileOperation(Struct)
Cancelado = Struct.fAnyOperationsAborted
APIDeletePath = (Ret = 0)
End Function

Public Function APIMovePath(Ruta As String, Destino As String, Optional MoveMode As Byte = 0) As Boolean
'Mode=0: No confirmar, no mostrar progreso
'Mode=1: Confirmar y mostrar progreso
Dim Ret As Long, Struct As SHFILEOPTSTRUCT
Struct.pFrom = Ruta
Struct.wFunc = FO_MOVE
Struct.pTo = Destino
If MoveMode = 0 Then Struct.fFlags = FOF_SILENT Or FOF_NOCONFIRMATION
Ret = SHFileOperation(Struct)
APIMovePath = (Ret = 0)
End Function

Public Function APICopyPath(Ruta As String, Destino As String, Optional CopyMode As Byte = 0) As Boolean
'Mode=0: No confirmar, no mostrar progreso
'Mode=1: Confirmar y mostrar progreso
Dim Ret As Long, Struct As SHFILEOPTSTRUCT
Struct.pFrom = Ruta
Struct.wFunc = FO_COPY
Struct.pTo = Destino
If CopyMode = 0 Then Struct.fFlags = FOF_SILENT Or FOF_NOCONFIRMATION
Ret = SHFileOperation(Struct)
APICopyPath = (Ret = 0)
End Function

Public Function WindowsAlwaysOnTop(handle As Long, Optional AlwaysOnTop As Boolean = True) As Boolean
On Error GoTo Salir
WindowsAlwaysOnTop = False
If AlwaysOnTop = True Then
If SetWindowPos(handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE) = 0 Then Exit Function
Else
If SetWindowPos(handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE) = 0 Then Exit Function
End If
WindowsAlwaysOnTop = True
Salir:
End Function

Public Function MatarProcesoPorRuta(ByVal Ruta As String, Optional ByRef ProcesosActivos As Integer, Optional ByRef ProcesosTerminados As Integer) As Boolean
'Termina todos los procesos asociados a una ruta
'Devuelve
'   True si todos los procesos fueron terminados o si no se encontró proceso asociado
'   False si al menos un proceso continua activo
'   El número de procesos que fueron finalizados en ProcesosTerminados
'   El número de procesos que continúan activos en ProcesosActivos
Dim IDProcesos(255) As Long, NumProcesos As Long, i As Integer
Dim ProcHandle As Long, RutaProc As String * 512, LongRuta As Long
If EnumProcesses(IDProcesos(0), ByVal 1024&, NumProcesos) = 0 Then Exit Function
NumProcesos = NumProcesos / 4 - 1
Ruta = LCase(Ruta)
ProcesosActivos = 0
ProcesosTerminados = 0
For i = 0 To NumProcesos
    ProcHandle = OpenProcess(ByVal PROCESS_QUERY_INFORMATION + PROCESS_VM_READ + PROCESS_TERMINATE, ByVal 0, ByVal IDProcesos(i))
    If ProcHandle <> 0 Then
        LongRuta = GetModuleFileNameExA(ByVal ProcHandle, ByVal 0, ByVal RutaProc, ByVal 512&)
        If Left(LCase(RutaProc), LongRuta) = Ruta Then
            If TerminateProcess(ByVal ProcHandle, ByVal 0&) <> 0 Then
                ProcesosTerminados = ProcesosTerminados + 1
            Else
                ProcesosActivos = ProcesosActivos + 1
            End If
        End If
        Call CloseHandle(ProcHandle)
    End If
Next
MatarProcesoPorRuta = (ProcesosActivos = 0)
End Function

Public Function BuscarProcesosAsociadosARuta(ByVal Ruta As String, ByRef ListaProcesos() As Long) As Integer
'Busca los procesos asociados a una ruta
'Devuelve:
'   El número de procesos encontrados
'   La lista de IDs de procesos encontrados en ListaProcesos()
Dim IDProcesos(255) As Long, NumProcesos As Long, i As Integer
Dim ProcHandle As Long, RutaProc As String * 512, LongRuta As Long
Dim Encontrados As Integer
If EnumProcesses(IDProcesos(0), ByVal 1024&, NumProcesos) = 0 Then Exit Function
NumProcesos = NumProcesos / 4 - 1
Ruta = LCase(Ruta)
Erase ListaProcesos
For i = 0 To NumProcesos
    ProcHandle = OpenProcess(ByVal PROCESS_QUERY_INFORMATION + PROCESS_VM_READ, ByVal 0, ByVal IDProcesos(i))
    If ProcHandle <> 0 Then
        LongRuta = GetModuleFileNameExA(ByVal ProcHandle, ByVal 0, ByVal RutaProc, ByVal 512&)
        If LCase(Left(RutaProc, LongRuta)) = Ruta Then
            Encontrados = Encontrados + 1
            ReDim Preserve ListaProcesos(1 To Encontrados)
            ListaProcesos(Encontrados) = IDProcesos(i)
        End If
        Call CloseHandle(ProcHandle)
    End If
Next
BuscarProcesosAsociadosARuta = Encontrados
End Function

Public Function GetParentProcessID(procID As Long) As Long
'Busca el proceso padre de un proceso dado su ID
'Devuelve:
'   el ID del proceso padre
'   0 si la función falla o si el proceso no tiene asociado un proceso padre
'procID: el ID del proceso hijo
Dim procEntry As PROCESSENTRY32, hSnap As Long
Dim Ret As Long
hSnap = CreateToolhelp32Snapshot(ByVal TH32CS_SNAPPROCESS, ByVal procID)
If hSnap = -1 Then Exit Function
procEntry.dwSize = Len(procEntry)
Ret = Process32First(hSnap, procEntry)
While procEntry.th32ProcessID <> procID And Ret <> 0: Ret = Process32Next(hSnap, procEntry): Wend
If procEntry.th32ProcessID = procID Then GetParentProcessID = procEntry.th32ParentProcessID
Call CloseHandle(hSnap)
End Function

Public Function MatarProcesoPorID(procID As Long) As Boolean
'Finaliza un proceso dado su ID
'Devuelve True si el proceso fue finalizado
'procID: el ID del proceso
Dim handleProc As Long
handleProc = OpenProcess(ByVal PROCESS_TERMINATE, ByVal 0, ByVal procID)
If handleProc = 0 Then Exit Function
If TerminateProcess(handleProc, ByVal 0&) <> 0 Then MatarProcesoPorID = True
Call CloseHandle(handleProc)
End Function

Public Function AlinearMenuDerecha(hWnd As Long, PosMenu As Long, MenuCaption As String) As Boolean
'Alinea un menú a la derecha de la barra de menús
'hwnd: el Handle de la ventana con el menú
'PosMenu: la posición del menú a alinear
'MenuCaption: el caption del menú a alinear
'Devuelve:
'True si el procedimiento concluye con éxito
Dim hMenu As Long, MenuID As Long
hMenu = GetMenu(hWnd)
MenuID = GetMenuItemID(hMenu, PosMenu)
If ModifyMenu(hMenu, MenuID, &H4000, MenuID, MenuCaption) = 0 Then Exit Function
If DrawMenuBar(hWnd) = 0 Then Exit Function
AlinearMenuDerecha = True
End Function
