vba verifica esistenza file per un determinato giorno della settimana

Option Explicit

'

Public Const cartellafile = "C:\Users\Downloads\"

'

' vba verifica esistenza file per un determinato giorno della settimana

'

Sub VerificaEsistenzaFileDataGiorno()

Dim quanterighe, contarighe, foglio, contenuto, colonnadaleggere, giorno, sfile

Set foglio = Sheets(ActiveSheet.Name)

'

quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row

colonnadaleggere = "A"

'

contarighe = 2

While contarighe <= quanterighe

      contenuto = foglio.Cells(contarighe, colonnadaleggere).Value

      If IsDate(contenuto) = True Then

         giorno = settimanaNomeGiorno(contenuto)

         If giorno = "domenica" Then

            foglio.Cells(contarighe, "B").Value = "x"

            sfile = cartellafile & dataansi(contenuto) & ".txt"

            If esistefile(sfile) = "si" Then

                foglio.Cells(contarighe, "c").Value = "esiste"

            Else

                foglio.Cells(contarighe, "c").Value = "NON esiste"

            End If

         End If

      End If

      contarighe = contarighe + 1

Wend

'

'

End Sub

'

'

'

Function esistefile(parchivio)

Dim fs

Set fs = CreateObject("Scripting.FileSystemObject")

If fs.FileExists(parchivio) = True Then

   esistefile = "si"

Else

   esistefile = "no"

End If

Set fs = Nothing

End Function

'

'

'

Function dataansi(pdata)

Dim sdata

sdata = Year(pdata)

sdata = sdata & Month(pdata)

sdata = sdata & Day(pdata)

dataansi = sdata

'

End Function

'

'

'

Function settimanaNomeGiorno(dt)

Dim NomeGiorno 'As String

Select Case Weekday(dt, 1)

      Case 1: NomeGiorno = "domenica" ' "Sun"

      Case 2: NomeGiorno = "lunedi'" ' "Mon"

      Case 3: NomeGiorno = "martedi'" ' "Tue"

      Case 4: NomeGiorno = "mercoledi'" ' "Wed"

      Case 5: NomeGiorno = "giovedi'" ' "Thu"

      Case 6: NomeGiorno = "venerdi'" ' "Fri"

      Case 7: NomeGiorno = "sabato" ' "Sat"

End Select

 

settimanaNomeGiorno = NomeGiorno

 

End Function

'

 

 

'

vbs - scrive dati foglio Excel in file csv per stampa mailmerge etichette in Word

'

' vbs - scrive dati foglio Excel in file csv per stampa mailmerge etichette in Word

'

Sub ScriviFoglioCsvSql()

Dim quanterighe, contarighe, foglio, contacolonne, quantecolonne, contenuto

'

Dim cartellafile, fs, a, archivio, stesto, nomefile

cartellafile = "C:\etichette-csv\"

nomefile = "etichette-" & Format(Now(), "yyyymmddmms") & ".txt" ' & ".csv"

archivio = cartellafile & nomefile

'

'

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile(archivio, True)

'

Set foglio = Sheets(ActiveSheet.Name)

'

quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row

quantecolonne = Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column

'

quantecolonne = 6

'

contarighe = 1

While contarighe <= quanterighe

   contacolonne = 1

   stesto = ""

   While contacolonne <= quantecolonne

      contenuto = foglio.Cells(contarighe, contacolonne).Value

      contenuto = Replace(contenuto, ";", " ")

      contenuto = contenuto & ";"

      stesto = stesto & contenuto

      contacolonne = contacolonne + 1

   Wend

   '

   a.WriteLine (stesto)

   '

   contarighe = contarighe + 1

Wend

'

a.Close

'

Dim cartella, documento, nomedoc

cartella = "C:\etichette-csv\"

documento = cartella & "b-etichette-105x37 - Copia.doc"

'

Dim oApp, wdDoc

'

Set oApp = CreateObject("Word.Application")

oApp.Visible = True

'

Set wdDoc = oApp.Documents.Open(documento)

'

With oApp

    nomedoc = .ActiveDocument.Name

   .Activate

   .Documents(nomedoc).Activate  ' setta il riferimento al documento

End With

'

 wdDoc.MailMerge.OpenDataSource Name:= _

        archivio, ConfirmConversions:=False, _

        ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _

        PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _

        WritePasswordTemplate:="", Revert:=False, Format:=0, _

        Connection:="", SQLStatement:="", SQLStatement1:="", SubType:=0

 

  wdDoc.MailMerge.Execute

'

oApp.Documents(documento).Close SaveChanges:=wdDoNotSaveChanges

