Crear Editor de Texto Plano

Option Explicit
' Función Api CHOOSECOLOR para llamar al CD de fuente
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" ( _
                                            pChoosecolor As CHOOSECOLOR) As Long
                                            
' Estructura CHOOSECOLOR para configurar el cuadro de diálogo
Private Type CHOOSECOLOR
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

'PROGRESO
Dim Prog As clsProgreso

Dim p As Long

'Lamada para funcion DESHACER y demas funciones las cuales se podria aplicar Ejm.
Const WM_USER = &H400
Const EM_GETSEL = WM_USER + 0
Const EM_SETSEL = WM_USER + 1
Const EM_REPLACESEL = WM_USER + 18
Const EM_UNDO = WM_USER + 23
Const EM_LINEFROMCHAR = WM_USER + 25
Const EM_GETLINECOUNT = WM_USER + 10
'
'Const WM_CUT = &H300
'Const WM_COPY = &H301
'Const WM_PASTE = &H302
'Const WM_CLEAR = &H303
'
'para estas funciones tambie  puedes utilizar: "Screen.ActiveForm.ActiveControl.hwnd" en lugar de "Text1.hwnd"
'Copiar:
    'If SendMessage(Text1.hwnd, WM_COPY, 0, ByVal 0&) Then
    'End If
'Cortar:
    'If SendMessage(Text1.hwnd, WM_CUT, 0, ByVal 0&) Then
    'End If
'Eliminar:
    'If SendMessage(Text1.hwnd, WM_CLEAR, 0, ByVal 0&) Then
    'End If
'Pegar:
    'If SendMessage(Text1.hwnd, WM_PASTE, 0, ByVal 0&) Then
    'End If
'Seleccionar Todo:
    'If SendMessage(Text1.hwnd, EM_SETSEL, 0, ByVal &HFFFF0000) Then
    'End If
'Funcion API Send Mensaje
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal _
hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

'Llamada API para Ejecutar programa
Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'Creamos un Boolean para dar a true(verdadero) cuando hay cambio en el texto
Private Modificado As Boolean

'Boton que hara la busqueda del texto
Private Sub cmdBuscar_Click()
If cmdBuscar.Caption = "Buscar" Then
    'Función que busca el texto escrito en el TxtBuscar
    BuscarTexto
    cmdBuscar.Caption = "Buscar siguiente"
End If

If cmdBuscar.Caption = "Buscar siguiente" Then
    'Sigue buscando mas coincidencias
    BuscarTexto (Text1.SelStart + 1)
End If
End Sub

'Cerrar el frame de buscar 
Private Sub cmdCancelar_Click()
    Picture1.Visible = False
    Picture2.Print ""
    txtBuscar.Text = ""
End Sub

Private Sub Form_Load()
'Llama al nuevo documento, que se generará automaticamente
VerNuevoDoc 'Llevara como nombre por defecto "Nuevo Doc 1", para modificarlo lo haces en Private Sub NuevoDoc()

'FUNCION PARA EL PROGRESO
Set Prog = New clsProgreso

    With Prog
       
       Set .PictureBox = Picture3
       .Progreso = True
       .ProgressColor = vbGreen
       .ColorPercent = vbBlue
    End With

End Sub

'funcion para buscar texto
Sub BuscarTexto(Optional ByVal PosIni As Integer)
On Error Resume Next
Dim Pos As Integer
Dim PalabraClave As String
'TipoBusqueda corresponde si se busca Mayus y Minus identicas...
Dim TipoBusqueda As Long
'La variable PalabraClave toma el valor de txtBuscar
PalabraClave = txtBuscar.Text
'Verificar si PalabraClave no esta vacía
If Len(PalabraClave) Then
'Verificar si Mayus y Minus esta desactivada
If cMayusMinus.Value = 1 Then TipoBusqueda = vbTextCompare
'Busca desde la PosIni que se indico...
Pos = InStr(PosIni + 1, Text1.Text, PalabraClave, TipoBusqueda)
If Pos > 0 Then
'Si devolvio mayor de 0...se encontro
Text1.SelStart = Pos - 1
Text1.SelLength = Len(PalabraClave)
Text1.SetFocus
'Picture2.Print "Buscar: Encontro la palabra."
Else
'No se encontró
Text1.SetFocus
txtBuscar.Text = "(No se encontro la palabra)"
End If
End If

