Makro pro export do txt - prosím o radu Vyřešeno

[jiri255]

Dobrý den, nedávno jsme řešili export do .txt viz toto téma:
http://www.pc-help.cz/viewtopic.php?f=35&t=101379
narazil jsem u toho kódu exportu na menší problém a nevím si s tím rady

Kód: Vybrat vše

Sub Makro10()
Application.DisplayAlerts = False
    Columns("A:A").Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and settings\jirka\Desktop\export.txt", FileFormat:= _
        xlTextPrinter, CreateBackup:=False
    ActiveWindow.Close
End Sub


uložení na "C:\Documents and settings\jirka\Desktop\export.txt" funguje na mém PC bez problémů,
ale potřeboval bych toto makro používat i na dalších 3 PC kde je, ale pokaždé jiný uživatel
Zkusil jsem tedy zapsat "C:\Documents and settings\%username%\Desktop\export.txt" což u
win funguje na plochu se dostanu, ale makro si s tím nějak neumí poradit
Nevíte jak správně zapsat do toho kódu, aby to ukládalo ten export na plochu s tím, že jméno
uživatele může být na každém PC jiné?

Předem děkuji za pomoc

[Reklama]

[Azuzula]

Zdravím,
uživatele přihlášeného ve win zjistíte třeba pomocí Environ("USERNAME") takže makro pak bude vypadat následovně:

Kód: Vybrat vše

Sub Makro10()
Dim strUziv As String
strUziv = Environ("USERNAME") 'zjistí přihlášeného uživatele ve Win
Application.DisplayAlerts = False
    Columns("A:A").Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and settings\" & strUziv & "\Desktop\export.txt", FileFormat:= _
        xlTextPrinter, CreateBackup:=False
    ActiveWindow.Close
End Sub


Makro je pouze pro anglické WinXP, nebo počeštěně anglické.Win98, Win7 a Win8 mají jinou cestu k ploše uživatele, šlo by to ošetřit testováním na OS a tím měnit cesty k ploše aby se předešlo potížím. Záleží na ostatních PC jaké tam jsou OS.

[jiri255]

tohle vypadá velice dobře před chvílí jsem to odzkoušel na win 7 a export txt se bez problémů
uložil na plochu.
Jak popisujete ty problémy z českými win xp, tak to bude asi problém jednoho s těch dalších PC
tam jsou právě české win XP a myslím, že jsem to musel přepisovat na "Plocha", protože "Desktop"
to nechtělo vůbec vzít ty další jsou počeštěné anglické win XP
Myslíte, že by se dalo ošetřit i to, že jednou to bude v cestě "Plocha" a jednou "Desktop"?
Děkuji

[Azuzula]

To už je drobnost
Upravené makro by mělo fungovat i v ostatních Windows

Kód: Vybrat vše

Sub Makro10()
Dim strUzivatel As String, strSlozka As String
Dim fso As Object

strUzivatel = Environ("USERPROFILE") 'zjistí přihlášeného uživatele ve Win vč. cesty. Pro případ kdyby nebyl OS nainstalován na disku C

' ověří dostupnost složky
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(strUzivatel & "\Plocha\") = True Then
    strSlozka = "Plocha" ' pro cz Win
ElseIf fso.FolderExists(strUzivatel & "\Desktop\") = True Then
    strSlozka = "Desktop" 'pro en Win
End If

Application.DisplayAlerts = False
    Columns("A:A").Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:=strUzivatel & "\" & strSlozka & "\export.txt", FileFormat:= _
        xlTextPrinter, CreateBackup:=False
    ActiveWindow.Close
End Sub


[jiri255]

zítra odzkouším i na dalších PC a dám vědět prozatím mnohokrát děkuji za pomoc :-)

[cmuch]

Makro bych upravil takto a mělo by jít na všech PC.

Kód: Vybrat vše

Sub Makro10()
Dim strUziv As String
strUziv = Environ("USERPROFILE") 'zjistí přihlášeného uživatele ve Win a cestu do jeho složky
Application.DisplayAlerts = False
    Columns("A:A").Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
   
    On Error GoTo err
    ActiveWorkbook.SaveAs Filename:= _
        strUziv & "\Desktop\export.txt", FileFormat:= _
        xlTextPrinter, CreateBackup:=False
        GoTo ok
err:
    ActiveWorkbook.SaveAs Filename:= _
        strUziv & "\Plocha\export.txt", FileFormat:= _
        xlTextPrinter, CreateBackup:=False
ok:
    ActiveWindow.Close
End Sub

//Azuzula to už vyřešila

[jiri255]

taky díky odzkouším a zítra dám také vědět :-)

[jiri255]

tak jsem odzkoušel na všech PC a funguje to výborně a zároveň jsem si podle toho upravil
i makro na import a dále jsem si upravil i makro na smazání toho exportu viz kód:

Kód: Vybrat vše

Sub Smaz_export_txt()
    On Error Resume Next
    Dim strUzivatel As String, strSlozka As String
Dim fso As Object

strUzivatel = Environ("USERPROFILE") 'zjistí přihlášeného uživatele ve Win vč. cesty. Pro případ kdyby nebyl OS nainstalován na disku C

