vba Excel inserisce Hyperlinks

‘

‘ vba  Excel inserisce Hyperlinks

‘

Sub InserisciLinkSupportif(colonnadocumento)

'

On Error Resume Next

'

Dim fs, archivio, percorso, h

Set fs = CreateObject("Scripting.FileSystemObject")

percorso = "\\Caem02\cosanostra\supporti\" ' cartella in cui sono presenti i files

'

Dim quanterighe, contarighe, foglio, contenuto

Set foglio = Sheets(ActiveSheet.Name)

' conteggio delle righe utilizzate

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

'

' cancella link presenti

Range("C2:C65536").Hyperlinks.Delete

'

contarighe = 2

While contarighe <= quanterighe

      contenuto = Trim(foglio.Cells(contarighe, colonnadocumento).Value)

      If Len(contenuto) > 0 Then

         archivio = percorso & contenuto & ".pdf"

         If fs.FileExists(archivio) = True Then

            foglio.Cells(contarighe, colonnadocumento).Select

            foglio.Hyperlinks.Add Anchor:=Selection, Address:=archivio

         End If

      End If

      contarighe = contarighe + 1

Wend

'

End Sub

'

vbs elenca tutte le sottocartelle di una directory crea un file pdf unico

'

option explicit

'

' vbs elenca tutte le sottocartelle di una directory.

' se nella sottocartella esiste una directory con un determinato nome

' scrive elenco dei file Pdf presenti e li raggruppa in un unico file.

dim cartella

cartella = "C:\azioniprogrammate\fornitori-note-accredito-tutte\"

'

dim dbcartelladascansionare, cartelladascansionare, dovearchiviare

'

dbcartelladascansionare = cartella & "db-cartella-da-scansionare.txt"

'

cartelladascansionare = leggiparametritogli(dbcartelladascansionare)

dovearchiviare = cartella & "elenco-cartelle.txt"

call cancellafile(dovearchiviare)

'

dim dblog, slog

dblog = cartella & "elencofatture.csv"

call cancellafile(dblog)

'

dim rtipofile

rtipofile = "pdf"

'

call ShowSubFolders(cartelladascansionare)

'

call leggifile(dovearchiviare)

'

call uniscipdf(cartella)

' =======

' ====

'

Sub ShowSubFolders(pcartelladascansionare)

dim folder, Subfolder, FSO

Set FSO = CreateObject("Scripting.FileSystemObject")

set folder = FSO.GetFolder(pcartelladascansionare)

For Each Subfolder in Folder.SubFolders

    call ScriviFileJollyAppend(dovearchiviare, Subfolder.Path)

   'ShowSubFolders Subfolder

 Next

End Sub

' ==========

' ===

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

sub leggifile(pfile)

dim objFSO, objFile, strLine, scartella, msg

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.OpenTextFile(pfile, 1)

Do While objFile.AtEndOfStream = False

    strLine = objFile.ReadLine

    scartella = strline & "\NA\"

    If (objFSO.FolderExists(scartella)) = true Then

        msg = scartella & " esiste."

        call elencafile(scartella)

    Else

        msg = scartella & " NON Esiste."

    End If

 

Loop

end sub

'

' === unisce in un unico file pdf i vari file.

'

sub uniscipdf(cartellainlettura)

dim azione, elencofilepdf, archiviofatturetutte

elencofilepdf  = cartellainlettura &  "elencofatture.csv"

archiviofatturetutte  = cartellainlettura &  "FattureTutte.pdf"

'

' utilizza la libreria java Pdfsam scaricabile dal sito Sourceforge.

azione = ""

azione = azione & "java -jar C:\Pubblica\pdfsam\lib\pdfsam-console-0.5.2.jar -l "

azione = azione & elencofilepdf 

azione = azione & " -overwrite -o "

azione = azione & archiviofatturetutte

azione = azione & " concat"

'

dim attesa, WshShell

set WshShell = CreateObject("WScript.Shell")

WshShell.CurrentDirectory = cartellainlettura

attesa = WshShell.Run (azione, 1, True)

'

end sub

' ===

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

'

sub elencafile(objStartFolder)

dim objFSO, objFolder, colFiles, objFile, sfile, stipo

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFSO.GetFolder(objStartFolder)

Set colFiles = objFolder.Files

'

For Each objFile in colFiles

    sfile = objStartFolder & objFile.Name

    stipo = objFSO.GetExtensionName(sfile)

    if lcase(stipo) = lcase(rtipofile) then

       call ScriviFileJollyAppend(dblog, sfile & ",")

    end if