End Sub

'Funcion para adecuar la caja de texto al tamaño del formulario
Private Sub Form_Resize()
'generas que el Text1 tenga el mismo tamaño que el Form
    On Error Resume Next
    Text1.Move 0, 0, Me.ScaleWidth - 0, Me.ScaleHeight - 0 'Aqui haces que el alto el ancho sean igual a 0 y ocupen todo el tamaño del Form
    Text1.RightToLeft = Text1.Width - 400 'Asi este tamaño sea modifcado por el usuario
End Sub

Private Sub Form_Unload(Cancel As Integer)
'Cerrar Programa
mnuFileSalir_Click 'Aqui te vas al menú salir que tiene la funcion de preguntar si se guarda el documento en caso este haya sido modificado
End Sub

'funcion para imprimir el texto
Public Sub imprimeLineas(texto As Object, Linea As Integer)
    On Error GoTo NoImprimir 'En caso de estar istalada la impresora se va hasta "NoImprimir:" para no generar error y el programa se cierre a causa de este
    Dim i As Long
    Dim Bloque As String
    'Numero de caracteres = NumC
    'Numero de Bloques = NumB
    Dim NumC, NumB As Integer
    NumC = Len(texto.Text)
    If NumC > Linea Then
        NumB = NumC \ Linea
        For i = 0 To NumB
            texto.SelStart = (Linea * i)
            texto.SelLength = Linea
            Bloque = texto.SelText
            Printer.Print Bloque
        Next i
    Else
        Printer.Print texto.Text
    End If
    Printer.EndDoc
NoImprimir:
End Sub

'Menú Buscar
Private Sub mnuBuscarBuscar_Click()
    Picture2.Print "Buscar"
    Picture1.Visible = True
    Picture1.Top = "800"
    Picture1.Left = "800"
End Sub

'Menú Copiar 
Private Sub mnuEditCopiar_Click()
'copiar texto
    Clipboard.Clear
    Clipboard.SetText Text1.SelText
    Text1.SetFocus
End Sub

mnuCortar
Private Sub mnuEditCortar_Click()
    'Cortar texto
    Clipboard.SetText Text1.SelText
    Text1.SelText = ""
    Text1.SetFocus
End Sub

Menú deshacer
Private Sub mnuEditDeshacer_Click()
Dim undoResultado
'deshacer texto
   undoResultado = SendMessage(Text1.hWnd, EM_UNDO, 0&, 0&)
    If undoResultado = -1 Then
        Beep
        MensajeBox "Error al intentar recuperar.", iconoInformacion + btnaceptar, "Deshacer texto"
    End If
End Sub

Menú eliminar
Private Sub mnuEditEliminar_Click()
'Eliminar texto hace que la seleccion sea igual a nada
    Text1.SelText = ""
End Sub

Private Function CommonDialogColor() As Long
    ' Array de tipo Byte dinámico
    Dim CustomColors() As Byte
    ' Variable para utilizar la estructura
    Dim cc As CHOOSECOLOR
    'array de tipo Long
    Dim Custcolor(16) As Long
    'Variable de retorno
    Dim lReturn As Long

    'Establecemos el tamaño de la extructura
    cc.lStructSize = Len(cc)
    'Le pasamos el hwnd del form a cc
    cc.hwndOwner = Me.hWnd
    'Establecemos la instancia de nuestra aplicación a cc.Hinstance
    cc.hInstance = App.hInstance
    'Establecemos los colores convertidos a Unicode
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    'El flag a 0 dialogo normal, en 2 dialogo completo
    cc.flags = 2
    
    'Mostramos el Cuadro de diálogo
    If CHOOSECOLOR(cc) <> 0 Then
        'Retornamos a nuestra función el valor elegido
        CommonDialogColor = cc.rgbResult
        'Para los colores personalizados
        CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
    Else
        CommonDialogColor = -1
    End If
End Function

