Guardar .xls como .txt En Escritorio

[Antonio]

Aquí está una pregunta simple (sospechoso que la respuesta no lo es..)

Este code guarda una parte del documento en al Dir A: como Text
Nesecito que tambien guarde una copia en el escritonrio

Thank's in Advance










Sub ImprimirCheque()

Dim FileSaveName As String
Dim TextExportExcel As Object
Set TextExportExcel = ThisWorkbook
Dim c As Object
Dim MyRange As Object

If Worksheets("Cheque").Range("R9") = "" Then
Range("R9").Select
MsgBox "Escriba la cantidad del cheque.", vbInformation, "MuEbLeS De
MeXiCo"
Exit Sub
End If
If Worksheets("Cheque").Range("P15") = "" Then
Range("P15").Select
MsgBox "Seleccione un concepto de pago.", vbInformation, "MuEbLeS De
MeXiCo"
Exit Sub
End If
Application.ScreenUpdating = False
Answer = MsgBox _
(" Esta el nombre o compañia y el numero de cheque correctos ? " &
Chr(13) & Chr(13) & _
"Si no lo es haga click en no y corrija la informacion ", vbYesNo,
"Maderas Y Muebles de Mexico")
If Answer = vbNo Then Exit Sub ' the macro ends if the user selects the
CANCEL-button
Application.GoTo Reference:="ImprimirCheque"
Selection.PrintOut Copies:=1, Collate:=True
Range("A1").Select
Sheets("PolizaToDisk").Select
ActiveSheet.Unprotect Password:="nelvita"
GetFile:

Set MyRange = ActiveCell.CurrentRegion.Rows
mypath = "a:\" 'set path to folder here, or use
'mypath=Application.DefaultFilePath
Range("B1").Select
'MsgBox "Text File Name := " & ActiveSheet.Name
FileSaveName = Application.GetSaveAsFilename _
(InitialFileName:=CStr(mypath & ActiveCell.Value), _
filefilter:="Text Files (*.txt), *.txt")
If Dir(FileSaveName) <> "" Then
Select Case MsgBox("File already exists! Overwrite?", vbYesNoCancel +
vbExclamation)
Case vbNo
GoTo GetFile
Case vbCancel
Sheets("Cheque").Select
Exit Sub
End Select
End If
'MsgBox " FileSaveName :" & FileSaveName
ActiveSheet.Protect Password:="nelvita"

WriteFile MyRange, FileSaveName
Sheets("Cheque").Select
ORDER# = Range("ChequeNo").Value
Range("ChequeNo") = ORDER# + 1
Sheets("Cheque").Select
Range("R6").Select
Selection.ClearContents
ActiveCell.FormulaR1C1 = "=NOW()"
Range("R9").Select
Selection.ClearContents
Range("P15").Select
Selection.ClearContents
Range("R9").Select
Application.ScreenUpdating = True
Application.StatusBar = "Espere!... Guardandoprogama y numero de cheque"
MsgBox "Se ha guardado una copia en el archivo Mis Documentos," _
& Chr(13) & Chr(13) & _
"Folder PlizaToCheck Como Procedimiento de BackUp.", _
vbInformation, "MuEbLeS De MeXiCo"
ActiveWorkbook.Save
Application.StatusBar = False
Exit Sub
Application.ScreenUpdating = True
End Sub
Sub WriteFile(MyRange, FileSaveName)
Dim FF As Integer, MyLine As String
FF = 0
FileNum = FreeFile ' next file number
' open the file & add currently selected data to the file (or create it)
Open FileSaveName For Append As #FileNum
'use output instead of append if you want to overwrite
'the entire file each time
For Each c In MyRange 'c=rows in range
'assuming five columns of data to be written to file
Print #FileNum, Cells(c.Row, c.Column).Text, _
Cells(c.Row, c.Column + 1).Text, Cells(c.Row, c.Column + 2) _
.Text, Cells(c.Row, c.Column + 3).Text, _
Cells(c.Row, c.Column + 4).Text
Next
Close #FileNum ' close the file
'MsgBox MyLine, vbInformation, "Last log information:"
End Sub