Next

'

'

end sub

' =====

' === legge parametri ==

' =======

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

     sFileContents = ""

End if

Set oFS = nothing

sFileContents = replace(sFileContents, vbcrlf, "")

sFileContents = replace(sFileContents, vbcr, "")

sFileContents = replace(sFileContents, vblf, "")

leggiparametritogli = sFileContents

'

'

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

' =======

' === cancella file =======

' ========

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 - finestra temporanea con messaggio e pulsanti

'

option explicit

'

' vbs - finestra temporanea con messaggio e pulsanti

'

Const wshYes = 6 

Const wshNo = 7 

Const wshYesNoDialog = 4 

Const wshQuestionMark = 32 

'

Dim objShell, intReturn

Set objShell = CreateObject("Wscript.Shell")

'

dim txtmsg, titolomsg

txtmsg = "Test chiusura popup 10 secondi. La presente finestra di chiuderà tra 10 secondi"

titolomsg = "Titolo finestra temporanea"

'

intReturn = objShell.Popup(txtmsg, 10, titolomsg, wshYesNoDialog + wshQuestionMark) 

'

If intReturn = wshYes Then

    Wscript.Echo "Scelto il tasto Yes."

ElseIf intReturn = wshNo Then

    Wscript.Echo "Scelto il tasto No."

Else

    Wscript.Echo "Nessuna Scelta operata."

End If

'

'

'

vbs legge output command line di ipconfig - scrive in un file indirizzo ip

' vbs legge output command line di ipconfig - scrive in un file indirizzo ip

option explicit

'

dim objShell, objWshScriptExec, objStdOut, strLine

'

dim cartella, dblog, slog

dim dbindirizzoip

cartella = "C:\lavori-07-2016\"

dblog = cartella & "ipconfig.txt"

dbindirizzoip = cartella & "il-mio-indirizzo-ip.txt"

'

call SovraScriviFile(dblog, " ")

'

Set objShell = CreateObject("WScript.Shell")

Set objWshScriptExec = objShell.Exec("ipconfig /all")

Set objStdOut = objWshScriptExec.StdOut

 

While Not objStdOut.AtEndOfStream

   strLine = objStdOut.ReadLine

   slog = strline

   call ScriviFileJollyAppend(dblog, slog)

   ' scrive in un file indirizzo ip

   If InStr(strLine,"Indirizzo IPv4") Then

       slog = strLine

       call SovraScriviFile(dbindirizzoip, slog)

   End If

Wend

'

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

End If

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' =========

'

excel trova tutte le parole in una descrizione di un articolo - crea file per ogni parola trovata

'

Option Explicit

'

' vba excel trova tutte le parole in una descrizione di un articolo - crea file per ogni parola trovata

Dim dblog, slog, stesto

Public Const cartella = "C:\lavori-articoli\tag\"

'

Function scrivifiletag(criteriodiricerca, stringaincuicercare, articolo)

'

  Dim oRE, oMatches, oMatch

  Set oRE = CreateObject("VBScript.RegExp")

  oRE.Global = True

  oRE.IgnoreCase = True

  oRE.Pattern = criteriodiricerca

  If oRE.Test(stringaincuicercare) = True Then

     Set oMatches = oRE.Execute(stringaincuicercare)

       For Each oMatch In oMatches

          'stesto = stesto & oMatch.FirstIndex & " : " & oMatch.Length & " : " & oMatch.Value & vbCrLf

          dblog = cartella & LCase(Trim(oMatch.Value)) & ".txt" ' nome del file da creare

          slog = articolo

          Call ScriviFileJollyAppend(dblog, slog) ‘ scrive nel file l’articolo

       Next

  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

'

' =========

'

vbs tutte le informazioni su un file - caratteristiche avanzate

'

' vbs tutte le informazioni su un file - caratteristiche avanzate

option explicit

'

' di un file formato jpg si ottengono, di norma,  le seguenti informazioni:

'

'0         Nome: 07060002.JPG

'1         Dimensione: 583 KB

'2         Tipo: Immagine JPEG

'3         Data ultima modifica: 05/09/2007 15.11

'4         Data creazione: 22/01/2014 16.28

'5         Data ultimo accesso: 07/01/2016 15.54

'6         Attributi: A

'7         Stato: In linea

'8         Proprietario: ...

'13        Pagine: 1

'24        Modello fotocamera: ...                     ' se il file è stato generato da una fotocamera.

'25        Data immagine scattata: 06/07/2007 0.00     ' se il file è stato generato da una fotocamera.

