Příspěvky uživatele

Otázkou je, v jakém formátu je ta adresa?
Jestli vždy končí 5 místným PSČ, nebo jestli PSČ je třeba i někde uprostřed. Případně je-li PSČ označeno např. "PSČ:", no a pak v jakém formátu to PSČ je 5 znaků, nebo 6 (s použitím mezery jako oddělovače).
Když se najde pravidlo, tak pak už stačí SVYHLEDAT.
Takže v jakém formátu je adresa? Příloha by se hodila, nebo alespoň pár vzorků.

M@

koukám že jsem do toho scriptu sice dal mazání scriptu, ale ne té prezentace :-), ale na to určitě přijdete :-).

Ještě mě napadlo bez použití naplánované úlohy vytvořit VB script který v sobě bude mít zpoždění.
WScript.Sleep(5000)

ale pořád to je o tom že se vytváří nevyžádaný soubor, byť se pak maže.

M@

Příklad v příloze.

Aplikace vlastního template, může být buď ze šablony, nebo z již hotové prezentace.

V kódu je to zakomentěno, stačí doplnit adresu k vlastnímu souboru s předlohou a odkomentit.

M@

Asi to nebude tak jednoduché smazat sebe sama :-)

Zkusím napsat jen co mě napadlo...
1) napsat makro jenž před ukončením prezentace vytvoří textový soubor, jehož obsahem bude VBS
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile("D:\SCRIPT.VBS")
Tento pak uloží jako např. D:\SCRIPT.VBS

2) po vytvoření scriptu vytvořit novou naplánovanou úlohu s jednorázovým spuštěním cca za 5s. Tato naplánovaná úloha by měla spustit výše zmíněný script.
Naplánovanou úlohu vytvořit pomocí příkazu Shell a dále za použití parametrů viz. odkaz
http://msdn.microsoft.com/en-us/library/bb736357

Je to jen teoretické nasměrování, nikoliv kompletní řešení.
Třeba to půjde i snáze a bez vytváření scriptů či naplánovaných úloh, což by potěšilo i koncového uživatele :-). Mno ale momentálně mě nenapadá jak.

M@

Neodjíždět zítra na dovolenou :-).

M@

Public Function exportpdf() As String
Dim counter As Single
Dim tmp As String
counter = 1
tmp = "C:\PDF_" & counter & ".PDF"

Do While Dir(tmp) <> ""
tmp = "C:\PDF_" & counter & ".PDF"
counter = counter + 1
Loop

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=tmp, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
exportpdf = tmp
End Function

M@

Sub EmailSKLAD()

Dim Resp As Integer
Dim fName As String
Dim poleADR(9, 1) As String, polozka As Variant
Dim poleZAK(7, 7) As String, mailAdresa As String, polePOPIS(7) As String
Dim text_zpravy As String, P1 As Variant, P2 As Variant
Dim VJ As Object
Set VJ = Worksheets("Vyjadreni")

' ----------------------------------------------------------------------------------
' --- v mailu MUSÍ být nastaveno takové písmo, které má stejnou šířku každého znaku
' --- to je například Courier New, nebo Consolas-----------------------------------
' ----------------------------------------------------------------------------------
' ---jinak bude text mailu rozházený -----------------------------------------------
Resp = MsgBox(prompt:="ANO - zkontrolovat email, NE - bez kontroly, nebo STORNO.", _
Title:="KONTROLA EMAILU PŘED ODESLÁNÍM ?", _
Buttons:=3 + 32)
' -----------------------------------------
' --- načtení potřebných hodnot a adres ---
' -----------------------------------------
With VJ