'

End Sub

'

'

salva allegati pdf dei messaggi di posta elettronica

'

option explicit

'

dim cartellaprg

cartellaprg = "C:\azioniprogrammate\allegati-posta-oggetto-fattura\"

dim prg1, prg2, prg3, prg4

prg1 = cartellaprg & "prg-010-salva-allegati-cartelle-pubbliche-oggetto-fattura.vbs"

prg2 = cartellaprg & "prg-020-converti-in-testo.vbs"

prg3 = cartellaprg & "prg-030-elenca-file-cartella.vbs"

prg4 = cartellaprg & "prg-040-cancella-file-messaggi.vbs"

'

dim prgemaildaarchiviodigitale, prgdominidaarchiviodigitale

prgemaildaarchiviodigitale = "C:\azioniprogrammate\archivio-digitale-fatture-2018\p02-cartelle-archivio-digitale.vbs"

prgdominidaarchiviodigitale  = "C:\azioniprogrammate\archivio-digitale-fatture-2018\p03-elenco-domini.vbs"

'

dim prgriferimentipartitaiva

prgriferimentipartitaiva = "C:\azioniprogrammate\salva-allegati-posta-piva\p02-cartelle-archivio-digitale.vbs"

'

' = verifica che outlook sia attivo

'

dim sprocesso, presente, trovato

dim sComputerName, objWMIService, sQuery, objItems, objItem

trovato = 0

'This function can report names from

'TaskManager -> Processes

    sComputerName = "."

    Set objWMIService = GetObject("winmgmts:\\" & sComputerName & "\root\cimv2")

    sQuery = "SELECT * FROM Win32_Process"

    Set objItems = objWMIService.ExecQuery(sQuery)

    'iterate all item(s)

    For Each objItem In objItems

        sprocesso = objItem.Name

        presente = instr(lcase(sprocesso), "outlook.exe")

        if presente > 0 then

           trovato = 1

           exit for

        else

           trovato = 0 

        end if

    Next

'

if trovato = 0 then

   'msgbox "outlook NON attivo"

else

  ' msgbox "outlook attivo"

  call prgrammasalvaallegati 

end if

'

'   =====

'

sub prgrammasalvaallegati()

Dim WshShell, esegui, attesa

Set WshShell = CreateObject("WScript.Shell")

'

' - salva allegati da exchange - stampa, in pdf, i messaggi

'

esegui = prg1

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgemaildaarchiviodigitale

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgdominidaarchiviodigitale

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgriferimentipartitaiva

attesa = WshShell.Run (esegui, 1, true)

'

' - converte in testo allegati pdf e i messaggi di posta

'

esegui = prg2

attesa = WshShell.Run (esegui, 1, true)

'

' cerca la partita, e poi cerca con indirizzo email

'

esegui = prg3

attesa = WshShell.Run (esegui, 1, true)

'

' cancella file temporanei

'

esegui = prg4

attesa = WshShell.Run (esegui, 1, true)

end sub

'

' ============

'

vbscript - filtra un file di testo utilizzando espressioni regolari

'

option explicit

'

' vbs - filtra un file di testo utilizzando espressioni regolari

'

dim objArgs, Filename, cartellalavori, Title

'

Set objArgs = WScript.Arguments  'Vedo se ci sono degli argomenti passati allo script

if objargs.count=0 then  'altrimenti mostro come si usa il programma

            msgbox "Trascinare un file sul programma per visualizzarlo", vbinformation+vbokonly, Title

            wscript.quit

end if

'

Filename=wscript.arguments(0)

'

cartellalavori = fcartellalavori(Filename)

'

dim dblog, slog

dblog = cartellalavori & "esito-1.txt"

call cancellafile(dblog)

'

dim criterioricerca

 criterioricerca = "[ ]{3,}"   ' solo righe con tre spazi consecutivi

' criterioricerca = "^\w{3}\s+\w*"

' criterioricerca = "^\w+\s\w+"

 

'

call leggifile(FileName)

'

FileName = dblog

dblog = cartellalavori & "esito-2.txt"

call cancellafile(dblog)

criterioricerca = "^\w+\s\w+"

call leggifile(FileName)

'

 

'

' ===

'

sub leggifile(pFileName)

dim  objFSO, objFile, text, txtStream

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

'

If objFSO.FileExists(pFilename) = true Then   

   Set txtStream = objFSO.OpenTextFile(pFilename) ' Apre file di testo.

   Do While Not (txtStream.atEndOfStream)      

       Text = txtStream.ReadLine 'legge una riga  

'

       call TestRegExp(criterioricerca, text)

