none
Your Digital Id Name Cannot Be Found By The Underlying Security RRS feed

  • Question

  • I ve an excel macro that extract emails from an additional mail box to local system. Script was working fine when i extract mail from my mail box but its throwing the below error when i tried to extract it from the additional mail box.

    I ve also digitally signed my ID and that has been granted permission in that additional mailbox but still throwing error.

    Please help me with this.

    Your Digital Id Name Cannot Be Found By The Underlying Security

    Thursday, June 22, 2017 4:20 AM

All replies

  • Hi KalFel,

    you had only posted the description about your issue.

    please try to post the sample code. so that we can try to reproduce the issue on our side.

    also I want to confirm with you that which Office version you are using?

    based on my search result , I find that this error caused by the below reasons.

    it is possible that you are trying to extract the encrypted emails.

    Encrypt email messages

    try to extract non encrypted emails and check whether you get any error or not.

    also try to use Outlook User Interface and try to extract that emails.

    if you get same error by the user interface then it possible that your Excel Macro code does not have issue and issue is related with Digital Certificate.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, June 23, 2017 1:21 AM
    Moderator
  • Hello Deepak,

    Thanks for the tips.

    The mail am trying to extract is not encrypted.

    Below is my code.

                    

    Sub Unzip()
        '''Variables for the main functionality
        Dim app As Object
        Dim NS As Object
        Dim InboX As Object
        Dim SubFolder As Object
        Dim MsG As Object
        Dim AtcHmt As Object
        Dim ReceivedHour As Date
        Dim oFrom As Date
        Dim oEnd As Date
        Dim f As Boolean
        '''Variables for unzipping
        Dim FSO As Object
        Dim ShellApp As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set ShellApp = CreateObject("Shell.Application")
        Dim FileNameFolder As Variant
        Dim FileName As Variant
        Dim Ldate As String

        Ldate = Date

        '''Define the Outlook folder you want to scan
        On Error Resume Next
        Set app = GetObject(Class:="Outlook.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Outlook.Application")
            f = True
        End If
        On Error GoTo ErrHandler
        Set NS = app.GetNamespace("MAPI")
        Set InboX = NS.PickFolder
        'Set SubFolder = InboX.Folders("Shadow Server Reports")
        'Dim myitem As Outlook.MailItems
        '''Define the folder where you want to save attachments
        FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"

        '''Define the hours in between which you want to apply the extraction
        oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _
                                "Example: 9AM", ("Shadowserver report"), "9AM"))
        oEnd = CDate(InputBox("Please give End time" & vbCrLf & _
                                "Example: 6PM", ("Shadowserver report"), "6PM"))

        For Each MsG In InboX.Items
        If Ldate = DateValue(MsG.SentOn) Then
            ReceivedHour = MsG.ReceivedTime
            If oFrom <= TimeValue(ReceivedHour) And _
                TimeValue(ReceivedHour) <= oEnd Then
                For Each AtcHmt In MsG.Attachments
                    FileName = AtcHmt.FileName
                    If LCase(Right(FileName, 3)) = "zip" Then
                        FileName = FileNameFolder & FileName
                        AtcHmt.SaveAsFile FileName

                        ShellApp.Namespace(FileNameFolder).CopyHere _
                                ShellApp.Namespace(FileName).Items

                        Kill FileName
                        On Error Resume Next
                        FSO.Deletefolder Environ$("Temp") & "\Temporary Directory*", True
                    End If
                Next AtcHmt
            End If
        End If
        Next MsG

    Call ImportCSVs
    ExitHandler:
        On Error Resume Next
        If f Then app.Quit
        Exit Sub

    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub

    Sub ImportCSVs()
    Dim fPath   As String
    Dim fCSV    As String
    Dim wbCSV   As Workbook
    Dim wbMST   As Workbook

    Set wbMST = ThisWorkbook
    fPath = "C:\Users\fdhivya\Documents\test\"                  'path to CSV files, include the final \
    Application.ScreenUpdating = False  'speed up macro
    Application.DisplayAlerts = False   'no error messages, take default answers
    fCSV = Dir(fPath & "*.csv")         'start the CSV file listing

        On Error Resume Next
        Do While Len(fCSV) > 0
            Set wbCSV = Workbooks.Open(fPath & fCSV)                    'open a CSV file
            wbMST.Sheets(ActiveSheet.Name).Delete                       'delete sheet if it exists
            ActiveSheet.Move After:=wbMST.Sheets(wbMST.Sheets.Count)    'move new sheet into Mstr
            Columns.AutoFit             'clean up display
            fCSV = Dir                  'ready next CSV
        Loop

    Application.ScreenUpdating = True
    Set wbCSV = Nothing
    Call Collect
    Call Worksheet_Activate
    End Sub
     Sub Collect()
        Dim myInSht As Worksheet
        Dim myOutSht As Worksheet
        Dim aRow As Range
        Dim aCol As Range
        Dim myInCol As Range
        Dim myOutCol As Range
        Dim calcState As Long
        Dim scrUpdateState As Long
        Dim cell As Range
        Dim iLoop As Long, jLoop As Long

        jLoop = 2

    ' loop through the worksheets
        For Each myInSht In ActiveWorkbook.Worksheets
    ' pick only the worksheets of interest
            'If myInSht.Name = "a" Or myInSht.Name = "aa" Or myInSht.Name = "aaa" Then
            ' find the columns of interest in the worksheet
                For Each aCol In myInSht.UsedRange.Columns
                    Set myOutCol = Nothing
                    If aCol.Cells(1, 1).Value = "timestamp" Then Set myOutCol = Sheets("Summary").Range("B2:B1000")
                    If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Summary").Range("C2:C1000")
                    If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Summary").Range("D2:D1000")
                    If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Summary").Range("E2:E1000")
                    If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Summary").Range("F2:F1000")
                    If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Summary").Range("G2:G1000")
                    If aCol.Cells(1, 1).Value = "asn" Then Set myOutCol = Sheets("Summary").Range("I2:I1000")
                    If aCol.Cells(1, 1).Value = "geo" Then Set myOutCol = Sheets("Summary").Range("J2:J1000")
                    If aCol.Cells(1, 1).Value = "region" Then Set myOutCol = Sheets("Summary").Range("K2:K1000")
                    If aCol.Cells(1, 1).Value = "naics" Then Set myOutCol = Sheets("Summary").Range("L2:L1000")
                    If aCol.Cells(1, 1).Value = "sic" Then Set myOutCol = Sheets("Summary").Range("M2:M1000")
                    If aCol.Cells(1, 1).Value = "server_name" Then Set myOutCol = Sheets("Summary").Range("H2:H1000")

                    If Not myOutCol Is Nothing Then
    ' don't move the top line, it contains the headers - no data
                        Set myInCol = aCol
                        Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count, myInCol.Columns.Count)
    ' transfer data from the project tab to the consolidated tab
                        iLoop = jLoop
                        For Each aRow In myInCol.Rows
                            myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
                            iLoop = iLoop + 1
                        Next aRow
                    End If
                Next aCol
                'End If
            If iLoop > jLoop Then jLoop = iLoop
        Next myInSht
        End Sub

    Monday, July 3, 2017 6:49 AM
  • Hi KalFel,

    I find that your code contains several subs.

    in which sub and on which line you got this error?

    also I don't have excel file to test this code.

    are you working with office 2016? I assume here.

    you had mentioned that ,"The mail am trying to extract is not encrypted."

    does it mean it's a normal mail?

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Monday, July 3, 2017 9:18 AM
    Moderator
  • Hi Deepak,

    Sorry for the misses.

    Am using 2010 version of outlook. Also i confirm the mails are normal mails.

    In addition ive altered my macros as below but this is not works well on restriction with date as today. This is throwing an error as "condition is not valid"

    Option Explicit

    Public Function getShadowReportItems() As Object
        Dim myNamespace As Object
        Dim myFolder As Object
        Dim myItems As Object
        Dim myItem As Object
        Set myNamespace = GetObject(Class:="Outlook.Application").GetNamespace("MAPI")
        Set myFolder = myNamespace.PickFolder
        Set myItems = myFolder.Items
        Set myItems = myItems.Restrict("DateValue[ReceivedTime]>='" & Format(DateValue(Now), "ddddd h:nn AMPM") & "'")
        Set getShadowReportItems = myItems
    End Function

    Sub Unzip()
        '''Variables for the main functionality
        Dim app As Object
        Dim NS As Object
        Dim InboX As Object
        Dim SubFolder As Object
        Dim MsG As Object
        Dim AtcHmt As Object
        Dim ReceivedHour As Date
        Dim oFrom As Date
        Dim oEnd As Date
        Dim f As Boolean
        '''Variables for unzipping
        Dim FSO As Object
        Dim ShellApp As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set ShellApp = CreateObject("Shell.Application")
        Dim FileNameFolder As Variant
        Dim FileName As Variant
        
        '''Define the Outlook folder you want to scan
        On Error Resume Next
        Set app = GetObject(Class:="Outlook.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Outlook.Application")
            f = True
        End If
        On Error GoTo ErrHandler

        FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"

        Set InboX = getShadowReportItems()
        Dim I As Integer
        For Each MsG In InboX
            For Each AtcHmt In MsG.Attachments
                FileName = AtcHmt.FileName
                If LCase(Right(FileName, 3)) = "zip" Then
                    FileName = FileNameFolder & FileName
                    AtcHmt.SaveAsFile FileName

                    ShellApp.Namespace(FileNameFolder).CopyHere ShellApp.Namespace(FileName).Items

                    Kill FileName
                    On Error Resume Next
                    FSO.Deletefolder Environ$("Temp") & "\Temporary Directory*", True
                End If
            Next AtcHmt
        Next

    Call ImportCSVs
    ExitHandler:
        On Error Resume Next
        If f Then app.Quit
        Exit Sub

    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub


    Tuesday, July 4, 2017 2:11 AM
  • Hi KalFel,

    I try to check the condition.

    I find that problem is with below part of the condition.

    myItems.Restrict("DateValue[ReceivedTime]
     

    if you try to print the value in immediate window then you will find that it will not give value and produce error.

    so try to correct it.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Tuesday, July 4, 2017 2:53 AM
    Moderator
  • Hi Deepak,

    Am sorry am not getting your point.

    When am trying with below snippet its working fine.

    myItems.restrict("[unread] = True") this thing is extracting the mails if it is unread. Am not getting why its is not working with Datevalue

    Your help is much appreciated.

    Regards,

    Dhivya Felix

    Tuesday, July 4, 2017 6:00 AM
  • Hi KalFel,

    is [ReceivedTime] field is described in your folder?

    I find that you need to add the field to the folder.

    then only you can fetch the value.

    if you did not added the field then it will not work and produce an error.

    try to check it on your side that field is added to the folder.

    Reference:

    Restrict Method

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Thursday, July 6, 2017 9:41 AM
    Moderator