'menu edit fuente
Private Sub mnuEditFuente_Click()
'Llamamos a nuestra fuente personalizada
'On Error GoTo AbrirFuente_Error
    Dim ElegirColor As Long
    
    'La variable ElegirColor almacenará el color en formato Long
    'del color elegido. Si no se eligió ninguno retornamos desde
    'la función el valor -1, si no establecemos el color defondo
    'del form pasandole el valor devuelto por la función
    
    ' llamamos al cuadro diálogo Seleccionar Color
    ElegirColor = CommonDialogColor
    
    If ElegirColor <> -1 Then
        ' establecemos el color de fondo del texto con el color seleccionado
        text1.ForeColor = ElegirColor
    Else
        'la funcion se cancela mejor dicho no escogieron ningun color, si deseas le pones un msgbox en esta linea
    End If
'Exit Sub
'AbrirFuente_Error:
End Sub

'Menú para colocar la hora
Private Sub mnuEditHoraFecha_Click()
    Text1.SelText = Format$(Date, "hh:mm " & "dd/mm/yyyy")
End Sub

'Menu Pegar
Private Sub mnuEditPegar_Click()
'pegar texto
    Text1.SelText = Clipboard.GetText()
    Text1.SetFocus
End Sub

'menu seleccionar todo
Private Sub mnuEditSeleccionarTodo_Click()
    'seleccionar todo
    Text1.SetFocus
    Text1.SelStart = 0
    Text1.SelLength = Len(Text1.Text)
End Sub

'menu abrir
Private Sub mnuFileAbrir_Click()
        On Error GoTo Abrir_Error
        'Llamamos a la funcion OPENFILENAME del modulo
    Dim file As OPENFILENAME, sFile As String, sFileTitle As String, lResult As Long, iDelim As Integer
    Dim i As Long, tamFic As Long
    
    file.lStructSize = Len(file)
    file.hwndOwner = Me.hWnd
    file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST
    'Esto se pondra en caja de texto Nombre del CDialog
    file.lpstrFile = "*.ptx; *.txt; *.inf; *.ini" & String$(250, 0)
    file.nMaxFile = 255
    'Retorna el nombre de archivo juztificado
    file.lpstrFileTitle = String$(255, 0)
    file.nMaxFileTitle = 255
    'Sesion inicial de directorio, esto quiere decir que cuando se abra el commodDialog lo hará el WINDOWS, lo puedes modificar para que se abra en cualquier otro directorio
    file.lpstrInitialDir = Environ$("WinDir")
    'Aqui coloca las extenciones que deseas abrir
    file.lpstrFilter = "Documentos de texto" & Chr$(0) & "*.ptx;*.lea; *.txt; *.inf; *.ini" & Chr$(0) & "Todos los Archivos" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
    file.nFilterIndex = 1 'este es el numero o index de filtro en que abrira, en este caso esta en 1 y si en vez de uno es dos se colocara automatimente en "Todos los archivos"
    ' Aqui va el titulo del dialog
    file.lpstrTitle = "Abrir Documento de Texto..."

    lResult = GetOpenFileName(file)
    If lResult <> 0 Then
        iDelim = InStr(file.lpstrFileTitle, Chr$(0))
        If iDelim > 0 Then
            sFileTitle = Left$(file.lpstrFileTitle, iDelim - 1)
        End If
        iDelim = InStr(file.lpstrFile, Chr$(0))
        If iDelim > 0 Then
            sFile = Left$(file.lpstrFile, iDelim - 1)
        End If
        'Aqui preguntamos si el archivo se guarda en case de haberse modificado, si el archivo no fue modificado se realiza la funcion abrir
        If Modificado Then
            If MsgBox("El documento " & Text3.Text & " ha sido modificado." & vbCrLf & _
                    "¿Desea Guardarlo?", vbQuestion + vbYesNo) = vbYes Then
                    mnuFileGuardar_Click
            End If
        End If
            'utlizamos el FREEFILE para abrir el texto
            i = FreeFile
            Open sFile For Input As i
            tamFic = LOF(i)
            Text1.Text = Input$(tamFic, i)
            Close i
            '
            'AGREGAR MENU -> para ello crea un menú llamado: name=mnuFileDocTextos con index=0
            'Dim ultElem As Integer
            'Static n As Long
            'n = n + 1
            'ultElem = ultElem + n
            'Load mnuFileDocTextos(ultElem)
            'mnuFileDocTextos(ultElem).Caption = sFile
            '
            '
            'Aqui colocamos el nombre del archivo abierto en el caption del form
            Caption = sFileTitle & " - Block de notas Y.A.L." 'caption del Form
            Text3.Text = sFileTitle 'Texto Oculto que almacena el nombre del Archivo abierto
            Text2.Text = sFile 'Texto oculto que almacena la Direccion del Archivo
            Modificado = False 'Le dice al Text1 que no esta modifcado solo que abierto un documento
            '
