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:
En Visual Basic 2005 y C# 2.0 puedes usar las propiedades AutoComplete y relacionadas.
'------------------------------------------------------------------------------
' 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