' ------------------------------------------------------------
mailAdresa = .Cells(20, 20)
' ---------------------------------------------------------
polozka = 0
For pocetPolozek = 37 To 51 Step 2
If .Cells(pocetPolozek, 2) = "" Then Exit For
poleZAK(polozka, 1) = .Cells(pocetPolozek, 2) 'cislo SKP
poleZAK(polozka, 2) = .Cells(pocetPolozek, 4) 'nazev vyrobku
poleZAK(polozka, 3) = .Cells(pocetPolozek, 7) 'počet kusu
poleZAK(polozka, 4) = .Cells(pocetPolozek, 8) 'čísko dan. dokl.
poleZAK(polozka, 5) = .Cells(pocetPolozek, 11) 'způsob vyřízení
poleZAK(polozka, 6) = .Cells(pocetPolozek, 14) 'vyjádření
' --- kontrola počtu reklamací ----------------------
If poleZAK(polozka, 2) = "" And poleZAK(polozka, 3) = "" Then Exit For
polozka = polozka + 1
Next pocetPolozek
polePOPIS(0) = "ČÍSLO VÝROBKU (SKP) "
polePOPIS(1) = "NÁZEV VÝROBKU "
polePOPIS(2) = "POČET KUSŮ "
polePOPIS(3) = "ČÍSLO DAŇ. DOKLADU "
polePOPIS(4) = "ZPŮSOB VYŘÍZENÍ REKLAMACE "
polePOPIS(5) = "VYJÁDŘENÍ "
End With
' --- nastavení stejné délky polí ----------------------------

For P1 = 0 To 7
For P2 = 0 To 7
Do While Len(poleZAK(P1, P2)) < 28
poleZAK(P1, P2) = poleZAK(P1, P2) & " "
Loop
Next P2
Next P1

' -----------------------------------------------
' --- vytvoření vlastního textu mailové zpráy ---
' -----------------------------------------------
' --- CHr(13) = další řádek ------------------

text_zpravy = "Automaticky generovaný email - Informace o nové reklamaci pro R03/R09:" & Chr(13) _
& Chr(13) _

For Z = 0 To polozka - 1
dalsi_text = "---- " & Z + 1 & ". reklamace ------------------------------------------ " & Chr(13) _
& polePOPIS(0) & ": " & poleZAK(Z, 1) & Chr(13) _
& polePOPIS(1) & ": " & poleZAK(Z, 2) & Chr(13) _
& polePOPIS(2) & ": " & poleZAK(Z, 3) & Chr(13) _
& polePOPIS(3) & ": " & poleZAK(Z, 4) & Chr(13) _
& polePOPIS(4) & ": " & poleZAK(Z, 5) & Chr(13) _
& polePOPIS(5) & ": " & poleZAK(Z, 6) & Chr(13) _
& "------------------------------------------------------------ " & Chr(13)
text_zpravy = text_zpravy & dalsi_text
Next Z
' & "Vystavil : "

Select Case Resp
'ano ----------------------------
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set OUTLApp = CreateObject("Outlook.Application")
Set OUTLNewMail = OUTLApp.CreateItem(olMailItem)
' pokud se má odeslat i aktivní soubor jako příloha, tak
' fName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
fName = exportpdf
With OUTLNewMail
' adresát nebo více oddělení čárkou
.To = "petr.vaculik@gmail.com"
' kopie
'.CC = "a@volny.cz"
' předmět mailu
.Subject = "Reklamace " & Worksheets("Vyjadreni").Cells(6, 10)
.Body = text_zpravy
.Attachments.Add fName
.Display
End With
Set OUTLNewMail = Nothing
Set OUTLApp = Nothing
Set OUTLAttach = Nothing
Set OUTLMess = Nothing
Set OUTLNSpace = Nothing
'NE -------------------------
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set OUTLApp = CreateObject("Outlook.Application")
Set OUTLNewMail = OUTLApp.CreateItem(olMailItem)
Call exportpdf
' pokud se má odeslat i aktivní soubor jako příloha, tak
fName = exportpdf
With OUTLNewMail
' adresát nebo více oddělení čárkou
.To = "petr.vaculik@gmail.com"
' kopie
'.CC = "a@volny.cz"
' předmět mailu
.Subject = "Reklamace " & Worksheets("Vyjadreni").Cells(6, 10)

