+ Rispondi al messaggio
Pagina 1 di 2 12 ultimoultimo
Visualizzazione dei risultati da 1 a 10 su 17

Problema memoria

  1. #1
    terrornoize non è in linea Scolaretto
    Ciao a tutti,
    ho creato una routine piuttosto lunga che mi fa una sorta di spidering su una lista di circa 50k siti e nel frattempo mi fa un check se al loro interno sono presenti degli indirizzi email pubblici.

    Il problema è che dopo circa 2/3 ore excel raggiunge i 1.2/1.3gb di memoria occupata e crasha.

    A livello di codice non vedo grosse porcherie, sembra proprio una questione interna ad excel.

    C'è qualche comando, trucco, impostazione per ovviare a questa situazione che mi limita in qualche modo l'operatività?

  2. #2
    L'avatar di gibra
    gibra non è in linea Very Important Person
    Quote Originariamente inviato da terrornoize Visualizza il messaggio
    Il problema è che dopo circa 2/3 ore excel raggiunge i 1.2/1.3gb di memoria occupata e crasha
    Quindi sembra che il problema sia proprio nel tuo codice che non rilascia la risorse in modo corretto.
    ℹ️ Leggi di più su gibra ...

  3. #3
    terrornoize non è in linea Scolaretto
    Quote Originariamente inviato da gibra Visualizza il messaggio
    Quindi sembra che il problema sia proprio nel tuo codice che non rilascia la risorse in modo corretto.
    Mah, alla fin fine scrollo attraverso le righe con l'indirizzo url, verifico che sia un sito valido, chiamo una funzione che verifichi se al suo interno ci siano altri url e che, se validi, a sua volta chiama una funzione per verificare che l'indirizzo non sia già nell'elenco da verificare e diversamente lo aggiunge all'elenco da controllare. Nel frattempo c'è un'altra funzione che verifica che non ci siano indirizzi email altrimenti me li aggiunge in uno sheet a parte.

    Non ho variant in giro

    Dite che devo mettere a nothing ogni stringa in ogni funzione?

    Ah, ho visto che avevo in giro qualche object, adesso li setto a nothing. Dite che potrebbe essere questo il problema?
    Ultima modifica di terrornoize; 16-08-2021 10:07 

  4. #4
    Quote Originariamente inviato da terrornoize Visualizza il messaggio
    ...Dite che devo mettere a nothing ogni stringa in ogni funzione?
    Diciamo che bisogna vedere qualcosa del codice, se non tutto, prima di dare suggerimenti.
    (PS: non si può mettere a Nothing una stringa)

  5. #5
    terrornoize non è in linea Scolaretto
    Si, intendevo a null... scusate deve fare ancora effetto il caffè.
    Comunque nella mia ignoranza pensavo che se anche lasciavo "sporco" o aperto qualcosa, si sarebbe "riazzerato" al prossimo utilizzo della stessa identica cosa. Evidendemente mi sbaglio, corretto?

    Cosa influisce più di tutto sulla memoria?

  6. #6
    Quote Originariamente inviato da terrornoize Visualizza il messaggio
    ...pensavo che se anche lasciavo "sporco" o aperto qualcosa, si sarebbe "riazzerato" al prossimo utilizzo della stessa identica cosa.
    Dipende. In teoria sì ma a volte no. Dipende da tante cose.
    Cosa influisce più di tutto sulla memoria?
    tante cose, difficile dirlo in senso assoluto.
    Il Gibra, e non lo cito solo perché è già intervenuto in merito, scrisse a suo tempo un discorso che finora non ho letto da nessun'altra parte: mai mescolare earlybing con il latebinding. Ovviamente ora non trovo il suo intervento ma ce l'ho ben impresso nella testa:
    Dim excelApp As Excel.Application
    Set excelApp = CreateObject("Excel.Application")
    
    Questo non va bene. A volte questo sistema di dichiarazione-assegnazione non permette di "liberare" le risorse. Magari funziona lo stesso 9 volte su 10 ma chi vuole provare a trovarsi nellla situazione in cui va ko? io no.
    Mi sono trovato anch'io in una situazione forse simile alla tua dalla quale sono uscito con un "trucchetto" e che non ho potuto approfondire ulteriormente: https://masterdrive.it/microsoft-acc...60-file-85612/
    Tutto questo per dire che bisogna vedere il codice per poter dire qualcosa di concreto.
    Ultima modifica di Phil_cattivocarattere; 16-08-2021 10:42 

  7. #7
    Devi mostrare il codice su cui discutere o è un segreto?
    ℹ️ Leggi di più su AntonioG ...

  8. #8
    terrornoize non è in linea Scolaretto
    Questa la routine con lo script

    Sub launch()
    
    On Error Resume Next
    
    Dim Url As String, filter As String
    Dim MaxResults As Long, counter As Long, ID As Long, actual_Level As Integer, max_Level As Integer, url_status As Long
    
    actual_Level = 1
    max_Level = 2
    
    
    Application.ScreenUpdating = False
    
    Dim r As Range
    Dim CurrRow As Long
    Dim lastRow As Long
    
    With Sheets("Sheet1")
    
        For Each r In .Range("B2:B1048576")
        
            If r.Value <> vbNullString Then
                
                ID = r.Offset(0, -1)
                
                If Len(r.Offset(0, 1)) = 0 Then
                    actual_Level = 1
                    r.Offset(0, 1) = actual_Level
                Else
                    actual_Level = r.Offset(0, 1)
                End If
                
                
                ' controlla links e mail ---------------------------------
                
                If actual_Level < max_Level And r.Offset(0, 2) <> "y" Then
                    
                    url_status = IsURLGood(r.Value)
                    
                    If url_status = 200 Then
                    
                        Call GrabLinksAndEmails(r.Value, ID, True, True, actual_Level + 1)
                        
                        counter = counter + 1
                        r.Offset(0, 2) = "y"
                        r.Offset(0, 3) = url_status
                    
                    Else
                        
                        r.Offset(0, 2) = "n"
                        r.Offset(0, 3) = url_status
                        
                        Debug.Print "Rejected url: " & r.Value & " - Url status: " & url_status & " - Id: " & ID
                        Debug.Print "--------------------------------"
                        
                    End If
                    
                End If
                
                '----------- se raggiunto livello max controlla solo mail
                
                If actual_Level = max_Level And r.Offset(0, 2) <> "y" Then
                    
                    url_status = IsURLGood(r.Value)
                    
                    If url_status = 200 Then
                    
                        Call GrabLinksAndEmails(r.Value, ID, False, True, actual_Level + 1)
                        counter = counter + 1
                        r.Offset(0, 2) = "y"
                        
                    Else
                        
                        r.Offset(0, 2) = "n"
                        r.Offset(0, 3) = url_status
                        
                        Debug.Print "Rejected url: " & r.Value & " - Url status: " & url_status & " - Id: " & ID
                        Debug.Print "--------------------------------"
                        
                    End If
                
                End If
                    
                ' --------------------------------------------
                    
                    
            Else
                MsgBox "Finito!"
                Exit Sub
            End If
            
            
            
            If counter > 0 And counter Mod 10 = 0 Then
            
                Debug.Print "******** Saving worksheet in progress ********"
                Debug.Print "----------------------------------------------"
                ActiveWorkbook.Save
                
            End If
            
            
            'If counter > 0 And counter Mod 200 = 0 Then
            
            '    Debug.Print "******** Empty memory in progress ********"
                
                'aspetta che un po' di tempo passi per effettuare lo svuotamento
            '    Application.Wait (Now() + TimeValue("00:00:10"))
                
                'empty memory
            '    Shell "cmd.exe /c C:\NoInstall\System_Utils\ReduceMemory\ReduceMemory.exe /S"
                
                'aspetta che un po' di tempo passi per effettuare lo svuotamento
            '    Application.Wait (Now() + TimeValue("00:00:10"))
                
            'End If
            
            
        Next r
    
    End With
    
    Application.ScreenUpdating = True
    
    End Sub
    

    --------------------------------------


    queste invece le funzioni:





    Option Explicit
    
    '* Tools->Refernces Microsoft HTML Object Library
    '* SOURCE: https://stackoverflow.com/questions/47592151/how-do-i-parse-html-without-creating-an-object-of-internet-explorer-in-vba
    
    
    '* MSDN - URLDownloadToFile function - https://msdn.microsoft.com/en-us/library/ms775123(v=vs.85).aspx
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
            ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    
    Function GrabLinksAndEmails(sURL As String, Source_ID As Long, Grab_Links As Boolean, Grab_Mails As Boolean, Level_Count As Integer)
       
        On Error Resume Next
       
        Dim dt As Date
        
        Dim pot_link As String
        Dim pot_email As String
        
        Dim Trunk_url As Integer
        
        Dim Links_count As Long
        Dim Emails_count As Long
        
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
    
        Dim sLocalFilename As String
        sLocalFilename = Environ$("TMP") & "\urlmon.html"
    
        'Dim sURL As String
        'sURL = "https://www.alidat.com/partners"
        'sURL = "https://www.gpbullhound.com/team/"
        'sURL = "https://www.kkr.com/our-firm/team"
        'sURL = "https://www.p101.it/contatti/"
        'sURL = "https://www.ventureup.it/venture/venture-capital/"
        'sURL = "https://tpg.com/"
        'sURL = "https://www.ecipartners.com/team"
        'sURL = "https://www.primaryeurope.com/contact-us1/"
        
        Debug.Print "Start scan url '" & sURL & "' - ID: " & Source_ID & " @ " & Now
        Application.StatusBar = "Start scanning: " & sURL
        
        Dim bOk As Boolean
        bOk = (URLDownloadToFile(0, sURL, sLocalFilename, 0, 0) = 0)
        If bOk Then
            If fso.FileExists(sLocalFilename) Then
    
                '* Tools->Refernces Microsoft HTML Object Library
                Dim oHtml4 As MSHTML.IHTMLDocument4
                Set oHtml4 = New MSHTML.HTMLDocument
    
                Dim oHtml As MSHTML.HTMLDocument
                Set oHtml = Nothing
    
                '* IHTMLDocument4.createDocumentFromUrl
                '* MSDN - IHTMLDocument4 createDocumentFromUrl method - https://msdn.microsoft.com/en-us/library/aa752523(v=vs.85).aspx
                Set oHtml = oHtml4.createDocumentFromUrl(sLocalFilename, "")
    
                '* need to wait a little whilst the document parses
                '* because it is multithreaded
                
                dt = Now + TimeSerial(0, 0, 60)            ' 30 is timeout in seconds
                
                While oHtml.ReadyState <> "complete"
                    
                    DoEvents  '* do not comment this out it is required to break into the code if in infinite loop
                
                    If Now > dt Then
                        Application.StatusBar = "Time out: " & sURL
                        Debug.Print ("Time out: " & sURL)
                        'MsgBox "Timeout has happened", vbExclamation, "Canceled"
                        Exit Function
                    End If
                
                
                Wend
                Debug.Assert oHtml.ReadyState = "complete"
                
                Application.StatusBar = "Analyzing content: " & sURL
    
                Dim sTest As String
                sTest = Left$(oHtml.body.outerHTML, 100)
                'Debug.Assert Len(Trim(sTest)) > 50  '* just testing we got a substantial block of text, feel free to delete
    
                '* page specific logic goes here
                Dim htmlAnswers As Object 'MSHTML.DispHTMLElementCollection
                'Set htmlAnswers = oHtml.getElementsByClassName("a class")
                Set htmlAnswers = oHtml.getElementsByTagName("a")
    
                Dim lAnswerLoop As Long
                For lAnswerLoop = 0 To htmlAnswers.Length - 1
                    Dim vAnswerLoop
                    Set vAnswerLoop = htmlAnswers.Item(lAnswerLoop)
                    'Debug.Print vAnswerLoop.Text
                    'Debug.Print vAnswerLoop.innerText
                    'Debug.Print vAnswerLoop.outerText
                    'Debug.Print vAnswerLoop.innerHTML
                    'Debug.Print vAnswerLoop.outerHTML
                    'Debug.Print vAnswerLoop.textContent
                    'Debug.Print vAnswerLoop.href
                    'Debug.Print vAnswerLoop
                    
                    
                    
                    
                    '------------------
                    
                    'GESTIONE MAIL
                    
                    If Grab_Mails = True Then
                    
                        If Left(vAnswerLoop.href, 7) = "mailto:" Then
                            pot_email = ExtractEmail(vAnswerLoop.href)
                            'Debug.Print "found a potential email tbv: >" & pot_email & "<"
                            If IsValidEmail(pot_email) = True Then
                            
                                'Debug.Print "found a valid email: <" & pot_email & ">"
                                Call Add_Email_Table(Source_ID, pot_email)
                                Emails_count = Emails_count + 1
                                
                            End If
                        End If
                        
                        
                        If InStr(vAnswerLoop.innerText, "@") > 0 Then
                            pot_email = ExtractEmail(vAnswerLoop.innerText)
                            'Debug.Print "found a potential email tbv: >" & pot_email & "<"
                            If IsValidEmail(pot_email) = True Then
                            
                                'Debug.Print "found a valid email: <" & pot_email & ">"
                                Call Add_Email_Table(Source_ID, pot_email)
                                Emails_count = Emails_count + 1
                                
                            End If
                            
                        End If
                    
                    End If
                    
                    '-------------------------
                    
                    
                    
                    'GESTIONE URLS
                    '-------------------------
                    
                    If Grab_Links = True Then
                    
                        If Left(vAnswerLoop.href, 8) = "file:///" Then
                            Trunk_url = InStr(9, sURL, "/") - 1
                            pot_link = Left(sURL, Trunk_url) & Mid(vAnswerLoop.href, 11)
                            'Debug.Print "found a valid url: " & pot_link
                        ElseIf Right(vAnswerLoop.href, 4) = ".pdf" Or _
                                Right(vAnswerLoop.href, 4) = ".doc" Or _
                                Right(vAnswerLoop.href, 5) = ".docx" Or _
                                Right(vAnswerLoop.href, 4) = ".xls" Or _
                                Right(vAnswerLoop.href, 5) = ".xlsx" Or _
                                Right(vAnswerLoop.href, 4) = ".png" Or _
                                Right(vAnswerLoop.href, 4) = ".bmp" Or _
                                Right(vAnswerLoop.href, 5) = ".jpeg" Or _
                                Right(vAnswerLoop.href, 4) = ".jpg" Then
                                    'ignore
                        Else
                            pot_link = vAnswerLoop.href
                        End If
                        
                        
                        If InStr(pot_link, ExtractDomain(sURL)) > 0 And _
                            Left(pot_link, 4) = "http" And _
                            IsURLGood(pot_link) < 400 Then
                                
                                'Debug.Print "found a valid url: " & pot_link
                                Call Add_Link_Table(Source_ID, pot_link, Level_Count)
                                Links_count = Links_count + 1
                                
                        End If
                    
                    End If
                    
                    '--------------------------------
                                    
                Next
    
            End If
        
        End If
        
    
    'Debug.Print "--------------------------------"
    Debug.Print "Total emails founded: " & Emails_count
    Debug.Print "Total links founded: " & Links_count
    Debug.Print "Finish @ " & Now
    Debug.Print "--------------------------------"
    
    Set fso = Nothing
    Set oHtml4 = Nothing
    Set oHtml = Nothing
    Set htmlAnswers = Nothing
    
    sURL = Null
    
    End Function
    
    Function IsValidEmail(sEmailAddress As String) As Boolean
        'Code from Officetricks
        'Define variables
        Dim sEmailPattern As String
        Dim oRegEx As Object
        Dim bReturn As Boolean
        
        'Use the below regular expressions
        sEmailPattern = "^\w+([\.-]?\w+)*@\w+([\.-]?\w+)*(\.\w{2,3})+$" 'or
        sEmailPattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
        
        'Create Regular Expression Object
        Set oRegEx = CreateObject("VBScript.RegExp")
        oRegEx.Global = True
        oRegEx.IgnoreCase = True
        oRegEx.Pattern = sEmailPattern
        bReturn = False
        
        'Check if Email match regex pattern
        If oRegEx.Test(sEmailAddress) Then
            'Debug.Print "Valid Email ('" & sEmailAddress & "')"
            bReturn = True
        Else
            'Debug.Print "Invalid Email('" & sEmailAddress & "')"
            bReturn = False
        End If
    
        'Return validation result
        IsValidEmail = bReturn
        
    Set oRegEx = Nothing
    
    End Function
    
    Public Function IsURLGood(Url As String) As Long
        Dim request As Object
        Set request = CreateObject("WinHttp.WinHttpRequest.5.1")
        On Error GoTo haveError
        With request
            .Open "HEAD", Url
            .send
            IsURLGood = .Status
        End With
        Set request = Nothing
        Exit Function
        
    haveError:
        Set request = Nothing
        'IsURLGood = Err.Description
    End Function
    
    Function ExtractEmail(extractStr As String) As String
    'Update by extendoffice
    Dim CharList, CheckStr, OutStr, getStr As String
    Dim p, Index, Index1 As Long
    
    On Error Resume Next
    CheckStr = "[A-Za-z0-9._-]"
    OutStr = ""
    Index = 1
    Do While True
        Index1 = VBA.InStr(Index, extractStr, "@")
        getStr = ""
        If Index1 > 0 Then
            For p = Index1 - 1 To 1 Step -1
                If Mid(extractStr, p, 1) Like CheckStr Then
                    getStr = Mid(extractStr, p, 1) & getStr
                Else
                    Exit For
                End If
            Next
            getStr = getStr & "@"
            For p = Index1 + 1 To Len(extractStr)
                If Mid(extractStr, p, 1) Like CheckStr Then
                    getStr = getStr & Mid(extractStr, p, 1)
                Else
                    Exit For
                End If
            Next
            Index = Index1 + 1
            If OutStr = "" Then
                OutStr = getStr
            Else
                OutStr = OutStr & Chr(10) & getStr
            End If
        Else
            Exit Do
        End If
    Loop
    ExtractEmail = OutStr
    End Function
    
    
    Function ExtractDomain(ByVal Url As String) As String
    'Update 20140904
        If InStr(Url, "//") Then
            Url = Mid(Url, InStr(Url, "//") + 2)
        End If
        If Left(Url, 4) Like "[Ww][Ww][Ww0-9]." Then
            Url = Mid(Url, 5)
        End If
        ExtractDomain = Split(Url, "/")(0)
    
    End Function
    
    Function Add_Link_Table(ID As Long, Url As String, Level As Integer)
    
    Dim erow As Long
    Dim Res As Variant
    
    erow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Res = CStr(Application.VLookup(Url, Worksheets("Sheet1").Range("B1:B" & erow), 1, False))
    
    If Res = Url Then
        'record duplicato
        'rec_dupl = rec_dupl + 1
    Else
        
        With Worksheets("Sheet1")
            .Cells(erow, 1).Value = ID
            .Cells(erow, 2).Value = Url
            .Cells(erow, 3).Value = Level
        End With
        
    End If
    
    erow = 0
    Set Res = Nothing
    
    
    End Function
    
    Function Add_Email_Table(ID As Long, Email As String)
    
    Dim erow As Long
    Dim Res As Variant
    
    Dim Unique_ID As String
    Unique_ID = ID & "_" & Email
    
    erow = Worksheets("Email_Output").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Res = CStr(Application.VLookup(Unique_ID, Worksheets("Email_Output").Range("C1:C" & erow), 1, False))
    
    If Res = Unique_ID Then
        'record duplicato
        'rec_dupl = rec_dupl + 1
    Else
        
        With Worksheets("Email_Output")
            .Cells(erow, 1).Value = ID
            .Cells(erow, 2).Value = Email
            .Cells(erow, 3).Value = Unique_ID
        End With
            
    End If
    
    erow = 0
    Set Res = Nothing
    
    
    End Function
    

  9. #9
    Quote Originariamente inviato da terrornoize Visualizza il messaggio
    Questa la routine con lo script
    ...
    queste invece le funzioni:
    Nell'immediato è impossibile almeno per me individuare errori anche evidenti, ci sono però consigli generali che vanno sempre bene.
    Prima però una domanda: il problema è spuntato di recente, all'improvviso o è "da sempre" che Excel si chiude all'improvviso?
    Ecco i consigli generali: usare con molta molta molta cautela il Resume Next nella gestione degli errori. Chi ci assicura che tutto non sia riconducibile ad errori ignorati?
    Poi... cavoli, c'è di mezzo internet explorer... si salvi chi può.
    Ah, sì, questa l'avevo vista scorrendo veloce
                Dim oHtml As MSHTML.HTMLDocument
                Set oHtml = Nothing
                '* IHTMLDocument4.createDocumentFromUrl
                '* MSDN - IHTMLDocument4 createDocumentFromUrl method - https://msdn.microsoft.com/en-us/library/aa752523(v=vs.85).aspx
                Set oHtml = oHtml4.createDocumentFromUrl(sLocalFilename, "")
    
    Quel Nothing lì non serve proprio a niente.
    Ultima modifica di Phil_cattivocarattere; 16-08-2021 11:30 

  10. #10
    terrornoize non è in linea Scolaretto
    In teoria non ci dovrebbe essere di mezzo ie... una volta utilizzavo ie per fare ste cose, ma poi erano più le rotture di scatole che altro, quindi scarico il file e lo "analizzo" con la HTML Object Library.
    Ho verificato ancora adesso, IE non compare in nessun processo da gestione attività di windows.

    Il problema c'è da sempre purtroppo.

    Avevo disattivato la gestione errori perché ragazzi altrimenti passerei più tempo a fare debugging che a mettermi li a manella a tirare giù le mail dai 50k siti.

    Come avrete capito dal codice (che in alcune parti è ovviamente copia incollato e personalizzato) il mio know-how è limitato.


    Peccato che ci sia sto problema, perché magari il codice non sarà pulito ma mi tira fuori abbastanza dati... però così mi costringe a controllarlo ogni 2/3 ore e perdo tanto tempo (specialmente di notte)...

+ Rispondi al messaggio
Pagina 1 di 2 12 ultimoultimo

Potrebbero interessarti anche ...

  1. Risposte: 5
    Ultimo Post: 05-09-2014, 10:55
  2. strano problema memoria su Acer Veriton M460
    Da alextrip nel forum Hardware, elettronica e retro-computing
    Risposte: 4
    Ultimo Post: 14-12-2013, 11:18
  3. Risposte: 7
    Ultimo Post: 06-05-2013, 11:10
  4. Problema con la Memoria -OpenGl 3D-
    Da xardas nel forum C/C++
    Risposte: 17
    Ultimo Post: 19-09-2008, 15:23
  5. Problema Alquanto Grave Con Applicazione e uso Memoria
    Da Frosty nel forum Visual Basic .Net
    Risposte: 18
    Ultimo Post: 14-02-2008, 17:50