End If
'En caso de Error de Activan Abrir_Click_Exit: y Abrir_Error:
Abrir_Click_Exit:
    Exit Sub
    
Abrir_Error:
    MensajeBox "El archivo no pede ser abierto por el programa. Error:" & Format$(Err) & " " & Error$ & vbCrLf & "Por favor verifique que el formato del documento que intenta abrir sea compatible con este editor", IconoAlto + btnaceptar, "Error de: " & file.lpstrTitle
    Resume Abrir_Click_Exit
End Sub

Private Sub mnuFileGuardar_Click()
    'guardar el texto
    Dim i As Integer
    
        If Text2.Text = "" Then ' si la direccion es vacia el el texto oculto
            mnuFileGuardarComo_Click 'Abre guardar como
            Else
                'si en el texto oculto esta escrita la direccion del documento lo guarda actualizando
                i = FreeFile 'los datos modificados utilizando FreeFile
                Open Text2.Text For Output As i 'Abre la direccion y grarda
                Print #i, Text1.Text ' el texto modificado
                Close i
                '
                mnuFileGuardar.Enabled = False
        End If
        Modificado = False
End Sub

Private Sub mnuFileGuardarComo_Click()
    On Error GoTo Guardar_Error
        Dim file As OPENFILENAME, sFile As String, sFileTitle As String, lResult As Long, iDelim As Integer
        Dim i As Long
    
    file.lStructSize = Len(file)
    file.hwndOwner = Me.hWnd
    file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_OVERWRITEPROMPT
    'Aqui se coloca el nombre del archivo, ya el "Nuevo PTX1" o el nombre del dimento abierto que se coloco en el Text3 que esta oculto
    file.lpstrFile = Text3.Text & String$(255, 0)
    file.nMaxFile = 255
    'Retorna el nombre de archivo justificado
    file.lpstrFileTitle = String$(255, 0)
    file.nMaxFileTitle = 255
    'Aqui el Dialog se abrira el Archivo especificado en este caso Windows
    file.lpstrInitialDir = Environ$("WinDir")
    'Aqui va las extenciones que utilizaras para abrir
    file.lpstrFilter = "Documento de texto" & Chr$(0) & "*.txt" & Chr$(0) & "Información sobre instalación" & Chr$(0) & "*.inf" & Chr$(0) & "Opciones de configuración" & Chr$(0) & "*.ini" & Chr$(0) & "Todos los Archivos" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
    file.nFilterIndex = 1
    'dialog title
    file.lpstrTitle = "Guardar..."
    'Tu puedes colocar una extencion por defecto
    file.lpstrDefExt = "txt"
    
    lResult = GetSaveFileName(file)
    If lResult <> 0 Then
        iDelim = InStr(file.lpstrFileTitle, Chr$(0))
        If iDelim > 0 Then
            sFileTitle = Left$(file.lpstrFileTitle, iDelim - 1)
        End If
        iDelim = InStr(file.lpstrFile, Chr$(0))
        If iDelim > 0 Then
            sFile = Left$(file.lpstrFile, iDelim - 1)
        End If
        'MsgBox "File Name is " & sFileTitle & Chr$(13) & Chr$(10) & "Full path and file is " & sFile, , "Save As..."
        'sFile = NomArchivo
        

	'Valores para la barra de progreso
	Prog.Min = 0
	Prog.Max = 100 'CByte(bytes) * 100 para cuando tengas procesos con bytes
	picButton2.Visible = True
	'Cambiar el mause a tiempo
	Screen.MousePointer = vbHourglass

	'Utilizas El FREEFILE para guardar el texto
        i = FreeFile
        Open sFile For Output As i
        'IMPRIMIR TEXTO
        Print #i, Text1.Text
        Close i
        '
        Caption = sFileTitle 'caption del form
        Text2.Text = sFile
        
        Modificado = False 'ledice al text1 que ya se guardo y que ya no esta modificado
    End If