.Body = text_zpravy
.Attachments.Add fName
On Error GoTo errHlaseni
druhyPokus:
.Send
End With
Set OUTLNewMail = Nothing
Set OUTLApp = Nothing
Set OUTLAttach = Nothing
Set OUTLMess = Nothing
Set OUTLNSpace = Nothing
'CANCEL --------------------------
Case Is = 2
MsgBox prompt:="Email byl zrušen.", _
Title:="EMAIL zrušen", _
Buttons:=64
End Select: Exit Sub
errHlaseni:
MsgBox "Neni spuštěn Outlook, spouštím ", vbCritical, "CHYBA"
Shell ("OUTLOOK")
GoTo druhyPokus
End Sub

Public Function exportpdf() As String
Dim counter As Single
Dim tmp As String
counter = 1
tmp = ThisWorkbook.Path & "\PDF_" & counter & ".PDF"

Do While Dir(tmp) <> ""
tmp = ThisWorkbook.Path & "\PDF_" & counter & ".PDF"
counter = counter + 1
Loop

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=tmp, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
exportpdf = tmp
End Function

V podstatě v tom kódu téměř vše podstatné máš, jen to odkomentit.

Nejprve je potřeba vyexportovat pdf např.
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= "C:\POKUS.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= False
a pak použiješ řádek:

fName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name

Zde dosadit cestu k danému pdf
takže třeba fname = "C:\POKUS.pdf"

no a nakonec odkomentit řádek
.Attachments.Add fName

M@

Stačí mrknout o dva řádky níže jak je zadána kopie (CC) a pochopíš:
.To = mailAdresa
' kopie
'.CC = "a@volny.cz"

.To = mailAdresa nahradíš .To = "honzo@gmail.net"

M@

Na to nebude nejvhodnější ověření dat, lepší by byl asi přímo Active X prvek se seznamem viz. příloha.

Nebo pak vlastní formulář.

M@

Budeš muset znát maximum daného měřidla, pak můžeš udělat
když nový stav < předchozí stav, tak( maximum - předchozí stav + nový stav) jinak (nový stav - předchozí stav).

M@

Trochu jsem googlil :-).
Když vybereš propojené pole a stiskneš Alt + F9, případně pravým tlačítkem na pole a vybrat "přepnout zobrazení", tak se ti zobrazí něco jako
{ MERGEFIELD "POLE" }

když pak nakonec přidáš formátovací příznak např.
{ MERGEFIELD "POLE" \#" # ##0" }
tak by to mělo zaokrouhlit na celá čísla s mezerou po tisících.

Čerpáno z ... http://www.extendoffice.com/documents/word/1003-word-mail-merge-date-currency-and-number-format.html

M@

Jo to bude asi problém nepřímých odkazů, tam systém asi neurčí závislosti.

Tak nezbývá než zůstat u pokusu 2 :-).
Ještě mě napadlo jestli by nepomohlo vypnutí automatických výpočtů na začátku makra a povolení automatických výpočtů na konci, ale sám to moc nedoporučuju, protože jsem se nejednou setkal se souborem, kde někdo výpočty vypnul a při jeho otevření na jiném pc, se výpočty vyply i tam, ale s otevřením jiného souboru už se nezaply a pak se občas člověk diví, proč mu ten excel nepočítá, nikoho nenapadne, že mu někdo poslal soubor s vypnutými výpočty, který mu ty vypnutý výpočty nastavil jako výchozí pro excel.

M@

pokus3, ale neručím za něj, zkoušel jsem to touto cestou poprvé a to pomocí následníků.
Makro si při změně najde následníky a ty označí. Mělo by to být snad rychlejší, protože nemusí procházet vždy všechny řádky. Platí jen pro následníky na jiném listu.
M@

Funkce prohledává sloupec B a zjistí si počet buněk s hodnotou, no a pokud jich najde jen 326. tak jede do řádku 326. Problém v tomto kódu nastane v případě, že mezi výsledky jsou prázdné buňky, pak to prohledá o to méně řádků.
rdlast = Application.WorksheetFunction.CountA(List2.Range("B:B"))
teoreticky by se to dalo nahradit maximálním počtem řádků na listu:rdlast = List2.UsedRange.Rows.Count

M@

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje