PC-HELP.CZ

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

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.

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

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

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

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

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

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

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

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í

PC-HELP.CZ

Makro pro export do txt - prosím o radu

Makro pro export do txt - prosím o radu

Re: Makro pro export do txt - prosím o radu

Re: Makro pro export do txt - prosím o radu

Re: Makro pro export do txt - prosím o radu

Re: Makro pro export do txt - prosím o radu

Re: Makro pro export do txt - prosím o radu

Re: Makro pro export do txt - prosím o radu

Re: Makro pro export do txt - prosím o radu

Re: Makro pro export do txt - prosím o radu

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