DoEvents
'Establecemos el value del progress
'Prog.Value = Prog.Value + 100
    For p = Prog.Min To Prog.Max
       Prog.Value = p
       DoEvents
   Next
'Poceso terminado
Close

picButton2.Visible = False
'En caso de error se activa Guardar_Click_Exit: y Guardar_Error:
Guardar_Click_Exit:
    Exit Sub
    
Guardar_Error:
    MensajeBox "El archivo Error: " & Format$(Err) & " " & Error$ & " no pede ser guardado." & vbCrLf & "Por favor intente guardarlo nuevamente.", IconoAlto + btnaceptar, "Error de: " & file.lpstrTitle
    Resume Guardar_Click_Exit
End Sub

Private Sub mnuFileImprimir_Click()
'On Error GoTo NoPrint
    'X es 60 en este ejmplo
    'imprimeLineas Text1, 600
'Exit Sub
'NoPrint: ' si hay error en imprimir aparece el siguiente mensaje
    'MensajeBox "Uno o mas componentes de la impresora no esta disponible, por favor verifique que la impresora este instalada correctamente.", iconoInformacion + btnaceptar, "Imforme sobre error de impresión"

    Call Show_Printer(Me)
End Sub

Private Sub mnuFileNuevo_Click()
'Aui se pregunta si el documento se guarda en caso de haberse modificado
If Modificado Then
        If MsgBox("El documento " & Text3.Text & " ha sido modificado." & vbCrLf & _
                    "¿Desea Guardarlo?", vbQuestion + vbYesNo) = vbYes Then
                    mnuFileGuardar_Click
        End If
    End If
VerNuevoDoc 'Llama al nuevo documento
Text1.Text = "" 'Coloca el Text1 a "" vacio
Modificado = False 'le dice que como se abrio un nuevo doc. no esta modificado

End Sub

Private Sub mnuFileSalir_Click()
'Pregunta si guarda en caso de haberse modificado el texto
    If Modificado Then
        If MsgBox("El documento " & Text3.Text & " ha sido modificado." & vbCrLf & _
                    "¿Desea Guardarlo?", vbQuestion + vbYesNo) = vbYes Then
                    mnuFileGuardar_Click
        End If
    End If
End
End Sub

'menu vista previa
Private Sub mnuFileVistaPrevia_Click()
Call Configuarar_Pagina(Me)
End Sub

'menu acerca de
Private Sub mnuHelpAcercaDe_Click()
MensajeBox "MBlock de notas Y.A.L." & vbCrLf & "Cortesia de Y.A.L. - RGPerú" & vbCrLf & vbCrLf & _
            "Esta Programa es de uso libre por el cual el autor no se responsabiliza del mal uso del mismo, no tienes que solicitar permiso para usar este codigo y crear tu programa personalizado." _
            & vbCrLf & "Informes: http://www.rgperu.com", iconoInformacion, "Acerca de Editor de Poder"

End Sub

Private Sub mnuHelpWeb_Click()
Dim res As Long
res = ShellExecute(frmMain.hWnd, "open", "http://www.rgperu.com", "", "", 1)
End Sub

Private Sub Text1_Change()
Modificado = True 'le dice que el texto esta modifcado
    'Coloca a los menus que estan deshabilitados a Habilitados
    mnuFileGuardar.Enabled = True
    mnuEditCopiar.Enabled = True
    mnuEditCortar.Enabled = True
    mnuEditDeshacer.Enabled = True
    mnuFileImprimir.Enabled = True
End Sub
Private Sub VerNuevoDoc()
' hace que se genere un nuevo documento
    Static lDocumentCount As Long 'hace que el numero u objeto sea estatico
    lDocumentCount = lDocumentCount + 1 'hace que el numero estatico vaya aumentando
    Caption = "Nuevo PTX " & lDocumentCount & " - MBlock de notas Y.A.L." 'el caption del form es: Nuevo PTX 1 "- lo que quieras"
    Text3.Text = "Nuevo PTX " & lDocumentCount 'Coloca el nombre del documento en el Text3
End Sub

------------------------------------------------------------------------------------------------

'Modulo1 ponle el nombre que desees aqui contienen las funciones del command dialog

