cartelle modello scansiona tag nome file - vbs

' p

Option explicit

'

dim fso: set fso = CreateObject("Scripting.FileSystemObject")

dim CurrentDirectory

CurrentDirectory = fso.GetAbsolutePathName(".")

'

dim cartelladascansionare, dbcartellaprocedura, esito

dbcartellaprocedura = CurrentDirectory & "\" ' "C:\da-pub\"

'cartelladascansionare = leggiparametri(dbcartellaprocedura & "cartella-da-scansionare.txt")

cartelladascansionare = dbcartellaprocedura

'

dim fileescluso

fileescluso = "ceram.jpg"

'

dim dblog, slog

dblog = dbcartellaprocedura & "note.txt"

'

slog = "tag: " & vbcrlf

call SovraScriviFile(dblog, slog)

'

Dim dizionario, chiave

Set dizionario = CreateObject("Scripting.Dictionary")

dizionario.CompareMode = vbTextCompare

'

call PrgElencaCartelletipo(cartelladascansionare, "jpg")

'

' srivi tag

'

dim a, i

a=dizionario.Keys

for i = 0 To dizionario.Count -1

slog = a(i)

if isnumeric(slog) = false then

call ScriviFileJollyAppend(dblog, slog)

end if

next

'

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

'

Sub PrgElencaCartelletipo(pFolder, ptipofile)

'

Dim fso, cartelle, percorsocartella, nomecartella, nomefile

dim SubFolder, File, tpath

Set fso = CreateObject("Scripting.FileSystemObject")

set Cartelle = fso.GetFolder(pFolder)

'

For Each File In fso.GetFolder(pFolder).Files

If UCASE(fso.GetExtensionName(File.Name)) = UCASE(ptipofile) Then

nomefile = File.Name

if ucase(nomefile) = ucase(fileescluso) then

else

tpath = percorsocartella & nomefile

' slog = "File.Name: " & File.Name & vbcrlf & tpath

nomefile = replace(nomefile, "-", " ")

nomefile = replace(nomefile, ".jpg", ".")

slog = "- " & nomefile & vbcrlf

call ScriviFileJollyAppend(dblog, slog)

' tag

call RicercaRisultato(nomefile, "\w+")

'

end if

End If

Next

'

'

End Sub

'

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

'

Function RicercaRisultato(strVal, comecercare) 'As String

Dim sParts, sPart, rPart 'As Object

Set rPart = CreateObject("VBScript.RegExp")

rPart.Global = True

rPart.IgnoreCase = True

rPart.pattern = comecercare '

'get the results

Set sParts = rPart.Execute(strVal)

'get the first match

For Each sPart In sParts

chiave = trim(spart)

If dizionario.Exists(chiave) = False Then

dizionario.Add chiave, chiave

else

End If

Next 'sPart

Set sParts = Nothing

End Function

'

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

'

function leggiparametri(sFilePathAndName)

dim sFileContents, oFS, oTextStream

Set oFS = CreateObject("Scripting.FileSystemObject")

If oFS.FileExists(sFilePathAndName) = True Then

Set oTextStream = oFS.OpenTextFile(sFilePathAndName,1)

sFileContents = trim(oTextStream.ReadAll)

oTextStream.Close

Set oTextStream = nothing

else

esito = esito + 1

End if

Set oFS = nothing

leggiparametri = sFileContents

'

if len(sFileContents) = 0 then

esito = esito + 1

end if

'

end function

'

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

'

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

'

' === 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

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

' === fine ===

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

suddividi listino metel per marchio prodotto - vbs

' p

' suddivide un listino Metel.

' divide un file listino Metel in mase al marchio prodotto.

' crea, nella stessa cartella di origine del file, archivi con il nome:

' <sigla produttore> - <sigla marchio> - da - <nome file di origine>

'

option explicit

'

dim objArgs, Filename

'

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)

'

dim objFSO, objFile, nomefile

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.GetFile(Filename)

'

dim cartellalavori

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

nomefile = objFSO.GetFileName(Filename)

'

dim dblog, slog

'

dim sigliaproduttore, siglamarchio

'

' dizionario dei file creati per evitare di accodare dati a file già esistenti

Dim dizionariofilecreati, chiave

Set dizionariofilecreati = CreateObject("Scripting.Dictionary")

dizionariofilecreati.CompareMode = vbTextCompare

'

Dim fso, Text, txtStream, testata

'

Set fso = CreateObject("Scripting.FileSystemObject")

'

If fso.FileExists(Filename) = true Then

Set txtStream = fso.OpenTextFile(Filename) ' Apre file di testo.

testata = txtStream.ReadLine 'legge la prima riga che contiene la testata

sigliaproduttore = mid(testata, 21, 3)

Do While Not (txtStream.atEndOfStream)

Text = txtStream.ReadLine 'legge una riga

'

siglamarchio = mid(text, 1, 3)

'

dblog = cartellalavori & sigliaproduttore & "-" & siglamarchio & "-da-" & nomefile

'

' verifica iniziale se un file con il nome analogo esiste, se esiste lo cancella

chiave = dblog

If dizionariofilecreati.Exists(chiave) = False Then

dizionariofilecreati.Add chiave, chiave

call SovraScriviFile(dblog, testata)

else

End If

'

slog = Text

call ScriviFileJollyAppend(dblog, slog)

'

Loop

End If

'

' === 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

'

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

'

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)

rifefile.WriteLine(testata)

End If

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' =========

'

sposta per nome file - vbs

'p

Option explicit

'

dim tipofile, suffisso

tipofile = "jpg"

suffisso = "." & tipofile

'

dim fso: set fso = CreateObject("Scripting.FileSystemObject")

dim CurrentDirectory

CurrentDirectory = fso.GetAbsolutePathName(".")

'

dim cartelladascansionare, dbcartellaprocedura, esito

dbcartellaprocedura = CurrentDirectory & "\" ' "C:\da-pub\"

cartelladascansionare = dbcartellaprocedura

'

dim dblog, slog, parolachiave

dblog = dbcartellaprocedura & "log-lavori.txt"

'

' parola presente nel nome file

parolachiave = inputbox("parola cercata", "parola cercata", " ")

'

dim cartelladestinazione

cartelladestinazione = dbcartellaprocedura & parolachiave & "\"

msgbox ReportFolderStatus(cartelladestinazione)

'

call PrgElencaCartelletipo(cartelladascansionare, tipofile)

'

Function ReportFolderStatus(cartelladestinazione)

Dim fso, msg, f

Set fso = CreateObject("Scripting.FileSystemObject")

If (fso.FolderExists(cartelladestinazione)) Then

msg = cartelladestinazione & " exists."

Else

msg = cartelladestinazione & " doesn't exist."

Set f = fso.CreateFolder(cartelladestinazione)

End If

ReportFolderStatus = msg

End Function

'

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

'

Sub PrgElencaCartelletipo(pFolder, ptipofile)

'

Dim fso, cartelle, percorsocartella, nomecartella, nomefile

dim SubFolder, File, tpath, presente

Set fso = CreateObject("Scripting.FileSystemObject")

set Cartelle = fso.GetFolder(pFolder)

'

For Each File In fso.GetFolder(pFolder).Files

If UCASE(fso.GetExtensionName(File.Name)) = UCASE(ptipofile) Then

nomefile = File.Name

tpath = percorsocartella & nomefile

presente = instr(ucase(nomefile), ucase(parolachiave))

if presente > 0 then

' slog = "File.Name: " & File.Name & vbcrlf & tpath

nomefile = replace(nomefile, "-", " ")

nomefile = replace(nomefile, suffisso , ".")

slog = "- " & nomefile & vbcrlf

call ScriviFileJollyAppend(dblog, slog)

'

fso.MoveFile tpath, cartelladestinazione

end if

'

End If

Next

'

'

End Sub

'

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

'

function leggiparametri(sFilePathAndName)