'26        Formato: 2048 x 1376

'

'  utilizzando queste informazioni è possibile creare un programma

'  che evidenzi quali files sono duplicati.

'

dim FolderPath, objShell, objFolder, i, strFileName

dim s

'

dim qualecartella

qualecartella = "C:\lavori-info-file\"

'

FolderPath = qualecartella

 

 

Dim TitoliIntestazione(300)

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.Namespace(FolderPath)

 

' crea elenco titoli informazioni

For i = 0 to 300

    TitoliIntestazione(i) = objFolder.GetDetailsOf(objFolder.Items, i)

Next

'

For Each strFileName in objFolder.Items

    s = ""

    call ScriviFileJollyAppend(qualecartella & "info.txt", s)

    For i = 0 to 300

       s =  i & vbtab & TitoliIntestazione(i) & ": " & objFolder.GetDetailsOf(strFileName, i)

       if len(trim(TitoliIntestazione(i))) > 0 and len(trim(objFolder.GetDetailsOf(strFileName, i))) > 0 then

          call ScriviFileJollyAppend("C:\lavori-info-file\info.txt", s)

       end if

    Next

Next

'

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

'

Sub ScriviFileJollyAppend(NomeArchivio, cosascrivere)

'

Dim fso, rifefile

Set fso = CreateObject("Scripting.FileSystemObject")

If (fso.FileExists(NomeArchivio)) Then

      'msg = NomeArchivio & " esiste!"

       Set rifefile = fso.OpenTextFile(NomeArchivio, 8)

   Else

      'msg = NomeArchivio & " NON esiste!!!"

       Set rifefile = fso.CreateTextFile(NomeArchivio, True)

   End If

rifefile.WriteLine (cosascrivere)

rifefile.Close

Set rifefile = Nothing

End Sub

'

' =========

'

vbs - trova il link di una immagine in una stringa html

'

Option Explicit

'

' vbs - trova il link di una immagine in una stringa html

'

dim stringa

stringa="<a href=""http://dominio/""><img src=""http://dominio/immagine.jpg""/></a><br>descrizione immanine."

'

msgbox getImgTagURL(stringa)

'

'

'

Function getImgTagURL(HTMLstring)

Dim RegEx, Matches, URL, Match

 

    Set RegEx = CreateObject("Scripting.FileSystemObject")

    With RegEx

        .Pattern = "src=[\""\']([^\""\']+)"

        .IgnoreCase = True

        .Global = True

    End With

 

    Set Matches = RegEx.Execute(HTMLstring)

    ' ricerca tutte le immagini

    URL = ""

    For Each Match in Matches

        ' estrae solo il primo risultato

        URL = Match.Value

        Exit For

    Next

    '

    Set Match = Nothing

    Set RegEx = Nothing

    '

    getImgTagURL = Replace(URL, "src=""", "")

End Function

'

'

'

dal foglio excel con il dettaglio delle fatture crea foglio inventario

' vba -  dal foglio excel con il dettaglio delle fatture crea foglio inventario

'

Sub creaInventario()

'

On Error Resume Next

'

 

Dim quanterighe, contarighe, foglioleggi, sigla, articolo, quantita, posizione, importo, codice

Dim dbquantita, dbimporto, colonnarticoloazienda, scolartazienda, articoloazienda

Dim prezzomedioacquisto

Dim fogliodb, righedb

Set foglioleggi = Sheets("fatture")

Set fogliodb = Sheets("inventario")

Dim scolArticolo, scolQta, scolImp, scolsigla, scolcodice, scolprm

'

'

Dim colonnaSigla, colonnaArticolo, ColonnaQuantita, colonnaImporto, ColonnaCodice

Dim colonnadtft, colonnanrft, colonnaultimoscarico, scoldtft, scolnrft, scolulsca

'

colonnaSigla = "A"

colonnaArticolo = "B"

ColonnaQuantita = "e"

colonnaImporto = "G"

colonnarticoloazienda = "O"

colonnadtft = "K"

colonnanrft = "J"

colonnaultimoscarico = "P"

'

'

'

scolcodice = "A"

scolsigla = "B"

scolArticolo = "C"

scolQta = "D"

scolImp = "E"

scolartazienda = "F"

scolprm = "G"

'

scoldtft = "H"

scolnrft = "I"

scolulsca = "J"

'

fogliodb.Cells(1, scolcodice).Value = "codice"

fogliodb.Cells(1, scolsigla).Value = "sigla"

fogliodb.Cells(1, scolArticolo).Value = "articolo"