'FUNCION EXECUTE
Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Const SW_NORMAL = 1
'
'funcion para crear un form splash con nombre frmSplash ahi si el formulario lleva el nombre de frmMain
Public fMainForm As frmMain

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

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer

Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000                      '  force no long names for 4.x modules
Public Const OFN_EXPLORER = &H80000                         '  new look commdlg
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000                       '  force long names for 3.x modules

Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0


' Declaración de las Constantes para los botones y los iconos
Const MB_DEFBUTTON1 = &H0&
Const MB_DEFBUTTON2 = &H100&
Const MB_DEFBUTTON3 = &H200&
Const MB_ICONASTERISK = &H40&
Const MB_ICONEXCLAMATION = &H30&
Const MB_ICONHAND = &H10&
Const MB_ICONINFORMATION = MB_ICONASTERISK
Const MB_ICONQUESTION = &H20&
Const MB_ICONSTOP = MB_ICONHAND
Const MB_OK = &H0&
Const MB_OKCANCEL = &H1&
Const MB_YESNO = &H4&
Const MB_YESNOCANCEL = &H3&
Const MB_ABORTRETRYIGNORE = &H2&
Const MB_RETRYCANCEL = &H5&


'Llamada API MsgBox
Private Declare Function MessageBox Lib "User32" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, _
             ByVal lpCaption As String, ByVal wType As Long) As Long

Public Enum EstiloBotones
'Enumeracion propias en español
    BtnDefecto1 = MB_DEFBUTTON1
    BtnDefecto2 = MB_DEFBUTTON2
    BtnDefecto3 = MB_DEFBUTTON3
    iconoInformacion = MB_ICONINFORMATION
    IconoExclamacion = MB_ICONEXCLAMATION
    IconoAlto = MB_ICONSTOP
    IconoPregunta = MB_ICONQUESTION
    btnaceptar = MB_OK
    btnAceptarCancelar = MB_OKCANCEL
    btnSiNo = MB_YESNO
    btnSiNoCancelar = MB_YESNOCANCEL
    btnAnularReintentarOmitir = MB_ABORTRETRYIGNORE
    btnReintentarCancelar = MB_RETRYCANCEL
End Enum

'FUNCTION PARA FUENTE
Type CHOOSEFONT
        lStructSize As Long
        hwndOwner As Long          '  controlador de ventana del que llama
        hdc As Long                '  impresora DC/IC o NULL
        lpLogFont As Long
        iPointSize As Long         '  10 * tamaño de fuente seleccionada en puntos
        flags As Long              '  indicadores de tipo enumerados
        rgbColors As Long          '  color de texto que se devuelve
        lCustData As Long          '  datos pasados a la función enlazada
        lpfnHook As Long           '  puntero a función enlazada
        lpTemplateName As String   '  nombre de la plantilla personalizada
        hInstance As Long          '  controlador de instancias de .EXE que
                                   '    contiene una plantilla de diálogo personalizada
        lpszStyle As String        '  aquí devuelve el campo de estilo
                                   '  debe ser LF_FACESIZE o mayor
        nFontType As Integer       '  el mismo valor que el enviado a EnumFonts
                                   '    vuelve a llamar con los bits extra de FONTTYPE_
                                   '    agregados
        MISSING_ALIGNMENT As Integer
        nSizeMin As Long           '  tamaño de puntos mínimo permitido &
        nSizeMax As Long           '  tamaño de puntos máximo si
                                   '    se usa CF_LIMITSIZE
End Type

Public Const LF_FACESIZE = 32

Public Const CF_LIMITSIZE = &H2000&


Sub Main()
    frmSplash.Show
    frmSplash.Refresh
    Set fMainForm = New frmMain
    Load fMainForm
    Unload frmSplash


    fMainForm.Show
End Sub

'mensage de box personalizado
Public Sub MensajeBox(texto, Optional Botones As EstiloBotones = btnaceptar, Optional Titulo As String) 'As ResultadoMensajeBox
Dim hWnd As Long

    MessageBox hWnd, texto, Titulo, Botones 'relacion el msgbox de API con nuestro propio mensajeBox
End Sub

----------------------------------------------------------------------------------------------------------------------------------------

'Modulo2 ponle el nombre que desees, este modulo lleva las funciones de vista previa, Imprimir
Option Explicit