dim sFileContents, oFS, oTextStream

Set oFS = CreateObject("Scripting.FileSystemObject")

If oFS.FileExists(sFilePathAndName) = True Then

Set oTextStream = oFS.OpenTextFile(sFilePathAndName,1)

sFileContents = trim(oTextStream.ReadAll)

oTextStream.Close

Set oTextStream = nothing

else

esito = esito + 1

End if

Set oFS = nothing

leggiparametri = sFileContents

'

if len(sFileContents) = 0 then

esito = esito + 1

end if

'

end function

'

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

'

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

'

' === 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

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

' ===

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

Importa Metel cross reference - vbs

'

' carica il File Metel Cross Reference

'

Set OXl = createobject ("Excel.Application")

'

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)

'

dim archiviomacro

archiviomacro = "C:\macro-importazione-cross-reference.txt"

'

oXL.Visible = true

'oXL.workbooks.OpenText Filename,,,1,,,False,,True,,False,,,,"."

'''oXl.workbooks.add

set fichxl=oXL.workbooks.add

'

dim vir, ecomm

vir = chr(34)

ecomm = chr(38)

'

Set mdle = fichxl.VBProject.VBComponents.Add(1)

'

Dim fso, Text, testo, txtStream, conta

dim dacambiare

dacambiare = "#nomeFileDaImportare#"

conta = 3

'

Set fso = CreateObject("Scripting.FileSystemObject")

'

If fso.FileExists(archiviomacro) = true Then

Set txtStream = fso.OpenTextFile(archiviomacro) ' Apre file di testo.

Do While Not (txtStream.atEndOfStream)

Text = txtStream.ReadLine 'legge una riga

testo = replace(Text,dacambiare,Filename)

mdle.CodeModule.InsertLines conta, testo

conta = conta + 1

Loop

End If

'

oXL.Run "ImportaCrossReference"

'

wscript.quit

'*** End ***

'

'

'

' testo archiviomacro = "C:\macro-importazione-cross-reference.txt"

'

'

' macro importazione Metel cross reference.

'



Sub ImportaCrossReference()

'

'

'

With ActiveSheet.QueryTables.Add(Connection:= _

"TEXT;#nomeFileDaImportare#", Destination:=Range("A1"))

.Name = "DATIIMPORTATI"

.FieldNames = True

.RowNumbers = False

.FillAdjacentFormulas = False

.PreserveFormatting = True

.RefreshOnFileOpen = False

.RefreshStyle = xlInsertDeleteCells

.SavePassword = False

.SaveData = True

.AdjustColumnWidth = True

.RefreshPeriod = 0

.TextFilePromptOnRefresh = False

.TextFilePlatform = xlWindows

.TextFileStartRow = 1

.TextFileParseType = xlFixedWidth

.TextFileTextQualifier = xlTextQualifierDoubleQuote

.TextFileConsecutiveDelimiter = False

.TextFileTabDelimiter = True

.TextFileSemicolonDelimiter = False

.TextFileCommaDelimiter = False

.TextFileSpaceDelimiter = False

.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2)

.TextFileFixedColumnWidths = Array(3, 16, 3, 16, 1, 30, 30)

.Refresh BackgroundQuery:=False

End With

'

' intestazione

Range("A1").Value = "Sigla Marchio"

Range("B1").Value = "Codice Prodotto"

Range("C1").Value = "Sigla Marchio"

Range("D1").Value = "Codice Prodotto"

Range("E1").Value = "Funzione"

Range("F1").Value = "Note"

Range("G1").Value = "Filler"

'

Range("h1").Value = "descrizione_Funzione"

Range("h2").Value = "0=ABBINAMENTO - 1=ALTERNATIVA"



'

Sheets(ActiveSheet.Name).Select

Sheets(ActiveSheet.Name).Name = "Cross_Reference"

'

End Sub

'

'

'

salva allegati posta file pdf - vbs

'

option explicit

'

' salva gli allegati in formato pdf nella casella di posta in arrivo.

'

dim cartellaprocedura, dbdata, dboggettomessaggi, slog

cartellaprocedura = "C:\Pubblica\allegati-posta\"

dbdata = cartellaprocedura & "db-data-ultima-scansione.txt" ' parametro data ultima scansione eseguita

dboggettomessaggi = cartellaprocedura & "log-oggettomessaggi.txt" ' memorizza nome allegato e oggetto messagio

'

dim LocalPath, CartellaOutlook, AttachName

LocalPath = cartellaprocedura & "allegati\"

CartellaOutlook = "Posta in arrivo"

'

dim tipofile, suffisso, flagdata, primadata

tipofile = "pdf"

flagdata = 0

'

dim datapartenza, oggettomessaggio, differenza

datapartenza = leggiparametritogli(dbdata)

'

dim DataRicezioneEmail, NomeAllegato, sfile

'Dichiarazione costanti

Dim Outlook, olkInbox, olkItem, olkAttach

Const olFolderInbox = 6

'

'riferimenti casella

Set Outlook = CreateObject("Outlook.Application")

'Set olkInbox = OutLook.Session.GetDefaultFolder(olFolderInbox).Folders(CartellaOutlook)

Set olkInbox = OutLook.Session.GetDefaultFolder(olFolderInbox)



'Esegue anche se outlook è chiuso

Outlook.Session.Logon

'

'--- ciclo su tuute le email ----------------------------

'

For Each olkItem In olkInbox.Items

'DataRicezioneEmail = olkItem.ReceivedTime

DataRicezioneEmail = olkItem.CreationTime

oggettomessaggio = ucase(olkItem.Subject)

'

if flagdata = 0 then

call SovraScriviFile(dbdata, DataRicezioneEmail)

flagdata = 1

end if

'

differenza = DateDiff( "n", datapartenza, DataRicezioneEmail)

if differenza > 0 then

'

If olkItem.Attachments.Count > 0 Then

For Each olkAttach In olkItem.Attachments

' Salva allegato/allegati

NomeAllegato = olkAttach.FileName

suffisso = right(NomeAllegato, 3)

if ucase(suffisso) = ucase(tipofile) then

'olkAttach.SaveAsFile LocalPath & NomeAllegato

NomeAllegato = esistefile(NomeAllegato) ' verifica se esiste file dal nome analogo

olkAttach.SaveAsFile NomeAllegato ' salva allegato

'

slog = sfile & "|" & oggettomessaggio

call ScriviFileJollyAppend(dboggettomessaggi, slog)

'

end if

Next

End If

else

exit for

end if

Next

'

'------------------------------------------------------

'

Set Outlook = nothing

Set OlkInbox = nothing

'

wscript.quit

'

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

'

function esistefile(parchivio)

dim contali, archiviodaverificare

dim fs

archiviodaverificare = LocalPath & parchivio

esistefile = archiviodaverificare

sfile = parchivio

contali = 0

'

set fs=CreateObject("Scripting.FileSystemObject")

while fs.FileExists(archiviodaverificare) = true

contali = contali + 1

sfile = "esisteva-" & contali & "-" & parchivio

archiviodaverificare = LocalPath & sfile

wend

esistefile = archiviodaverificare

set fs=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

'

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

'

function leggiparametritogli(sFilePathAndName)

dim sFileContents, oFS, oTextStream

Set oFS = CreateObject("Scripting.FileSystemObject")

If oFS.FileExists(sFilePathAndName) = True Then

Set oTextStream = oFS.OpenTextFile(sFilePathAndName,1)

sFileContents = trim(oTextStream.ReadAll)

oTextStream.Close

Set oTextStream = nothing

else



End if

Set oFS = nothing

sFileContents = replace(sFileContents, vbcrlf, "")

sFileContents = replace(sFileContents, vbcr, "")

sFileContents = replace(sFileContents, vblf, "")

leggiparametritogli = sFileContents

'

'

end function

'

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

'

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

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

' === fine ===

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