Spm 441240 IGEN

John - > fremfor at chekke hver celle i B8:B60, vil jeg godt nøjes med at chekke een. Er en af disse en sum på de andre, så man bare kan chekke den ?
(det bliver mange kald til hvert lukket ark ellers)

Bak
Det er helt fint hvis den bliver sendt når der står en
Værdi >0 i B8.

Johnfm

Ideen er at du i række 1 (Fra E1 til L1) skriver alle de ugenumre du skal bruge og udfylder kolonne A,B,C og D. med hhv. Firmanavn, emailadr, att-person og bodytekst.

Makroen udfylder resten, med sti til filerne.  (filerne skal ligge i underfoldere til det sted hvor min test.xls ligger og underfolderne skal hedde det samme som de ugenumre der står i række 1)

Du skal have sat reference under TOOLS/REFERENCES til MS Outlook 10.0  (Jeg har lavet det i XP, så hvis du ikke bruger det skal du ændre references til et lavere nummer)



Du skal så bare køre Sub Main.

I sub CreateMail har jeg for testens skyld indsat .Save. Dette skal du ændre til .Send hvis du vil sende automatisk

Bemærk.: Der er næsten igen fejlfangere.

Function CreateMail(astrRecip As Variant, _
                  strSubject As String, _
                  strMessage As String, _
                  Optional astrAttachments As Variant) As Boolean

  Dim olApp                As Outlook.Application
  Dim objNewMail            As Outlook.MailItem
  Dim varAttach            As Variant
  Dim blnResolveSuccess    As Boolean

  On Error GoTo CreateMail_Err

  Set olApp = New Outlook.Application
  Set objNewMail = olApp.CreateItem(olMailItem)

  With objNewMail
    .Recipients.Add astrRecip
      For Each varAttach In astrAttachments
        If Not IsEmpty(varAttach) Then .Attachments.Add varAttach
      Next varAttach
      .Subject = strSubject
      .Body = strMessage
      .Save    '.Send
     
  End With

  CreateMail = True

CreateMail_End:
  Exit Function
CreateMail_Err:
  CreateMail = False
 
  Resume CreateMail_End
End Function

Sub BatchProcess()
Dim FS As FileSearch
Dim FilePath As String, FilePathStart As String
Dim i As Integer, j As Integer
Dim v As Variant
Dim C As Range, rgFCell As Range
Dim Firmaer As Range
Dim Cell2Get
Const Filespec As String = "*.xls"
Const sheet As String = "SUM"

With ThisWorkbook.Sheets(1)
    Set Firmaer = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With
FilePathStart = ThisWorkbook.path
Cell2Get = "B8"
Application.ScreenUpdating = False
Set FS = Application.FileSearch
For Each C In Range("E1:L1")
    With FS
        .LookIn = FilePathStart & "\" & C & "\"
        .Filename = Filespec
        .SearchSubFolders = False
        .Execute
        If .FoundFiles.Count = 0 Then GoTo Igen
        For i = 1 To .FoundFiles.Count
            v = Split(.FoundFiles(i), Application.PathSeparator)
            FilePath = Left(.FoundFiles(i), InStrRev(.FoundFiles(i), Application.PathSeparator))
           
            If GetValue(FilePath, v(UBound(v)), sheet, Cell2Get) > 0 Then
                For Each rgFCell In Firmaer
                    If v(UBound(v)) Like "??" & rgFCell & "*" Then
                        Cells(rgFCell.Row, C.Column) = .FoundFiles(i)
                        Exit For
                    End If
                Next
            End If
        Next i
    End With
Igen:
Next
Application.ScreenUpdating = False
End Sub


Private Function GetValue(path, file, sheet, range_ref)
Dim arg As String
arg = "'" & path & "[" & file & "]" & sheet & "'!" & Range(range_ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function


Sub Main()
Dim vfiler
Dim x As Boolean
Dim C As Range
BatchProcess
For Each C In Range("B2:B" & Range("B65536").End(xlUp).Row)
    vfiler = Range("E" & C.Row, "L" & C.Row)
    x = CreateMail(C.Value, C.Offset(0, 1), C.Offset(0, 2), vfiler)
    If x = False Then MsgBox C.Value & "  ikke oprettet"
Next
End Sub

PS hvis du får alt for mange problemer med outlook så se lige http://www.eksperten.dk/spm/420210

Bak
Tak for ugeMappen med test filen den funger fint.

Jeg har oprette en lille mappe/ ”Sandkasse” med ti mappe fra uge01 til og med uge10, hvor jeg har afprøvet din Makro.
01Firma12004
01Firma22004
01Firma32004
01Firma42004
01Firma52004
01Firma62004
Når jeg kører Makroen opretter den fint de 6 mail, men den henter igen filen til 01Firma62004 selv om der er værdier i B8 i uge01, uge02 og uge04, så der
er ikke Indsat nogen Filer i mailen til 01Firma62004.

Der må gerne kunne hentes filer der omfatter ca. 30 firmaer.

Jeg kører WindowsXP og outlook2002 her hjemme, på arbejde har jeg Windows2000 og autlook2002 har det nogen betydning??

GODT NYTÅR

John

zip & send din sandkasse

Sandkassen er sendt

:-)

Bak

Tak for hjælpen nu funger Makroen fint,
efter jeg har lært at kende forskel på – og _

John