14. december 2006 - 21:42
Der er
3 kommentarer
Makro i Excel / Outlook
Jeg har brug for at lave en makro i Excel der gør følgende:
1.: Gem mit exeldokument i en sti - Det har jeg løst sådan her !
Sub Makro1()
'
' Makro1 Makro
' Makro indspillet 14-12-2006 af Jacob Skjødt Møller
'
'
ChDir "c:\"
ActiveWorkbook.SaveAs Filename:="c:\" & Range("C6").Value & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
2. Overfører excel-filen til Outlook, hvor den vedhæfter den en ny mail, der åbnes automatisk.
3. Adr. felt udfyldes automatisk
4. Emnefelt udfyldes automatisk med filnavn
5. Posten afsendes i Outlook
Hvis det kan lade sig gøre vil det være helt kanon !
Den forkromede løsning vil så være at den enkelte excel-fil hedder noget unikt - fx. at der kobles fortløbende nr. ind i filnavnet. Så jeg kan gennem excel-filerne fortløbende, men stadig overføre den aktuelle fil med makroen
15. december 2006 - 10:45
#1
Har oprettet filen basis.xls i en mappe - koden ligger i VBA/Ark1
I samme mappe er der oprettet en undermappemed navnet xlsArkiv - her gemmes de filer, som tilpasses på grundlag af "basis" og efterfølgende sendes via Outlook.
Filerne lagres i xlsArkiv under det valgte filnavn fra C6 - indledende med et løbenr, der beregnes på basis af antallet af filer i xlsArkiv. Derfor må disse filer ikke slettes - eller princippet skal laves om - hvilket også kan lade sig gøre - f.eks. via en tekstfil, der indeholder løbenr.
Kode ser således ud:
Dim xSti, filNr, filNavn
Const gemMappe = "xlsArkiv\" 'mappe til filer, der sendes - ligger i samme mappe som basis.xls
Sub KlarTilOutLook()
findSti
filNr = findNæsteFilnr
gemFilen
sendFilen "Modtager@mail.dk", filNavn, ActiveWorkbook.FullName 'modtager@mail.dk skal erstattes af ........
Rem Luk filen
ActiveWorkbook.Close
End Sub
Private Sub findSti()
xSti = ActiveWorkbook.Path
If Right(xSti, 1) <> "\" Then
xSti = xSti + "\"
End If
End Sub
Private Function findNæsteFilnr() 'tæller antal filer i mappen
Dim fs, f, f1, fc, s, antalFiler
antalFiler = 0
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(xSti + gemMappe)
Set fc = f.Files
For Each f1 In fc
antalFiler = antalFiler + 1
Next
findNæsteFilnr = antalFiler + 1
End Function
Private Sub gemFilen()
Dim xFilnr
xFilnr = fireTegn(CStr(filNr)) 'udvid filnr til 4 tegn
filNavn = Range("C6").Value
ActiveWorkbook.SaveAs Filename:=xSti + gemMappe + "Fil_" + xFilnr + "_" & filNavn + ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
Private Function fireTegn(nr)
While Len(nr) < 4
nr = "0" + nr
Wend
fireTegn = nr
End Function
Public Sub sendFilen(modtager, emne, vedhft)
Dim mailApp, Namespace, nyMail, att
Set mailApp = CreateObject("Outlook.Application")
Set Namespace = mailApp.GetNamespace("MAPI")
Set nyMail = mailApp.CreateItem(olMailItem)
Set nymod = nyMail.Recipients
nymod.Add modtager
Set att = nyMail.Attachments
att.Add vedhft
nyMail.Subject = emne
nyMail.Display 'visning af mail
nyMail.Send 'send mailen
End Sub
