Run Time Error 70 Permission Denied Excel VBA

[Legacy 286866]

I have created some code that will move emails to a folder, add a unique ID, put into a spreadsheet and not overwrite duplicates.
This worked when I made it and now it comes up with Run Time Error 70 Permission Denied. Been looking through the code and cant figure out where or why this is happening.
Can you guys see anything I am missing?

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, 'Lucida Console', 'Liberation Mono', 'DejaVu Sans Mono', 'Bitstream Vera Sans Mono', 'Courier New', monospace, sans-serif; white-space: inherit;">

Option Explicit
Const fPath AsString="C:\Users\Emails"'The path to save the messages

Sub Download_Outlook_Mail_To_Excel()
Dim olApp AsObject
Dim olFolder AsObject
Dim olNS AsObject
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow AsLong
Dim i AsLong
Dim olItem AsObject
    Set xlBook = Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    OnErrorResumeNext
    Set olApp = GetObject(,"Outlook.Application")
    If Err <>0Then
        Set olApp = CreateObject("Outlook.Application")
    EndIf
    OnErrorGoTo0
    With xlSheet
        .Cells(1,1)="Sender"
        .Cells(1,2)="Subject"
        .Cells(1,3)="Date"
        '.Cells(1, 4) = "Size"
        .Cells(1,5)="EmailID"
        .Cells(1,6)="Body"
        CreateFolders fPath
        Set olNS = olApp.GetNamespace("MAPI")
        Set olFolder = olNS.PickFolder
        ForEach olItem In olFolder.Items
            NextRow =.Cells(.Rows.Count,"A").End(xlUp).Row +1
            If olItem.Class=43Then
                .Cells(NextRow,1)= olItem.Sender
                .Cells(NextRow,2)= olItem.Subject
                .Cells(NextRow,3)= olItem.SentOn
                '.Cells(NextRow, 4) =
                .Cells(NextRow,5)= SaveMessage(olItem)
                .Cells(NextRow,6)= olItem.Body
            EndIf
        Next olItem
    EndWith
     MsgBox "Outlook Mails Extracted to Excel"
lbl_Exit:
    Set olApp =Nothing
    Set olFolder =Nothing
    Set olItem =Nothing
    Set xlBook =Nothing
    Set xlSheet =Nothing
    ExitSub
EndSub

Function SaveMessage(olItem AsObject)AsString
Dim Fname AsString
    Fname = Format(olItem.ReceivedTime,"yyyymmdd")& Chr(32)& _
            Format(olItem.ReceivedTime,"HH.MM")& Chr(32)& olItem.SenderName &" - "& olItem.Subject
    Fname = Replace(Fname, Chr(58)& Chr(41),"")
    Fname = Replace(Fname, Chr(58)& Chr(40),"")
    Fname = Replace(Fname, Chr(34),"-")
    Fname = Replace(Fname, Chr(42),"-")
    Fname = Replace(Fname, Chr(47),"-")
    Fname = Replace(Fname, Chr(58),"-")
    Fname = Replace(Fname, Chr(60),"-")
    Fname = Replace(Fname, Chr(62),"-")
    Fname = Replace(Fname, Chr(63),"-")
    Fname = Replace(Fname, Chr(124),"-")
    SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
    ExitFunction
EndFunction

PrivateFunction SaveUnique(oItem AsObject, _
                            strPath AsString, _
                            strFileName AsString)AsString
Dim lngF AsLong
Dim lngName AsLong
    lngF =1
    lngName = Len(strFileName)
    DoWhile FileExists(strPath & strFileName &".msg")=True
        strFileName = Left(strFileName, lngName)&"("& lngF &")"
        lngF = lngF +1
    Loop
    oItem.SaveAs strPath & strFileName &".msg"
    SaveUnique = strPath & strFileName &".msg"
lbl_Exit:
    ExitFunction
EndFunction

PrivateSub CreateFolders(strPath AsString)
Dim strTempPath AsString
Dim iPath AsLong
Dim vPath AsVariant
    vPath = Split(strPath,"\")
    strPath = vPath(0)&"\"
    For iPath =1To UBound(vPath)
        strPath = strPath & vPath(iPath)&"\"
        IfNot FolderExists(strPath)Then MkDir strPath
    Next iPath
EndSub

PrivateFunction FolderExists(ByVal PathName AsString)AsBoolean
   Dim nAttr AsLong
   OnErrorGoTo NoFolder
   nAttr = GetAttr(PathName)
   If(nAttr And vbDirectory)= vbDirectory Then
      FolderExists =True
   EndIf
NoFolder:
EndFunction

PrivateFunction FileExists(filespec)AsBoolean
Dim fso AsObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec)Then
        FileExists =True
    Else
        FileExists =False
    EndIf
lbl_Exit:
    ExitFunction
EndFunction

</code>

 

[Legacy 286866]

My god.... I found the issue. The folder where I was trying to save the emails had special permissions..... (sorry). Now resolved.