Private Sub Command1_Click()
'PARA ESCRIBIR EN UN ARCHIVO

on error goto fallo
cd.Filter = "Archivos de texto|*.txt"    'es un filtro que solo puedes coger los txt, si kieres borralo
cd.ShowSave                                     'muestra la pantalla para elegir el archivo
If cd.FileName = "" Then Exit Sub               'Sino no as seleccionao ninguna se va fuera
    
    Open cd.FileName For Append As #1           'Se abre el archivo
        Print #1, Text1                         'se escribe lo que ay en el text1
    Close #1                                    'se cierra
exit sub
fallo:
' lo que pongas aquí es lo que ocurre si pulsaron ESC

End Sub

Public Function LeerIni(sección As String, Entrada As String, ArchivoIni As String)
    Dim I As Integer
    Dim Dato As String
    Dato = String$(128, " ")
    I = GetPrivateProfileString(sección, Entrada, Directorio, Dato, Len(Dato), ArchivoIni)
    LeerIni = IIf(I > 0, Est, "")
End Function

Public Function EscribirIni(sección As String, Entrada As String, DatoAEscribir As String, ArchivoIni)
    Dim I As Integer
    I = WritePrivateProfileString(sección, Entrada, "", , DatoAEscribir, ArchivoIni)
    EscribirIni = IIf(I = 1, True, False)
End Function

Public Function ObtenerUsuario() As String
    'Esta función devuelve el nombre del Usuario
    Dim sBuffer As String
    Dim lSize As Long
    Dim sUsuario As String

    sBuffer = Space$(260)
    lSize = Len(sBuffer)
    Call GetUserName(sBuffer, lSize)
    If lSize > 0 Then
        sUsuario = Left$(sBuffer, lSize)
        'Quitarle el CHR$(0) del final...
        lSize = InStr(sUsuario, Chr$(0))
        If lSize Then
            sUsuario = Left$(sUsuario, lSize - 1)
        End If
    Else
        sUsuario = ""
    End If
    ObtenerUsuario = sUsuario
End Function

Public Function ObtenerNombreEquipo() As String
Dim sBuffer As String, lSize As Long, Resultado As Long
Const MAX_COMPUTERNAME_LENGTH As Long = 31 'longitud máxima del nombre de un equipo
sBuffer = String(MAX_COMPUTERNAME_LENGTH + 1, vbNullChar)
lSize = MAX_COMPUTERNAME_LENGTH

Resultado = GetComputerName(sBuffer, lSize)
ObtenerNombreEquipo = IIf(Resultado, Left(sBuffer, lSize), "")

End Function

 Public Function ObtenerSystem() As String
    Dim DirectorioSystem As String * 255
    Dim CadenaResultante As Long

    CadenaResultante = GetSystemDirectory(DirectorioSystem, 255)
    ObtenerSystem = Left(DirectorioSystem, CadenaResultante)
End Function

Public Function ObtenerTemp() As String
    Dim Buffer As String, Size As Long
    Const MAX_PATH = 260

    ' Inicializamos la cadena donde se cargará la trayectoria
    Buffer = String(MAX_PATH, 0)

    ' Recuperamos la trayectoria
    Size = GetTempPath(Len(Buffer) - 1, Buffer)

    If Size <> 0 Then
        GetTempFolder = Left(Buffer, Size)
    End If

End Function

Const CSIDL_DESKTOP = &H0
Const CSIDL_PROGRAMS = &H2
Const CSIDL_CONTROLS = &H3
Const CSIDL_PRINTERS = &H4
Const CSIDL_PERSONAL = &H5
Const CSIDL_FAVORITES = &H6
Const CSIDL_STARTUP = &H7
Const CSIDL_RECENT = &H8
Const CSIDL_SENDTO = &H9
Const CSIDL_BITBUCKET = &HA
Const CSIDL_STARTMENU = &HB
Const CSIDL_DESKTOPDIRECTORY = &H10
Const CSIDL_DRIVES = &H11
Const CSIDL_NETWORK = &H12
Const CSIDL_NETHOOD = &H13
Const CSIDL_FONTS = &H14
Const CSIDL_TEMPLATES = &H15
Const MAX_PATH = 260

Public Function ObtenerMenuUsuario() As String
    ObtenerMenuUsuario = GetSpecialfolder(CSIDL_STARTMENU)
End Function

Public Function ObtenerFavoritos() As String
    ObtenerFavoritos = GetSpecialfolder(CSIDL_FAVORITES)
End Function
Public Function ObtenerMenuProgramas() As String
    ObtenerMenuProgramas = GetSpecialfolder(CSIDL_PROGRAMS)
End Function
Public Function ObtenerEscritorio() As String
    ObtenerEscritorio = GetSpecialfolder(CSIDL_DESKTOP)
End Function