Indsæt automatisk filer i en e-mail i Outlook

Denne kode kører fint i XL2000, men ikke i XP.

'******EN NY PARAMETER TILFØJET (astrCCPers) til CC-personer)**********
Function CreateMail(astrRecip As Variant, _
                  astrCCpers 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
  '*****NYT *************
  Set myNameSpace = olApp.GetNamespace("MAPI")
  Set myFolder = myNameSpace.GetDefaultFolder(olFolderDrafts)
  '***********************
  Set objNewMail = olApp.CreateItem(olMailItem)

  With objNewMail
      .Recipients.Add (astrRecip)
      '*** nyt ****
      If Not astrCCpers = "" Then
        Set test = .Recipients.Add(astrCCpers)
        test.Type = olCC
      End If
      '************
      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 = "Opgørelse"

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
'******** ÆNDRET RANGE ***************
For Each C In Range("F1:O1")
'*************************************
    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)
    '********ÆNDRET RANGE ***************
    vfiler = Range("F" & C.Row, "O" & C.Row)
    '********EN NY PARAMETER SAT PÅ ***************
    x = CreateMail(C.Value, C.Offset(0, 1), C.Offset(0, 2), C.Offset(0, 3), vfiler) 'ændret
    '*************************************************
    If x = False Then MsgBox C.Value & "  ikke oprettet"
Next
End Sub

svar :-)

Den funger fint her hos mig, jeg har XP og 2000 på arbejde hvor jeg også "håber den kan køre.
Johnfm