Módulos BAS:
Nota del 25/Oct/2006:
Si quieres este mismo efecto de auto completar mientras se escribe para Visual Basic o C# 2003
(.NET 1.x)
sigue este link: Auto completar en Visual Basic y C# 2003
En Visual Basic 2005 y C# 2.0 puedes usar las propiedades AutoComplete y relacionadas, en el
link anterior encontrarás el link al artículo con la explicación (cuando esté publicado).
'------------------------------------------------------------------------------
' Procedimiento para realizar búsqueda en combos ( 2/Abr/98)
' mientras se escribe (auto completar)
'
' ©Guillermo 'guille' Som, 1998-2001
'------------------------------------------------------------------------------
'
' Para usarlo:
' En el Form que contiene el combo en el que se hará el efecto:
'
'Private Sub Combo1_Change(Index As Integer)
' Static YaEstoy As Boolean
'
' On Local Error Resume Next
'
' If Not YaEstoy Then
' YaEstoy = True
' unCombo_Change Combo1(Index).Text, Combo1(Index)
' YaEstoy = False
' End If
' Err = 0
'End Sub
'
'Private Sub Combo1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
' unCombo_KeyDown KeyCode
'End Sub
'
'Private Sub Combo1_KeyPress(Index As Integer, KeyAscii As Integer)
' unCombo_KeyPress KeyAscii
'End Sub
'------------------------------------------------------------------------------
Option Explicit
Dim Combo1Borrado As Boolean
Public Sub unCombo_KeyDown(KeyCode As Integer)
If KeyCode = vbKeyDelete Then
Combo1Borrado = True
Else
Combo1Borrado = False
End If
End Sub
Public Sub unCombo_KeyPress(KeyAscii As Integer)
'si se pulsa Borrar... ignorar la búsqueda al cambiar
If KeyAscii = vbKeyBack Then
Combo1Borrado = True
Else
Combo1Borrado = False
End If
End Sub
Public Sub unCombo_Change(ByVal sText As String, elCombo As ComboBox)
Dim i As Integer, L As Integer
If Not Combo1Borrado Then
L = Len(sText)
With elCombo
For i = 0 To .ListCount - 1
If StrComp(sText, Left$(.List(i), L), 1) = 0 Then
.ListIndex = i
.Text = .List(.ListIndex)
.SelStart = L
.SelLength = Len(.Text) - .SelStart
Exit For
End If
Next
End With
End If
End Sub
gsDBR_bas (módulo para gsDBR.frm)
'------------------------------------------------------------------------------
' gsDBR.bas Módulo para el diálogo de Buscar y Reemplazar
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit
'Flag para usar con el RichTextBox (24/Mar/98)
Dim EsRichTextBox As Boolean
'Nuevas variables para palabra completa y dirección: ( 6/Sep/97)
Global iFFCompleta As Boolean
Global iFFAtras As Boolean
Global Const cFFAc_Accion = 15 'para los valores normales
Global Const cFFAc_Completa = 32 'si se muestra palabra completa
Global Const cFFAc_Atras = 64 'si se muestra la dirección de búsqueda
'
'Para usar procedimientos genéricos de búsqueda (31/Ago/97)
Global LineaEstado As Control
'Constantes para el menú de Edición
Global Const mEdDeshacer = 0
Global Const mEdCortar = 1
Global Const mEdCopiar = 2
Global Const mEdPegar = 3
'Const mEdSep1 = 4
Global Const mEdBuscarActual = 5
Global Const mEdBuscarSigActual = 6
Global Const mEdReemplazarActual = 7
'Const mEdSep2 = 8
Global Const mEdSeleccionarTodo = 9
'
'Constantes para las opciones de búsqueda en el TextBox actual
Global Const CMD_BuscarActual = 101
Global Const CMD_BuscarSigActual = 102
Global Const CMD_ReemplazarActual = 103
Global Const CMD_SeleccionarTodo = 104
'Variables y constantes para buscar/reemplazar
Global sFFBuscar As String
Global sFFPoner As String
Global iFFAccion As Integer
'
'Constantes para la acción a realizar
Global Const cFFAc_Cancelar = True
Global Const cFFAc_IDLE = 0
Global Const cFFAc_Buscar = 1
Global Const cFFAc_BuscarSiguiente = 2
Global Const cFFAc_Reemplazar = 3
Global Const cFFAc_ReemplazarTodo = 4
Global Const cFFAc_Aceptar = 5
'
Global sFFIni As String 'Archivo de configuración
'Funciones Globales del API
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'Declaración de las constantes, para usar con SendMessage/PostMessage
Global Const WM_CUT = &H300
Global Const WM_COPY = &H301
Global Const WM_PASTE = &H302
'Global Const WM_CLEAR = &H303
'
Global Const EM_CANUNDO = &HC6
Global Const EM_UNDO = &HC7
Public Function ActualizarLista(ByVal sTexto As String, cList As Control, Optional vTipoBusqueda, Optional vAddLista) As Long
'Esta función comprobará si el texto indicado existe en la lista
'Si no es así, lo añadirá
'El valor devuelto, será la posición dentro de la lista ó -1 si hay "fallos"
'
'Para buscar en el List/combo usaremos una llamada al API
'(si ya hay una forma de hacerlo, ¿para que re-hacerla?)
'
'Constantes para los combos
Const CB_FINDSTRINGEXACT = &H158
Const CB_FINDSTRING = &H14C
Const CB_SELECTSTRING = &H14D
'Constantes para las Listas
Const LB_FINDSTRINGEXACT = &H1A2 'Busca la cadena exactamente igual
Const LB_FINDSTRING = &H18F 'Busca en cualquier parte de la cadena
Const LB_SELECTSTRING = &H18C 'Busca desde el principio de la cadena
'
Dim lTipoBusqueda As Long
Dim bTipoBusqueda As Integer '0= Exacta, 1= cualquier parte, 2=desde el principio
Dim bAddLista As Boolean
Dim L As Long
'Si se busca palabra completa o parcial,
'por defecto COMPLETA
If IsMissing(vTipoBusqueda) Then
bTipoBusqueda = False
Else
bTipoBusqueda = vTipoBusqueda
End If
'Si se debe añadir o no, por defecto SI
If IsMissing(vAddLista) Then
bAddLista = True
Else
bAddLista = vAddLista
End If
'Si el control es un Combo
If TypeOf cList Is ComboBox Then
If bTipoBusqueda = 1 Then
lTipoBusqueda = CB_FINDSTRING
ElseIf bTipoBusqueda = 2 Then
lTipoBusqueda = CB_SELECTSTRING
Else
lTipoBusqueda = CB_FINDSTRINGEXACT
End If
'Si el control es un list
ElseIf TypeOf cList Is ListBox Then
If bTipoBusqueda = 1 Then
lTipoBusqueda = LB_FINDSTRING
ElseIf bTipoBusqueda = 2 Then
lTipoBusqueda = LB_SELECTSTRING
Else
lTipoBusqueda = LB_FINDSTRINGEXACT
End If
Else
'no es un control List o Combo, salir
ActualizarLista = -1
Exit Function
End If
If cList.ListCount = 0 Then
'Seguro que no está, así que añadirla, si viene al caso...
L = -1
Else
L = SendMessage(cList.hWnd, lTipoBusqueda, -1, ByVal sTexto)
End If
'Si no está, añadirla
If L = -1 Then
If bAddLista Then
'Con el 0 se añade al principio de la lista
cList.AddItem sTexto, 0
L = ActualizarLista(sTexto, cList, bTipoBusqueda, bAddLista)
End If
End If
ActualizarLista = L
End Function
Public Function gsReemplazar(sBuscar As String, sPoner As String, Optional vModo, Optional vCaption) As Integer
'Prepara el diálogo de Reemplazar
Dim iModo As Integer
Dim sCaption As String
If IsMissing(vModo) Then
iModo = cFFAc_Reemplazar
Else
iModo = vModo
End If
If IsMissing(vCaption) Then
sCaption = "Reemplazar"
Else
sCaption = CStr(vCaption)
End If
iFFAccion = cFFAc_IDLE
With gsDBR
'Por ahora no se muestra en reemplazar ( 6/Sep/97)
.chkCompleta.Visible = False
.chkCompleta.Enabled = False
.chkDireccion.Visible = False
.chkDireccion.Enabled = False
.Caption = sCaption
.cmdFindNext.Default = False
.cmdFindNext.Visible = False
.cmdReplaceAll.Default = True
.Combo1(0).Text = sBuscar
.Combo1(1).Text = sPoner
.PosicionarControles
'Mostrar el form y esperar a que se tome una acción
.Show vbModal
'Do
' .Show
' DoEvents
'Loop Until iFFAccion
End With
'Devolver la cadena a reemplazar y buscar
sBuscar = sFFBuscar
sPoner = sFFPoner
'Si tanto buscar como poner están en blanco, devolver cancelar
If Len(Trim$(sBuscar)) = 0 Then
If Len(Trim$(sPoner)) = 0 Then
iFFAccion = cFFAc_Cancelar
End If
End If
'Devolver la acción
gsReemplazar = iFFAccion
End Function
Public Function gsBuscar(sBuscar As String, Optional vModo, Optional vCaption) As Integer
'Prepara el diálogo para buscar
Dim iModo As Integer
Dim sCaption As String
Dim bCompleta As Boolean
Dim bAtras As Boolean
If IsMissing(vModo) Then
iModo = cFFAc_Buscar
bCompleta = False
bAtras = False
Else
bCompleta = vModo And cFFAc_Completa
bAtras = vModo And cFFAc_Atras
'quedarse sólo con los valores normales
iModo = vModo And cFFAc_Accion
End If
'Sólo permitir buscar y buscar-siguiente
Select Case iModo
Case cFFAc_Buscar, cFFAc_BuscarSiguiente
'está bien, no hay nada que hacer
Case Else
iModo = cFFAc_Buscar
End Select
If IsMissing(vCaption) Then
sCaption = "Buscar"
Else
sCaption = CStr(vCaption)
End If
iFFAccion = cFFAc_IDLE
With gsDBR
'Si se muestra la opción de palabra completa
.chkCompleta.Visible = bCompleta
.chkCompleta.Enabled = bCompleta
.chkCompleta = Abs(CInt(iFFCompleta))
'si se muestra la opción de dirección de búsqueda
.chkDireccion.Visible = bAtras
.chkDireccion.Enabled = bAtras
.chkDireccion = Abs(CInt(iFFAtras))
.Caption = sCaption
.cmdReplace.Visible = False
.lblReplace.Visible = False
.cmdReplaceAll.Visible = False
.Combo1(1).Visible = False
.Combo1(1).Enabled = False
.cmdFindNext.Left = .cmdReplaceAll.Left
If iModo = cFFAc_BuscarSiguiente Then
.cmdFindNext.Caption = "Siguiente"
DoEvents
End If
.Combo1(0).Text = sBuscar
.PosicionarControles
'Mostrar el form y esperar a que se tome una acción
.Show vbModal
'Do
' .Show
' DoEvents
'Loop Until iFFAccion
End With
'Devolver la cadena seleccionada/introducida
sBuscar = sFFBuscar
'Devolver la acción
gsBuscar = iFFAccion
End Function
Public Sub gsPedirUnValor(spuvTitulo As String, spuvMensaje As String, spuvPregunta As String, spuvValor As String, spuvBoton As String)
'Rutina de propósito general para pedir un valor (00.22 23/May/96)
With gsDBR
.chkCompleta.Visible = False
.chkCompleta.Enabled = False
.chkDireccion.Visible = False
.chkDireccion.Enabled = False
.Caption = spuvTitulo
.Combo1(0).Visible = False
.lblBuscar.Width = .ScaleWidth - 120
.lblBuscar = spuvMensaje
.Combo1(0).Visible = False
.cmdReplace.Visible = False
.cmdFindNext.Default = False
.cmdFindNext.Visible = False
.lblReplace = spuvPregunta
.cmdReplaceAll.Default = True
.cmdReplaceAll.Caption = spuvBoton
If Len(Trim$(spuvValor)) Then
.Combo1(1).Text = spuvValor
Else
If .Combo1(1).ListCount Then
.Combo1(1).ListIndex = 0
End If
End If
.PosicionarControles
.Show vbModal
End With
spuvValor = sFFPoner
End Sub
Private Sub AccionBuscar(Index As Integer)
'--------------------------------------------------------------
'Procedimiento genérico para realizar búsquedas (31/Ago/97)
'
'Valores necesarios:
' LineaEstado un control para mostrar mensajes temporales
' CMD_xxx Apuntará a los índices del menú de edición
' que deberá tener estas opciones:
' Deshacer
' Cortar
' Copiar
' Pegar
' ---
' Buscar
' Buscar Siguiente
' Reemplazar
' ---
' Seleccionar Todo
'
'--------------------------------------------------------------
Static sBuscar As String
Static lngUltimaPos As Long
Dim lngPosActual As Long
Dim sTmp As String
Dim tText As Control
Set tText = Screen.ActiveForm.ActiveControl
'Si no es un cuadro de texto, salir
If Not (TypeOf tText Is TextBox) And Not (TypeOf tText Is RichTextBox) Then
Exit Sub
End If
LineaEstado.Tag = LineaEstado
'para procesar las otras acciones adicionales (15/Abr/97)
Select Case Index
Case CMD_BuscarActual
'Si hay texto seleccionado...
With tText
If .SelLength > 0 Then
sBuscar = Trim$(.SelText)
End If
End With
'Para "personalizar" la sección de búsqueda...
gsDBR.Combo1(0).Tag = "Buscar_" & sUsuario
If gsBuscar(sBuscar, , "Buscar en el campo actual") > cFFAc_IDLE Then
sBuscar = Trim$(sBuscar)
If Len(sBuscar) Then
LineaEstado = "Buscando en el campo actual " & sBuscar & "..."
DoEvents
lngUltimaPos = 0&
lngPosActual = InStr(tText, sBuscar)
If lngPosActual Then
lngUltimaPos = lngPosActual + 1
'posicionarse en esa palabra:
With tText
.SelStart = lngPosActual - 1
.SelLength = Len(sBuscar)
End With
Else
Beep
MsgBox "No se ha hallado el texto buscado", vbOK + vbInformation, "Buscar en el campo actual"
End If
'posicionarse en ese control
tText.SetFocus
End If
End If
Case CMD_BuscarSigActual
'Si no hay nada hallado con anterioridad
'o no se ha procesado la última búsqueda en este control
If Len(sBuscar) = 0 Or lngUltimaPos = 0& Then
AccionBuscar CMD_BuscarActual
Else
LineaEstado = "Buscando " & sBuscar & "..."
DoEvents
lngPosActual = InStr(lngUltimaPos, tText, sBuscar)
If lngPosActual Then
lngUltimaPos = lngPosActual + Len(sBuscar)
'posicionarse en esa palabra:
With tText
.SelStart = lngPosActual - 1
.SelLength = Len(sBuscar)
End With
Else
lngUltimaPos = 1&
Beep
MsgBox "No se ha hallado el texto buscado.", vbOK + vbInformation, "Buscar en el campo actual"
End If
'posicionarse en ese control
tText.SetFocus
End If
Case CMD_ReemplazarActual
'Si hay texto seleccionado...
With tText
If .SelLength > 0 Then
sBuscar = Trim$(.SelText)
End If
End With
sFFBuscar = sBuscar
sFFPoner = ""
'Personalizar las secciones de buscar/reemplazar
gsDBR.Combo1(0).Tag = "Buscar_" & sUsuario
gsDBR.Combo1(1).Tag = "Reemplazar_" & sUsuario
iFFAccion = gsReemplazar(sFFBuscar, sFFPoner, , "Reemplazar en el campo actual")
If iFFAccion <> cFFAc_Cancelar Then
elForm.MousePointer = vbHourglass
DoEvents
sBuscar = Trim$(sFFBuscar)
If Len(sFFBuscar) <> 0 And Len(sFFPoner) <> 0 Then
If iFFAccion = cFFAc_Reemplazar Or iFFAccion = cFFAc_ReemplazarTodo Then
LineaEstado = "Reemplazando " & sBuscar & "..."
DoEvents
lngUltimaPos = 0&
lngPosActual = InStr(tText, sBuscar)
If lngPosActual Then
lngUltimaPos = lngPosActual + Len(sBuscar)
sTmp = tText 'Text1(ControlActual).Text
sTmp = Left$(sTmp, lngPosActual - 1) & sFFPoner & Mid$(sTmp, lngPosActual + Len(sFFBuscar))
tText = sTmp
'Si sólo es reemplazar uno...
If iFFAccion = cFFAc_Reemplazar Then Exit Sub
'Cambiar todas las coincidencias en el mísmo text
lngUltimaPos = 1
Do
lngPosActual = InStr(lngUltimaPos, sTmp, sFFBuscar)
If lngPosActual Then
lngUltimaPos = lngPosActual + 1
sTmp = Left$(sTmp, lngPosActual - 1) & sFFPoner & Mid$(sTmp, lngPosActual + Len(sFFBuscar))
tText = sTmp
End If
Loop While lngPosActual
DoEvents
Else
Beep
MsgBox "No se ha hallado el texto buscado.", vbOK + vbInformation, "Buscar en el campo actual"
End If
'Si se ha reemplazado to, no debe estar esta palabra...
lngUltimaPos = 0&
End If
End If
elForm.MousePointer = vbDefault
DoEvents
End If
Case CMD_SeleccionarTodo
With tText
.SelStart = 0
.SelLength = Len(.Text)
End With
End Select
LineaEstado = LineaEstado.Tag
End Sub
Public Sub menuEdi()
'Habilitar las opciones disponibles
Dim Habilitada As Boolean
Dim i As Integer
'los separadores no se pueden deshabilitar!!!
On Local Error Resume Next
EsRichTextBox = False
'Asegurarnos que es un textbox
If TypeOf Screen.ActiveForm.ActiveControl Is TextBox Then
'ok, todo bien...
Habilitada = True
ElseIf TypeOf Screen.ActiveForm.ActiveControl Is RichTextBox Then
Habilitada = True
EsRichTextBox = True
Else
'no poder hacer estas cosas
Habilitada = False
End If
For i = mEdDeshacer To mEdSeleccionarTodo
elForm!mnuEdicion(i).Enabled = Habilitada
Next
'Algunos chequeos para las opciones de edición:
If Habilitada Then
'Si no se puede deshacer, no habilitarlo
If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_CANUNDO, 0, ByVal 0&) Then
elForm!mnuEdicion(mEdDeshacer).Enabled = True
Else
elForm!mnuEdicion(mEdDeshacer).Enabled = False
End If
'comprobar si hay algo que pegar...
If Clipboard.GetFormat(vbCFText) Then
elForm!mnuEdicion(mEdPegar).Enabled = True
Else
elForm!mnuEdicion(mEdPegar).Enabled = False
End If
End If
Err = 0
On Local Error GoTo 0
End Sub
Public Sub menuEdicion(Index As Integer)
Dim sTmp As String
Select Case Index
Case mEdDeshacer
'-------------------------------------------------------------
' IMPORTANTE:
' En ambos casos se podría usar SendMessage,
' pero en el caso de EM_CANUNDO, NO serviría PostMessage,
' porque esta función sólo devuelve un valor de
' si se ha puesto o no en la cola de mensajes de windows.
'-------------------------------------------------------------
'Si se puede deshacer...
If SendMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_CANUNDO, 0, ByVal 0&) Then
'Deshacerlo!
Call PostMessage(Screen.ActiveForm.ActiveControl.hWnd, EM_UNDO, 0, ByVal 0&)
End If
Case mEdCopiar
Call PostMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_COPY, 0, ByVal 0&)
' ' ( 6/May/98)
' 'Si se copia desde el RichTextBox, algunas aplicaciones
' 'se hacen un lio..
' If Screen.ActiveForm.ActiveControl.Name = "RichTextBox1" Then
' 'sTmp = Clipboard.GetText(vbCFRTF)
' sTmp = Clipboard.GetText(vbCFText)
' If Len(sTmp) Then
' Clipboard.SetText sTmp, vbCFText
' End If
' End If
' 'Pues no sirve... ni aún usando Control+C
'
Case mEdCortar
Call PostMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_CUT, 0, ByVal 0&)
Case mEdPegar
Call PostMessage(Screen.ActiveForm.ActiveControl.hWnd, WM_PASTE, 0, ByVal 0&)
Case mEdBuscarActual
AccionBuscar CMD_BuscarActual
Case mEdBuscarSigActual
AccionBuscar CMD_BuscarSigActual
Case mEdReemplazarActual
AccionBuscar CMD_ReemplazarActual
Case mEdSeleccionarTodo
AccionBuscar CMD_SeleccionarTodo
End Select
End Sub
gsImprimir_Bas (módulo para el formulario
Imprimir.frm)
'------------------------------------------------------------------------------
' Módulo con función genérica para imprimir (31/Ago/97)
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit
Public Sub gsImprimir(qControl As Control)
'--------------------------------------------------------------
'Procedimiento genérico para imprimir (31/Ago/97)
'
'Entrada:
' qControl control a imprimir (TextBox, ListBox)
'
'--------------------------------------------------------------
Const MAXLINEA = 136& ' Número de caracteres máximos por línea
'
Dim nFicSal As Long
Dim sLpt As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim sTmp As String
Dim sImpresora As String
Dim sngFS As Single
Dim sFN As String
Dim bDirecto As Boolean
Dim bCourierNew As Boolean
Dim nCourierNew As Currency
Dim tPrinter As Printer
Dim tOrientacion As Long
Dim tOrientacionAnt As Long
'
Dim L1 As Long, L2 As Long
Const EM_GETLINECOUNT = &HBA
Const EM_LINEINDEX = &HBB
Const EM_LINELENGTH = &HC1
'On Local Error Resume Next 'GoTo ErrorImprimiendo
Set tPrinter = Printer
'Seleccionar impresora
Dim frmImpresora As Imprimir 'Form
'
iFFAccion = cFFAc_IDLE
'
' Cargar la ventana de selección de impresora
Set frmImpresora = New Imprimir
With frmImpresora
' Mostrar el Form
' Controlador de Windows
.OptMétodoImpresión(0) = 1
.chkCourierNew.Enabled = True
' Imprimir directamente
.OptMétodoImpresión(1) = 0
.Show vbModal
If iFFAccion <> cFFAc_Cancelar Then
sLpt = .sLpt
' If Right$(sLpt, 1) <> ":" Then
' sLpt = sLpt & ":"
' End If
bDirecto = .OptMétodoImpresión(1)
bCourierNew = .chkCourierNew
nCourierNew = .txtCourierNew
'Seleccionar la impresora como predeterminada
'Dim tPrinter2 As Printer
'For Each tPrinter2 In Printers
' If tPrinter2.DeviceName = .CboImpresoras.Text Then
' Set Printer = tPrinter2
' Exit For
' End If
'Next
Set tPrinter = Printer
If .chkOrientacion Then
tOrientacionAnt = tPrinter.Orientation
If .optOrientacion(0) Then
tOrientacion = vbPRORPortrait
Else
tOrientacion = vbPRORLandscape
End If
tPrinter.Orientation = tOrientacion
End If
End If
End With
Unload frmImpresora
Set frmImpresora = Nothing
If iFFAccion = cFFAc_Cancelar Then Exit Sub
'If Right$(sLpt, 1) = ":" Then
' sLpt = Left$(sLpt, Len(sLpt) - 1)
'End If
'
If TypeOf qControl Is ListBox Then
k = qControl.ListCount
Else
' Número de líneas del TextBox
k = SendMessage(qControl.hWnd, EM_GETLINECOUNT, 0, 0&)
End If
If bDirecto Then
' Imprimir directamente...
j = 0
nFicSal = FreeFile
Open sLpt For Output As nFicSal
Print #nFicSal, Chr$(15); 'Letra pequeña
Else
' Usar controlador de Windows
sngFS = tPrinter.FontSize
sFN = tPrinter.FontName
'If MsgBox("¿Quieres Imprimir con Courier New 8 puntos?", 4 + 32, "Imprimir") = 6 Then
If bCourierNew Then
tPrinter.FontSize = nCourierNew ' 8
tPrinter.FontName = "Courier New"
End If
If Err Then Err = 0
tPrinter.Print ""
tPrinter.Print ""
End If
For i = 0 To k - 1
DoEvents
If iFFAccion = cFFAc_Cancelar Then Exit For
'Caption = "Imprimiendo " & i + 1 & " de " & k
If TypeOf qControl Is ListBox Then
If bDirecto Then
Print #nFicSal, Left$(qControl.List(i), MAXLINEA)
Else
tPrinter.Print Left$(qControl.List(i), MAXLINEA)
End If
Else
' Primer carácter de la línea actual
L1 = SendMessage(qControl.hWnd, EM_LINEINDEX, i, 0&) + 1
' Longitud de la línea actual
L2 = SendMessage(qControl.hWnd, EM_LINELENGTH, L1, 0&)
If L2 > MAXLINEA Then L2 = MAXLINEA
If bDirecto Then
Print #nFicSal, Mid$(qControl.Text, L1, L2)
j = j + 1
' cada 60 líneas en una página
If j = 60 Then
Print #nFicSal, Chr$(12);
j = 0
End If
Else
tPrinter.Print Mid$(qControl.Text, L1, L2)
End If
End If
Next
If bDirecto Then
If j Then
Print #nFicSal, Chr$(12);
End If
Print #nFicSal, Chr$(18);
Close nFicSal
Else
tPrinter.EndDoc
' restaurar la fuente anterior
tPrinter.FontSize = sngFS
tPrinter.FontName = sFN
End If
' Restaurar la orientación anterior del papel
If tOrientacionAnt Then
tPrinter.Orientation = tOrientacionAnt
End If
End Sub
Public Sub gsImprimir1(qControl As Control, Optional vLPT, Optional vDirecto)
'--------------------------------------------------------------
'Procedimiento genérico para imprimir (31/Ago/97)
'
'Entrada:
' qControl control a imprimir (TextBox, ListBox)
' vLPT Impresora de salida, sólo para impresión directa
' vDirecto Si se imprime directamente o se usa el controlador
'--------------------------------------------------------------
Const MAXLINEA = 136 'Número de caracteres máximos por línea
Dim nFicSal As Integer
Dim sLpt As String
Dim i As Long
Dim j As Integer
Dim k As Long
Dim sTmp As String
Dim sImpresora As String
Dim bDirecto As Boolean
Dim tPrinter As Printer
Dim L1&, L2&
Const EM_GETLINECOUNT = &HBA
Const EM_LINEINDEX = &HBB
Const EM_LINELENGTH = &HC1
Set tPrinter = Printer
'El port de impresora a usar
If IsMissing(vLPT) Then 'Si no se especifica,
sLpt = "LPT1:" 'usar LPT1:
Else
sLpt = CStr(vLPT)
End If
'Si se va a imprimir directamente en el puerto
'o se va a usar el controlador de Windows
If IsMissing(vDirecto) Then 'Si no se especifica,
bDirecto = False 'usar el controlador de Windows
Else
bDirecto = CBool(vDirecto)
End If
'Quitarle los dos puntos, si lo tiene,
'seguramente no es necesario, pero...
If Right$(sLpt, 1) = ":" Then
sLpt = Left$(sLpt, Len(sLpt) - 1)
End If
If TypeOf qControl Is ListBox Then
'Número de items en el listbox
k = qControl.ListCount
Else
'Número de líneas del TextBox
k = SendMessage(qControl.hWnd, EM_GETLINECOUNT, 0, 0&)
End If
If bDirecto Then
'Imprimir directamente...
j = 0
nFicSal = FreeFile
'Abrir el puerto de impresora para salida...
Open sLpt For Output As nFicSal
Print #nFicSal, Chr$(15); 'Letra pequeña
Else
'Usar controlador de Windows
tPrinter.Print ""
tPrinter.Print ""
End If
'Se imprimirá cada una de las líneas del listbox o del textbox
'-------------------------------------------------------------
'En este último caso no sería necesario,
'ya que se puede imprimir TODO de una vez, usando esto:
'Printer.Print qControl.Text 'usando el controlador
'Print #nFicSal, qControl.Text 'imprimiendo directamente
'-------------------------------------------------------------
For i = 0 To k - 1
DoEvents
If TypeOf qControl Is ListBox Then
If bDirecto Then
Print #nFicSal, Left$(qControl.List(i), MAXLINEA)
Else
tPrinter.Print Left$(qControl.List(i), MAXLINEA)
End If
Else
'Primer carácter de la línea actual
L1 = SendMessage(qControl.hWnd, EM_LINEINDEX, i, 0&) + 1
'Longitud de la línea actual
L2 = SendMessage(qControl.hWnd, EM_LINELENGTH, L1, 0&)
If L2 > MAXLINEA Then L2 = MAXLINEA
If bDirecto Then
Print #nFicSal, Mid$(qControl.Text, L1, L2)
j = j + 1
'cada 60 líneas en una página
If j = 60 Then
Print #nFicSal, Chr$(12);
j = 0
End If
Else
tPrinter.Print Mid$(qControl.Text, L1, L2)
End If
End If
Next
If bDirecto Then
'Restaurar el tamaño de la fuente a normal
Print #nFicSal, Chr$(18);
'Si j vale CERO, ya se imprimió un salto de página
'en caso contrario, echar la hoja fuera
If j Then
Print #nFicSal, Chr$(12);
End If
Close nFicSal
Else
tPrinter.EndDoc
End If
End Sub
MgsNotas (módulo para gsNotas)
'------------------------------------------------------------------------------
' glbNotas Módulo para las declaraciones globales (28/Feb/97)
'
' Revisado: 01/Oct/2001
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
Option Explicit
Public gCD As cgsFileOp ' Para manejar los ficheros INIs y otras cosas
' Dependiendo del proveedor, el tipo de datos a usar será diferente
Public DataProvider As String
Public Cnn As ADODB.Connection ' La conexión para acceder a la base de datos
'
Global gNoCargar As Boolean ' Poder seleccionar otra (10/Nov/00)
' base sin procesar la línea de comandos
Global Const MaxApartados As Long = 7 ' Número máximo de apartados
Global asApartados() As String ' Las imágenes de los apartados
Private pNumApartados As Long ' Número de apartados (07/Ago/00)
Global sClasif As String ' orden de clasificación
Global NumCampos As Long ' Numero de campos
Global elForm As gsNotas 'Form
' Tipo para los fields (campos) de la base de datos
Type Campo_t
Nombre As String ' Name
Tipo As Long ' Type
Tamaño As Long ' Size
Anterior As String ' Dato anterior
End Type
Global Campos() As Campo_t ' Para el manejo de los campos
Global sSepFecha As String ' El separador de las fechas
Global sFicIni As String ' Fichero de configuración
Global sUsuario As String ' Nombre del usuario actual
Global sBase As String ' Nombre de la base
Global sTabla As String ' Nombre de la tabla (10/Abr/97)
Public Function AjustarFecha(ByVal sFecha As String) As String
' Ajustar la cadena introducida a formato de fecha (27/Abr/01)
Dim i As Long
Dim s As String
'
If sFecha = "" Then
AjustarFecha = ""
Exit Function
End If
'
'On Error Resume Next
On Error GoTo 0
'
' Comprobar si se usan puntos como separador
' si es así, cambiarlos por /
Do
i = InStr(sFecha, ".")
If i Then
Mid$(sFecha, i, 1) = "/"
End If
Loop While i
'
' Comprobar si se usan - como separador
' si es así, cambiarlos por /
Do
i = InStr(sFecha, "-")
If i Then
Mid$(sFecha, i, 1) = "/"
End If
Loop While i
'
s = ""
Do
i = InStr(sFecha, "/")
If i Then
s = s & Right$("0" & Left$(sFecha, i - 1), 2) & "/"
sFecha = Mid$(sFecha, i + 1)
End If
Loop While i
sFecha = s & sFecha
'
If InStr(sFecha, "/") Then
If Len(sFecha) = 5 Then
' Si es igual a 5 caracteres, es que falta el año
sFecha = sFecha & "/"
ElseIf Len(sFecha) < 3 Then
' Si es menor de 3 caracteres es que falta el mes
sFecha = sFecha & "/" & CStr(Month(Now)) & "/"
End If
ElseIf Len(sFecha) < 3 Then
sFecha = sFecha & "/" & CStr(Month(Now)) & "/"
Else
s = ""
For i = 1 To 2
s = s & "/" & Mid$(sFecha, (i - 1) * 2 + 1, 2)
Next
s = s & "/" & Mid$(sFecha, 5)
sFecha = s
End If
sFecha = Trim$(sFecha)
'
' Comprobar si tiene una barra al principio, si es así, quitarla
If Left$(sFecha, 1) = "/" Then
sFecha = Mid$(sFecha, 2)
End If
' Si tiene una barra al final, es que falta el año
If Right$(sFecha, 1) = "/" Then
sFecha = sFecha & CStr(Year(Now))
End If
'
' Convertir la fecha, por si no se especifican todos los caracteres
' Nota: Aquí puedes usar el formato que más te apetezca
sFecha = Format$(sFecha, "dd/mm/yyyy")
'
' ' Si no es una fecha correcta...
' If IsDate(sFecha) = False Then
' AjustarFecha = sFecha
' Else
' AjustarFecha = sFecha
' End If
'
Err = 0
'
AjustarFecha = sFecha
End Function
Public Property Get dbByte() As Long
' Devuelve el valor para un campo Byte, dependiendo del proveedor
dbByte = adUnsignedTinyInt
End Property
Public Sub CrearConexion(ByRef Cnn As ADODB.Connection, _
Optional ByVal CrearSiempre As Boolean = False)
' Crear la conexión a la base de datos, (01/Oct/01)
' Se intenta conectar con la cadena de OLEDB.4.0, si da error,
' se intentará con OLEDB.3.51
'
' Intentarlo primero con OLEDB.4.0 para que sea compatible con Access 2000
If DataProvider = "" Then
DataProvider = "Microsoft.Jet.OLEDB.4.0"
End If
'
' El nombre de la base ya está asignado en sBase
'
If Cnn Is Nothing Then
CrearSiempre = True
End If
'
If CrearSiempre Then
' Crear los objetos
Set Cnn = New ADODB.Connection
'
On Error Resume Next
'
' Para usar con password (28/Ago/01)
' Probar primero con OLEDB.4.0 (31/Ago/01)
Cnn.Open "Provider=" & DataProvider & "; " & _
"Data Source=" & sBase & ";"
'& _
"Jet OLEDB:Database Password=xxx"
If Err Then
Err = 0
DataProvider = "Microsoft.Jet.OLEDB.3.51"
' Si da error con el 4.0, probar con el 3.51 (31/Ago/01)
Cnn.Open "Provider=" & DataProvider & "; " & _
"Data Source=" & sBase & ";"
'& _
"Jet OLEDB:Database Password=xxx"
' Si tampoco... avisar del error
If Err Then
MsgBox "ERROR al crear la conexión a la base de datos:" & vbCrLf & _
Err.Number & " " & Err.Description & vbCrLf & vbCrLf & _
"Toma nota del error y avisa a Guillermo."
End If
End If
'
Err = 0
End If
End Sub
Public Property Get dbDate() As Long
' Devuelve el valor para un campo Date, es el mismo valor para todos los proveedores
dbDate = adDate
End Property
Public Property Get dbText() As Long
' Devuelve el valor para un campo Text, dependiendo del proveedor
Select Case DataProvider
Case "Microsoft.Jet.OLEDB.3.51"
dbText = adVarChar
Case "Microsoft.Jet.OLEDB.4.0"
dbText = adVarWChar
End Select
End Property
Public Function QuitarCaracterEx(ByVal sValor As String, ByVal sCaracter As String, Optional ByVal sPoner) As String
'--------------------------------------------------------------
' CAmbiar/Quitar caracteres (17/Sep/97)
' Si se especifica sPoner, se cambiará por ese carácter
'
'Esta versión permite cambiar los caracteres (17/Sep/97)
'y sustituirlos por el/los indicados
'a diferencia de QuitarCaracter, no se buscan uno a uno,
'sino todos juntos
'--------------------------------------------------------------
Dim i As Long
Dim sCh As String
Dim bPoner As Boolean
Dim iLen As Integer
bPoner = False
If Not IsMissing(sPoner) Then
sCh = sPoner
bPoner = True
End If
iLen = Len(sCaracter)
i = 1
Do While i <= Len(sValor)
If Mid$(sValor, i, iLen) = sCaracter Then
If bPoner Then
sValor = Left$(sValor, i - 1) & sCh & Mid$(sValor, i + iLen)
i = i - 1
Else
sValor = Left$(sValor, i - 1) & Mid$(sValor, i + iLen)
End If
End If
i = i + 1
Loop
QuitarCaracterEx = sValor
End Function
Public Function QuitarCaracter(ByVal sValor As String, Optional ByVal vCaracter, Optional ByVal sPoner) As String
'----------------------------------------------
' Quitar los símbolos ( 5/Jun/96)
' Si se especifica sPoner, se cambiará por ese carácter (26/Abr/97)
'----------------------------------------------
Dim i As Long
Dim j As Long
Dim sTmp As String
Dim sCaracter$
Dim sCh$, bPoner As Boolean
If IsMissing(vCaracter) Then
sCaracter = "., "
Else
sCaracter = vCaracter
End If
bPoner = False
If Not IsMissing(sPoner) Then
sCh = sPoner
bPoner = True
End If
sTmp = ""
For i = 1 To Len(sValor)
If InStr(sCaracter, Mid$(sValor, i, 1)) = 0 Then
sTmp = sTmp & Mid$(sValor, i, 1)
Else
If bPoner Then
sTmp = sTmp & sCh
End If
End If
Next
QuitarCaracter = sTmp
End Function
Public Sub SplitPath(ByVal sTodo As String, sPath As String, Optional vNombre, Optional vExt)
'----------------------------------------------------------------
'Divide el nombre recibido en la ruta, nombre y extensión
'(c)Guillermo Som, 1997 ( 1/Mar/97)
'
'Esta rutina aceptará los siguientes parámetros:
'sTodo Valor de entrada con la ruta completa
'Devolverá la información en:
'sPath Ruta completa, incluida la unidad
'vNombre Nombre del archivo incluida la extensión
'vExt Extensión del archivo
'
'Los parámetros opcionales sólo se usarán si se han especificado
'----------------------------------------------------------------
Dim bNombre As Boolean 'Flag para saber si hay que devolver el nombre
Dim i As Integer
If Not IsMissing(vNombre) Then
bNombre = True
vNombre = sTodo
End If
If Not IsMissing(vExt) Then
vExt = ""
i = InStr(sTodo, ".")
If i Then
vExt = Mid$(sTodo, i + 1)
End If
End If
sPath = ""
'Asignar el path
For i = Len(sTodo) To 1 Step -1
If Mid$(sTodo, i, 1) = "\" Then
sPath = Left$(sTodo, i - 1)
'Si hay que devolver el nombre
If bNombre Then
vNombre = Mid$(sTodo, i + 1)
End If
Exit For
End If
Next
End Sub
Public Property Get NumApartados() As Long
' Devolver el número almacenado
NumApartados = pNumApartados
End Property
Public Property Let NumApartados(ByVal NewValue As Long)
' Asignar el nuevo valor de apartados (07/Ago/00)
' Aquí se redimensionará el array con las imágenes
If NewValue > MaxApartados Then NewValue = MaxApartados
pNumApartados = NewValue
If pNumApartados > 0 Then
ReDim Preserve asApartados(0 To pNumApartados - 1)
End If
End Property
Public Property Get dbMemo() As Long
' Devuelve el valor para un campo Memo, dependiendo del proveedor
Select Case DataProvider
Case "Microsoft.Jet.OLEDB.3.51"
dbMemo = adLongVarChar
Case "Microsoft.Jet.OLEDB.4.0"
dbMemo = adLongVarWChar
End Select
End Property
Módulos de clases:
cgsFileOP (colección de rutinas y funciones
para manejo de ficheros, etc.)
'------------------------------------------------------------------------------
' Clase para entrada/salida de ficheros (27/Oct/97)
'
' Últimas revisiones: 13/Abr/98
' 26/Dic/99
' 17/Jul/00
' 09/Feb/01
' 04/Abr/01 Añadida la constante BIF_BROWSEINCLUDEFILES
' 03/May/01 Añadida la función AppPath
' 20/May/01 Añadida la función ShowPrinter y ShowColor
' 24/May/01 Algunos retoques en ShowPrinter
' 31/Jul/01 Nueva función: AppShow
' 03/Ago/01 Nueva función: ExecCmdPipe
' 26/Sep/01 Nuevas funciones de manejo de ficheros INI:
' IniDeleteKey, IniDeleteSection, IniGet, IniGetSection,
' IniGetSections, IniWrite
' 09/Oct/01 Modificada el método NameFromFileName
'
' ©Guillermo 'guille' Som, 1997-2001
'------------------------------------------------------------------------------
'
' Métodos añadidos el 03/Ago/2001:
' ExecCmdPipe Ejecutar un comando y capturar la salida del programa
'
' Métodos añadidos el 31/Jul/2001:
' AppShow Activar la aplicación con el Caption indicado
'
' Métodos añadidos el 17/Jul/2000:
' PathFromFileName Devuelve sólo el path del fichero indicado
' NameFromFileName Devuelve el nombre y extensión de un fichero
' ExtFromFileName Devuelve la extensión del fichero indicado
'
' Métodos añadidos el 26/Dic/1999:
' GetLongFilename Convertir a un nombre largo
' QuitarComillasDobles Quitar las comillas dobles que haya en una cadena
'
'------------------------------------------------------------------------------
'La mayoría de los métodos están sacados de las Knowledge de Microsoft
'pero adaptados/mejorados por un servidor... 8-)
'------------------------------------------------------------------------------
'
'Esta clase incluye los siguientes métodos:
' Un archivo origen y/o uno de destino
' FileCopy para copiar
' FileMove para mover
' FileRename para renombrar
'
' FileDelete Sólo el archivo a borrar
'
' FilesCopy Varios archivos a un directorio
' FilesMove NOTA: el último valor será
' FilesRename el directorio de destino
'
' FilesDelete Uno varios archivos a borrar
'
' FileExist Comprueba si existe un archivo (no lo busca)
' FolderExist Comprueba si existe un directorio (no lo busca)
'
' FileFind Busca coincidencias de la especificación de archivo, en el directorio (opcional) indicado
' FileFindAll Devuelve una colección de archivos que coincidan con la especificación de búsqueda, NULL si no halla ninguno
' FileFindCustom Customiza la forma de buscar y lo que se debe buscar
'
' FolderFind Busca coincidencias de la carpeta
' FolderFindAll Devuelve una colección con todos los directorios que cumplan la especificación
'
' FileRead o OpenFile Lee un archivo y lo guarda en una cadena
' FileSave o SaveFile Graba el contenido de una cadena en un archivo
' ShowOpen Muestra el diálogo de abrir archivos
' ShowSave Muestra el diálogo de guardar archivos
' ShowPrinter Muestra el diálogo de Imprimir y seleccionar impresora
' ShowColor Muestra el diálogo de seleccionar colores
'
' BrowseForFolder Para seleccionar un directorio
'- BrowseForFile
'
' FileOperationDescription
' Devuelve una cadena con la descripción
' de la acción realizada, para usar con el evento Done
'
'Otros métodos:
' AgregarALista Añade a una lista una serie de archivos
' AgregarAText Añade a un textbox una serie de archivos, los separa por comas
' QuitarCaracterEx Quitar/cambiar caracteres de una cadena
'
' ExecCmd Ejecuta un comando y espera a que termine
' AddBackSlash Añade \ a un nombre, si no la tiene
' QuitarBackSlash Quita el \ del path introducido...
' RTrimNull Devuelve una cadena normal de una cadena terminada en NULL
'
' GetSetting Leer de un archivo INI
' SaveSetting Escribir en un archivo INI
'
' SplitPath Divide una ruta en Path, File y Extensión
' AddPath Añade el path indicado si no tiene
'
'Las propiedades son:
' Flags
' FilesOnly
' NoConfirmation
' NoConfirmMKDIR
' RenameOnCollision
' Silent
' SimpleProgress
'
' (además de las de los diálogos comunes, ver más abajo)
'
'Los eventos producidos serán:
' Done Una vez terminada la operación
'--------------------------------------------------------------
Option Explicit
Option Compare Text
Public Color As Long
'
Public hDC As Long
Public FromPage As Long
Public ToPage As Long
Public MinPage As Long
Public MaxPage As Long
Public Copies As Long
'
Public Flags As eOFN
'Constantes para la operación realizada
Public Enum eFileOperation
eFileCopy = 1
eFileMove
eFileRename
eFileDelete
eFileFindFirst
eFileFindNext
eFileExist
eFolderExist
eFileRead
eFileSave
eBrowseForFolder
eFileFind
End Enum
'Indicará que ha terminado, el valor de error estará en Success
'el tipo de operación realizada en FileOperation
Public Event Done(ByVal Success As Long, ByVal FileOperation As eFileOperation)
'
'------------------------------------------------------------------------------
' Constantes
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
' Para la función BrowseForFolders (04/Dic/00)
'------------------------------------------------------------------------------
'
Public Enum eBIF
BIF_RETURNONLYFSDIRS = &H1 ' Sólo directorios del sistema
BIF_DONTGOBELOWDOMAIN = &H2 ' No incluir carpetas de red
BIF_STATUSTEXT = &H4 '
BIF_RETURNFSANCESTORS = &H8 '
BIF_BROWSEFORCOMPUTER = &H1000 ' Buscar PCs
BIF_BROWSEFORPRINTER = &H2000 ' Buscar impresoras
BIF_BROWSEINCLUDEFILES = &H4000& ' Incluir los ficheros (04/Abr/01)
' (esta constante no estaba asignada)
End Enum
' Valores para usar con pIDLRoot
'Public Enum ShellSpecialFolderConstants
' ssfDESKTOP = &H0
' ssfPROGRAMS = &H2
' ssfCONTROLS = &H3
' ssfPRINTERS = &H4
' ssfPERSONAL = &H5
' ssfFAVORITES = &H6
' ssfSTARTUP = &H7
' ssfRECENT = &H8
' ssfSENDTO = &H9
' ssfBITBUCKET = &HA
' ssfSTARTMENU = &HB
' ssfDESKTOPDIRECTORY = &H10
' ssfDRIVES = &H11
' ssfNETWORK = &H12
' ssfNETHOOD = &H13
' ssfFONTS = &H14
' ssfTEMPLATES = &H15
'End Enum
'
'
'------------------------------------------------------------------------------
' Estructuras
'------------------------------------------------------------------------------
'
Private 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
'Declaración de SHFILEOPSTRUCT
'typedef WORD FILEOP_FLAGS;
'
'typedef struct _SHFILEOPSTRUCTA
'{
' HWND hwnd;
' UINT wFunc;
' LPCSTR pFrom;
' LPCSTR pTo;
' FILEOP_FLAGS fFlags;
' BOOL fAnyOperationsAborted;
' LPVOID hNameMappings;
' LPCSTR lpszProgressTitle; // only used if FOF_SIMPLEPROGRESS
'} SHFILEOPSTRUCTA, FAR *LPSHFILEOPSTRUCTA;
'también me he encontrado con esta declaración:
'(pero después de comprobar cómo se declara en ShellApi.h...)
'Private Type SHFILEOPSTRUCT2
' hWnd As Long
' wFunc As Long
' pFrom As String
' pTo As String
' fFlags As Long
' fAnyOperationsAborted As Long
' hNameMappings As Long
' lpszProgressTitle As String
'End Type
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long 'Especifica dónde se empezará a mostrar
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
'
'
'------------------------------------------------------------------------------
' Funciones del API
'------------------------------------------------------------------------------
'
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
(lpbi As BrowseInfo) As Long
Private Declare Sub CoTaskMemFree Lib "OLE32.DLL" _
(ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
'----------------------------------------------------------------
' cComDlg Clase para simular el control de Diálogos Comunes
'
' Primera tentativa: (04:57 25/Ago/97)
'
' Versión reducida Diálogos de Abrir y Guardar (21/Oct/97)
'
' ©Guillermo 'guille' Som, 1997
'----------------------------------------------------------------
Private sFilter As String
'Esta propiedad hará referencia al hWnd de un Form
Public hWnd As Long
'Propiedades genéricas de los diálogos comunes
Public DialogTitle As String
Public CancelError As Boolean
'Propiedades para Abrir y Guardar como
Public DefaultExt As String
Public FileName As String
Public FileTitle As String
Public FilterIndex As Long
Public InitDir As String
'Public MaxFileSize As Long (será 260)
'----------------------------------------------------------------------------
' Estructura de datos para Abrir y Guardar como...
'----------------------------------------------------------------------------
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
'Constantes para las funciones de archivos
Public Enum eOFN
'Tamaño máximo de un nombre de archivo (incluyendo el path)
MAX_PATH = 260
'Constantes para el diálogo de archivos
OFN_READONLY = &H1
OFN_OVERWRITEPROMPT = &H2
OFN_HIDEREADONLY = &H4
OFN_NOCHANGEDIR = &H8
OFN_SHOWHELP = &H10
OFN_ENABLEHOOK = &H20
OFN_ENABLETEMPLATE = &H40
OFN_ENABLETEMPLATEHANDLE = &H80
OFN_NOVALIDATE = &H100
OFN_ALLOWMULTISELECT = &H200
OFN_EXTENSIONDIFFERENT = &H400
OFN_PATHMUSTEXIST = &H800
OFN_FILEMUSTEXIST = &H1000
OFN_CREATEPROMPT = &H2000
OFN_SHAREAWARE = &H4000
OFN_NOREADONLYRETURN = &H8000
OFN_NOTESTFILECREATE = &H10000
OFN_NONETWORKBUTTON = &H20000
OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules
OFN_EXPLORER = &H80000 ' new look commdlg
OFN_NODEREFERENCELINKS = &H100000
OFN_LONGNAMES = &H200000 ' force long names for 3.x modules
'
OFN_SHAREFALLTHROUGH = 2
OFN_SHARENOWARN = 1
OFN_SHAREWARN = 0
'Constantes para FileOperation
FO_COPY = &H2 'Copiar
FO_DELETE = &H3 'Borrar
FO_MOVE = &H1 'Mover
FO_RENAME = &H4 'Renombrar
'
FOF_ALLOWUNDO = &H40 'Permitir deshacer
FOF_CONFIRMMOUSE = &H2 'No está implementada
FOF_FILESONLY = &H80 'Si se especifica *.*, hacerlo sólo con archivos
FOF_MULTIDESTFILES = &H1 'Multiples archivos de destino
FOF_NOCONFIRMATION = &H10 'No pedir confirmación
FOF_NOCONFIRMMKDIR = &H200 'No confirmar la creación de directorios
FOF_RENAMEONCOLLISION = &H8 'Cambiar el nombre si el archivo de destino ya existe
FOF_SILENT = &H4 'No mostrar el progreso
FOF_SIMPLEPROGRESS = &H100 'No mostrar los nombres de los archivos
FOF_WANTMAPPINGHANDLE = &H20 'Rellena el valor de hNameMappings
'
' Constantes para ShowPrinter
'
'/* field selection bits */
DM_ORIENTATION = &H1&
DM_PAPERSIZE = &H2&
DM_PAPERLENGTH = &H4&
DM_PAPERWIDTH = &H8&
DM_SCALE = &H10&
'
DM_DUPLEX = &H1000&
'
'#if(WINVER >= 0x0500)
'#define DM_POSITION 0x00000020L
'#endif /* WINVER >= 0x0500 */
'#define DM_COPIES 0x00000100L
'#define DM_DEFAULTSOURCE 0x00000200L
'#define DM_PRINTQUALITY 0x00000400L
'#define DM_COLOR 0x00000800L
'#define DM_DUPLEX 0x00001000L
'#define DM_YRESOLUTION 0x00002000L
'#define DM_TTOPTION 0x00004000L
'#define DM_COLLATE 0x00008000L
'#define DM_FORMNAME 0x00010000L
'#define DM_LOGPIXELS 0x00020000L
'#define DM_BITSPERPEL 0x00040000L
'#define DM_PELSWIDTH 0x00080000L
'#define DM_PELSHEIGHT 0x00100000L
'#define DM_DISPLAYFLAGS 0x00200000L
'#define DM_DISPLAYFREQUENCY 0x00400000L
'#if(WINVER >= 0x0400)
'#define DM_ICMMETHOD 0x00800000L
'#define DM_ICMINTENT 0x01000000L
'#define DM_MEDIATYPE 0x02000000L
'#define DM_DITHERTYPE 0x04000000L
'#define DM_PANNINGWIDTH 0x08000000L
'#define DM_PANNINGHEIGHT 0x10000000L
'#endif /* WINVER >= 0x0400 */
'
PD_ALLPAGES = &H0
PD_SELECTION = &H1
PD_PAGENUMS = &H2
PD_NOSELECTION = &H4
PD_NOPAGENUMS = &H8
PD_COLLATE = &H10
PD_PRINTTOFILE = &H20
PD_PRINTSETUP = &H40
PD_NOWARNING = &H80
PD_RETURNDC = &H100
PD_RETURNIC = &H200
PD_RETURNDEFAULT = &H400
PD_SHOWHELP = &H800
PD_ENABLEPRINTHOOK = &H1000
PD_ENABLESETUPHOOK = &H2000
PD_ENABLEPRINTTEMPLATE = &H4000
PD_ENABLESETUPTEMPLATE = &H8000
PD_ENABLEPRINTTEMPLATEHANDLE = &H10000
PD_ENABLESETUPTEMPLATEHANDLE = &H20000
PD_USEDEVMODECOPIES = &H40000
PD_USEDEVMODECOPIESANDCOLLATE = &H40000
PD_DISABLEPRINTTOFILE = &H80000
PD_HIDEPRINTTOFILE = &H100000
PD_NONETWORKBUTTON = &H200000
'
End Enum
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
' Para esperar a que un proceso termine
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Const STARTF_USESHOWWINDOW = &H1
Const STARTF_USESIZE = &H2
Const STARTF_USEPOSITION = &H4
Const STARTF_USECOUNTCHARS = &H8
Const STARTF_USEFILLATTRIBUTE = &H10
Const STARTF_RUNFULLSCREEN = &H20 '// ignored for non-x86 platforms
Const STARTF_FORCEONFEEDBACK = &H40
Const STARTF_FORCEOFFFEEDBACK = &H80
Const STARTF_USESTDHANDLES = &H100
'#if(WINVER >= 0x0400)
'Const STARTF_USEHOTKEY = &H200
'#endif /* WINVER >= 0x0400 */
'/*
' * ShowWindow() Commands
' */
Public Enum eSW
SW_HIDE = 0
SW_SHOWNORMAL = 1
SW_NORMAL = 1
SW_SHOWMINIMIZED = 2
SW_SHOWMAXIMIZED = 3
SW_MAXIMIZE = 3
SW_SHOWNOACTIVATE = 4
SW_SHOW = 5
SW_MINIMIZE = 6
SW_SHOWMINNOACTIVE = 7
SW_SHOWNA = 8
SW_RESTORE = 9
SW_SHOWDEFAULT = 10
SW_MAX = 10
End Enum
'
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32.dll" _
(ByVal hWnd As Long) As Long
'
Private Declare Function ShowWindow Lib "user32.dll" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
'
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" _
(ByVal lpApplicationName As Long, ByVal lpCommandLine As String, _
ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
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
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400
'Tipos de datos y funciones para FindFirstFile y FindNextFile
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
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Const INVALID_HANDLE_VALUE = -1
'------------------------------------------------------------------------------
' Funciones del API para leer ficheros INI (26/Sep/01)
'------------------------------------------------------------------------------
Private sBuffer As String ' Para usarla en las funciones GetSection(s)
'
'--- Declaraciones para leer ficheros INI ---
' Leer todas las secciones de un fichero INI, esto seguramente no funciona en Win95
' Esta función no estaba en las declaraciones del API que se incluye con el VB
Private Declare Function GetPrivateProfileSectionNames Lib "kernel32" Alias "GetPrivateProfileSectionNamesA" _
(ByVal lpszReturnBuffer As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long
' Leer una sección completa
Private Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" _
(ByVal lpAppName As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
' Leer una clave de un fichero INI
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As String) As Long
' Escribir una clave de un fichero INI (también para borrar claves y secciones)
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpString As Any, ByVal lpFileName As String) As Long
'------------------------------------------------------------------------------
'' Declaraciones para leer ficheros INI
'Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
' (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
' ByVal lpDefault As String, ByVal lpReturnedString As String, _
' ByVal nSize As Long, ByVal lpFileName As String) As Long
'Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
' (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
' ByVal lpString As Any, ByVal lpFileName As String) As Long
'------------------------------------------------------------------------------
' data buffer for the PrintDlg function
Private Type PRINTDLGT
lStructSize As Long
hwndOwner As Long
hDevMode As Long
hDevNames As Long
hDC As Long
Flags As Long
nFromPage As Integer
nToPage As Integer
nMinPage As Integer
nMaxPage As Integer
nCopies As Integer
hInstance As Long
lCustData As Long
lpfnPrintHook As Long
lpfnSetupHook As Long
lpPrintTemplateName As String
lpSetupTemplateName As String
hPrintTemplate As Long
hSetupTemplate As Long
End Type
' API function called by ShowPrint method
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLGT) As Long
' data buffer for the ChooseColor function
Private Type CHOOSECOLORT
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
' API function called by ChooseColor method
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLORT) As Long
' constants for API memory functions
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
' API memory functions
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
'
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Private Type DEVMODE_TYPE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
'Public DevMode As DEVMODE_TYPE
Private mDevMode As DEVMODE_TYPE
Private Type DEVNAMES_TYPE
wDriverOffset As Integer
wDeviceOffset As Integer
wOutputOffset As Integer
wDefault As Integer
extra As String * 100
End Type
'------------------------------------------------------------------------------
' Para capturar la salida dirigida a StdOut y StdError (03/Ago/01)
'------------------------------------------------------------------------------
'This example illustrates a Visual Basic application starting
'another process with the purpose of redirecting that process's
'standard IO handles.
'The Visual Basic application redirects the created process's
'standard output handle to an anonymous pipe,
'then proceeds to read the output through the pipe.
'This sample just redirects STDOUT of the new process.
'
'To redirect other handles (STDIN and STDERR),
'create a pipe for each handle for which redirection is desired.
'The Visual Basic application would read from the read ends
'of the pipes for the redirected STDOUT and STDERR.
'If STDIN redirection was desired, the Visual Basic application
'would write to the write end of the appropriate pipe.
'
'An example follows:
'
'
' 'A pipe for redirection of STDOUT
' CreatePipe(hReadPipe1, hWritePipe1, sa, 0)
'
' 'A pipe for redirection of STDERR
' CreatePipe(hReadPipe2, hWritePipe2, sa, 0)
'
' 'A pipe for redirection of STDIN
' CreatePipe(hReadPipe3, hWritePipe3, sa, 0)
'
' 'Preparing to start the process with redirected handles
' start.hStdOutput = hWritePipe1
' start.hStdError = hWritePipe2
' start.hStdInput = hReadPipe3
'
' 'Reading output from the started process's STDOUT
' ReadFile(hReadPipe1, mybuff1, 100, bytesread, ByVal 0&)
'
' 'Reading output from the started process's STDERR
' ReadFile(hReadPipe2, mybuff2, 100, bytesread, ByVal 0&)
'
' 'Writing to the started process's STDIN
' WriteFile(hWritePipe3, mybuff3, 100, byteswritten, ByVal 0&)
'
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
'Private Type STARTUPINFO
' cb As Long
' lpReserved As Long
' lpDesktop As Long
' lpTitle As Long
' dwX As Long
' dwY As Long
' dwXSize As Long
' dwYSize As Long
' dwXCountChars As Long
' dwYCountChars As Long
' dwFillAttribute As Long
' dwFlags As Long
' wShowWindow As Integer
' cbReserved2 As Integer
' lpReserved2 As Long
' hStdInput As Long
' hStdOutput As Long
' hStdError As Long
'End Type
'Private Type PROCESS_INFORMATION
' hProcess As Long
' hThread As Long
' dwProcessID As Long
' dwThreadID As Long
'End Type
Private Declare Function CreateProcessAny Lib "kernel32" Alias "CreateProcessA" _
(ByVal lpApplicationName As Long, ByVal lpCommandLine As String, _
lpProcessAttributes As Any, lpThreadAttributes As Any, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As Any, lpProcessInformation As Any) As Long
'Private Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
'Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
'Private Const NORMAL_PRIORITY_CLASS = &H20&
'Private Const STARTF_USESTDHANDLES = &H100&
'
'Private Const SW_SHOWMINNOACTIVE = 7
'Private Const STARTF_USESHOWWINDOW = &H1
'Private Const INFINITE = -1&
Private Declare Function CreatePipe Lib "kernel32" _
(phReadPipe As Long, phWritePipe As Long, _
lpPipeAttributes As Any, ByVal nSize As Long) As Long
'Private Declare Function WriteFile Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As Any) As Long
Private Declare Function ReadFile Lib "kernel32" _
(ByVal hFile As Long, ByVal lpBuffer As String, _
ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Any) As Long
Public Function ExecCmdPipe(ByVal CmdLine As String) As String
'--------------------------------------------------------------------------
' Ejecuta el comando indicado, espera a que termine
' se devuelve la salida normal así como la de error
'--------------------------------------------------------------------------
Dim proc As PROCESS_INFORMATION
Dim ret As Long, bSuccess As Long
Dim start As STARTUPINFO
Dim sa As SECURITY_ATTRIBUTES
Dim hReadPipe As Long, hWritePipe As Long
Dim bytesread As Long, mybuff As String
'
Dim sReturnStr As String
'
'=== Longitud de la cadena, en teoría 64 KB,
' pero no en la práctica
'mybuff = String(64 * 1024, Chr$(65))
' Con 10KB hay más que suficiente
mybuff = String(10 * 1024, Chr$(65))
'
sa.nLength = Len(sa)
sa.bInheritHandle = 1&
sa.lpSecurityDescriptor = 0&
ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
If ret = 0 Then
'===Error
ExecCmdPipe = "Error: CreatePipe failed. " & Err.LastDllError
Exit Function
End If
start.cb = Len(start)
'start.dwFlags = STARTF_USESTDHANDLES
start.hStdOutput = hWritePipe
' Si se produce error, usar el mismo "pipe" que para escribir
start.hStdError = hWritePipe
start.dwFlags = STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW
start.wShowWindow = SW_SHOWMINNOACTIVE
'
' Start the shelled application:
ret = CreateProcessAny(0&, CmdLine, sa, sa, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
If ret <> 1 Then
'===Error
sReturnStr = "Error: CreateProcess failed. " & Err.LastDllError
End If
'
' Wait for the shelled application to finish:
ret = WaitForSingleObject(proc.hProcess, INFINITE)
'
' Si la aplicación acaba con error... (03/Ago/01)
' se queda colgado en esta llamada...
' ¡SOLUCIONADO! (03/Ago/01)
' He asignado a hStdError el mismo handle que a hStdOutput
bSuccess = ReadFile(hReadPipe, mybuff, Len(mybuff), bytesread, 0&)
If bSuccess = 1 Then
sReturnStr = Left(mybuff, bytesread)
Else
'===Error
sReturnStr = "Error: ReadFile failed. " & Err.LastDllError
End If
ret = CloseHandle(proc.hProcess)
ret = CloseHandle(proc.hThread)
ret = CloseHandle(hReadPipe)
ret = CloseHandle(hWritePipe)
'
ExecCmdPipe = sReturnStr
End Function
Public Sub AppShow(ByVal sCaption As String, _
Optional ByVal nCmdShow As eSW = SW_RESTORE)
'
' Activar la aplicación con el Caption indicado (31/Jul/01)
'
Dim lhWnd As Long
Dim sClassName As String
'
lhWnd = FindWindow(sClassName, sCaption)
If lhWnd Then
Call SetForegroundWindow(lhWnd)
'
Call ShowWindow(lhWnd, nCmdShow)
'
End If
End Sub
Public Function QuitarComillasDobles(ByVal sFic As String) As String
Dim i As Long, j As Long
' Si tiene comillas dobles, quitárselas (26/Dic/99)
Do
i = InStr(sFic, Chr$(34))
If i Then
j = InStr(i + 1, sFic, Chr$(34))
If j = 0 Then
j = Len(sFic) + 1
End If
If j Then
sFic = Left$(sFic, i - 1) & Mid$(sFic, i + 1, j - (i + 1)) & Mid$(sFic, j + 1)
End If
Else
Exit Do
End If
Loop
QuitarComillasDobles = sFic
End Function
Public Function GetLongFilename(ByVal sShortName As String) As String
' Convertir un Path corto en otro largo (26/Dic/99)
'
' HOWTO: Get a Long Filename from a Short Filename (Article ID: Q163227)
'
Dim sLongName As String
Dim sTemp As String
Dim iSlashPos As Integer
' Add \ to short name to prevent Instr from failing
sShortName = sShortName & "\"
' Start from 4 to ignore the "[Drive Letter]:\" characters
'If InStr(sShortName, ":\") Then
iSlashPos = InStr(4, sShortName, "\")
'Else
' ' Comprobar si es un path UNC
'End If
' Pull out each string between \ character for conversion
While iSlashPos
sTemp = Dir$(Left$(sShortName, iSlashPos - 1), vbNormal + vbHidden + vbSystem + vbDirectory)
If sTemp = "" Then
'Error 52 - Bad File Name or Number
GetLongFilename = ""
Exit Function
End If
sLongName = sLongName & "\" & sTemp
iSlashPos = InStr(iSlashPos + 1, sShortName, "\")
Wend
' Prefix with the drive letter
GetLongFilename = Left$(sShortName, 2) & sLongName
End Function
Public Sub IniDelete(ByVal sIniFile As String, ByVal sSection As String, _
Optional ByVal sKey As String = "")
' Borrar una clave o entrada de un fichero INI (16/Feb/99)
' Si no se indica sKey, se borrará la sección indicada en sSection
' En otro caso, se supone que es la entrada (clave) lo que se quiere borrar
If Len(sKey) = 0 Then
' Borrar una sección
Call WritePrivateProfileString(sSection, 0&, 0&, sIniFile)
Else
' Borrar una entrada
Call WritePrivateProfileString(sSection, sKey, 0&, sIniFile)
End If
End Sub
Public Sub IniDeleteKey(ByVal sIniFile As String, ByVal sSection As String, _
Optional ByVal sKey As String = "")
'--------------------------------------------------------------------------
' Borrar una clave o entrada de un fichero INI (16/Feb/99)
' Si no se indica sKey, se borrará la sección indicada en sSection
' En otro caso, se supone que es la entrada (clave) lo que se quiere borrar
'
' Para borrar una sección se debería usar IniDeleteSection
'
If Len(sKey) = 0 Then
' Borrar una sección
Call WritePrivateProfileString(sSection, 0&, 0&, sIniFile)
Else
' Borrar una entrada
Call WritePrivateProfileString(sSection, sKey, 0&, sIniFile)
End If
End Sub
Public Sub IniDeleteSection(ByVal sIniFile As String, ByVal sSection As String)
'--------------------------------------------------------------------------
' Borrar una sección de un fichero INI (04/Abr/01)
' Borrar una sección
Call WritePrivateProfileString(sSection, 0&, 0&, sIniFile)
End Sub
Public Function IniGet(ByVal sFileName As String, ByVal sSection As String, _
ByVal sKeyName As String, _
Optional ByVal sDefault As String = "") As String
'--------------------------------------------------------------------------
' Devuelve el valor de una clave de un fichero INI
' Los parámetros son:
' sFileName El fichero INI
' sSection La sección de la que se quiere leer
' sKeyName Clave
' sDefault Valor opcional que devolverá si no se encuentra la clave
'--------------------------------------------------------------------------
Dim ret As Long
Dim sRetVal As String
'
sRetVal = String$(255, 0)
'
ret = GetPrivateProfileString(sSection, sKeyName, sDefault, sRetVal, Len(sRetVal), sFileName)
If ret = 0 Then
IniGet = sDefault
Else
IniGet = Left$(sRetVal, ret)
End If
End Function
Public Sub IniWrite(ByVal sFileName As String, ByVal sSection As String, _
ByVal sKeyName As String, ByVal sValue As String)
'--------------------------------------------------------------------------
' Guarda los datos de configuración
' Los parámetros son los mismos que en LeerIni
' Siendo sValue el valor a guardar
'
Call WritePrivateProfileString(sSection, sKeyName, sValue, sFileName)
End Sub
Public Function IniGetSection(ByVal sFileName As String, _
ByVal sSection As String) As String()
'--------------------------------------------------------------------------
' Lee una sección entera de un fichero INI (27/Feb/99)
' Adaptada para devolver un array de string (04/Abr/01)
'
' Esta función devolverá un array de índice cero
' con las claves y valores de la sección
'
' Parámetros de entrada:
' sFileName Nombre del fichero INI
' sSection Nombre de la sección a leer
' Devuelve:
' Un array con el nombre de la clave y el valor
' Para leer los datos:
' For i = 0 To UBound(elArray) -1 Step 2
' sClave = elArray(i)
' sValor = elArray(i+1)
' Next
'
Dim i As Long
Dim j As Long
Dim sTmp As String
Dim sClave As String
Dim sValor As String
'
Dim aSeccion() As String
Dim n As Long
'
ReDim aSeccion(0)
'
' El tamaño máximo para Windows 95
sBuffer = String$(32767, Chr$(0))
'
n = GetPrivateProfileSection(sSection, sBuffer, Len(sBuffer), sFileName)
'
If n Then
'
' Cortar la cadena al número de caracteres devueltos
sBuffer = Left$(sBuffer, n)
' Quitar los vbNullChar extras del final
i = InStr(sBuffer, vbNullChar & vbNullChar)
If i Then
sBuffer = Left$(sBuffer, i - 1)
End If
'
n = -1
' Cada una de las entradas estará separada por un Chr$(0)
Do
i = InStr(sBuffer, Chr$(0))
If i Then
sTmp = LTrim$(Left$(sBuffer, i - 1))
If Len(sTmp) Then
' Comprobar si tiene el signo igual
j = InStr(sTmp, "=")
If j Then
sClave = Left$(sTmp, j - 1)
sValor = LTrim$(Mid$(sTmp, j + 1))
'
n = n + 2
ReDim Preserve aSeccion(n)
aSeccion(n - 1) = sClave
aSeccion(n) = sValor
End If
End If
sBuffer = Mid$(sBuffer, i + 1)
End If
Loop While i
If Len(sBuffer) Then
j = InStr(sBuffer, "=")
If j Then
sClave = Left$(sBuffer, j - 1)
sValor = LTrim$(Mid$(sBuffer, j + 1))
n = n + 2
ReDim Preserve aSeccion(n)
aSeccion(n - 1) = sClave
aSeccion(n) = sValor
End If
End If
End If
' Devolver el array
IniGetSection = aSeccion
End Function
Public Function IniGetSections(ByVal sFileName As String) As String()
'--------------------------------------------------------------------------
' Devuelve todas las secciones de un fichero INI (27/Feb/99)
' Adaptada para devolver un array de string (04/Abr/01)
'
' Esta función devolverá un array con todas las secciones del fichero
'
' Parámetros de entrada:
' sFileName Nombre del fichero INI
' Devuelve:
' Un array con todos los nombres de las secciones
' La primera sección estará en el elemento 1,
' por tanto, si el array contiene cero elementos es que no hay secciones
'
Dim i As Long
Dim sTmp As String
Dim n As Long
Dim aSections() As String
'
ReDim aSections(0)
'
' El tamaño máximo para Windows 95
sBuffer = String$(32767, Chr$(0))
'
' Esta función del API no está definida en el fichero TXT
n = GetPrivateProfileSectionNames(sBuffer, Len(sBuffer), sFileName)
'
If n Then
' Cortar la cadena al número de caracteres devueltos
sBuffer = Left$(sBuffer, n)
' Quitar los vbNullChar extras del final
i = InStr(sBuffer, vbNullChar & vbNullChar)
If i Then
sBuffer = Left$(sBuffer, i - 1)
End If
'
n = 0
' Cada una de las entradas estará separada por un Chr$(0)
Do
i = InStr(sBuffer, Chr$(0))
If i Then
sTmp = LTrim$(Left$(sBuffer, i - 1))
If Len(sTmp) Then
n = n + 1
ReDim Preserve aSections(n)
aSections(n) = sTmp
End If
sBuffer = Mid$(sBuffer, i + 1)
End If
Loop While i
If Len(sBuffer) Then
n = n + 1
ReDim Preserve aSections(n)
aSections(n) = sBuffer
End If
End If
' Devolver el array
IniGetSections = aSections
End Function
Public Sub SaveSetting(ByVal lpFileName As String, ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As String)
'Guarda los datos de configuración
'Los parámetros son los mismos que en LeerIni
'Siendo lpString el valor a guardar
'
Dim LTmp As Long
LTmp = WritePrivateProfileString(lpAppName, lpKeyName, lpString, lpFileName)
End Sub
Public Function GetSetting(ByVal lpFileName As String, ByVal lpAppName As String, ByVal lpKeyName As String, Optional ByVal vDefault As Variant) As String
'Nota 14/Abr/98, antes el valor devuelto era Variant
' Lo he cambiado para compatibilizarlo
' con LeerIni
'
'Los parámetros son:
'lpFileName: La Aplicación (fichero INI)
'lpAppName: La sección que suele estar entrre corchetes
'lpKeyName: Clave
'vDefault: Valor opcional que devolverá
' si no se encuentra la clave.
'
Dim lpString As String
Dim LTmp As Long
Dim sRetVal As String
'Si no se especifica el valor por defecto,
'asignar incialmente una cadena vacía
If IsMissing(vDefault) Then
lpString = ""
Else
lpString = CStr(vDefault)
End If
sRetVal = String$(255, 0)
LTmp = GetPrivateProfileString(lpAppName, lpKeyName, lpString, sRetVal, Len(sRetVal), lpFileName)
If LTmp = 0 Then
GetSetting = lpString
Else
GetSetting = Left(sRetVal, LTmp)
End If
End Function
Private Function FindAllFiles(ByVal sFile As String, ByVal sPath As String, colAllFiles As Variant, ByVal bSubDirs As Boolean, ByVal bOnlyOne As Boolean, ByVal bOnlyDir As Boolean) As Boolean
'
Static sFileName As String
Static WFD As WIN32_FIND_DATA
Dim hFindFile As Long
Dim ret As Long
'Si no se indica el directorio, se usa el actual
sPath = AddBackSlash(sPath)
'Buscar la primera coincidencia
hFindFile = FindFirstFile(sPath & "*.*", WFD)
ret = (hFindFile <> INVALID_HANDLE_VALUE)
DoEvents
Do While ret
sFileName = RTrimNull(WFD.cFileName)
'Ajustar el nuevo valor del path
' No examinar . ni ..
If Left$(sFileName, 1) <> "." Then
'Si es un directorio
If WFD.dwFileAttributes And vbDirectory Then
'Si sólo se buscan directorios
If bOnlyDir Then
If (sFileName Like sFile) Then
If TypeOf colAllFiles Is Collection Then
colAllFiles.Add AddBackSlash(sPath) & sFileName
Else
colAllFiles.AddItem AddBackSlash(sPath) & sFileName
End If
If bOnlyOne Then
FindAllFiles = True
Exit Function
End If
End If
End If
'Si NO es un directorio oculto y del sistema (¿Recycled?)
If Not (WFD.dwFileAttributes = vbDirectory + vbSystem + vbHidden) Then
'Comprobar si hay que continuar
If bSubDirs Then
FindAllFiles = FindAllFiles(sFile, sPath & sFileName, colAllFiles, bSubDirs, bOnlyOne, bOnlyDir)
If FindAllFiles Then Exit Function
Else
If bOnlyDir Then
FindAllFiles = True
Exit Function
End If
End If
End If
Else
'Añadirlo a la colección si coincide
'con el tipo solicitado
If (sFileName Like sFile) Then
If TypeOf colAllFiles Is Collection Then
colAllFiles.Add AddBackSlash(sPath) & sFileName
Else
colAllFiles.AddItem AddBackSlash(sPath) & sFileName
End If
If bOnlyOne Then
FindAllFiles = True
Exit Function
End If
End If
End If
End If
'continuar buscando archivos
ret = FindNextFile(hFindFile, WFD)
Loop
ret = FindClose(hFindFile)
End Function
Public Sub ExecCmdWithFocus(ByVal CmdLine As String)
'Esperar a que un proceso termine,
'la ventana se mostrará en primer plano con foco
'
Dim tProc As PROCESS_INFORMATION
Dim tStart As STARTUPINFO
Dim ret&
' Initialize the STARTUPINFO structure:
tStart.cb = Len(tStart)
'Start.dwFlags = STARTF_USESHOWWINDOW
'Start.wShowWindow = SW_SHOWMINNOACTIVE
' Start the shelled application:
ret = CreateProcessA(0&, CmdLine$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, tStart, tProc)
' Wait for the shelled application to finish:
ret = WaitForSingleObject(tProc.hProcess, INFINITE)
ret = CloseHandle(tProc.hProcess)
End Sub
Public Sub ExecCmd(ByVal CmdLine As String, Optional vNoFocus As Boolean = True)
'Ejecutar un comando y esperar a que termine
'
'Parámetros:
' CmdLine
' vNoFocus Si es False se ejecuta con foco
' Si es True se ejecuta sin foco (valor por defecto)
'
'---------------------------------------------------------
'NOTA: Si se va a enviar un comando del DOS, se debe usar
'con Command /C
'sino, no se cerrará la ventana y el proceso no terminará
'---------------------------------------------------------
If vNoFocus Then
ExecCmdNoFocus CmdLine
Else
ExecCmdWithFocus CmdLine
End If
End Sub
Public Sub ExecCmdNoFocus(ByVal CmdLine As String, Optional ByVal bConShell As Boolean = True)
'Esperar a que un proceso termine,
'la ventana se mostrará minimizada sin foco
Dim hProcess As Long
Dim RetVal As Long
'Usando el Id del proceso de la orden Shell
If bConShell Then
'The next line launches CmdLine as icon,
'captures process ID
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(CmdLine, vbMinimizedNoFocus))
'hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(CmdLine, vbHide))
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
Else
'Esperar a que un proceso termine,
'la ventana se mostrará en primer plano con foco
'
Dim tProc As PROCESS_INFORMATION
Dim tStart As STARTUPINFO
' Initialize the STARTUPINFO structure:
tStart.cb = Len(tStart)
tStart.dwFlags = STARTF_USESHOWWINDOW
tStart.wShowWindow = SW_SHOWMINNOACTIVE
' Start the shelled application:
RetVal = CreateProcessA(0&, CmdLine$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, tStart, tProc)
' Wait for the shelled application to finish:
RetVal = WaitForSingleObject(tProc.hProcess, INFINITE)
RetVal = CloseHandle(tProc.hProcess)
End If
End Sub
Public Sub AgregarAText(ByVal sArchivos As String, queControl As Object, Optional ByVal vSeparador As Variant)
' Agregar los archivos indicados al control indicado
' Parámetros:
' sArchivos Los archivos estarán separados por
' espacios y dentro de comillas
' o simplemente será un archivo
' queControl Será cualquier control que acepte una cadena
' en la propiedad predeterminada
' vSeparador Separador a usar entre cada nombre de archivo
'
' La cambios realizados en el tratamiento de las comillas,
' están copiados de las modificaciones que hice a AgregarALista en Dic/99
'
Dim i As Long, j As Long
Dim sTmp As String, sDir As String
'Dim colArchivos As New Collection
Dim colArchivos As Collection
Dim sSeparador As String
'
sArchivos = Trim$(sArchivos)
If Len(sArchivos) = 0 Then Exit Sub
'
Set colArchivos = New Collection
If IsMissing(vSeparador) Then
sSeparador = " "
Else
sSeparador = CStr(vSeparador)
End If
' Si hay varios ficheros, (09/Feb/01)
' irán separados por comillas, espacio, comillas
If InStr(sArchivos, Chr$(34) & " " & Chr$(34)) Then
'If InStr(sArchivos, Chr$(34)) Then
' hay comillas, es que hay varios archivos
j = 0
Do While Len(sArchivos)
Do While Left$(sArchivos, 1) = Chr$(34)
sArchivos = Trim$(Mid$(sArchivos, 2))
Loop
i = InStr(sArchivos, Chr$(34))
If i Then
sTmp = Left$(sArchivos, i - 1)
sArchivos = Trim$(Mid$(sArchivos, i + 1))
If j Then
' Si ya tiene el nombre del directorio (09/Feb/01)
If InStr(sTmp, ":\") Then
colArchivos.Add sTmp
Else
colArchivos.Add sDir & sTmp
End If
Else
'El primer parámetro es el directorio
j = j + 1
sDir = sTmp
'Si no tiene la barra ponersela
If Right$(sDir, 1) <> "\" Then
sDir = sDir & "\"
End If
End If
Else
Exit Do
End If
Loop
If Len(sArchivos) Then
' Si ya tiene el nombre del directorio (09/Feb/01)
If InStr(sArchivos, ":\") Then
colArchivos.Add sArchivos
Else
colArchivos.Add sDir & sArchivos
End If
End If
'Por si sólo se selecciona un archivo
If colArchivos.Count = 0 Then
colArchivos.Add sTmp
End If
ElseIf InStr(sArchivos, Chr$(34) & " " & Chr$(34)) = 0 Then '(09/Feb/01)
' Quitar las comillas y añadirlo
colArchivos.Add QuitarComillasDobles(sArchivos)
Else
'no hay comillas, es sólo un archivo
colArchivos.Add sArchivos
End If
'Asignar los datos anteriores
sTmp = Trim$(queControl)
If Len(sTmp) Then
If Right$(RTrim$(sTmp), 1) <> sSeparador Then
sTmp = sTmp & sSeparador
End If
End If
For i = colArchivos.Count To 1 Step -1
If i > 1 Then
sTmp = sTmp & colArchivos(i) & sSeparador
Else
sTmp = sTmp & colArchivos(i)
End If
Next
queControl = sTmp
Set colArchivos = Nothing
End Sub
Public Sub AgregarALista(ByVal sArchivos As String, _
queControl As Object, _
Optional ByVal bAlPrincipio As Boolean = False)
'Agregar los archivos indicados a la lista
'Parámetros:
' sArchivos Los archivos estarán separados por
' espacios y dentro de comillas
' o simplemente será un archivo
' queControl será un List o un Combo
' vAlPrincipio si True se añade al principio de la lista
'
Dim i&, j&
Dim sTmp$, sDir$
'Dim bAlPrincipio As Boolean
Dim colArchivos As Collection
sArchivos = Trim$(sArchivos)
If Len(sArchivos) = 0 Then Exit Sub
Set colArchivos = New Collection
'If IsMissing(vAlPrincipio) Then
' bAlPrincipio = False
'Else
' bAlPrincipio = CBool(vAlPrincipio)
'End If
' Si hay varios ficheros, (26/Dic/99)
' irán separados por comillas, espacio, comillas
If InStr(sArchivos, Chr$(34) & " " & Chr$(34)) Then
'If InStr(sArchivos, Chr$(34)) Then
' Hay comillas, es que hay varios archivos...
' o no...
j = 0
Do While Len(sArchivos)
Do While Left$(sArchivos, 1) = Chr$(34)
sArchivos = Trim$(Mid$(sArchivos, 2))
Loop
i = InStr(sArchivos, Chr$(34))
If i Then
sTmp = Left$(sArchivos, i - 1)
sArchivos = Trim$(Mid$(sArchivos, i + 1))
If j Then
' Si ya tiene el nombre del directorio (15/May/99)
If InStr(sTmp, ":\") Then
colArchivos.Add sTmp
Else
colArchivos.Add sDir & sTmp
End If
Else
'El primer parámetro es el directorio
j = j + 1
sDir = sTmp
'Si no tiene la barra ponersela
If Right$(sDir, 1) <> "\" Then
sDir = sDir & "\"
End If
End If
Else
Exit Do
End If
Loop
If Len(sArchivos) Then
' Si ya tiene el nombre del directorio (15/May/99)
If InStr(sArchivos, ":\") Then
colArchivos.Add sArchivos
Else
colArchivos.Add sDir & sArchivos
End If
End If
'Por si sólo se selecciona un archivo
If colArchivos.Count = 0 Then
colArchivos.Add sTmp
End If
ElseIf InStr(sArchivos, Chr$(34) & " " & Chr$(34)) = 0 Then '(26/Dic/99)
' Quitar las comillas y añadirlo
colArchivos.Add QuitarComillasDobles(sArchivos)
Else
'no hay comillas, es sólo un archivo
colArchivos.Add sArchivos
End If
For i = colArchivos.Count To 1 Step -1
If bAlPrincipio Then
queControl.AddItem colArchivos(i), 0
Else
queControl.AddItem colArchivos(i)
End If
Next
Set colArchivos = Nothing
End Sub
Public Function ShowOpen(Optional ByVal vFileName As String = "", _
Optional ByVal vTitle As String = "", _
Optional ByVal vFilter As String = "", _
Optional ByVal vFlags As Long = 0, _
Optional ByVal vhWnd As Long = 0) As Boolean
'--------------------------------------------------------------------------
' Método para mostrar el cuadro de diálogo de Abrir
'
' (c) Guillermo Som Cerezo 24/Oct/93
'
' Convertido en objeto (clase) (25/Ago/97)
'
' Los parámetros opcionales especificarán:
' vFileName El nombre del archivo
' vTitle Título del cuadro de diálogo
' vFilter Extensiones
' vFlags Los flags
' vhWnd El hWnd del Form
'--------------------------------------------------------------------------
Dim resultado As Long
Dim ofn As OpenFilename
Err.Clear
Err.Number = 0
'
'On Error GoTo 0
'
If Len(vFileName) Then _
FileName = CStr(vFileName)
If vhWnd <> 0 Then _
hWnd = CLng(vhWnd)
If Len(vFilter) Then _
Me.Filter = CStr(vFilter)
If Len(vTitle) Then _
DialogTitle = CStr(vTitle)
If vFlags <> 0 Then _
Flags = CLng(vFlags)
'
With ofn
.lStructSize = Len(ofn)
.hwndOwner = hWnd
.hInstance = 0
If Len(sFilter) = 0 Then _
sFilter = "Todos los Archivos (*.*)" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
'
.lpstrFilter = sFilter
.nFilterIndex = FilterIndex
'
' Indicar el tamaño máximo de los ficheros seleccionados (09/Feb/01)
' el máximo de cada fichero individual es de 260
.nMaxFile = 260 * 20 '260
.lpstrFile = Left$(FileName & String$(.nMaxFile, 0), .nMaxFile)
'.lpstrFile = Left$(FileName & String$(260, 0), 260)
'
.nFileOffset = 0
.nFileExtension = 0
.lpstrDefExt = DefaultExt
.lpstrFileTitle = Left$(FileTitle & String$(260, 0), 260)
.nMaxFileTitle = 260
.lpstrInitialDir = Left$(InitDir & String$(260, 0), 260)
'
'Nombres largos y estilo explorer (21/Oct/97)
'y otros valore "obvios"
'Flags = Flags Or OFN_LONGNAMES Or OFN_EXPLORER Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
.Flags = Flags
If Len(DialogTitle) = 0 Then 'Si no se especifica el título
DialogTitle = "Abrir"
End If
.lpstrTitle = DialogTitle
'
.nFileOffset = 0
.lpstrDefExt = 0
.lCustData = 0
.lpfnHook = 0
.lpTemplateName = 0
End With
resultado = GetOpenFileName(ofn)
If resultado <> 0 Then
If Flags And OFN_ALLOWMULTISELECT Then
'Si está multiselect, se separan los nombres con Chr$(0)
FileName = Chr$(34) & Trim$(QuitarCaracterEx(ofn.lpstrFile, Chr$(0), Chr$(34) & " " & Chr$(34))) & Chr$(34)
FileTitle = Chr$(34) & Trim$(QuitarCaracterEx(ofn.lpstrFileTitle, Chr$(0), Chr$(34) & " " & Chr$(34))) & Chr$(34)
InitDir = Chr$(34) & Trim$(QuitarCaracterEx(ofn.lpstrInitialDir, Chr$(0), Chr$(34) & " " & Chr$(34))) & Chr$(34)
Else
FileName = Left$(ofn.lpstrFile, InStr(ofn.lpstrFile, Chr$(0)) - 1)
FileTitle = Left$(ofn.lpstrFileTitle, InStr(ofn.lpstrFileTitle, Chr$(0)) - 1)
InitDir = Left$(ofn.lpstrInitialDir, InStr(ofn.lpstrInitialDir, Chr$(0)) - 1)
End If
If InitDir = """" Then InitDir = ""
Else
If CancelError Then
'Err.Raise 32755, "cComDlg.ShowOpen", "Error en Abrir (clase cComDlg)"
With Err
.Source = "cgsFileOp.ShowOpen"
.Number = 32755
.Description = "Error en ShowOpen..."
End With
End If
End If
'Devuelve True si se puede abrir
ShowOpen = (resultado <> 0)
End Function
Public Function ShowSave(Optional ByVal vFileName As String = "", _
Optional ByVal vTitle As String = "", _
Optional ByVal vFilter As String = "", _
Optional ByVal vFlags As Long = 0, _
Optional ByVal vhWnd As Long = 0) As Boolean
'----------------------------------------------------------
'Método para mostrar el cuadro de diálogo de Guardar como...
'
'(c) Guillermo Som Cerezo 24/Oct/93
'
'Convertido en objeto (clase) (25/Ago/97)
'
'Los parámetros opcionales especificarán:
' vFileName El nombre del archivo
' vTitle Título del cuadro de diálogo
' vFilter Extensiones
' vFlags Los flags
' vhWnd El hWnd del Form
'----------------------------------------------------------
Dim resultado As Long
Dim ofn As OpenFilename
'
Err.Clear
Err.Number = 0
'
If Len(vFileName) Then _
FileName = CStr(vFileName)
If vhWnd <> 0 Then _
hWnd = CLng(vhWnd)
If Len(vFilter) Then _
Me.Filter = CStr(vFilter)
If Len(vTitle) Then _
DialogTitle = CStr(vTitle)
If vFlags <> 0 Then _
Flags = CLng(vFlags)
'
With ofn
.lStructSize = Len(ofn)
.hwndOwner = hWnd
.hInstance = 0
If Len(sFilter) = 0 Then _
sFilter = "Todos los Archivos (*.*)" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
'
.lpstrFilter = sFilter
'.lpstrCustomFilter = ""
'.nMaxCustFilter = 0
.nFilterIndex = FilterIndex
.lpstrFile = Left$(FileName & String$(260, 0), 260)
.nMaxFile = 260
.lpstrFileTitle = Left$(FileTitle & String$(260, 0), 260)
.nMaxFileTitle = 260
.lpstrDefExt = DefaultExt
.lpstrInitialDir = Left$(InitDir & String$(260, 0), 260)
'
'Nombres largos y estilo explorer (21/Oct/97)
'Flags = Flags Or OFN_LONGNAMES Or OFN_EXPLORER Or OFN_HIDEREADONLY
'
.Flags = Flags
If Len(DialogTitle) = 0 Then
DialogTitle = "Guardar como..."
End If
.lpstrTitle = DialogTitle
'
.nFileOffset = 0
.lpstrDefExt = 0
.lCustData = 0
.lpfnHook = 0
.lpTemplateName = 0
End With
'
resultado = GetSaveFileName(ofn)
If resultado <> 0 Then
FileName = Left$(ofn.lpstrFile, InStr(ofn.lpstrFile, Chr$(0)) - 1)
FileTitle = Left$(ofn.lpstrFileTitle, InStr(ofn.lpstrFileTitle, Chr$(0)) - 1)
InitDir = Left$(ofn.lpstrInitialDir, InStr(ofn.lpstrInitialDir, Chr$(0)) - 1)
Else
If CancelError Then
'Err.Raise 32755, "cComDlg.ShowSave", "Error en Guardar como... (clase cComDlg)"
With Err
.Source = "cgsFileOp.ShowSave"
.Number = 32755
.Description = "Error en ShowSave..."
End With
End If
End If
'Devuelve True si se puede abrir
ShowSave = (resultado <> 0)
End Function
Public Function ShowPrinter() As Boolean
' Código para seleccionar de la impresora, etc tomado de: (13/Mar/01)
' PRB: Working with Print Dialog and Printer Object under NT 4.0
' Article ID: Q173981
'
Dim tPrintDlg As PRINTDLGT
'Dim mDevMode As mDevMode_TYPE
Dim DevName As DEVNAMES_TYPE
'
Dim lpDevMode As Long, lpDevName As Long
Dim bReturn As Long 'Integer
Dim objPrinter As Printer, NewPrinterName As String
Dim strSetting As String
Dim resultado As Long
'
' Use PrintDialog to get the handle to a memory
' block with a mDevMode and DevName structures
'
tPrintDlg.lStructSize = Len(tPrintDlg)
tPrintDlg.hwndOwner = Me.hWnd
'
tPrintDlg.Flags = Flags
'
'Set the current orientation and duplex setting
mDevMode.dmDeviceName = Printer.DeviceName
mDevMode.dmSize = Len(mDevMode)
mDevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX Or DM_PAPERSIZE
mDevMode.dmOrientation = Printer.Orientation
On Error Resume Next
mDevMode.dmDuplex = Printer.Duplex
On Error GoTo 0
'
'Allocate memory for the initialization hmDevMode structure
'and copy the settings gathered above into this memory
tPrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(mDevMode))
lpDevMode = GlobalLock(tPrintDlg.hDevMode)
If lpDevMode > 0 Then
CopyMemory ByVal lpDevMode, mDevMode, Len(mDevMode)
bReturn = GlobalUnlock(tPrintDlg.hDevMode)
End If
'
'Set the current driver, device, and port name strings
With DevName
.wDriverOffset = 8
.wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
.wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
.wDefault = 0
End With
With Printer
DevName.extra = .DriverName & Chr(0) & .DeviceName & Chr(0) & .Port & Chr(0)
End With
'
'Allocate memory for the initial hDevName structure
'and copy the settings gathered above into this memory
tPrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
lpDevName = GlobalLock(tPrintDlg.hDevNames)
If lpDevName > 0 Then
CopyMemory ByVal lpDevName, DevName, Len(DevName)
bReturn = GlobalUnlock(lpDevName)
End If
'
'Call the print dialog up and let the user make changes
resultado = PrintDlg(tPrintDlg)
If resultado Then
'First get the DevName structure.
lpDevName = GlobalLock(tPrintDlg.hDevNames)
CopyMemory DevName, ByVal lpDevName, 45
bReturn = GlobalUnlock(lpDevName)
GlobalFree tPrintDlg.hDevNames
'
'Next get the mDevMode structure and set the printer
'properties appropriately
lpDevMode = GlobalLock(tPrintDlg.hDevMode)
CopyMemory mDevMode, ByVal lpDevMode, Len(mDevMode)
bReturn = GlobalUnlock(tPrintDlg.hDevMode)
GlobalFree tPrintDlg.hDevMode
NewPrinterName = UCase$(Left(mDevMode.dmDeviceName, InStr(mDevMode.dmDeviceName, Chr$(0)) - 1))
If Printer.DeviceName <> NewPrinterName Then
For Each objPrinter In Printers
If UCase$(objPrinter.DeviceName) = NewPrinterName Then
Set Printer = objPrinter
End If
Next
End If
On Error Resume Next
'
'Set printer object properties according to selections made
'by user
With Printer
.Copies = mDevMode.dmCopies
.Duplex = mDevMode.dmDuplex
.Orientation = mDevMode.dmOrientation
.PaperSize = mDevMode.dmPaperSize
End With
On Error GoTo 0
End If
'
' Devuelve True si se todo fue bien
ShowPrinter = (resultado <> 0)
'
'--------------------------------------------------------------------------
' 'display the print dialog
' Dim tPrintDlg As PRINTDLGT
' Dim resultado As Long
' '
' '
' ttPrintDlg.lStructSize = Len(tPrintDlg)
' ' hdc As Long - init from hDC property
' ttPrintDlg.hDC = hDC
' '
' ttPrintDlg.hwndOwner = hWnd
' '
' ttPrintDlg.Flags = Flags
' '
' ttPrintDlg.nFromPage = FromPage
' '
' ttPrintDlg.nToPage = ToPage
' '
' ttPrintDlg.nMinPage = MinPage
' '
' ttPrintDlg.nMaxPage = MaxPage
' '
' ttPrintDlg.nCopies = Copies
' '
' resultado = PrintDlg(tPrintDlg)
' '
' If resultado <> 0 Then
' ' nFromPage As Integer - store to FromPage property
' FromPage = ttPrintDlg.nFromPage
' ' nToPage As Integer - store to ToPage property
' ToPage = ttPrintDlg.nToPage
' ' nMinPage As Integer - store to Min property
' MinPage = ttPrintDlg.nMinPage
' ' nMaxPage As Integer - store to Max property
' MaxPage = ttPrintDlg.nMaxPage
' ' nCopies As Integer - store to Copies property
' Copies = ttPrintDlg.nCopies
' Else
' If CancelError Then
' 'Err.Raise 32755, "cComDlg.ShowSave", "Error en Guardar como... (clase cComDlg)"
' With Err
' .Source = "cgsFileOp.ShowPrinter"
' .Number = 32755
' .Description = "Error en ShowPrinter..."
' End With
' End If
' End If
' ' Devuelve True si se todo fue bien
' ShowPrinter = (resultado <> 0)
End Function
Public Function ShowColor() As Boolean
' display the color dialog box
Dim tChooseColor As CHOOSECOLORT
Dim alCustomColors(15) As Long
Dim lCustomColorSize As Long
Dim lCustomColorAddress As Long
Dim lMemHandle As Long
Dim n As Long
Dim resultado As Long
'
'
tChooseColor.lStructSize = Len(tChooseColor)
'
tChooseColor.hwndOwner = hWnd
'
tChooseColor.rgbResult = Color
'
' Fill custom colors array with all white
For n = 0 To UBound(alCustomColors)
alCustomColors(n) = &HFFFFFF
Next
' Get size of memory needed for custom colors
lCustomColorSize = Len(alCustomColors(0)) * 16
' Get a global memory block to hold a copy of the custom colors
lMemHandle = GlobalAlloc(GHND, lCustomColorSize)
If lMemHandle = 0 Then
Exit Function
End If
' Lock the custom color's global memory block
lCustomColorAddress = GlobalLock(lMemHandle)
If lCustomColorAddress = 0 Then
Exit Function
End If
' Copy custom colors to the global memory block
Call CopyMemory(ByVal lCustomColorAddress, alCustomColors(0), lCustomColorSize)
tChooseColor.lpCustColors = lCustomColorAddress
'
tChooseColor.Flags = Flags
'
resultado = ChooseColor(tChooseColor)
'
If resultado <> 0 Then
Color = tChooseColor.rgbResult
Else
If CancelError Then
With Err
.Source = "cgsFileOp.ShowColor"
.Number = 32755
.Description = "Error en ShowColor..."
End With
End If
End If
' Devuelve True si se todo fue bien
ShowColor = (resultado <> 0)
End Function
Public Property Let Action(ByVal vNewValue As Integer)
'0 Ninguna acción.
'1 Muestra el cuadro de diálogo Abrir.
'2 Muestra el cuadro de diálogo Guardar como.
'3 Muestra el cuadro de diálogo Color.
'4 Muestra el cuadro de diálogo Fuente.
'5 Muestra el cuadro de diálogo Impresora.
'6 Ejecuta WINHELP.EXE.
'
Select Case vNewValue
Case 1: ShowOpen
Case 2: ShowSave
Case 3: ShowColor
Case 4: 'ShowFont
Case 5: ShowPrinter
Case 6: 'ShowHelp
Case Else
'nada que mostrar
End Select
End Property
Public Property Let Filter(ByVal sNewFilter As String)
'Procesar el parámetro para convertirlo a formato C,
'Se usará | como separador.
Dim i As Integer, j As Integer
Dim sTmp As String
sTmp = ""
If InStr(sNewFilter, "|") Then
sNewFilter = Trim$(sNewFilter)
If Right$(sNewFilter, 1) <> "|" Then
sNewFilter = sNewFilter & "|"
End If
Do
i = InStr(sNewFilter, "|")
If i Then
sTmp = sTmp & Left$(sNewFilter, i - 1) & Chr$(0)
sNewFilter = Mid$(sNewFilter, i + 1)
Else
Exit Do
End If
Loop While i
If Right$(sTmp, 1) = Chr$(0) Then
sNewFilter = sTmp & Chr$(0)
Else
sNewFilter = sTmp & Chr$(0) & Chr$(0)
End If
ElseIf InStr(sNewFilter, Chr$(0)) = 0 Then
sNewFilter = ""
End If
sFilter = sNewFilter
End Property
Public Function OpenFile(ByVal sFile As String, sCadena As String) As Boolean
'devuelve True si no se ha leido
OpenFile = FileRead(sFile, sCadena)
End Function
Public Function SaveFile(ByVal sFile As String, sCadena As String, Optional bOverWrite As Boolean = True) As Boolean
SaveFile = FileSave(sFile, sCadena, bOverWrite)
End Function
Public Function FileSave(ByVal sFile As String, sCadena As String, Optional bOverWrite As Boolean = True) As Boolean
'----------------------------------------------------------
'Guarda una cadena en un archivo (27/Ago/97)
'
'Entrada:
' sFile Archivo dónde se guardará
' sCadena Cadena a guardar
' bOverWrite Si se sobreescribe sin pedir confirmación
' por defecto =TRUE (no pedir confirmación)
'Salida:
' True Si NO se pudo guardar
'----------------------------------------------------------
Dim nF As Integer
On Local Error Resume Next
Err = 0
If FileExist(sFile) Then
If Not bOverWrite Then
'Preguntar si se sobreescribe
If MsgBox("Ya existe el archivo:" & vbCrLf & sFile & "¿quieres sobreescribirlo?", vbYesNo + vbQuestion, "Guardar Archivo") = vbNo Then
'Se ha contestado que no, salir
Err = 76
End If
End If
If Err = 0 Then Kill sFile
End If
If Err = 0 Then
'Guardar el contenido de sCadena
nF = FreeFile
Open sFile For Output As nF
Print #nF, sCadena
Close nF
FileSave = False
Else
FileSave = True
End If
Err = 0
On Local Error GoTo 0
End Function
Public Function FileRead(ByVal sFile As String, sCadena As String) As Boolean
'----------------------------------------------------------
'Abrir el archivo y asignarlo a una cadena (27/Ago/97)
'
'Entrada:
' sFile Archivo dónde se guardará
' sCadena Cadena a guardar
'Salida:
' True Si NO se pudo abrir
'----------------------------------------------------------
Dim nF As Integer
On Local Error Resume Next
If FileExist(sFile) Then
'Abrir y guardar el contenido de sCadena
nF = FreeFile
Open sFile For Input As nF
sCadena = Input$(LOF(nF), nF)
Close nF
Else
Err = 76
End If
If Err Then
FileRead = True
Else
FileRead = False
End If
Err = 0
On Local Error GoTo 0
End Function
Public Property Get FilesOnly() As Boolean
FilesOnly = (Flags And FOF_FILESONLY)
End Property
Public Property Let FilesOnly(ByVal bNewValue As Boolean)
Flags = Flags Xor FOF_FILESONLY
If bNewValue Then
Flags = Flags Or FOF_FILESONLY
End If
End Property
Public Function FileRename(ByVal sFileFrom As String, ByVal sFileTo As String) As Long
Dim SHFileOp As SHFILEOPSTRUCT
On Local Error Resume Next
sFileFrom = sFileFrom & vbNullChar & vbNullChar
sFileTo = sFileTo & vbNullChar & vbNullChar
With SHFileOp
.wFunc = FO_RENAME
.pFrom = sFileFrom
'Flags = Flags Xor FOF_ALLOWUNDO
.fFlags = FOF_ALLOWUNDO Or Flags
If Err Then
Err = 0
.fFlags = FOF_ALLOWUNDO
End If
.pTo = sFileTo
End With
FileRename = SHFileOperation(SHFileOp)
RaiseEvent Done(FileRename, eFileRename)
End Function
Public Function FilesRename(ByVal sFilesFrom As String, ParamArray vFiles() As Variant) As Long
'Si sFilesFrom contiene una o más comas, se supone que
'es un string con múltiples archivos separados por comas
'a continuación estará el archivo/directorio de destino.
'Los demás parámetros SIEMPRE estarán separados por comas
Dim i As Long
Dim sFiles As String
Dim DestDir As String
Dim SHFileOp As SHFILEOPSTRUCT
Dim lb As Long
Dim ub As Long
On Local Error Resume Next
'Convertir los caracteres "," en vbNullChar
If InStr(sFilesFrom, ",") Then
sFiles = Me.QuitarCaracterEx(sFilesFrom, ",", vbNullChar)
If Right$(sFiles, 1) <> vbNullChar Then
sFiles = sFiles & vbNullChar
End If
Else
sFiles = sFilesFrom & vbNullChar
End If
lb = LBound(vFiles)
ub = UBound(vFiles)
DestDir = vFiles(ub) & vbNullChar & vbNullChar
For i = lb To ub - 1
sFiles = sFiles & vFiles(i) & vbNullChar
Next
sFiles = sFiles & vbNullChar
With SHFileOp
.wFunc = FO_RENAME
.pFrom = sFiles
'Flags = Flags Xor FOF_ALLOWUNDO
.fFlags = FOF_ALLOWUNDO Or Flags
If Err Then
Err = 0
.fFlags = FOF_ALLOWUNDO
End If
.pTo = DestDir
End With
FilesRename = SHFileOperation(SHFileOp)
RaiseEvent Done(FilesRename, eFileRename)
End Function
Public Function FileCopy(ByVal sFileFrom As String, ByVal sFileTo As String) As Long
Dim SHFileOp As SHFILEOPSTRUCT
On Local Error Resume Next
sFileFrom = sFileFrom & vbNullChar & vbNullChar
sFileTo = sFileTo & vbNullChar & vbNullChar
With SHFileOp
.wFunc = FO_COPY
.pFrom = sFileFrom
'Flags = Flags Xor FOF_ALLOWUNDO
.fFlags = FOF_ALLOWUNDO Or Flags
If Err Then
Err = 0
.fFlags = FOF_ALLOWUNDO
End If
.pTo = sFileTo
End With
FileCopy = SHFileOperation(SHFileOp)
RaiseEvent Done(FileCopy, eFileCopy)
End Function
Public Function FilesCopy(ByVal sFilesFrom As String, ParamArray vFiles() As Variant) As Long
'Si sFileFrom contiene una o más comas, se supone que
'es un string con múltiples archivos separados por comas
'a continuación estará el archivo/directorio de destino.
'Los demás parámetros SIEMPRE estarán separados por comas
Dim i As Long
Dim sFiles As Variant
Dim DestDir As String
Dim SHFileOp As SHFILEOPSTRUCT
Dim lb As Long
Dim ub As Long
On Local Error Resume Next
'Convertir los caracteres "," en vbNullChar
If InStr(sFilesFrom, ",") Then
sFiles = Me.QuitarCaracterEx(sFilesFrom, ",", vbNullChar)
If Right$(sFiles, 1) <> vbNullChar Then
sFiles = sFiles & vbNullChar
End If
Else
sFiles = sFilesFrom & vbNullChar
End If
lb = LBound(vFiles)
ub = UBound(vFiles)
DestDir = vFiles(ub) & vbNullChar & vbNullChar
For i = lb To ub - 1
sFiles = sFiles & vFiles(i) & vbNullChar
Next
sFiles = sFiles & vbNullChar
With SHFileOp
.wFunc = FO_COPY
.pFrom = sFiles
'Flags = Flags Xor FOF_ALLOWUNDO
.fFlags = FOF_ALLOWUNDO Or Flags
If Err Then
Err = 0
.fFlags = FOF_ALLOWUNDO
End If
.pTo = DestDir
End With
FilesCopy = SHFileOperation(SHFileOp)
RaiseEvent Done(FilesCopy, eFileCopy)
End Function
Public Function QuitarCaracterEx(ByVal sValor As String, ByVal sCaracter As String, Optional ByVal sPoner) As String
'----------------------------------------------------------
' Cambiar/Quitar caracteres (17/Sep/97)
' Si se especifica sPoner, se cambiará por ese carácter
'
'Esta versión permite cambiar los caracteres (17/Sep/97)
'y sustituirlos por el/los indicados
'a diferencia de QuitarCaracter, no se buscan uno a uno,
'sino todos juntos
'----------------------------------------------------------
Dim i As Long
Dim sCh As String
Dim bPoner As Boolean
Dim iLen As Long
bPoner = False
If Not IsMissing(sPoner) Then
sCh = sPoner
bPoner = True
End If
iLen = Len(sCaracter)
If iLen = 0 Then
QuitarCaracterEx = sValor
Exit Function
End If
'Si el caracter a quitar/cambiar es Chr$(0), usar otro método
If Asc(sCaracter) = 0 Then
'Quitar todos los chr$(0) del final
Do While Right$(sValor, 1) = Chr$(0)
sValor = Left$(sValor, Len(sValor) - 1)
If Len(sValor) = 0 Then Exit Do
Loop
iLen = 1
Do
i = InStr(iLen, sValor, sCaracter)
If i Then
If bPoner Then
sValor = Left$(sValor, i - 1) & sCh & Mid$(sValor, i + 1)
Else
sValor = Left$(sValor, i - 1) & Mid$(sValor, i + 1)
End If
iLen = i
Else
'ya no hay más, salir del bucle
Exit Do
End If
Loop
Else
i = 1
Do While i <= Len(sValor)
'Debug.Print Mid$(sValor, i, 1); Asc(Mid$(sValor, i, 1));
If Mid$(sValor, i, iLen) = sCaracter Then
If bPoner Then
sValor = Left$(sValor, i - 1) & sCh & Mid$(sValor, i + iLen)
i = i - 1
'Si lo que hay que poner está incluido en
'lo que se busca, incrementar el puntero
' (11/Jun/98)
If InStr(sCh, sCaracter) Then
i = i + 1
End If
Else
sValor = Left$(sValor, i - 1) & Mid$(sValor, i + iLen)
End If
End If
i = i + 1
Loop
End If
QuitarCaracterEx = sValor
End Function
Public Function FileMove(ByVal sFileFrom As String, ByVal sFileTo As String) As Long
Dim SHFileOp As SHFILEOPSTRUCT
On Local Error Resume Next
sFileFrom = sFileFrom & vbNullChar & vbNullChar
sFileTo = sFileTo & vbNullChar & vbNullChar
With SHFileOp
.wFunc = FO_MOVE
.pFrom = sFileFrom
'Flags = Flags Xor FOF_ALLOWUNDO
.fFlags = FOF_ALLOWUNDO Or Flags
If Err Then
Err = 0
.fFlags = FOF_ALLOWUNDO
End If
.pTo = sFileTo
End With
FileMove = SHFileOperation(SHFileOp)
RaiseEvent Done(FileMove, eFileMove)
End Function
Public Function FilesMove(ByVal sFilesFrom As String, ParamArray vFiles() As Variant) As Long
'Si sFileFrom contiene una o más comas, se supone que
'es un string con múltiples archivos separados por comas,
'a continuación estará el archivo/directorio de destino.
'Los demás parámetros SIEMPRE estarán separados por comas
Dim i As Long
Dim sFiles As Variant
Dim DestDir As String
Dim SHFileOp As SHFILEOPSTRUCT
Dim lb As Long
Dim ub As Long
On Local Error Resume Next
'Convertir los caracteres "," en vbNullChar
If InStr(sFilesFrom, ",") Then
sFiles = Me.QuitarCaracterEx(sFilesFrom, ",", vbNullChar)
If Right$(sFiles, 1) <> vbNullChar Then
sFiles = sFiles & vbNullChar
End If
Else
sFiles = sFilesFrom & vbNullChar
End If
lb = LBound(vFiles)
ub = UBound(vFiles)
DestDir = vFiles(ub) & vbNullChar & vbNullChar
For i = lb To ub - 1
sFiles = sFiles & vFiles(i) & vbNullChar
Next
sFiles = sFiles & vbNullChar
With SHFileOp
.wFunc = FO_MOVE
.pFrom = sFiles
'Flags = Flags Xor FOF_ALLOWUNDO
.fFlags = FOF_ALLOWUNDO Or Flags
If Err Then
Err = 0
.fFlags = FOF_ALLOWUNDO
End If
.pTo = DestDir
End With
FilesMove = SHFileOperation(SHFileOp)
RaiseEvent Done(FilesMove, eFileMove)
End Function
Public Function FileDelete(ByVal sFileFrom As String) As Long
Dim SHFileOp As SHFILEOPSTRUCT
On Local Error Resume Next
sFileFrom = sFileFrom & vbNullChar & vbNullChar
With SHFileOp
.wFunc = FO_DELETE
.pFrom = sFileFrom
'Flags = Flags Xor FOF_ALLOWUNDO
.fFlags = FOF_ALLOWUNDO Or Flags
If Err Then
Err = 0
.fFlags = FOF_ALLOWUNDO
End If
End With
FileDelete = SHFileOperation(SHFileOp)
RaiseEvent Done(FileDelete, eFileDelete)
End Function
Public Function FilesDelete(ByVal sFilesFrom As String, ParamArray vFiles() As Variant) As Long
'--------------------------------------------------------------------------
' Si sFileFrom contiene una o más comas, se supone que
' es un string con múltiples archivos separados por comas,
' a continuación puede haber más archivos a borrar.
' SIEMPRE separados por comas
'
'--------------------------------------------------------------------------
' Si se especifica: PATH\*.* (31/Jul/01)
' se borra el directorio y su contenido (algunas veces)
'--------------------------------------------------------------------------
Dim i As Long
Dim sFiles As String
Dim SHFileOp As SHFILEOPSTRUCT
On Local Error Resume Next
' Convertir los caracteres "," en vbNullChar
If InStr(sFilesFrom, ",") Then
sFiles = Me.QuitarCaracterEx(sFilesFrom, ",", vbNullChar)
If Right$(sFiles, 1) <> vbNullChar Then
sFiles = sFiles & vbNullChar
End If
Else
sFiles = sFilesFrom & vbNullChar
End If
For i = LBound(vFiles) To UBound(vFiles)
sFiles = sFiles & vFiles(i) & vbNullChar
Next
sFiles = sFiles & vbNullChar
With SHFileOp
.wFunc = FO_DELETE
.pFrom = sFiles
'Flags = Flags Xor FOF_ALLOWUNDO
.fFlags = FOF_ALLOWUNDO Or Flags
If Err Then
Err = 0
.fFlags = FOF_ALLOWUNDO
End If
End With
FilesDelete = SHFileOperation(SHFileOp)
RaiseEvent Done(FilesDelete, eFileDelete)
End Function
Public Function FileFindCustom(ByVal sFile As String, ByVal sPath As String, colFiles As Variant, Optional ByVal vSubDirs As Variant, Optional ByVal vOnlyOne As Variant, Optional ByVal vOnlyDir As Variant) As Variant
'----------------------------------------------------------
'Parámetros:
' sFile Fichero o extensión a buscar
' sPath Directorio o unidad de búsqueda
' vSubDirs Incluir subdirectorios
' vOnlyOne Devolver sólo el primero hallado
' Si no se especifica este parámetro o
' el valor es False, se devuelve
' una colección con todos los hallados
' vOnlyDir Sólo buscar directorios
'----------------------------------------------------------
Dim bSubDirs As Boolean
Dim bOnlyOne As Boolean
Dim bOnlyDir As Boolean
Dim sFileName As String
Dim sFileTmp As String
Dim WFD As WIN32_FIND_DATA
Dim hFindFile As Long
Dim ret As Long
Dim esColObjeto As Boolean
If IsMissing(vSubDirs) Then
bSubDirs = False
Else
bSubDirs = CBool(vSubDirs)
End If
If IsMissing(vOnlyOne) Then
bOnlyOne = False
Else
bOnlyOne = CBool(vOnlyOne)
End If
If IsMissing(vOnlyDir) Then
bOnlyDir = False
Else
bOnlyDir = CBool(vOnlyDir)
End If
esColObjeto = False
If TypeOf colFiles Is Collection Then
esColObjeto = True
ElseIf TypeOf colFiles Is Object Then
esColObjeto = True
End If
If esColObjeto Then
Call FindAllFiles(sFile, sPath, colFiles, bSubDirs, bOnlyOne, bOnlyDir)
Else
'Crear una colección
Dim BrowcolFiles As New Collection
Call FindAllFiles(sFile, sPath, BrowcolFiles, bSubDirs, bOnlyOne, bOnlyDir)
End If
On Local Error Resume Next
If bOnlyOne Then
ret = 1
If Not esColObjeto Then
If BrowcolFiles.Count Then
colFiles = BrowcolFiles(1)
Else
colFiles = ""
ret = 0
End If
Set BrowcolFiles = Nothing
End If
'si se produce un error
If Err Then
Err = 0
ret = 0
End If
FileFindCustom = ret
Else
If esColObjeto Then
If TypeOf colFiles Is Collection Then
ret = colFiles.Count
Else
ret = colFiles.ListCount
End If
Else
If BrowcolFiles.Count Then
colFiles = BrowcolFiles(1)
ret = 1
Else
colFiles = ""
ret = 0
End If
Set BrowcolFiles = Nothing
End If
'si se produce un error
If Err Then
Err = 0
ret = 0
End If
FileFindCustom = ret
End If
'Devolverá -1 si no ha tenido éxito
RaiseEvent Done(ret - 1, eFileFind)
Err = 0
On Local Error GoTo 0
End Function
Public Sub SplitPath(ByVal sTodo As String, ByRef sPath As String, _
Optional ByRef vNombre, Optional ByRef vExt)
'----------------------------------------------------------------
' Divide el nombre recibido en la ruta, nombre y extensión
' (c)Guillermo Som, 1997 ( 1/Mar/97)
'
' Esta rutina aceptará los siguientes parámetros:
' sTodo Valor de entrada con la ruta completa
' Devolverá la información en:
' sPath Ruta completa, incluida la unidad
' vNombre Nombre del archivo incluida la extensión
' vExt Extensión del archivo (sin el punto)
'
' Los parámetros opcionales sólo se usarán si se han especificado
'----------------------------------------------------------------
Dim bNombre As Boolean ' Flag para saber si hay que devolver el nombre
Dim i As Long
'
If Not IsMissing(vNombre) Then
bNombre = True
vNombre = sTodo
End If
'
' La extensión se debe buscar desde atrás, (13/Ene/99)
' ya que el nombre puede contener puntos en el nombre.
If Not IsMissing(vExt) Then
vExt = ""
i = InStrRev(sTodo, ".")
If i Then
vExt = Mid$(sTodo, i + 1)
End If
' For i = Len(sTodo) To 1 Step -1
' If Mid$(sTodo, i, 1) = "." Then
' vExt = Mid$(sTodo, i + 1)
' Exit For
' End If
' Next
If Len(vExt) = 0 Then
vExt = "*"
End If
End If
'
sPath = ""
' Asignar el path
For i = Len(sTodo) To 1 Step -1
If Mid$(sTodo, i, 1) = "\" Then
sPath = Left$(sTodo, i - 1)
' Si hay que devolver el nombre
If bNombre Then
vNombre = Mid$(sTodo, i + 1)
End If
Exit For
End If
Next
End Sub
Public Function BrowseForFolder(ByVal hwndOwner As Long, _
ByVal sPrompt As String, _
Optional ByVal lFlags As eBIF = BIF_RETURNONLYFSDIRS) As String
'--------------------------------------------------------------------------
' Seleccionar el directorio
'--------------------------------------------------------------------------
Dim iNull As Long
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
'Dim lFlags As Long
'
'If IsMissing(vFlags) Then
' lFlags = BIF_RETURNONLYFSDIRS
'Else
'If Not IsMissing(vFlags) Then
'lFlags = CInt(vFlags)
'If lFlags = 0 Then
' lFlags = BIF_RETURNONLYFSDIRS
'End If
'End If
'
With udtBI
.hwndOwner = hwndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = lFlags Or BIF_RETURNONLYFSDIRS
End With
'
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
Else
' Se ha pulsado en cancelar
sPath = ""
If CancelError Then
With Err
.Source = "cgsFileOp.BrowseForFolder"
.Number = 32755
.Description = "Cancelada la operación de BrowseForFolder"
End With
End If
End If
'
BrowseForFolder = sPath
'
RaiseEvent Done(Len(sPath), eBrowseForFolder)
End Function
Public Property Get NoConfirmation() As Boolean
NoConfirmation = (Flags And FOF_NOCONFIRMATION)
End Property
Public Property Let NoConfirmation(ByVal bNewValue As Boolean)
Flags = Flags Xor FOF_NOCONFIRMATION
If bNewValue Then
Flags = Flags Or FOF_NOCONFIRMATION
End If
End Property
Public Property Get Silent() As Boolean
Silent = (Flags And FOF_SILENT)
End Property
Public Property Let Silent(ByVal bNewValue As Boolean)
Flags = Flags Xor FOF_SILENT
If bNewValue Then
Flags = Flags Or FOF_SILENT
End If
End Property
Public Property Get RenameOnCollision() As Boolean
RenameOnCollision = (Flags And FOF_RENAMEONCOLLISION)
End Property
Public Property Let RenameOnCollision(ByVal bNewValue As Boolean)
Flags = Flags Xor FOF_RENAMEONCOLLISION
If bNewValue Then
Flags = Flags Or FOF_RENAMEONCOLLISION
End If
End Property
Public Property Get NoConfirmMKDIR() As Boolean
NoConfirmMKDIR = (Flags And FOF_NOCONFIRMMKDIR)
End Property
Public Property Let NoConfirmMKDIR(ByVal bNewValue As Boolean)
Flags = Flags Xor FOF_NOCONFIRMMKDIR
If bNewValue Then
Flags = Flags Or FOF_NOCONFIRMMKDIR
End If
End Property
Public Property Get SimpleProgress() As Boolean
SimpleProgress = (Flags And FOF_SIMPLEPROGRESS)
End Property
Public Property Let SimpleProgress(ByVal bNewValue As Boolean)
Flags = Flags Xor FOF_SIMPLEPROGRESS
If bNewValue Then
Flags = Flags Or FOF_SIMPLEPROGRESS
End If
End Property
Public Function FileOperationDescription(ByVal FileOperation As eFileOperation) As String
Dim sTmp As String
Select Case FileOperation
Case eFileCopy
sTmp = "FileCopy / FilesCopy"
Case eFileMove
sTmp = "FileMove / FilesMove"
Case eFileRename
sTmp = "FileRename / FilesRename"
Case eFileDelete
sTmp = "FileDelete / FileDelete"
Case eFileFindFirst
sTmp = "FileFindFirst"
Case eFileFindNext
sTmp = "FileFindNext"
Case eFileExist
sTmp = "FileExist"
Case eFolderExist
sTmp = "FolderExist"
Case eFileRead
sTmp = "FileRead"
Case eFileSave
sTmp = "FileSave"
Case eBrowseForFolder
sTmp = "BrowseForfolder"
Case eFileFind
sTmp = "FileFind"
Case Else
sTmp = "<desconocido>"
End Select
FileOperationDescription = sTmp
End Function
Public Function RTrimNull(ByVal sFileName As String) As String
'Devuelve una cadena hasta el primer Null
Dim i%
i = InStr(sFileName, vbNullChar)
If i > 1 Then
sFileName = Left(sFileName, i - 1)
End If
RTrimNull = sFileName
End Function
Public Function AddBackSlash(ByVal sPath As String) As String
'Si no tiene la barra de directorio añadirsela
'Nota: Para quitarla, ver QuitarBackSlah (13/abr/98)
If Len(sPath) Then ' (30/Ene/99)
If Right$(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
End If
AddBackSlash = sPath
End Function
Public Function FolderExist(ByVal sFile As String) As Boolean
'comprobar si existe este directorio
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
FolderExist = False
Else
If WFD.dwFileAttributes And vbDirectory Then
FolderExist = True
End If
'Cerrar el handle de FindFirst
hFindFile = FindClose(hFindFile)
End If
RaiseEvent Done(FolderExist, eFolderExist)
End Function
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
RaiseEvent Done(FileExist, eFileExist)
End Function
Public Function FolderFindAll(ByVal sFileSpec As String, Optional ByVal vPath As Variant) As Variant
'Busca todos los directorios que coincidan con la especificación indicada
'
'Parámetros:
' sFileSpec Directorio a buscar, permite caracteres de comodines
' vPath Path de inicio de la búsqueda (opcional)
'
'Nota: se buscará también en todos los directorios que estén debajo del especificado
'
Dim sPath As String
Dim colFiles As New Collection
If IsMissing(vPath) Then
'Si no se especifica el path, buscar en el directorio actual
sPath = CurDir$
Else
sPath = CStr(vPath)
End If
Call FileFindCustom(sFileSpec, sPath, colFiles, True, False, True)
Set FolderFindAll = colFiles
RaiseEvent Done(colFiles.Count, eFileFind)
Set colFiles = Nothing
End Function
Public Function FileFindAll(ByVal sFileSpec As String, Optional ByVal vPath As Variant) As Variant
'Busca todas las coincidencias de la especificación indicada
'y lo devuelve como una colección
'
'Parámetros:
' sFileSpec Archivo a buscar, permite caracteres de comodines
' vPath Path de inicio de la búsqueda (opcional)
'
'Nota: se buscará también en todos los directorios que estén debajo del especificado
'
Dim sPath As String
Dim colFiles As New Collection
If IsMissing(vPath) Then
'Si no se especifica el path, buscar en el directorio actual
sPath = CurDir$
Else
sPath = CStr(vPath)
End If
Call FileFindCustom(sFileSpec, sPath, colFiles, True, False)
Set FileFindAll = colFiles
RaiseEvent Done(colFiles.Count, eFileFind)
Set colFiles = Nothing
End Function
Public Function FolderFind(ByVal sFileSpec As String, Optional ByVal vPath As Variant) As String
'Busca el primer directorio que coincida con la especificación indicada
'
'Parámetros:
' sFileSpec Archivo a buscar, permite caracteres de comodines
' vPath Path de inicio de la búsqueda (opcional)
'
'Nota: se buscará también en todos los directorios que estén debajo del especificado
'
Dim sPath As String
Dim sFileName As String
If IsMissing(vPath) Then
'Si no se especifica el path, buscar en el directorio actual
sPath = CurDir$
Else
sPath = CStr(vPath)
End If
Call FileFindCustom(sFileSpec, sPath, sFileName, True, True, True)
FolderFind = sFileName
RaiseEvent Done(Len(sFileName) - 1, eFileFind)
End Function
Public Function FileFind(ByVal sFileSpec As String, Optional ByVal vPath As Variant) As String
'Busca la primera coincidencia de la especificación indicada
'
'Parámetros:
' sFileSpec Archivo a buscar, permite caracteres de comodines
' vPath Path de inicio de la búsqueda (opcional)
'
'Nota: se buscará también en todos los directorios que estén debajo del especificado
'
Dim sPath As String
Dim sFileName As String
If IsMissing(vPath) Then
'Si no se especifica el path, buscar en el directorio actual
sPath = CurDir$
Else
sPath = CStr(vPath)
End If
Call FileFindCustom(sFileSpec, sPath, sFileName, True, True)
FileFind = sFileName
RaiseEvent Done(Len(sFileName) - 1, eFileFind)
End Function
Public Function AddPath(ByVal sFile As String, Optional ByVal vPath As Variant) As String
'Añadir el path sino lo tiene ( 2/Nov/97)
'Si no se especifica el path a añadir, usar App.Path
Dim sTmp As String
Dim sPath As String
'Si ya incluye el path, devolver el valor actual
If InStr(sFile, "\") Then
AddPath = sFile
Else
If IsMissing(vPath) Then
sPath = App.Path
Else
sPath = Trim$(CStr(vPath))
End If
'si se indica con cadena vacía... ( 8/Nov/97)
'añadir el path actual
If Len(sPath) = 0 Then
sPath = CurDir$
End If
AddPath = AddBackSlash(sPath) & sFile
End If
End Function
Public Function QuitarBackSlash(ByVal sPath As String) As String
'Quitarle el \ del final
'Para añadirsela, ver AddBackSlash
If Right$(sPath, 1) = "\" Then
sPath = Left$(sPath, Len(sPath) - 1)
End If
QuitarBackSlash = sPath
End Function
Public Function LeerIni(ByVal lpFileName As String, ByVal lpAppName As String, ByVal lpKeyName As String, Optional ByVal vDefault As Variant) As String
If IsMissing(vDefault) Then
LeerIni = Me.GetSetting(lpFileName, lpAppName, lpKeyName)
Else
LeerIni = Me.GetSetting(lpFileName, lpAppName, lpKeyName, vDefault)
End If
End Function
Public Sub GuardarIni(ByVal lpFileName As String, ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As String)
Me.SaveSetting lpFileName, lpAppName, lpKeyName, lpString
End Sub
Public Function GetDir(ByVal sPath As String) As String
Dim i&
'Devuelve el directorio del path indicado
GetDir = sPath
For i = Len(sPath) To 1 Step -1
If Mid$(sPath, i, 1) = "\" Then
GetDir = Left$(sPath, i - 1)
Exit For
End If
Next
End Function
Public Sub DeleteSetting(ByVal sIniFile As String, ByVal sSection As String, _
Optional ByVal sKey As String = "")
'
' Añadida a cgsFileOP (10/Jul/00)
'
' Borrar una clave o entrada de un fichero INI (16/Feb/99)
' Si no se indica sKey, se borrará la sección indicada en sSection
' En otro caso, se supone que es la entrada (clave) lo que se quiere borrar
'
If Len(sKey) = 0 Then
' Borrar una sección
Call WritePrivateProfileString(sSection, 0&, 0&, sIniFile)
Else
' Borrar una entrada
Call WritePrivateProfileString(sSection, sKey, 0&, sIniFile)
End If
End Sub
Public Function NameFromFileName(ByVal sFileName As String, _
Optional ByVal ConExt As Boolean = True) As String
' Devuelve sólo el Nombre y extensión del fichero indicado (17/Jul/00)
' Si se indica False en ConExt, no devolver la extensión
Dim sPath As String
Dim sName As String
Dim i As Long
'
' Usar SplitPath para hacer el trabajo "sucio"
SplitPath sFileName, sPath, sName
If ConExt = False Then
' Si no debe devolverse la extensión, comprobar si tiene (09/Oct/01)
i = InStrRev(sName, ".")
If i Then
sName = Left$(sName, i - 1)
End If
End If
NameFromFileName = sName
End Function
Public Function PathFromFileName(ByVal sFileName As String) As String
' Devuelve sólo el Path del fichero indicado (17/Jul/00)
Dim sPath As String
'
' Usar SplitPath para hacer el trabajo "sucio"
SplitPath sFileName, sPath
PathFromFileName = sPath
End Function
Public Function ExtFromFileName(ByVal sFileName As String) As String
' Devuelve sólo la extensión del fichero indicado (17/Jul/00)
Dim sPath As String
Dim sName As String
Dim sExt As String
'
' Usar SplitPath para ahcer el trabajo "sucio"
SplitPath sFileName, sPath, sName, sExt
ExtFromFileName = sExt
End Function
Public Function AppPath(Optional ByVal conBackSlash As Boolean = True) As String
' Devuelve el path de la aplicación con la barra al final (03/May/01)
' o sin ella, según se especifique en el parámetro
Dim s As String
'
s = App.Path
If conBackSlash Then
If Right$(s, 1) <> "\" Then
s = s & "\"
End If
Else
If Right$(s, 1) = "\" Then
s = Left$(s, Len(s) - 1)
End If
End If
AppPath = s
End Function
Friend Function DevMode() As DEVMODE_TYPE
LSet DevMode = mDevMode
End Function