'Constantes
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Const DM_DUPLEX = &H1000&
Const DM_ORIENTATION = &H1&
Const PD_PRINTSETUP = &H40
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const PD_DISABLEPRINTTOFILE = &H80000

'Funciones API
Private Declare Function PrintDialog Lib "comdlg32.dll" Alias "PrintDlgA" ( _
    pPrintdlg As PRINTDLG_TYPE) As Long
Private Declare Function PAGESETUPDLG Lib "comdlg32.dll" Alias "PageSetupDlgA" ( _
    pPagesetupdlg As PAGESETUPDLG) 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
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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    hpvDest As Any, _
    hpvSource As Any, _
    ByVal cbCopy As Long)

' UDT
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type PAGESETUPDLG
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    flags As Long
    ptPaperSize As POINTAPI
    rtMinMargin As RECT
    rtMargin As RECT
    hInstance As Long
    lCustData As Long
    lpfnPageSetupHook As Long
    lpfnPagePaintHook As Long
    lpPageSetupTemplateName As String
    hPageSetupTemplate As Long
End Type


Private Type PRINTDLG_TYPE
    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
Private Type DEVNAMES_TYPE
    wDriverOffset As Integer
    wDeviceOffset As Integer
    wOutputOffset As Integer
    wDefault As Integer
    extra As String * 100
End Type

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

'Fin de declaraciones

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


' función Para el Common diálogo de Configurar página
'---------------------------------------------------------
Public Function Configuarar_Pagina(El_Formulario As Form) As Long

    Dim T_Configurar_Pagina As PAGESETUPDLG
    Dim m_PSD
    
    With T_Configurar_Pagina
        .lStructSize = Len(m_PSD)
        .hwndOwner = El_Formulario.hWnd
        .hInstance = App.hInstance
        .flags = 0
    End With
    
    If PAGESETUPDLG(T_Configurar_Pagina) Then
        Configuarar_Pagina = 0
    Else
        Configuarar_Pagina = -1
    End If
End Function