'

  Loop

End If

'

'

end sub

'

'  =====

'

function fcartellalavori(pfile) ' determina la cartella di origine del file

dim  objFSO, objFile

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.GetFile(pfile)

'

fcartellalavori = objFSO.GetParentFolderName(objFile)  & "\"

'

'

end function

'

' ========= ===========

'

Sub TestRegExp(sPattern, ptesto)

'

dim sSearch

sSearch = ptesto

'

Dim oRE, oMatches, oMatch

Set oRE = CreateObject("VBScript.RegExp")

oRE.Global = True

oRE.IgnoreCase = True

oRE.Pattern = sPattern

if oRe.Test(sSearch) = true then

   Set oMatches = oRE.Execute(sSearch)

   For Each oMatch In oMatches

       ' msgbox oMatch.value

       ' stesto = stesto & oMatch.FirstIndex & " : " &  oMatch.Length  & " : " & oMatch.value & vbcrlf

       slog = ptesto

       '

       call ScriviFileJollyAppend(dblog, ptesto)

   Next

end if

'

'

End Sub

'

' =======

'

sub cancellafile(pfile)

dim fs

Set fs=CreateObject("Scripting.FileSystemObject")

if fs.FileExists(pfile) then

   fs.DeleteFile(pfile)

end if

set fs=nothing

end sub

'

' ==================

'

Sub ScriviFileJollyAppend(pNomeArchivio, pcosascrivere)

dim fso,  rifefile

Set fso=CreateObject("Scripting.FileSystemObject")

If (fso.FileExists(pNomeArchivio)) Then

      'msg = filespec & " esiste."

       Set rifefile = fso.OpenTextFile(pNomeArchivio, 8)

Else

      'msg = filespec & " Non esiste."

       Set rifefile = fso.CreateTextFile(pNomeArchivio, TRUE)

End If

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' =========

'

vbs - elenca file per data modifica

'

option explicit

'

' vbs - elenca file con data di modifica

' diversa dall'ultima scansione della cartella

'

'

dim cartella

cartella = "C:\archivio-listini\"

'

dim adesso, dbdataultimalettura, dataultimalettura

adesso = now

'

dbdataultimalettura = cartella & "db-data-ultima-lettura.txt"

dataultimalettura = leggituttoverifica(dbdataultimalettura, adesso)

'

'

Dim a, f, b, i

'

Set f  = FilesModificati(cartella, dataultimalettura)

'

a = f.keys

b = f.items

 

For i = 0 To f.count - 1

  WScript.Echo "nuovo file: " &  a(i) & " : " & b(i)

Next

'

call SovraScriviFile(dbdataultimalettura, adesso)

'

Set f = Nothing

WScript.Quit(0)

'

' =====

'

Function FilesModificati (FolderSpec, pdataultimalettura)

  Dim fso, fc, f, d, numerogiorni

  Set fso = CreateObject("Scripting.FileSystemObject")

  Set fc = fso.GetFolder(FolderSpec).Files

  Set d = CreateObject("Scripting.Dictionary")

 

  For Each f in fc

      numerogiorni =  DateDiff("d", pdataultimalettura, f.DateLastModified)

      if numerogiorni > 0 then

         d.Add f, f.DateLastModified & " :nr: " & numerogiorni

      end if

  Next

  Set fso = Nothing

  Set fc = Nothing

  Set FilesModificati = d

End function

'

' ===== =========

'

function leggituttoverifica(pfiledaleggere, pvaloredefault)

'

dim objFSO, objFile, contenutoletto

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FileExists(pfiledaleggere) Then

    'esistefile = "si"

    Set objFile = objFSO.OpenTextFile(pfiledaleggere, 1)

    contenutoletto = objFile.Readall

    contenutoletto = replace(contenutoletto, vbcrlf, "")

    contenutoletto = replace(contenutoletto, vbcr, "")

    contenutoletto = replace(contenutoletto, vblf, "")

    objFile.Close

Else

    'esistefile = "no"

    contenutoletto = pvaloredefault

    Set objFile = objFSO.CreateTextFile(pfiledaleggere, TRUE)

    objFile.WriteLine(pvaloredefault)

End If

'

objFile.Close

'

leggituttoverifica = contenutoletto

'

Set objFSO = Nothing

'

end function

'

' === sovra scrive file ===================

'

Sub SovraScriviFile(pNomeArchivio, pcosascrivere)

dim fso,  rifefile

Set fso=CreateObject("Scripting.FileSystemObject")

Set rifefile = fso.CreateTextFile(pNomeArchivio, TRUE)

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' =======================

'