' ověří dostupnost složky
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(strUzivatel & "\Plocha\") = True Then
    strSlozka = "Plocha" ' pro cz Win
ElseIf fso.FolderExists(strUzivatel & "\Desktop\") = True Then
    strSlozka = "Desktop" 'pro en Win
End If

    Kill strUzivatel & "\" & strSlozka & "\export.txt"
    On Error GoTo 0
End Sub


funguje mi to, ale smaže to ten export.txt trvale(nehodí ho to do koše) což je trochu problém kdybych potřeboval dohledat chybu.
Našel jsem na nějakých stránkách tento kód:

My.Computer.FileSystem.DeleteFile("C:\test.txt",
Microsoft.VisualBasic.FileIO.RecycleOption.SendToRecycleBin)

který by měl údajně ten export.txt smazat z plochy a přesunout do koše akorát se mi nedaří
ho správně zapsat do toho výše uvedeného kódu
Takto jsem to zapsal, ale je to špatně nevíte někdo v čem jsem udělal chybu?

Kód: Vybrat vše

Sub Smaz_export_txt()
    On Error Resume Next
    Dim strUzivatel As String, strSlozka As String
Dim fso As Object

strUzivatel = Environ("USERPROFILE") 'zjistí přihlášeného uživatele ve Win vč. cesty. Pro případ kdyby nebyl OS nainstalován na disku C

' ověří dostupnost složky
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(strUzivatel & "\Plocha\") = True Then
    strSlozka = "Plocha" ' pro cz Win
ElseIf fso.FolderExists(strUzivatel & "\Desktop\") = True Then
    strSlozka = "Desktop" 'pro en Win
End If

    My.Computer.FileSystem.DeleteFile(strUzivatel & "\" & strSlozka & "\export.txt",
    Microsoft.VisualBasic.FileIO.RecycleOption.SendToRecycleBin)
    On Error GoTo 0
End Sub


[Azuzula]

Práce se soubory vyžaduje mimo jiné i deklaraci dalších funkcí a konstatnt, takhle jednoduché to není. (Snadno jde odstranit soubor pomocí funkce Kill, ale pouze trvale odstranit z disku.)
Našla jsem makro co umí přesouvat soubory do koše.
Vaše upravené bude vypadat následovně:
Od Option explicit až po začátek makra tzn. veškeré deklarace typů, funkcí a konstant má být na začátku modulu. Samotné makro potom jde vložit kamkoliv do modulu. Pokud používám makro resp. část kódu na přesun do koše i v jiném modulu, musí být ty počáteční deklarace i v něm jinak nebude fungovat.

Kód: Vybrat vše

Option Explicit
'deklarace uživatelského typu
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
sFrom As String
sTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
'deklarace funkce a konstant
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(ByRef lpFileOp As SHFILEOPSTRUCT) As Long
Private Const FO_DELETE = &H3
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_ALLOWUNDO = &H40

Sub Smaz_export_txt()
On Error Resume Next
Dim strUzivatel As String, strSlozka As String
Dim fso As Object

Dim oFilAPI As SHFILEOPSTRUCT
Dim lReturn As Long
Dim sFile As String

strUzivatel = Environ("USERPROFILE") 'zjistí přihlášeného uživatele ve Win vč. cesty. Pro případ kdyby nebyl OS nainstalován na disku C

' ověří dostupnost složky
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(strUzivatel & "\Plocha\") = True Then
    strSlozka = "Plocha" ' pro cz Win
ElseIf fso.FolderExists(strUzivatel & "\Desktop\") = True Then
    strSlozka = "Desktop" 'pro en Win
End If

sFile = strUzivatel & "\" & strSlozka & "\export.txt" 'uloží cestu souboru pro smazání (do koše) do proměnné
'přesouvá soubor do koše
With oFilAPI
.wFunc = FO_DELETE
.sFrom = sFile
.sTo = vbNullChar
.fFlags = FOF_SILENT + FOF_NOCONFIRMATION + FOF_ALLOWUNDO
End With
' Use WinAPI User Defined Function
lReturn = SHFileOperation(oFilAPI)
End Sub


Takto vypadá samotné makro vč. všech deklarací na přesun souboru do koše kdyby to chtěl použít i někdo jiný:

Kód: Vybrat vše

Option Explicit
'deklarace uživatelského typu
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
sFrom As String
sTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
'deklarace funkce a konstant
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
(ByRef lpFileOp As SHFILEOPSTRUCT) As Long
Private Const FO_DELETE = &H3
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_ALLOWUNDO = &H40

Sub DeleteFileUsingAPI()
Dim oFilAPI As SHFILEOPSTRUCT
Dim lReturn As Long
Dim sFile As String
sFile = "C:\thumbs.db" ' soubor určený k přesunu do koše
With oFilAPI
.wFunc = FO_DELETE
.sFrom = sFile
.sTo = vbNullChar
.fFlags = FOF_SILENT + FOF_NOCONFIRMATION + FOF_ALLOWUNDO
End With
' Use WinAPI User Defined Function
lReturn = SHFileOperation(oFilAPI)
End Sub


[jiri255]

jak na to, tak koukám opravdu velmi najivně jsem si myslel, že by to šlo nějak jednodušeji.... chybama se člověk učí
Děkuji za pomoc to Vaše makro funguje bezvadně
Narazil jsem ještě na jednu věc, pro kterou bych rád našle řešení, ale týká se to úplně něčeho jiného, tak na to raději
založím nové téma, aby až někdo bude řešit podobný problém snáze našel řešení