'Para el Common diálogo de imprimir ( pasar el formulario como parámetro )
'---------------------------------------------------------
Public Sub Show_Printer(El_Formulario As Form, Optional flags As Long)
    
    On Error GoTo ErrSub
    
    Dim t_Printer As PRINTDLG_TYPE
    Dim DevMode As DEVMODE_TYPE
    Dim DevName As DEVNAMES_TYPE

    Dim lpDevMode As Long, lpDevName As Long
    Dim bReturn As Integer
    Dim objPrinter As Printer, NewPrinterName As String

    With t_Printer
        .lStructSize = Len(t_Printer)
        .hwndOwner = El_Formulario.hWnd
        .flags = flags
    End With
    
    On Error Resume Next
    
    DevMode.dmDeviceName = Printer.DeviceName
    DevMode.dmSize = Len(DevMode)
    DevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX
    DevMode.dmPaperWidth = Printer.Width
    DevMode.dmOrientation = Printer.Orientation
    DevMode.dmPaperSize = Printer.PaperSize
    DevMode.dmDuplex = Printer.Duplex
    
    On Error GoTo 0
    
    t_Printer.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevMode))
    lpDevMode = GlobalLock(t_Printer.hDevMode)
    
    If lpDevMode > 0 Then
        CopyMemory ByVal lpDevMode, DevMode, Len(DevMode)
        bReturn = GlobalUnlock(t_Printer.hDevMode)
    End If

    
    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

    t_Printer.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
    lpDevName = GlobalLock(t_Printer.hDevNames)
    
    If lpDevName > 0 Then
        CopyMemory ByVal lpDevName, DevName, Len(DevName)
        bReturn = GlobalUnlock(lpDevName)
    End If

    
    If PrintDialog(t_Printer) <> 0 Then
        lpDevName = GlobalLock(t_Printer.hDevNames)
        CopyMemory DevName, ByVal lpDevName, 45
        bReturn = GlobalUnlock(lpDevName)
        GlobalFree t_Printer.hDevNames

        
        lpDevMode = GlobalLock(t_Printer.hDevMode)
        CopyMemory DevMode, ByVal lpDevMode, Len(DevMode)
        bReturn = GlobalUnlock(t_Printer.hDevMode)
        GlobalFree t_Printer.hDevMode
        NewPrinterName = UCase$(Left(DevMode.dmDeviceName, _
                InStr(DevMode.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
        
        With Printer
            .PaperSize = DevMode.dmPaperSize
            .PrintQuality = DevMode.dmPrintQuality
            .ColorMode = DevMode.dmColor
            .PaperBin = DevMode.dmDefaultSource
            .Copies = DevMode.dmCopies
            .Duplex = DevMode.dmDuplex
            .Orientation = DevMode.dmOrientation
        End With
        On Error GoTo 0
    
    End If

Exit Sub

ErrSub:

If Err.Number = 484 Then
    MsgBox "Error al obtener información de la impresora." & _
            "Asegurarse que está instalada correctamente.", vbCritical
End If

End Sub

-----------------------------------------------------------------------------

Clase para la Barra de Progreso clsProgreso

Option Explicit

'Variables locales para las propiedades

Private m_Value As Long
Private m_min As Long
Private m_max As Long
Private m_PictureBox As PictureBox
Private m_Progreso As Boolean
Private m_ProgressColor As Long
Private m_ColorPercent As Long



'Sub que redibuja el progreso en el PictureBox
Private Sub Mostrar()
    
    Dim pWidth As Long, percent As Integer, strPercent As String, Farblong As Long
    Dim cRGB(0 To 3) As Byte, Grauwert As Long
    
    
    ' Verifica los valores de la propiedad Value
    If m_Value < m_min Then m_Value = m_min
    If m_Value > m_max Then m_Value = m_max
    
    
    If m_max > 0 Then
        percent = Int(m_Value / m_max * 100 + 0.5)
    Else
        percent = 100
    End If
    
    With m_PictureBox
        
        If .AutoRedraw = False Then
           .AutoRedraw = True
        End If
        'Limpia el Picture
        m_PictureBox.Cls
        
        If m_Value > 0 Then
           'Ancho del progreso
           pWidth = .ScaleWidth / 100 * percent
           m_PictureBox.Line (0, 0)-(pWidth, .ScaleHeight), m_ProgressColor, BF
           
           'Imprime el porcentaje centrado en el Picture
           If m_Progreso Then
              strPercent = CStr(percent) & " %"
              .CurrentX = (.ScaleWidth - .TextWidth(strPercent)) / 2
              .CurrentY = (.ScaleHeight - .TextHeight(strPercent)) / 2

              .ForeColor = m_ColorPercent
              m_PictureBox.Print strPercent
           End If
         End If
    End With
End Sub



'Propiedades
'**************************************
Public Property Get Min() As Long
Min = m_min
End Property
Public Property Let Min(valor As Long)
m_min = valor
End Property

Public Property Get Max() As Long
Max = m_max
End Property
Public Property Let Max(valor As Long)
m_max = valor
End Property

Public Property Get Value() As Long
Value = m_Value
End Property
Public Property Let Value(valor As Long)
m_Value = valor
Mostrar
End Property

Public Property Get PictureBox() As PictureBox
PictureBox = m_PictureBox
End Property

Public Property Set PictureBox(PictureBox As PictureBox)
Set m_PictureBox = PictureBox
End Property

Public Property Get Progreso() As Boolean
Progreso = m_Progreso
End Property

Public Property Let Progreso(valor As Boolean)
m_Progreso = valor
End Property

Public Property Get ProgressColor() As Long
ProgressColor = m_ProgressColor
End Property
Public Property Let ProgressColor(valor As Long)
m_ProgressColor = valor
End Property

Public Property Get ColorPercent() As Long
ColorPercent = m_ColorPercent
End Property
Public Property Let ColorPercent(valor As Long)
m_ColorPercent = valor
End Property


'Valores por defecto al iniciar
'******************************
Private Sub Class_Initialize()
    m_Progreso = True
    m_ProgressColor = vbBlue
    m_Value = 0
    m_min = 0
    m_max = 100
    m_ColorPercent = vbWhite
End Sub

POR FIN! Bueno ya terminamos

si quieres bajar la fuente de datos hazlo desde aquí (ZIP - 38Kb)
Saludos.

Yuri Lizama Aguirre http://www.rgperu.com 
rgperu22@yahoo.es 

TEMAS RELACIONADOS:

Crear barra de progreso con picture box