fogliodb.Cells(1, scolQta).Value = "ddt_qta"

fogliodb.Cells(1, scolImp).Value = "ddt_valore"

fogliodb.Cells(1, scolprm).Value = "pr_medio_acq"

fogliodb.Cells(1, scolartazienda).Value = "articolo_azienda"

fogliodb.Cells(1, scoldtft).Value = "dt_ft"

fogliodb.Cells(1, scolnrft).Value = "nr_ft"

fogliodb.Cells(1, scolulsca).Value = "ultimo_scarico"

'

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

'

contarighe = 2

While contarighe <= quanterighe

      sigla = Trim(foglioleggi.Cells(contarighe, colonnaSigla).Value)

      articolo = Trim(foglioleggi.Cells(contarighe, colonnaArticolo).Value)

      quantita = foglioleggi.Cells(contarighe, ColonnaQuantita).Value

      importo = foglioleggi.Cells(contarighe, colonnaImporto).Value

      articoloazienda = foglioleggi.Cells(contarighe, colonnarticoloazienda).Value

      codice = sigla & articolo

      If Len(articolo) > 0 Then

         If Application.IsError(Application.Match(codice, fogliodb.Range("A:A"), 0)) Then

            'ActiveSheet.Cells(riga, "C").ClearContents

            righedb = Range(fogliodb.UsedRange.Cells(fogliodb.UsedRange.Rows.Count, 1).Address).Row

          righedb = righedb + 1

         fogliodb.Cells(righedb, scolcodice).Value = "'" & codice

         fogliodb.Cells(righedb, scolsigla).Value = "'" & sigla

         fogliodb.Cells(righedb, scolArticolo).Value = "'" & articolo

         fogliodb.Cells(righedb, scolartazienda).Value = "'" & articoloazienda

         '

         fogliodb.Cells(righedb, scoldtft).Value = "'" & foglioleggi.Cells(contarighe, colonnadtft).Value

         fogliodb.Cells(righedb, scolnrft).Value = "'" & foglioleggi.Cells(contarighe, colonnanrft).Value

         fogliodb.Cells(righedb, scolulsca).Value = "'" & foglioleggi.Cells(contarighe, colonnaultimoscarico).Value

        

         '

         posizione = righedb

         If IsNumeric(quantita) = True Then

            fogliodb.Cells(righedb, scolQta).Value = quantita

         Else

             fogliodb.Cells(righedb, scolQta).Value = 0

         End If

         If IsNumeric(importo) = True Then

            fogliodb.Cells(righedb, scolImp).Value = importo

         Else

            fogliodb.Cells(righedb, scolImp).Value = 0

         End If

      Else

         posizione = Application.Match(codice, fogliodb.Range("A:A"), 0)

'

         dbquantita = fogliodb.Cells(posizione, scolQta).Value

         dbimporto = fogliodb.Cells(posizione, scolImp).Value

         If IsNumeric(quantita) = True Then

            dbquantita = dbquantita + quantita

         End If

         If IsNumeric(importo) = True Then

            dbimporto = dbimporto + importo

         End If

         fogliodb.Cells(posizione, scolQta).Value = dbquantita

         fogliodb.Cells(posizione, scolImp).Value = dbimporto

         fogliodb.Cells(posizione, scoldtft).Value = "'" & foglioleggi.Cells(contarighe, colonnadtft).Value

         fogliodb.Cells(posizione, scolnrft).Value = "'" & foglioleggi.Cells(contarighe, colonnanrft).Value

         fogliodb.Cells(posizione, scolulsca).Value = "'" & foglioleggi.Cells(contarighe, colonnaultimoscarico).Value

         '

         End If

         '

         '

      End If

      contarighe = contarighe + 1

Wend

' calcola prezzo acquisto

contarighe = 2

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

While contarighe <= quanterighe

      dbquantita = fogliodb.Cells(contarighe, scolQta).Value

      dbimporto = fogliodb.Cells(contarighe, scolImp).Value

      If IsNumeric(dbimporto) = True And IsNumeric(dbquantita) = True Then

         If dbimporto > 0 And dbquantita > 0 Then

            prezzomedioacquisto = dbimporto / dbquantita

            fogliodb.Cells(contarighe, scolprm).Value = CCur(prezzomedioacquisto)

         End If

      End If

      contarighe = contarighe + 1

Wend

'

'

fogliodb.Activate

Columns("A:F").Select

    ActiveWorkbook.Names.Add Name:="dbinventario", RefersToR1C1:= _

        "=inventario!C1:C10"

'

End Sub