ESEMPI CODICE VBA/ACCESS

INDICE 1 - TIPS & TRICKS 1.a) VBA: codice per andare all'ultimo record all'apertura di una maschera 1.b) VBA: codice per compattare e ripristinare il DB (NON FUNZIONA) 1.c) VBA: aggiorna utilizzando il codice che va a utilizzare il pulsante AGGIORNA sulla ribbon 2) VBA: inserire un VAI A CAPO (INVIO) 3) Azzerare un campo contatore 4) Trasformare il mouse in clessidra 5) N° campi presenti in una tabella dalla finestra immediata di Access 6) MsgBox con sceltra SI/NO/ANNULLA 7) Sintassi nella costruzione di un nome etichetta con variabile 8) Query per ottenere una colonna con un numero progressivo (DA VERIFICARE) 9) ACCESS 2013: visualizzare gli oggetti nascosti 10) Inserire un campo contatore progressivo in un report o query 11) Sintassi WHERE con campo DATA 12) Creare un sottoreport che si "formatta" in orizzontale 13) Proprietà colori campi etichette e textbox 14) Proprietà formattazione campi etichette e textbox 15) Personalizzare le impostazioni predefinite per i database 16) Definizione di una costante 17) Apertura applicazione con Shell 18) Esegui command01 da command02 19) Passare un recordset ad una funzione 2 - Esempio base ADO/DAO 3 - Invio e@mail di gruppo 4 - Riorganizzare il campo priorità di una sottotabella 5 - Invio e@mail singola 6 - Oggi si festeggia (ricorrenze all'aperture di Access) 7 - Copia dati in nuova tabella 8 - Quante volte ricorre un carattere in una stringa 9 - Dimensiona le colonne di una SSTAB 10 - Funzione GestioneLoghi(Me.Report.Name) 11 - Aprire il FORM Windows per sfogliare le cartelle e solezionare un file (PDF) 12 - Leggere dati da un foglio EXCEL collegato come tabella 13 - Abilita Maiuscolo 14 - Scrivendo un carattere nella cella VERDE nella ROSSA esce il corrispettivo n ASCII 15 - Contatori su FORM / Progressivo elaborazione 16 - Funzioni Nz, CtrlSeNULL, CtrlSeZERO, CtrlSeVUOTO, CtrlSeVUOTOeZERO 17 - Funzioni MASSIMO e MINIMO su un array 18 - Leggi dati da foglio EXCEL (.xlsx) 19 - Q_ZeroAlSecondoDecimale 20 - Inserire numero progressivo in query di ordinamento 21 - Funzione che ritorna più parametri 22 - Il comando LIKE nel codice VBA 23 - Assegnare via codice il recordsource 24 - Aprire un recordset su un'altro DB 25 - Form ricerca dati 26 - Collegare una tabella da codice (DAO) 27 - Eliminare una tabella da codice (DAO) 28 - Passare il nome della FORM ad una funzione 29 - Funzione GestPagIniFin("Nome_Report") 30 - CancellaRecord("NOME_TAB", "NOME_FORM", CP1, CP2) 31 - Gestione Data Estesa 32 - Copy file da un percorso ad un altro 33 - Assegnare permessi a cartelle - funzione icacls 34 - Query con nome tabella parametrizzato 35 - Scrivere in file Excel xlsx 36 - Apertura e chiusura file di testo (open) 37 - Lettura dati di un file di testo (input/Line Input) 38 - Scrittura dati in un File di testo (print/write) 39 - Esempi funzione timer 40 - Compatta e ripristina database 41 - Funzione collegata tabelle database anni diversi 42 - Copia campi tipo ALLEGATO 43 - Duplica record 44 - Set db [CurrentDb, OpenDatabase()] 45 - Errore Access: query danneggiata 46 - Trova record in FORMS/Vai al record 47 - Macro/Vba 32/64 bit 48 - Aprire DB Access da altro DB Access 49 - Funzione Sleep per ritardare esecuzione codice S1 - Script1 - Cancellazione file e directory con più di N giorni
BLOG ACCESS EXPERT (ENG) 10 errori database di Microsoft Access che influenzano le prestazioni Database multiutente in rete, ottimizzazione/query lato server MS Access code (Alessandro Baraldi)
1 - TIPS & TRICKS 1.a) VBA: codice per andare all'ultimo record all'apertura di una maschera: DoCmd.RunCommand acCmdRecordsGoToLast 1.b) VBA: codice per compattare e ripristinare il DB (NON FUNZIONA): DoCmd.RunCommand acCmdCompactDatabase questo però sembra funzionare anche in ACCESS 2016: ' Menu Strumenti SendKeys "(%(S))", False ' Pulsante utilità database SendKeys "u", False ' Pulsante compatta e ripristina DB SendKeys "o", False 1.c) VBA: è come premere il pulsante AGGIORNA RECORD: DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70 2) VBA: inserire un VAI A CAPO (INVIO): Rst1!CAMPO1 & vbCrLf & Rst1!CAMPO2 3) ACCESS 2013: per azzerare un campo contatore si può svuotare la tabella e fare un COMPATTA E RIPRISTINA, oppure cancelare il campo contatore e ricrearlo 4) Trasformare il mouse in clessidra: Screen.MousePointer = 11 ' MOUSE CLESSIDRA Screen.MousePointer = 0 ' MOUSE NORMALE 5) Dalla finestra immediata di Access digitando: ?Currentdb.TableDefs("NOME_TABELLLA").Fields.Count mi da il totale dei campi contenuti PS: il programma deve essere in ESECUZIONE! 6) MsgBox con sceltra SI/NO/ANNULLA: Dim Messaggio, Stile, Titolo as String Messaggio = "RICHIESTA CHE VIENE MOSTRATA ALL'UTENTE" & Chr(13) Stile = vbYesNo + vbCritical + vbDefaultButton2 Titolo = "ATTENZIONE" Risposta = MsgBox(Messaggio, Stile, Titolo) If Risposta = vbYes Then ..... else exit sub end if 7) Sintassi nella costruzione di un nome etichetta con variabile: Me("PARTE_FISSA" & VARIABILE & "PARTE_FISSA").Caption Sintassi nella costruzione di un nome TABELLA con variabile: *Rst1.Open "SELECT FROM T_PARTE1_" & Rst2!T_PARTE2, CurrentProject.Connection, adOpenDynamic, adLockOptimistic se Rst2!T_PARTE2 = "TEST" selezionerò i record dalla tabella: T_PARTE1_TEST 8) Query per ottenere una colonna con un numero progressivo. Nell'esempio partiamo dalla creazione di una tabella di test: CREATE TABLE test (id int, nome text); Inseriamo dei dati: INSERT INTO Test (Id, Nome) VALUES (9,"Ciccio"); INSERT INTO Test (Id, Nome) VALUES (5,"Pippo"); INSERT INTO Test (Id, Nome) VALUES (3,"Lillo"); E finalmente ecco la query per ottenere le due colonne più una terza colonna con un numero progressivo SELECT Id, Nome, (SELECT Count() + 1 FROM Test t2 WHERE t2.id* < test.id) AS Progressivo FROM Test ORDER BY Id; Nella slide sotto l'esempio ricostruito sull'ACCESS 2013 Fatture.accdb: 9) ACCESS 2013: visualizzare gli oggetti nascosti: tasto destro sull'area sinistra in un posto vuoto sotto MODULI. Si apre la form: 10) Inserire un campo contatore progressivo in un report o query (per tabella vedi punto 8) 11) Sintassi WHERE con campo DATA "HAVING data >= #" & Forms!M_STAMPE!DAL & "# AND data <= #" & Forms!M_STAMPE!AL & "# AND ... 12) Creare un sottoreport che si "formatta" in orizzontale Per creare una situazione del genere non bisogna impostare NESSUNA proprietà ma aprire il report/sottoreport e selezionare il menù: si aprirà il form: dove impostiamo quante volte il sottoreport si ripeterà orizzontalmente (vedi ad es. report CRI) 13) Proprietà colori campi etichette e textbox BackColor = è il colore dello sfondo del controllo ForeColor = è il colore del testo del controllo Codici colori: vbYellow = 65535 vbRed = 255 vbBlue = 16711680 vbGreen = 65280 vbWhite = 16777215 vbBlack = 0 vbCyan = 16776960 vbMagenta = 16711935 14) Proprietà formattazione campi etichette e textbox il GRASSETTO è gestito dalla funzione: FontBold PS: la proprietà FontWeight, può essere utilizzata per impostare lo spessore della linea per il testo di un controllo. La proprietà FontBold consente di velocizzare l'applicazione del formato grassetto al testo, mentre la proprietà FontWeight semplifica la gestione dell'impostazione dello spessore della linea per il testo. il SOTTOLINEATO è gestito dalla funzione: FontUnderline** l'ITALICO è gestito dalla funzione: FontItalic 15) Personalizzare le impostazioni predefinite per i database Sono parte delle Opzioni di Access. Di seguito il link dal supporto Office: link 16) Definizione di una costante Public Const PercorsoTXT = "C:\PERCORTO_TXT\" 17) Apertura applicazione con Shell ' ESEMPIO APERTURA PROGRAMMA CALCOLATRICE Call Shell("C:\Windows\WinSxS\wow64_microsoft-windows-calc_31bf3856ad364e35_10.0.17134.1_none_999337e4b8471fe2\CALC.EXE", 1) ' ESEMPIO APERTURA PROGRAMMA PROMPT DEL DOS Call Shell("C:\Windows\WinSxS\wow64_microsoft-windows-commandprompt_31bf3856ad364e35_10.0.17134.1_none_7ae1fd66b7e7b154\cmd.exe") 18) Esegui commando da un altro commando Se ad esempio voglio eseguire il Comando200 dal Comando300 nello stesso form: call Comando200_Click() su due form diversi faremo: call Forms("NOME_FORM").NomeComando_Click (NON FUNZIONA, da verificare)
19) Passare un recordset ad una funzione Public Function FUNZIONE(RST1 As Variant, RST2 As Variant, RST3 As Variant, .... (Vedi DB Demografici)
2 - Esempio base ADO/DAO Function ADO() Dim Rst1 As New ADODB.Recordset Rst1.CursorLocation = adUseClient Rst1.Open "NOME_TABELLA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst1.MoveFirst Rst1.Find "[NOME_CAMPO] = '" & Me.NOME_CAMPO & "'" Me.NOME_CAMPO = Rst1![NOME_CAMPO] Set Rst1 = Nothing End Function Function DAO1() Dim rs1 As Recordset, rs2 As Recordset Set rs1 = CurrentDb.OpenRecordset("NOME_TABELLA_1", dbOpenDynaset) Set rs2 = CurrentDb.OpenRecordset("NOME_TABELLA_2", dbOpenDynaset) rs1.MoveFirst rs2.MoveFirst While rs1.EOF = False rs2.MoveFirst rs2.FindFirst "CAMPO = '" & rs1![CAMPO] & "'" If rs2.NoMatch = True Then MsgBox "CAMPO = " & rs1!CAMPO End If rs1.MoveNext Wend rs1.Close rs2.Close End Function Function DAO2() Dim Schede As Recordset, Percorsi As Recordset, Anag As Recordset, Certificato As Recordset, NewDB As Database Dim Ultimo As Long Dim i As Integer Set Percorsi = CurrentDb.OpenRecordset("Select * from Percorsi", dbOpenSnapshot) Percorsi.MoveFirst Set Anag = CurrentDb.OpenRecordset("Select * from Anagrafe", dbOpenDynaset) ' LEGGO NEL CAMPO [SCHEDE] DELLA TABELLA [Percorsi], AD ES. CONTENTE IL VALORE: F:\PACCESS\Schede.mdb Set NewDB = OpenDatabase(Percorsi![Schede]) ' LA STRINGA DI CODICE SOPRA EQUIVALE ALLA STRINGA: Set NewDB = OpenDatabase("F:\PACCESS\Schede.mdb") Set Schede = NewDB.OpenRecordset("Select * from Schede Where (date() - DATA) = 8 AND VIDIM = TRUE ", dbOpenSnapshot) If Schede.RecordCount > 0 Then Schede.MoveFirst While Schede.EOF = False Set Certificato = CurrentDb.OpenRecordset("Select * from CPM Order By numero", dbOpenDynaset) Certificato.MoveLast Ultimo = certificato!numero Certificato.MoveFirst Certificato.FindFirst "Commessa = '" & Schede!commessa & "/" & Schede!Posizione & "'" If Certificato.NoMatch = False Then Certificato.Close GoTo .... Else Certificato.AddNew Certificato!Num = Ultimo + 1 Certificato!pag = 1 .... Certificato.Update Certificato.Close .... End Function
3 - Invio di e@mail di gruppo Public Function InvioMailGruppo() Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Dim ListaIndEmail As String Dim UltimoIndirizzo As Integer Dim ContaIndirizzi As Integer On Error GoTo Errori Rst1.CursorLocation = adUseClient Rst2.CursorLocation = adUseClient Rst1.Open "SELECT * FROM [Q_Anag_x_invio_email] WHERE [INVIO_MAIL] = true", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst2.Open "T_CAMPI_MAIL", CurrentProject.Connection, adOpenDynamic, adLockOptimistic UltimoIndirizzo = Rst1.RecordCount ContaIndirizzi = 1 ListaIndEmail = "" Rst1.MoveFirst While Not Rst1.EOF If ContaIndirizzi = UltimoIndirizzo Then ListaIndEmail = ListaIndEmail & Rst1!Numero Else ListaIndEmail = ListaIndEmail & Rst1!Numero & ";" End If ContaIndirizzi = ContaIndirizzi + 1 Rst1.MoveNext Wend DoCmd.SendObject , "", "", ListaIndEmail, , , Rst2!OGGETTO2, Rst2!Testo2, False, "" Set Rst1 = Nothing Set Rst2 = Nothing Errori: If Err.Number = 2293 Then MsgBox ("Per inviare devi acconsentire") Exit Function End If End Function
4 - Riorganizzare il campo priorità di una sottotabella Public Function RiorganizzaPriorita() Dim Rst1 As New ADODB.Recordset Dim INCR_PRIORITA As Integer Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM ST1_TITOLO" & TitoloTab & " " & _ "WHERE ID_TP = " & Forms![01_M_PRINCIPALE].ID_TP & " ORDER BY PRIORITA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic INCR_PRIORITA = 5 If Rst1.RecordCount > 0 Then Rst1.MoveFirst While Not Rst1.EOF Rst1!PRIORITA = INCR_PRIORITA Rst1.Update INCR_PRIORITA = INCR_PRIORITA + 5 Rst1.MoveNext Wend Forms![01_M_PRINCIPALE].Refresh Set Rst1 = Nothing End Function
5 - Invio e@mail singola Public Function InviaMail(INDIRIZZO As String, Titolo As String, NOMINATIVO As String) 'DoCmd.SendObject , "", "", "morosini@insor.it", , , "Auguri di buon compleanno", "La Cooperativa Arcobaleno le porge i più sinceri auguri per il suo compleanno. ", False, "" DoCmd.SendObject , "", "", INDIRIZZO, , , "Auguri!" & Titolo & " " & NOMINATIVO, "La Cooperativa Arcobaleno le porge i più sinceri auguri per il suo compleanno. ", False, "" End Function
6 - Oggi si festeggia (ricorrenze all'aperture di Access) Public Function OggiSiFesteggia2() Dim Rst1 As New ADODB.Recordset Dim GIORNO As String Dim GIORNO1 As String Dim GIORNO2 As String Dim Mese As String Dim Festeggiati As String On Error GoTo Errori Rst1.CursorLocation = adUseClient GIORNO = Day(Date) Mese = Month(Date) ' Se è Venerdì mostrami anche gli anniversari di Sabato e Domenica If Weekday(Date) = 6 Then If GIORNO = 27 And Mese = 2 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0227"" or MESE_GIORNO=""0228"" or MESE_GIORNO=""0301""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 29 And Mese = 4 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0429"" or MESE_GIORNO=""0430"" or MESE_GIORNO=""0501""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 29 And Mese = 6 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0629"" or MESE_GIORNO=""0630"" or MESE_GIORNO=""0701""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 29 And Mese = 9 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0929"" or MESE_GIORNO=""0930"" or MESE_GIORNO=""1001""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 29 And Mese = 11 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1129"" or MESE_GIORNO=""1130"" or MESE_GIORNO=""1201""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 1 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0130"" or MESE_GIORNO=""0131"" or MESE_GIORNO=""0201""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 3 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0330"" or MESE_GIORNO=""0331"" or MESE_GIORNO=""0401""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 5 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0530"" or MESE_GIORNO=""0531"" or MESE_GIORNO=""0601""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 7 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0730"" or MESE_GIORNO=""0731"" or MESE_GIORNO=""0801""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 8 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0830"" or MESE_GIORNO=""0831"" or MESE_GIORNO=""0901""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 10 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1030"" or MESE_GIORNO=""1031"" or MESE_GIORNO=""1101""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 12 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1230"" or MESE_GIORNO=""1231"" or MESE_GIORNO=""0101""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 28 And Mese = 2 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0228"" or MESE_GIORNO=""0301"" or MESE_GIORNO=""0302""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 4 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0430"" or MESE_GIORNO=""0501"" or MESE_GIORNO=""0502""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 6 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0630"" or MESE_GIORNO=""0701"" or MESE_GIORNO=""0702""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 9 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0930"" or MESE_GIORNO=""1001"" or MESE_GIORNO=""1002""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 11 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1130"" or MESE_GIORNO=""1101"" or MESE_GIORNO=""1202""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 1 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0131"" or MESE_GIORNO=""0201"" or MESE_GIORNO=""0202""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 3 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0331"" or MESE_GIORNO=""0401"" or MESE_GIORNO=""0402""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 5 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0531"" or MESE_GIORNO=""0601"" or MESE_GIORNO=""0602""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 7 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0731"" or MESE_GIORNO=""0801"" or MESE_GIORNO=""0802""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 8 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0831"" or MESE_GIORNO=""0901"" or MESE_GIORNO=""0902""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 10 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1031"" or MESE_GIORNO=""1101"" or MESE_GIORNO=""1102""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 12 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1231"" or MESE_GIORNO=""0101"" or MESE_GIORNO=""0102""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic Else If Len(Trim(Mese)) = 1 Then Mese = "0" & Mese End If If Len(Trim(GIORNO)) = 1 Then GIORNO = "0" & GIORNO GIORNO1 = "0" & GIORNO + 1 If Len(GIORNO1) > 2 Then GIORNO1 = GIORNO + 1 End If GIORNO2 = "0" & GIORNO + 2 If Len(GIORNO2) > 2 Then GIORNO2 = GIORNO + 2 End If ElseIf Len(Trim(GIORNO)) = 2 Then GIORNO = GIORNO GIORNO1 = GIORNO + 1 If Len(GIORNO1) > 2 Then GIORNO1 = Right(GIORNO + 1, 2) End If GIORNO2 = GIORNO + 2 If Len(GIORNO2) > 2 Then GIORNO2 = Right(GIORNO + 2, 2) End If End If Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = '" & Mese & GIORNO & "' or _ MESE_GIORNO = '" & Mese & GIORNO1 & "' or MESE_GIORNO = '" & Mese & GIORNO2 & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic End If Else If Len(Trim(Mese)) = 1 Then Mese = "0" & Mese End If If Len(Trim(GIORNO)) = 1 Then GIORNO = "0" & GIORNO End If Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr_2 WHERE MESE_GIORNO = '" & Mese & GIORNO & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic End If Festeggiati = "" If Rst1.RecordCount > 0 Then Rst1.MoveFirst End If While Not Rst1.EOF ' SE IL GIORNO DELLA SETTIMANA E' VENERDI' (WEEKDAY=6) If Weekday(Date) = 6 Then Festeggiati = Festeggiati & "Il " & Rst1![GIORNO] & " " & Rst1![Mese] & ": " & Rst1![COSA_FESTEGGIANO] & " di " & Rst1![NOMINATIVO] & Chr(13) 'Festeggiati = Festeggiati & AggiuntaGiorniOre Rst1.MoveNext Else Festeggiati = Festeggiati & Rst1![COSA_FESTEGGIANO] & " di " & Rst1![NOMINATIVO] & Chr(13) 'Festeggiati = Festeggiati & AggiuntaGiorniOre Rst1.MoveNext End If Wend If Rst1.RecordCount <> 0 And Weekday(Date) = 6 Then If GIORNO = 27 And Mese = 2 Then MsgBox ("Oggi Venerdi 27 febbraio, domani Sabato 28 febbraio e Domenica 1 marzo si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 29 And Mese = 4 Then MsgBox ("Oggi Venerdi 29 aprile, domani Sabato 30 aprile e Domenica 1 maggio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 29 And Mese = 6 Then MsgBox ("Oggi Venerdi 29 giugno, domani Sabato 30 giugno e Domenica 1 luglio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 29 And Mese = 9 Then MsgBox ("Oggi Venerdi 29 settembre, domani Sabato 30 settembre e Domenica 1 ottobre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 29 And Mese = 11 Then MsgBox ("Oggi Venerdi 29 novembre, domani Sabato 30 novembre e Domenica 1 dicembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 1 Then MsgBox ("Oggi Venerdi 30 gennaio, domani Sabato 31 gennaio e Domenica 1 febbraio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 3 Then MsgBox ("Oggi Venerdi 30 marzo, domani Sabato 31 marzo e Domenica 1 aprile si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 5 Then MsgBox ("Oggi Venerdi 30 maggio, domani Sabato 31 maggio e Domenica 1 giugno si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 7 Then MsgBox ("Oggi Venerdi 30 luglio, domani Sabato 31 luglio e Domenica 1 agosto si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 8 Then MsgBox ("Oggi Venerdi 30 agosto, domani Sabato 31 agosto e Domenica 1 settembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 10 Then MsgBox ("Oggi Venerdi 30 ottobre, domani Sabato 31 ottobre e Domenica 1 novembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 12 Then MsgBox ("Oggi Venerdi 30 dicembre, domani Sabato 31 dicembre e Domenica 1 gennaio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 28 And Mese = 2 Then MsgBox ("Oggi Venerdi 28 febbraio, domani Sabato 1 marzo e Domenica 2 marzo si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 4 Then MsgBox ("Oggi Venerdi 30 aprile, domani Sabato 1 maggio e Domenica 2 maggio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 6 Then MsgBox ("Oggi Venerdi 30 giugno, domani Sabato 1 luglio e Domenica 2 luglio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 9 Then MsgBox ("Oggi Venerdi 30 settembre, domani Sabato 1 ottobre e Domenica 2 ottobre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 11 Then MsgBox ("Oggi Venerdi 30 novembre, domani Sabato 1 dicembre e Domenica 2 dicembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 1 Then MsgBox ("Oggi Venerdi 31 gennaio, domani Sabato 1 febbraio e Domenica 2 febbraio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 3 Then MsgBox ("Oggi Venerdi 31 marzo, domani Sabato 1 aprile e Domenica 2 aprile si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 5 Then MsgBox ("Oggi Venerdi 31 maggio, domani Sabato 1 giugno e Domenica 2 giugno si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 7 Then MsgBox ("Oggi Venerdi 31 luglio, domani Sabato 1 agosto e Domenica 2 agosto si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 8 Then MsgBox ("Oggi Venerdi 31 agosto, domani Sabato 1 settembre e Domenica 2 settembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 10 Then MsgBox ("Oggi Venerdi 31 ottobre, domani Sabato 1 novembre e Domenica 2 novembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 12 Then MsgBox ("Oggi Venerdi 31 dicembre, domani Sabato 1 gennaio e Domenica 2 gennaio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) Else If Mese = 1 Then Mese = "Gennaio" ElseIf Mese = 2 Then Mese = "Febbraio" ElseIf Mese = 3 Then Mese = "Marzo" ElseIf Mese = 4 Then Mese = "Aprile" ElseIf Mese = 5 Then Mese = "Maggio" ElseIf Mese = 6 Then Mese = "Giugno" ElseIf Mese = 7 Then Mese = "Luglio" ElseIf Mese = 8 Then Mese = "Agosto" ElseIf Mese = 9 Then Mese = "Settembre" ElseIf Mese = 10 Then Mese = "Ottobre" ElseIf Mese = 11 Then Mese = "Novembre" ElseIf Mese = 12 Then Mese = "Dicembre" End If MsgBox ("Oggi Venerdi " & CInt(GIORNO) & ", domani Sabato " & CInt(GIORNO + 1) & " e Domenica " & CInt(GIORNO + 2) & " " & Mese & " si festeggia (o si ricorda):" & _ Chr(13) & Chr(13) & Festeggiati) End If ElseIf Rst1.RecordCount <> 0 And Weekday(Date) <> 6 Then MsgBox ("Oggi " & Date & " si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) Else MsgBox ("Oggi " & Date & " non si festeggia (o si ricorda) niente.") End If Set Rst1 = Nothing Errori: If Err.Number = 3021 Then MsgBox ("Oggi " & Date & " non si festeggia (o si ricorda) niente.") PrimoAccesso = False End If
7 - Copia dati in nuova tabella Public Function CopiaDatiInNewTab() Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Dim Rst3 As New ADODB.Recordset Dim IDTESTA As Double Dim InizCorpo As String On Error GoTo Errori Rst1.CursorLocation = adUseClient Rst2.CursorLocation = adUseClient Rst3.CursorLocation = adUseClient Rst1.Open "DATI", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst2.Open "DATI_TESTA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst3.Open "DATI_CORPO", CurrentProject.Connection, adOpenDynamic, adLockOptimistic 'DoCmd.OpenQuery "Q_SVUOTA_TAB_DATI ' PARTE INSERIMENTO RECORD DI TESTA Rst2.AddNew Rst1.MoveFirst While Not Rst1.EOF If Mid(Rst1!CAMPO1, 1, 4) = "DATE" And IsNull(Rst1!CAMPO2) Then Rst2!DATA = Mid(Rst1!CAMPO1, 5) Rst1.MoveNext ElseIf IsNull(Rst1!CAMPO1) And Not IsNull(Rst1!CAMPO2) And Mid(Rst1!CAMPO2, 1) <> "Lunghezza tot./LENGTH" Then Dim CAMPO As String CAMPO = Mid(Rst1!CAMPO2, 1, 4) Select Case CAMPO Case "TIME" Rst2!ORA = Mid(Rst1!CAMPO2, 5) Case "OPER" Rst2!OPERATORE = Mid(Rst1!CAMPO2, 11) Case "PROV" Rst2!PROVA = Mid(Rst1!CAMPO2, 11) Case "CLIE" Rst2!CLIENTE = Mid(Rst1!CAMPO2, 9) End Select Rst1.MoveNext ElseIf IsNull(Rst1!CAMPO1) And Mid(Rst1!CAMPO2, 1) = "Lunghezza tot./LENGTH" Then Rst1.MoveLast ElseIf Mid(Rst1!CAMPO1, 1, 3) = "END" Then Rst1.MoveNext End If Wend Rst2.Update IDTESTA = Rst2!ID_TESTA ' PARTE INSERIMENTO RECORD DEL CORPO Rst1.MoveFirst InizCorpo = "Lunghezza tot./LENGTH" Rst1.Find "[CAMPO2] = '" & InizCorpo & "'" While Not Rst1.EOF And IsNull(Rst1!CAMPO1) Rst3.AddNew Rst3!ID_TESTA = IDTESTA Rst3!COLONNA1 = Rst1!CAMPO2 'DESCRIZIONE Rst3!COLONNA2 = Rst1!CAMPO3 'NOMINALE Rst3!COLONNA3 = Rst1!Campo4 'RILEVATO Rst3!COLONNA4 = Rst1!Campo5 'TOLLERANZA+ Rst3!COLONNA5 = Rst1!Campo6 'TOLLERANZA- Rst3!COLONNA6 = Rst1!campo7 'DEVIAZIONE Dim ValTolMax, ValTolMin, ValDEV, RangeTOT, RangePARZ As Single ValTolMax = CSng(Rst1!Campo5) ValTolMin = CSng(Rst1!Campo6) ValDEV = CSng(Rst1!campo7) RangeTOT = ValTolMax - ValTolMin RangePARZ = RangeTOT / 8 Select Case ValDEV Case ValTolMin To ValTolMin + RangePARZ Rst3![F-TOLL] = "----" Case ValTolMin + RangePARZ To ValTolMin + RangePARZ * 2 Rst3![F-TOLL] = "---" Case ValTolMin + RangePARZ * 2 To ValTolMin + RangePARZ * 3 Rst3![F-TOLL] = "--" Case ValTolMin + RangePARZ * 3 To ValTolMin + RangePARZ * 4 Rst3![F-TOLL] = "-" Case ValTolMin + RangePARZ * 4 To ValTolMin + RangePARZ * 5 Rst3![F-TOLL] = "+" Case ValTolMin + RangePARZ * 5 To ValTolMin + RangePARZ * 6 Rst3![F-TOLL] = "++" Case ValTolMin + RangePARZ * 6 To ValTolMin + RangePARZ * 7 Rst3![F-TOLL] = "+++" Case ValTolMin + RangePARZ * 7 To ValTolMax Rst3![F-TOLL] = "++++" Case Is > ValTolMax Rst3![F-TOLL] = ValDEV - ValTolMax Case Is < ValTolMin Rst3![F-TOLL] = ValTolMin + ValDEV End Select Rst3.Update Rst1.MoveNext Wend Set Rst1 = Nothing Set Rst2 = Nothing Set Rst3 = Nothing Errori: If Err.Number = -2147217900 Then MsgBox ("ATTENZIONE! Manca il file DEFINITIVO.STA nella cartella " & PercFileSTA) End If End Function
8 - Quante volte ricorre un carattere in una stringa Public Function QuanteVolte(car As String, str As String) As Long If Len(car) <> 1 Then Err.Raise 5 ' car DEVE essere 1 carattere ! QuanteVolte = Len(str) - Len(Replace(str, car, "", , , vbTextCompare)) End Function
9 - Dimensiona le colonne di una SSTAB Public Function RegolaColonne(Numero As Byte) Dim DimDATA As Integer Dim DimCheck As Integer DimDATA = 1040 DimCheck = 580 Forms![01_M_PRINCIPALE]("SM1_TITOLO" & Numero)!NOME_CAMPO.ColumnWidth = DimDATA Forms![01_M_PRINCIPALE]("SM1_TITOLO" & Numero)!NOME_CAMPO.ColumnWidth = DimCheck End Function
10 - Funzione GestioneLoghi(Me.Report.Name) Call GestioneLoghi(Me.Report.Name) Public Function GestioneLoghi(NomeReport As String) Reports(NomeReport)!ImmLOGO1.Picture = "C:\PERCORSO\Logo1.jpg" Reports(NomeReport)!ImmLOGO2.Picture = "C:\PERCORSO\Logo2.jpg" Reports(NomeReport)!ImmLOGO3.Picture = "C:\PERCORSO\Logo3.jpg" ...... End Function
11 - Sfoglia le cartelle di C: 'APRE SOLO FILE PDF ..... da verificare Public Function SFOGLIA_CARTELLE() Dim sh As Object, obj As Object, cNomefile As String, fso As Object Set sh = CreateObject("Shell.Application") On Error Resume Next Set obj = sh.BrowseForFolder(Me.Hwnd, "Selezionare un file", 16385, 17) If Err.Number <> 0 Then Set obj = Nothing End If On Error GoTo 0 If obj Is Nothing Then cNomefile = "" Else With obj cNomefile = .ParentFolder.ParseName(.Title).Path End With Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(cNomefile) Then cNomefile = "" End If Set fso = Nothing End If Set sh = Nothing If cNomefile <> "" Then txtCasella.Value = cNomefile End If End Sub
12 - Leggere dati da un foglio EXCEL collegato come tabella Public Function LeggiDatiFoglioEXCEL() Dim Rst1 As New ADODB.Recordset Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim A, B, C, D As Integer Set xlApp = CreateObject("Excel.Application") xlApp.Visible = False 'Set xlBook = xlApp.Workbooks.Open(CurrentProject.Path & "\FileDaBanca.xls") Set xlBook = xlApp.Workbooks.Open("C:\Users\riccardo_morosini\Desktop\CANONI_BRENO\PROVA_CANONI.xlsx") Rst1.CursorLocation = adUseClient Rst1.Open "T_TMP_FOGLI", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount > 0 Then Rst1.MoveFirst Set xlSheet = xlBook.Worksheets(NomeFoglio) A = 18 While A <= 60 ' VERIFICO PARTENDO DALLA CELLA [G18]=QUANTITA' SE C'E' UN VALORE If xlSheet.Cells(A, 7) <> "" Then ' SE C'E' If xlSheet.Cells(A, 4) <> "" Then Rst1.AddNew Rst1!CLIENTE = xlSheet.Cells(3, 6) 'F3 Rst1!RIFERIMENTO = xlSheet.Cells(2, 6) 'F2 Rst1!CODICE_PANTHERA = xlSheet.Cells(2, 10) 'J2 Rst1!CODICE1 = xlSheet.Cells(A, 4) 'D&"A" Rst1!CODICE2 = xlSheet.Cells(A, 5) 'E&"A" Rst1!DESCRIZIONE = xlSheet.Cells(A, 6) 'F&"A" Rst1!QUANTITA = xlSheet.Cells(A, 7) 'G&"A" Rst1!CANONE = xlSheet.Cells(A, 95) 'CQ&"A" Rst1!DATA_CONTRATTO = xlSheet.Cells(11, 7) 'G11 Rst1.Update Else ' GENERO UN FILE TXT CONTENENTE IL CLIENTE E LA RIGA CON IL PROBLEMA File_Anomalie = Trim(Rst1!CLIENTE) & ";" & Trim(Rst1!RIFERIMENTO) & ";CODICE1 NON PRESENTE" Print #1, File_Anomalie End If End If A = A + 1 Wend Chiudi: xlBook.Close SaveChanges:=False xlApp.Quit Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing Set Rst1 = Nothing End Function
13 - Abilita Maiuscolo Option Compare Database Option Explicit ' NON MODIFICARE IL NOME DELLA MACRO AUTOEXEC 'Questo modulo consente di applicare una sorta di Protezione e/o 'impostazione di AVVIO in modo Automatico 'Si può utilizzare lanciandola da un Menù sotto Password 'oppure inserendo un controllo nascosto in una Form. 'Consente di Modificare in un solo colpo tutte le proprietà 'del menù di AVVIO compreso ALLOW_BYPASS_KEY ed eventualmente 'la Macro AUTOEXEC. 'Startup properties 'Private Const strAppTitle As String = "ESEMPIO DISABILITAZIONE TASTO MAIUSCOLO" Private Const strAppTitle As String = "INSOR" Private Const strStartUpForm As String = "M_LOGIN" 'Private Const strStartUpMenuBar As String = "mnuPrincipale" Private Const strStartUpMenuBar As String = "" Private Const strStartUpShortcutMenuBar As String = vbNullString Private Const strAppIcon As String = vbNullString Private Const blnStartUpShowDBWindow As Boolean = False Private Const blnStartUpShowStatusBar As Boolean = False Private Const blnAllowShortcutMenus As Boolean = False Private Const blnAllowFullMenus As Boolean = False Private Const blnAllowBuiltInToolbars As Boolean = False Private Const blnAllowToolbarChanges As Boolean = False Private Const blnAllowBreakIntoCode As Boolean = False Private Const blnAllowSpecialKeys As Boolean = False Private Const blnAllowBypassKey As Boolean = False Public Function Secure() On Error Resume Next Call ChangeProperty("AppTitle", dbText, strAppTitle) Call ChangeProperty("StartUpForm", dbText, strStartUpForm) Call ChangeProperty("StartUpMenuBar", dbText, strStartUpMenuBar) Call ChangeProperty("StartupShortcutMenuBar", dbText, strStartUpShortcutMenuBar) Call ChangeProperty("AppIcon", dbText, strAppIcon) Call ChangeProperty("StartUpShowDBWindow", dbBoolean, blnStartUpShowDBWindow) Call ChangeProperty("StartUpShowStatusBar", dbBoolean, blnStartUpShowStatusBar) Call ChangeProperty("AllowShortcutMenus", dbBoolean, blnAllowShortcutMenus) Call ChangeProperty("AllowFullMenus", dbBoolean, blnAllowFullMenus) Call ChangeProperty("AllowBuiltInToolbars", dbBoolean, blnAllowBuiltInToolbars) Call ChangeProperty("AllowToolbarChanges", dbBoolean, blnAllowToolbarChanges) Call ChangeProperty("AllowBreakIntoCode", dbBoolean, blnAllowBreakIntoCode) Call ChangeProperty("AllowSpecialKeys", dbBoolean, blnAllowSpecialKeys) Call ChangeProperty("AllowBypassKey", dbBoolean, blnAllowBypassKey) If CurrentDb.Containers("Scripts").Documents("$Autoexec").Name = "$Autoexec" Then _ EnableAutoExec End Function Public Function UnSecure() On Error GoTo Errori 'Call ChangeProperty("AppTitle", dbText, "My Application is UnSecured") Call ChangeProperty("AppTitle", dbText, strAppTitle) 'Call ChangeProperty("StartUpForm", dbText, vbNullString) 'Call ChangeProperty("StartUpMenuBar", dbText, vbNullString) 'Call ChangeProperty("StartupShortcutMenuBar", dbText, vbNullString) Call ChangeProperty("AppIcon", dbText, vbNullString) Call ChangeProperty("StartUpShowDBWindow", dbBoolean, True) Call ChangeProperty("StartUpShowStatusBar", dbBoolean, True) Call ChangeProperty("AllowShortcutMenus", dbBoolean, True) Call ChangeProperty("AllowFullMenus", dbBoolean, True) Call ChangeProperty("AllowBuiltInToolbars", dbBoolean, True) Call ChangeProperty("AllowToolbarChanges", dbBoolean, True) Call ChangeProperty("AllowBreakIntoCode", dbBoolean, True) Call ChangeProperty("AllowSpecialKeys", dbBoolean, True) Call ChangeProperty("AllowBypassKey", dbBoolean, True) If CurrentDb.Containers("Scripts").Documents("Autoexec").Name = "Autoexec" Then _ DisableAutoExec Errori: If Err.Number = 3265 Then Exit Function End If End Function Public Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Boolean Dim prp As Property On Error GoTo Change_Err If Len(varPropValue) > 0 Then CurrentDb.Properties(strPropName) = varPropValue Else CurrentDb.Properties.Delete strPropName End If ChangeProperty = True Change_Bye: Set prp = Nothing Exit Function Change_Err: Select Case Err Case 3265 'Item not found in this collection. Resume Next Case 3270 'prop not found With CurrentDb Set prp = .CreateProperty(strPropName, varPropType, varPropValue) .Properties.Append prp End With Resume Next Case Else ChangeProperty = False Resume Change_Bye End Select End Function Public Function DisableAutoExec() As Boolean Dim docCiclo As DAO.Document Dim dbs As DAO.Database Set dbs = CurrentDb DisableAutoExec = False For Each docCiclo In dbs.Containers!Scripts.Documents 'Scorre l'insieme Documents del database per verificare la presenza della Macro se esiste la Rinomina If docCiclo.Name = "Autoexec" Then DoCmd.Rename "_Autoexec", acMacro, "Autoexec" DisableAutoExec = True End If Next docCiclo Set dbs = Nothing End Function Private Function EnableAutoExec() As Boolean Dim docCiclo As DAO.Document Dim dbs As DAO.Database Set dbs = CurrentDb EnableAutoExec = False For Each docCiclo In dbs.Containers!Scripts.Documents 'Scorre l'insieme Documents del database per verificare la presenza della Macro ' se esiste la Rinomina If docCiclo.Name = "_Autoexec" Then DoCmd.Rename "Autoexec", acMacro, "_Autoexec" EnableAutoExec = True End If Next docCiclo Set dbs = Nothing End Function Private Sub BLOCCA_Click() Secure DoCmd.Close End Sub Private Sub OK_Click() If Me.Password = "1234" Then Me.SBLOCCA.Enabled = True Me.BLOCCA.Enabled = True End If End Sub Private Sub SBLOCCA_Click() UnSecure DoCmd.Close End Sub
14 - Scrivendo un carattere nella cella VERDE nella ROSSA esce il corrispettivo n ASCII Option Compare Database Dim NumTastiPremuti As Integer Public Function Form_KeyDown(KeyCode As Integer, Shift As Integer) Me.COdTastoDigitato = KeyCode Me.ValTastoDigitato = Chr(KeyCode) NumTastiPremuti = NumTastiPremuti + 1 End Sub Public Function Form_KeyUp(KeyCode As Integer, Shift As Integer) If NumTastiPremuti = 1 Then InizializzaVar1 = KeyCode ElseIf NumTastiPremuti = 2 Then InizializzaVar2 = KeyCode ElseIf NumTastiPremuti = 3 Then InizializzaVar3 = KeyCode End If If InizializzaVar1 = "17" And InizializzaVar2 = "16" And InizializzaVar3 = "27" Then MsgBox "Hai premuto CTRL+SHIFT" NumTastiPremuti = 0 InizializzaVar1 = "" InizializzaVar2 = "" InizializzaVar3 = "" ElseIf InizializzaVar1 = "17" And InizializzaVar2 = "16" And InizializzaVar3 = "77" Then MsgBox "Hai premuto CTRL+SHIFT+M" NumTastiPremuti = 0 InizializzaVar1 = "" InizializzaVar2 = "" InizializzaVar3 = "" Else End If End Sub Private Sub Form_Open(Cancel As Integer) InizializzaVar1 = "" InizializzaVar2 = "" InizializzaVar3 = "" Me.COdTastoDigitato = "" Me.ValTastoDigitato = "" NumTastiPremuti = 0 DoCmd.Maximize End Sub
15 - Contatori su FORM / Progressivo elaborazione numPassi = 1 numPasso = numPasso + 1 Forms!M_NOME_FORM![NOME TEXTBOX].Value = "Elabora tabelle: Bonifica I.C.I. (Passo: " & numPasso & "/" & numPassi & ")" Forms!M_NOME_FORM.Repaint Forms!M_NOME_FORM![NOME_LABEL].Caption = "Importa nuove commesse (record: " & RecordAttuale & "/" & TOTNuoveColate & ")" Forms!M_NOME_FORM.Repaint
16 - Funzioni CtrlSeNULL, CtrlSeZERO, CtrlSeVUOTO, CtrlSeVUOTOeZERO Tutte le funzioni sotto possono essere sostituite dalla funzione di sistema Nz È possibile usare la funzione Nz per restituire zero, una stringa di lunghezza zero (" ") oppure un altro valore specificato quando un Variant è Null. Ad esempio, si può usare questa funzione per convertire un valore Null in un altro valore ed evitare che si propaghi tramite un'espressione. Public Function CtrlSeNULL(CampoControllo As Variant) As Variant If IsNull(Trim(CampoControllo)) Then CtrlSeNULL = 0 Else CtrlSeNULL = Trim(CampoControllo) End If End Function Public Function CtrlSeZERO(CampoControllo As Variant) As Variant If Trim(CampoControllo) = 0 Then CtrlSeZERO = "" Else CtrlSeZERO = Trim(CampoControllo) End If End Function Public Function CtrlSeVUOTO(CampoControllo As Variant) As Variant If Trim(CampoControllo) = "" Then CtrlSeVUOTO = Null Else CtrlSeVUOTO = Trim(CampoControllo) End If End Function Public Function CtrlSeVUOTOeZERO(CampoControllo As Variant) As Variant If Trim(CampoControllo) = "" Or Trim(CampoControllo) = 0 Then CtrlSeVUOTOeZERO = Null Else CtrlSeVUOTOeZERO = Trim(CampoControllo) End If End Function
17 - Funzioni MASSIMO e MINIMO su un array Option Compare Database Public Type MinMaxROFase Min As Single Max As Single RO As Single FASE As String End Type Public Function GetMinMaxROFase(L1 As Single, L2 As Single, L3 As Single, L4 As Single, L5 As Single, L6 As Single, L7 As Single, L8 As Single) As MinMaxROFase Dim emp As MinMaxROFase Dim Minimo As Single, Massimo As Single Dim Valori(7) As Single Dim FASE As String ' POPOLA L'ARRAY DI T1 Valori(0) = CtrlSeNULL(L1) ' 0° Valori(1) = CtrlSeNULL(L2) ' 45° Valori(2) = CtrlSeNULL(L3) ' 90° Valori(3) = CtrlSeNULL(L4) ' 135° Valori(4) = CtrlSeNULL(L5) ' 180° Valori(5) = CtrlSeNULL(L6) ' 225° Valori(6) = CtrlSeNULL(L7) ' 270° Valori(7) = CtrlSeNULL(L8) ' 315° Minimo = 1000 Massimo = -1000 FASE = "" For x = 0 To 7 If Valori(x) < Minimo Then Minimo = Valori(x) If Valori(x) > Massimo Then Massimo = Valori(x) If x = 0 Then FASE = "0°" ElseIf x = 1 Then FASE = "45°" ElseIf x = 2 Then FASE = "90°" ElseIf x = 3 Then FASE = "135°" ElseIf x = 4 Then FASE = "180°" ElseIf x = 5 Then FASE = "225°" ElseIf x = 6 Then FASE = "270°" ElseIf x = 7 Then FASE = "315°" End If End If Next 'MsgBox ("Minimo: " & Minimo & " : Massimo " & Massimo) emp.Min = Minimo emp.Max = Massimo emp.RO = Minimo - Massimo emp.FASE = FASE GetMinMaxROFase = emp End Function
18 - Leggi dati da foglio EXCEL (.xlsx) Public Function LeggiDatiFoglio02(NomeFoglio As String) Dim Rst1 As New ADODB.Recordset Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim A, B, C, D As Integer Set xlApp = CreateObject("Excel.Application") xlApp.Visible = False 'Set xlBook = xlApp.Workbooks.Open(CurrentProject.Path & "\FileDaBanca.xls") Set xlBook = xlApp.Workbooks.Open("C:\Users\riccardo_morosini\Desktop\CANONI_BRENO\PROVA_CANONI.xlsx") Rst1.CursorLocation = adUseClient Rst1.Open "T_TMP_FOGLI", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount > 0 Then Rst1.MoveFirst Set xlSheet = xlBook.Worksheets(NomeFoglio) A = 18 While A <= 60 ' VERIFICO PARTENDO DALLA CELLA [G18]=QUANTITA' SE C'E' UN VALORE If xlSheet.Cells(A, 7) <> "" Then ' SE C'E' If xlSheet.Cells(A, 4) <> "" Then Rst1.AddNew Rst1!CLIENTE = xlSheet.Cells(3, 6) 'F3 Rst1!RIFERIMENTO = xlSheet.Cells(2, 6) 'F2 Rst1!CODICE_PANTHERA = xlSheet.Cells(2, 10) 'J2 Rst1!CODICE1 = xlSheet.Cells(A, 4) 'D&"A" Rst1!CODICE2 = xlSheet.Cells(A, 5) 'E&"A" Rst1!DESCRIZIONE = xlSheet.Cells(A, 6) 'F&"A" Rst1!QUANTITA = xlSheet.Cells(A, 7) 'G&"A" Rst1!CANONE = xlSheet.Cells(A, 95) 'CQ&"A" Rst1!DATA_CONTRATTO = xlSheet.Cells(11, 7) 'G11 Rst1.Update Else ' GENERO UN FILE TXT CONTENENTE IL CLIENTE E LA RIGA CON IL PROBLEMA File_Anomalie = Trim(Rst1!CLIENTE) & ";" & Trim(Rst1!RIFERIMENTO) & ";CODICE1 NON PRESENTE" Print #1, File_Anomalie End If End If A = A + 1 Wend Chiudi: xlBook.Close SaveChanges:=False xlApp.Quit Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing Set Rst1 = Nothing End Function
19 - Q_ZeroAlSecondoDecimale NewC: InStr([C];",") NewC2: Mid([C];InStr([C];",")+1) NewC3: IIf(Len(Mid([C];InStr([C];",")+1))>1;Mid([C];InStr([C];",")+1);Mid([C];InStr([C];",")+1) & "0") NewC4: Mid([C];1;InStr([C];",")) & IIf(Len(Mid([C];InStr([C];",")+1))>1;Mid([C];InStr([C];",")+1);Mid([C];InStr([C];",")+1) & "0")
20 - Inserire numero progressivo in query di ordinamento Sotto la slide della query in questione: Il risultato sarà: Il codice è questo: *NumIncr: (Select Count () FROM T_CTT_CICLO_ST1 as A WHERE [A].[ID_CICLO_CTT] < [T_CTT_CICLO_ST1].[ID_CICLO_CTT])+1 Da verificare perchè non funziona .... Ho risolto il problema creando al tabella T_TEMP con un campo ContRecT_CTT_CICLO_ST1 NUMERICO con valore predefinito = 1 Public Function ContaRecord(numero As Long, pag As Integer) As Integer Dim Rst2 As New ADODB.Recordset Dim ValoreIniziale As Integer Rst2.CursorLocation = adUseClient Rst2.Open "SELECT ContRecT_CTT_CICLO_ST1 FROM T_TEMP", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If PrimoRecord Then Rst2!ContRecT_CTT_CICLO_ST1 = 1 Rst2.Update End If ValoreIniziale = Rst2!ContRecT_CTT_CICLO_ST1 ContaRecord = ValoreIniziale Rst2!ContRecT_CTT_CICLO_ST1 = Rst2!ContRecT_CTT_CICLO_ST1 + 1 Rst2.Update PrimoRecord = False Set Rst2 = Nothing End Function Nella tabella del sottoreport inseriamo il campo NumIncr** che ci restituirà il numero del record corrente
21 - Funzione che ritorna più parametri Nelle parte di dichiarazione delle variabili: Option Compare Database Option Explicit ............................ Public Type NumIDDTTarDTScad NumID As String DTTar As String DTScad As String End Type La funzione sarà: Public Function CercaStrumento(NomeStrumento As String) As NumIDDTTarDTScad Dim Rst1 As New ADODB.Recordset Dim emp As NumIDDTTarDTScad Dim IDMorandini, DataTaratura, DataScadenza As String Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM T_CPU_STRUMENTI WHERE NOME_STRUMENTO = '" & Replace(NomeStrumento, "'", "''") & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount = 1 Then emp.NumID = DaNullaVUOTO(Rst1!NUM_IDENTIFICATIVO_MORANDINI) emp.DTTar = DaNullaVUOTO(Rst1!DATA_TARATURA_STRUMENTO) emp.DTScad = DaNullaVUOTO(Rst1!DATA_SCADENZA_STRUMENTO) Else emp.NumID = "" emp.DTTar = "" emp.DTScad = "" End If CercaStrumento = emp Set Rst1 = Nothing End Function Questa funzione potrà essere usata nel seguente modo all'interno del programma: If Not IsNull(Me.STRUMENTO) Then Me.ETI_NUMERO_ID.Caption = CercaStrumento(Me.STRUMENTO).NumID Me.ETI_DATA_SCA.Caption = CercaStrumento(Me.STRUMENTO).DTScad Me.ETI_DATA_TAR.Caption = CercaStrumento(Me.STRUMENTO).DTTar Else Me.ETI_NUMERO_ID.Caption = "" Me.ETI_DATA_SCA.Caption = "" Me.ETI_DATA_TAR.Caption = "" End If
22 - Il comando LIKE nel codice VBA Questo esempio funziona: Dim Rst1 As New ADODB.Recordset Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM [TABELLA/QUERY] WHERE NOME CAMPO like '%" & Me.PARAMETRO & "%'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic
23 - Assegnare via codice il RecordSsource Si crea un interruttore che gestisce il RecordSource della sottotabella: If Me.Interruttore1 = -1 Then ' Interruttore attivato Me.M_Maschera_ST1.Form.RecordSource = "SELECT campo1, campo2, campo3 WHERE campo1 = " & Me.X & " AND campo2 = " & Me.Y & " AND Not IsNull(Campo3)" ElseIf Me.Interruttore1 = 0 Then ' Interruttore disattivato Me.M_Maschera_ST1.Form.RecordSource = "SELECT campo1, campo2, campo3 WHERE campo1 = " & Me.X & " AND campo2 = " & Me.Y End If
24 - Aprire un recordset su un'altro DB Dim Rst1 As New ADODB.Recordset Rst1.CursorLocation = adUseClient ' Si inserisce il [percorso completo].[nome database].[nome tabella] Rst1.Open "SELECT * FROM F:\CARTELLA1\CARTELLA2\NOME_DATABASE.accdb.NOME_TABELLA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic PS: non funziona se c'è già una tabella/query con quel nome! ' Vediamo un esempio più complesso DoCmd.RunSQL "DELETE * FROM T_TEMP_ElenchiDiagrammiInCiclo" Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM Tabella1 ORDER BY ANNO", CurrentProject.Connection, adOpenDynamic, adLockOptimistic While Not Rst1.EOF Rst2.CursorLocation = adUseClient Rst2.Open "INSERT INTO Tabella2 ( Campo1, Campo2, Campo3, Campo4, Campo5, ANNO) " & _ "SELECT Campo1, Campo2, Campo3, Campo4, Campo5, " & Rst1!ANNO & " " & _ "FROM (C:\CARTELLA1" & Rst1!ANNO & ".accdb.TABELLA1 LEFT JOIN C:\CARTELLA1" & Rst1!ANNO & ".accdb.TABELLA2 .." & _ "LEFT JOIN C:\CARTELLA1" & Rst1!ANNO & ".accdb.TABELLA2 ON (....) " & _ "WHERE ((Not (Campo1) Is Null)) AND .....", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst1.MoveNext Wend
25 - Form ricerca dati Si crea una form non associata ad alcuna tabella e si creano i combobox per la ricerca dei dati, impostando come valore predefinito * All'interno di questa form si crea una sottoform con recordsource associato alla tabella dove vogliamo cercare i dati. Sulla query metteremo nei campi di ricerca il nome delle combobox (ad es: Forms![NOME_FORM]!NOME_COMBOBOX)
26 - Collegare una tabella da codice (DAO) Dim DATABASE As DAO.Database Dim n As Integer, TableArray() As String Dim TFileName As String, LinkedTable As TableDef, i As Integer Dim TFileName2016 As String, LinkedTable2016 As TableDef Set DATABASE = CurrentDb ' Database esterno TFileName = "F:\forge\DATABASE\DATABASE.accdb" DoCmd.Hourglass True n = 4 ReDim TableArray(1 To n) ' Tabelle esistenti sul database esterno... TableArray(1) = "T_CPP" TableArray(2) = "T_CPM" TableArray(3) = "T_CPU" TableArray(4) = "T_CTT" ' ... che si vogliono collegare al database corrente con lo stesso nome For i = 1 To n Set LinkedTable = DATABASE.CreateTableDef(TableArray(i)) LinkedTable.Connect = ";DATABASE=" & TFileName LinkedTable.SourceTableName = TableArray(i) DATABASE.TableDefs.Append LinkedTable Next i DATABASE.TableDefs.Refresh DoCmd.Hourglass False
27 - Eliminare una tabella collegata ....... For I = 1 To n On Error Resume Next CurrentDb.Execute "DROP TABLE " & TableArray(I) Next I CurrentDb.TableDefs.Refresh .......
28 - Passare il nome della FORM ad una funzione EF = GestioneDescrizioneANAGRAFE(Me.Report.Name) Public Function GestioneDescrizioneANAGRAFE(NomeReport As String) ' GESTIONE CAMPO DESCRIZIONE ANAGRAFE If Reports(NomeReport)!ANNO_CERTIFICATO = Replace(Forms!inizio!EtiANNO.Caption, " ", "") Then If (Reports(NomeReport)!FORGIATO_TIPO = "" Or IsNull(Reports(NomeReport)!FORGIATO_TIPO)) Then Reports(NomeReport)!DESCRIZIONE_ITALIA.Visible = True Reports(NomeReport)!FORGIATO_TIPO.Visible = False Else Reports(NomeReport)!DESCRIZIONE_ITALIA.Visible = False Reports(NomeReport)!FORGIATO_TIPO.Visible = True End If If Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE = "" Or _ IsNull(Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE) Then Reports(NomeReport)!DESCRIZIONE_DIMENSIONI_EFF.Visible = False Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE.Visible = False Else Reports(NomeReport)!DESCRIZIONE_DIMENSIONI_EFF.Visible = True Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE.Visible = True End If Else Reports(NomeReport)!DESCRIZIONE_ITALIA.Visible = True Reports(NomeReport)!FORGIATO_TIPO.Visible = False Reports(NomeReport)!DESCRIZIONE_DIMENSIONI_EFF.Visible = False Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE.Visible = False End If End Function
29 - Funzione GestPagIniFin("Nome_Report") Call GestPagIniFin("Nome_Report") Public Function GestPagIniFin(NomeReport As String) If PagIniziale = 0 And PagFinale = 0 Then Reports(NomeReport).GestNumPag.Caption = Reports(NomeReport).Page & " / " & Reports(NomeReport).Pages ElseIf PagIniziale <> 0 And PagFinale = 0 Then Reports(NomeReport).GestNumPag.Caption = PagIniziale & " / " & Reports(NomeReport).Pages ElseIf PagIniziale = 0 And PagFinale <> 0 Then Reports(NomeReport).GestNumPag.Caption = Reports(NomeReport).Page & " / " & PagFinale ElseIf PagIniziale <> 0 And PagFinale <> 0 Then Reports(NomeReport).GestNumPag.Caption = Reports(NomeReport).Page + PagIniziale - 1 & " / " & PagFinale Else End If End Function
30 - CancellaRecord("NOME_TAB", "NOME_FORM", CP1, CP2) Call CancellaRecord("NOME_TAB", "NOME_FORM", CP1, CP2) ' CP=Chiave Primaria Public Function CancellaRecord(NomeTab As String, NomeForm As String, CP1 As Integer, CP2 As Integer) On Error GoTo ERRORI Messaggio = "SELEZIONANDO [Sì] CANCELLERAI IL CERTIFICATO N° " & CP1 & "/" & CP2 & Chr(13) & Chr(13) & _ "SELEZIONANDO [No] ANNULLERAI L'OPERAZIONE DI CANCELLAZIONE" Stile = vbYesNo + vbCritical + vbDefaultButton2 Titolo = "ATTENZIONE" Risposta = MsgBox(Messaggio, Stile, Titolo) If Risposta = vbYes Then DoCmd.RunSQL "DELETE * FROM " & NomeTab & " WHERE CP1 = " & CP1 & " AND cP2 = " & CP2 Forms(NomeForm).Requery End If ERRORI: If Err.Number = 3167 Then Forms(NomeForm).Requery End If End Function
31 - Gestione Data Estesa Public Function CreaDataEstesa() As String ' GENERIAMO LA DATA NEL FORMATO GG MESE AA Select Case CByte(Mid(Date, 4, 2)) Case 1 CreaDataEstesa = Mid(Date, 1, 2) & " gennaio " & Mid(Date, 7, 4) Case 2 CreaDataEstesa = Mid(Date, 1, 2) & " febbraio " & Mid(Date, 7, 4) Case 3 CreaDataEstesa = Mid(Date, 1, 2) & " marzo " & Mid(Date, 7, 4) Case 4 CreaDataEstesa = Mid(Date, 1, 2) & " aprile " & Mid(Date, 7, 4) Case 5 CreaDataEstesa = Mid(Date, 1, 2) & " maggio " & Mid(Date, 7, 4) Case 6 CreaDataEstesa = Mid(Date, 1, 2) & " giugno " & Mid(Date, 7, 4) Case 7 CreaDataEstesa = Mid(Date, 1, 2) & " luglio " & Mid(Date, 7, 4) Case 8 CreaDataEstesa = Mid(Date, 1, 2) & " agosto " & Mid(Date, 7, 4) Case 9 CreaDataEstesa = Mid(Date, 1, 2) & " settembre " & Mid(Date, 7, 4) Case 10 CreaDataEstesa = Mid(Date, 1, 2) & " ottobre " & Mid(Date, 7, 4) Case 11 CreaDataEstesa = Mid(Date, 1, 2) & " novembre " & Mid(Date, 7, 4) Case 12 CreaDataEstesa = Mid(Date, 1, 2) & " dicembre " & Mid(Date, 7, 4) End Select End Function
32 - Copy file da un percorso ad un altro Dim PathORIG, PathDEST, File1Nome, File2Nome As String PathORIG = "C:\percorso origine\" PathDEST = "C:\percorso destinazione\" File1Nome = "NomeFileOrigine.lnk" File2Nome = "NomeFileDestinazione.lnk" FileCopy PathORIG & File1Nome, PathDEST & File1Nome FileCopy PathORIG & File2Nome, PathDEST & File2Nome
33 - Assegnare permessi a cartelle - funzione icacls Dim NomeCart As String NomeCart = "TEST" If Dir("\\PERCORSO\" & NomeCart, vbDirectory) = "" Then MkDir ("\\PERCORSO\" & NomeCart) Else 'Kill ("\\PERCORSO\.") End If Call Shell("icacls \\192.168.2.2\DATI\Privati\Documenti-TEST\" & NomeCart & " /grant administrator@dominio.locale:(OI)(CI)F /grant user1.pippo@dominio.locale:(OI)(CI)F /grant user2.pluto@dominio.locale:(OI)(CI)F /inheritance:r")
34 - Query con nome tabella parametrizzato Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Dim Rst3 As New ADODB.Recordset Dim Rst4 As New ADODB.Recordset Dim NumeroGIORNI, J As Byte Dim ElencoNomiTAB(31) As String ' 32 RECORD IN TABELLLA [T_NOMI_TABELLE] Rst4.CursorLocation = adUseClient Rst4.Open "SELECT * FROM T_NOMI_TABELLE ORDER BY PRIORITA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst4.MoveFirst J = 0 While J < Rst4.RecordCount ElencoNomiTAB(J) = Rst4!NOME_TABELLA Rst4.MoveNext J = J + 1 Wend J = 0 If Rst2.RecordCount Then Rst2.MoveFirst Rst4.MoveFirst While Not Rst2.EOF Rst3.CursorLocation = adUseClient Rst3.Open "SELECT * FROM anagrafepulsanti WHERE KEY = '" & Rst2!KEY & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic ' SE NON TROVO IL KEY LO CREO If Rst3.RecordCount = 0 Then Rst3.AddNew Rst3!KEY = Rst2!KEY While Not Rst4.EOF NOME_CAMPO = Rst4!CODICE_CERTIFICATO Rst1.CursorLocation = adUseClient Rst1.Open "SELECT COMMESSA FROM " & ElencoNomiTAB(J) & " WHERE commessa = '" & Rst2!KEY & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount > 0 Then Rst3(NOME_CAMPO) = True Else Rst3(NOME_CAMPO) = False Rst1.Close Rst4.MoveNext J = J + 1 Wend ' SE TROVO IL KEY AGGIORNO I CAMPI Else If Forms!INIZIO!CCRicompilaTutto = -1 Or SoloQuestaCommessa Then While Not Rst4.EOF NOME_CAMPO = Rst4!CODICE Rst1.CursorLocation = adUseClient Rst1.Open "SELECT COMMESSA FROM " & ElencoNomiTAB(J) & " WHERE commessa = '" & Rst2!KEY & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount > 0 Then Rst3(NOME_CAMPO) = True Else Rst3(NOME_CAMPO) = False Rst1.Close Rst4.MoveNext J = J + 1 Wend End If End If Rst3.Update Rst3.Close Rst2.MoveNext Wend
35 - crivere in file Excel xlsx Public Function ScriviDatiSuFoglio_Grade1() Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Dim riga, COLONNA, COLONNA_INT As Integer Dim PARAMETRO As String PARAMETRO = "91" Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM TABELLA WHERE CAMPO like '%" & PARAMETRO & "%' ORDER BY CAMPO", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Workbooks.Open FileName:="C:\PERCORSO\FILE_EXCEL.xlsx" riga = 5 COLONNA = 3 COLONNA_INT = 3 If Rst1.RecordCount > 0 Then Rst1.MoveFirst While Not Rst1.EOF Rst2.CursorLocation = adUseClient Rst2.Open "SELECT * FROM TABELLA WHERE CAMPO = '" & Rst1!CAMPO & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst2.RecordCount = 1 Then Worksheets("NOME_FOGLIO").Cells(3, COLONNA_INT).Value = Rst2!colata & " " & Rst2!data_colata Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO1) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO2) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO3) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO4) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO5) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO6) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO7) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO8) Else End If riga = 5 COLONNA = COLONNA + 1 COLONNA_INT = COLONNA_INT + 2 Rst2.Close Rst1.MoveNext Wend Workbooks.Close Set Rst1 = Nothing Set Rst2 = Nothing End Function
36 - Apertura e chiusura file di testo (Open) Apertura e chiusura file di testo Per aprire un file di testo si utilizza l'istruzione open Open nomepercorso For modalità [accesso] As [#]numerofile nomepercorso = percorso e nome del file da aprire ES:C:\Prova.log modalità (Obbligatoria) = Parola chiave che specifica la modalità di accesso al file, ovvero Append,Binary, Input, Output o Random. Se non viene specificata, il file verrà aperto in modalità Random. Noi analizzeremo: Input = Apertura file in lettura (se il file non esiste va in errore) Output = Apertura file in scrittura dati (se il file non esiste viene creato, se il file esiste viene sovrascritto) Append = Apertura di un file in scrittura dati (se il file non esiste viene creato,se il file esiste viene accodato il testo al contenuto già esistente) accesso (Facoltativa) = Parola chiave che specifica le operazioni consentite nel file aperto, ovvero: Read, Write o Read Write. numerofile (Obbligatoria) = Numero di file valido compreso tra 1 e 511 inclusi. La funzione FreeFile restituisce il primo numero di file disponibile. Per chiudere il file usare Close [#]numerofile 'Apertura file in Lettura Dim NumeroFIle as integer Open "C:\Pova.txt" for Input As #1 ..... close #1 'Chiusura File 'Apertura file in Scrittura Open "C:\Pova.txt" for output As #1 ..... close #1 'Chiusura File Open "C:\Pova.txt" for append As #1 ..... close #1 'Chiusura File 'Uso del FreeFile Dim Numero as Integer NumeroFIle = FreeFile Open "C:\Pova.txt" for append As #NumeroFIle ...... close #NumeroFIle 'Chiusura File
37 - Lettura dati di un file di testo (input/Line Input) Lettura dati di un file di testo Il file deve essere aperto con modalità Input Vi sono 2 Comandi: Input: Legge i dati da un file ad accesso sequenziale aperto e li assegna a delle variabili. Line Input: Legge una singola riga in un file aperto ad accesso sequenziale e la assegna a una variabile. I dati letti tramite Line Input # vengono in genere scritti su file con Print #. L'istruzione Line Input # consente di leggere tutti i caratteri in un file un carattere per volta, fino al ritorno a capo (Chr(13)) o alla sequenza ritorno a capo–avanzamento riga (Chr(13) + Chr(10)). Le sequenze ritorno a capo–avanzamento riga vengono ignorate e non aggiunte alla stringa di caratteri. Input #numerofile, elencovariabili Line Input #numerofile, elencovariabili elencovariabili = variabile che prende il valore della prima riga del file Dim testo as String Open "C:\Pova.txt" for input As #1 Line Input#1,testo close #1 'Chiusura File
38 - Scrittura dati in un File di testo (print/write) Lettura dati di un file di testo Il file deve essere aperto con modalità Output Vi sono 2 Metodi per scrivere i dati Print: Scrive dati formattati per la visualizzazione in un file ad accesso sequenziale. Write: I dati scritti tramite Write # vengono in genere letti da un file con Input # . I dati numerici vengono sempre scritti utilizzando il punto (.) come separatore decimale. I dati di tipo Boolean vengono stampati i valori #TRUE# o #FALSE# I dati di tipo Stringa vengono stampati i valori tra Virgolette In entrambi i codici vengono aggiunti in automatico i carateeri di andata a capo (Chr(13) + Chr(10)) write#numerofile, elencovariabili oppure Print#numerofile, elencovariabili elencovariabili = Una o più espressioni numeriche o espressioni stringa delimitate da virgole che si desidera scrivere sul file. 'apertura file in Lettura Open "C:\Pova.txt" for Input As #1 Input #1, testo 'Legge la 1° riga del file Input #1, testo 'Legge la 2° riga del file close #1 'Chiusura File 'Lettura competa di un file 'Questo esempio legge un intero file 'Visualizza una finestra per ogni riga contenuta nel file Open "C:\Pova.txt" for Input As #1 do Until EOF(1) Line Input #1, testo 'Legge la riga del file msgbox testo 'Visualizza riga letta loop close #1 'Chiusura File 'Apertura file in Scrittura Open "C:\Pova.txt" for output As #1 write #1, "Sono a casa" 'Scrive la 1° riga del file write #1, "Seconda Riga" 'Scrive la 2° riga del file close #1 'Chiusura File
39 - Esempi funzione timer Public Function TestTimer() Dim PauseTime, Start, Finish, TotalTime If (MsgBox("Press Yes to pause for 5 seconds", 4)) = vbYes Then PauseTime = 5 ' Set duration. Start = Timer ' Set start time. Do While Timer > Start + PauseTime DoEvents ' Yield to other processes. Loop Finish = Timer ' Set end time. TotalTime = Finish - Start ' Calculate total time. MsgBox "Paused for " & TotalTime & " seconds" Else End End If End Function
40 - Compatta e ripristina database Private Sub CompattaERipristina_Click() Dim sDataFile As String, sDataFileTemp As String, sDataFileBackup As String Dim s1 As Long, s2 As Long On Error GoTo ERRORI If Me.CCAnnoCompattazione = "" Or IsNull(Me.CCAnnoCompattazione) Then MsgBox "ATTENZIONE! Selezionare l'anno del database da ripristinare" Exit Sub End If sDataFile = "C:\PERCORSO\" & Me.CCAnnoCompattazione & ".accdb" sDataFileTemp = "C:\PERCORSO\" & Me.CCAnnoCompattazione & "TEMP.accdb" sDataFileBackup = "C:\PERCORSO\" & Me.CCAnnoCompattazione & "BACKUP " & Format(Now, "YYYY-MM-DD HHMMSS") & ".accdb" DoCmd.Hourglass True 'get file size before compact Open sDataFile For Binary As #1 s1 = LOF(1) Close #1 'backup data file FileCopy sDataFile, sDataFileBackup 'only proceed if data file exists If Dir(sDataFileBackup) <> "" Then 'compact data file to temp file On Error Resume Next Kill sDataFileTemp On Error GoTo 0 DBEngine.CompactDatabase sDataFile, sDataFileTemp If Dir(sDataFileTemp, vbNormal) <> "" Then 'delete old data file data file Kill sDataFile 'copy temp file to data file FileCopy sDataFileTemp, sDataFile 'get file size after compact Open sDataFile For Binary As #1 s2 = LOF(1) Close #1 DoCmd.Hourglass False 'MsgBox "Compact complete " & vbCrLf & vbCrLf _ & "Size before: " & Round(s1 / 1024 / 1024, 2) & "Mb" & vbCrLf _ & "Size after: " & Round(s2 / 1024 / 1024, 2) & "Mb", vbInformation Else DoCmd.Hourglass False MsgBox "ERROR: Unable to compact data file" End If Else DoCmd.Hourglass False MsgBox "ERROR: Unable to backup data file" End If DoCmd.Hourglass False MsgBox "FINE COMPATTAZIONE, DATABASE RECUPERATO, VERIFICARE" ERRORI: If Err.Number = 3343 Then MsgBox "IL DATABASE NON ESISTE!" DoCmd.Hourglass False Else DoCmd.Hourglass False End If End Sub
41 - Funzione collegata tabelle database anni diversi Public Function ModificaAnnoDB(ANNO As Integer) Dim Rst1 As New ADODB.Recordset Dim DATABASE As DAO.Database Dim n As Integer, TableArray() As String Dim TFileName As String, LinkedTable As TableDef, I As Integer DoCmd.Hourglass True n = 9 ReDim TableArray(1 To n) ' Tabelle esistenti sul database esterno... TableArray(1) = "Tabella1" TableArray(2) = "Tabella2" TableArray(3) = "Tabella3" TableArray(4) = "Tabella4" TableArray(5) = "Tabella5" TableArray(6) = "Tabella6" TableArray(7) = "Tabella7" TableArray(8) = "Tabella8" TableArray(9) = "Tabella9" ' ... che si vogliono collegare al database corrente con lo stesso nome For I = 1 To n On Error Resume Next CurrentDb.Execute "DROP TABLE " & TableArray(I) Next I CurrentDb.TableDefs.Refresh Set DATABASE = CurrentDb ' Database esterno TFileName = "C:\PERCORSO\NOME_DATABASE" & ANNO & ".accdb" DoCmd.Hourglass True ReDim TableArray(1 To n) ' Tabelle esistenti sul database esterno... TableArray(1) = "Tabella1" TableArray(2) = "Tabella2" TableArray(3) = "Tabella3" TableArray(4) = "Tabella4" TableArray(5) = "Tabella5" TableArray(6) = "Tabella6" TableArray(7) = "Tabella7" TableArray(8) = "Tabella8" TableArray(9) = "Tabella9" ' ... che si vogliono collegare al database corrente con lo stesso nome For I = 1 To n Set LinkedTable = DATABASE.CreateTableDef(TableArray(I)) LinkedTable.Connect = ";DATABASE=" & TFileName LinkedTable.SourceTableName = TableArray(I) DATABASE.TableDefs.Append LinkedTable Next I DATABASE.TableDefs.Refresh ' AGGIUNGO L'ANNO NELL'APPOSITA TABELLA DoCmd.RunSQL "DELETE * FROM T_ANNO_DB" Rst1.CursorLocation = adUseClient Rst1.Open "SELECT ANNO FROM T_ANNO_DB", CurrentProject.Connection, adOpenDynamic, adLockOptimistic ' MEMORIZZO L'ANNO CORRETTO NELLA TABELLA [T_ANNO_DB] If Rst1.RecordCount = 0 Then Rst1.AddNew If ANNO = 9999 Then Rst1!ANNO = "T E S T" Else Rst1!ANNO = Mid(ANNO, 1, 1) & " " & Mid(ANNO, 2, 1) & " " & Mid(ANNO, 3, 1) & " " & Mid(ANNO, 4, 1) End If Rst1.Update End If ' REIMPOSTO L'ANNO CORRETTO SULL'ETICHETE [ANNO] DELLA HOME PAGE If ANNO = 9999 Then Me.EtiANNO.Caption = "T E S T" Else Me.EtiANNO.Caption = Rst1!ANNO End If Rst1.Close DoCmd.Hourglass False Forms!INIZIO.Refresh Set Rst1 = Nothing End Function
42 - Copia campi tipo ALLEGATO Public Function CopiaAllegato(NomeCampo As String, NomeTabella As String, numero As Integer, pag As Integer, TipoCiclo As String) ' CODICE PER LA COPIA DELL'ALLEGATO Dim rsSource As DAO.Recordset Dim rsDest As DAO.Recordset Dim rsPicturesSource As DAO.Recordset Dim rsPicturesDest As DAO.Recordset Dim strPath As String If Dir("C:\PERCORSO\_temp", vbDirectory) = "" Then MkDir ("C:\PERCORSO\_temp") Else Kill ("C:\PERCORSO\_temp\.") End If strPath = "C:\PERCORSO\\_temp" Set rsSource = CurrentDb.OpenRecordset("SELECT * FROM " & NomeTabella & " WHERE numero = " & numero & " AND pag = " & pag & " AND TIPO_CICLO = '" & TipoCiclo & "'") Set rsDest = CurrentDb.OpenRecordset("SELECT * FROM " & NomeTabella & " WHERE numero = " & numero & " AND pag = " & pag & " AND TIPO_CICLO = '" & TipoCiclo & "'") Set rsPicturesSource = rsSource.Fields(NomeCampo).Value While Not rsPicturesSource.EOF ' rsPicturesSource.Fields("FileData").SaveToFile strPath & "\" & rsPicturesSource.Fields("FileName") ' SALVO CON UN NOME CHE DEFINISCO IO PER NON AVER 2 O PIU' FILE CON LO STESSO NOME rsPicturesSource.Fields("FileData").SaveToFile strPath & "\Disegno" & I & Right(rsPicturesSource.Fields("FileName"), 4) rsDest.Edit Set rsPicturesDest = rsDest.Fields(NomeCampo).Value rsPicturesDest.AddNew ' rsPicturesDest.Fields("FileData").LoadFromFile strPath & "\" & rsPicturesSource.Fields("FileName") rsPicturesDest.Fields("FileData").LoadFromFile strPath & "\Disegno" & I & Right(rsPicturesSource.Fields("FileName"), 4) rsPicturesDest.Update rsDest.Update rsPicturesSource.MoveNext I = I + 1 Wend Kill ("C:\PERCORSO\_temp\.") RmDir ("C:\PERCORSO\_temp") rsSource.Close rsDest.Close Set rsSource = Nothing Set rsPicturesSource = Nothing Set rsPicturesDest = Nothing Set rsDest = Nothing End Function
43 - Duplica record Private Sub ComDuplicaREC_Click() Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Messaggio = "DUPLICARE IL RECORD?" & Chr(13) Stile = vbYesNo + vbCritical + vbDefaultButton2 Titolo = "ATTENZIONE" Risposta = MsgBox(Messaggio, Stile, Titolo) If Risposta = vbYes Then ' TROVO IL NUMERO PIU' ALTO DEL CAMPO CHIAVE PRIMARIA/INDICE E LO AUMENTO DI 1 Rst1.CursorLocation = adUseClient Rst1.Open "SELECT numero FROM TABELLA ORDER BY numero desc", CurrentProject.Connection, adOpenDynamic, adLockOptimistic MaxNumCert = Rst1!numero Rst1.Close NumRecordTabella = CurrentDb.TableDefs("TABELLA").Fields.Count Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM TABELLA WHERE numero = " & Me.numero, CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst2.CursorLocation = adUseClient Rst2.Open "SELECT * FROM TABELLA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount = 1 Then Rst2.AddNew Rst2!numero = MaxNumCert + 1 For PosCampo = 1 To NumRecordTabella If Not IsNull(Rst1.Fields(PosCampo)) Then On Error Resume Next Rst2.Fields(PosCampo) = Rst1.Fields(PosCampo) Else Rst2.Fields(PosCampo) = Null End If Next PosCampo Rst2.Update MsgBox "RECORD DUPLICATO" End If Rst1.Close Rst2.Close Forms!M_MASCHERA.Requery DoCmd.RunCommand acCmdRecordsGoToLast End If Set Rst1 = Nothing Set Rst2 = Nothing End Sub
44 - Set db [CurrentDb, OpenDatabase()] Dim db As DAO.Database Set db = CurrentDb Set db = OpenDatabase("C:\PERCORSO\DBAccess.accdb")
45 - Errore Access: query danneggiata A causare il problema sono gli aggiornamenti: - KB4484127 per Windows a 64 bit - KB4484119 per Windows a 32 bit
46 - Trova record in FORMS/Vai al record ' CHIUDENDO E RIAPRENDO FUNZIONA DoCmd.Close DoCmd.OpenForm "M_CPU_SP_master", acNormal, , "DISEGNO = '" & DisegnoORIGINALE & "-BIS" & "'" ' OPPURE Dim rs As Object Set rs = Me.Recordset.Clone rs.FindFirst "[disegno] = '" & DisegnoORIGINALE & "-BIS" & "'" If Not rs.EOF Then Me.Bookmark = rs.Bookmark
47 - Macro/Vba 32/64 bit Riguarda l'errore: Errore di Run-Time-214741848 (80010108) Metodo 'EOF' dell'oggetto _Recordset' non riuscito.
48 - Aprire DB Access da altro DB Access Call Shell(SysCmd(acSysCmdAccessDir) & "MSAccess.exe " & Chr(34) & ".....\.......\.....\NomeFile.accdb" & Chr(34), vbMaximizedFocus) DoCmd.Quit acSave
49 - Funzione Sleep per ritardare esecuzione codice Si inserisce il codice seguente nel modulo API e si crea la funzione Sleep1Sec (per creare una funzione che rallenta l'esecuzione 1s) Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Sub SleepMilliSeconds(pnMilliseconds As Long) Sleep pnMilliseconds End Sub Call SleepMilliSeconds(1000) ' FERMO L'ESECUZIONE PER 1 Sec che poi richiameremo nelle funzioni che vogliamo rallentare
50 -
S1 - Script1 - Cancellazione file e directory con più di N giorni FORFILES /P "C:\--PERCORSO--\" /M . /D -180 /C "CMD /C DEL @PATH" FORFILES /P "C:\--PERCORSO--\" /D -180 /C "cmd /C if @isdir==TRUE rmdir @path /S /Q"

INDICE

1 - TIPS & TRICKS 1.a) VBA: codice per andare all'ultimo record all'apertura di una maschera 1.b) VBA: codice per compattare e ripristinare il DB (NON FUNZIONA) 1.c) VBA: aggiorna utilizzando il codice che va a utilizzare il pulsante AGGIORNA sulla ribbon 2) VBA: inserire un VAI A CAPO (INVIO) 3) Azzerare un campo contatore 4) Trasformare il mouse in clessidra 5) N° campi presenti in una tabella dalla finestra immediata di Access 6) MsgBox con sceltra SI/NO/ANNULLA 7) Sintassi nella costruzione di un nome etichetta con variabile 8) Query per ottenere una colonna con un numero progressivo (DA VERIFICARE) 9) ACCESS 2013: visualizzare gli oggetti nascosti 10) Inserire un campo contatore progressivo in un report o query 11) Sintassi WHERE con campo DATA 12) Creare un sottoreport che si "formatta" in orizzontale 13) Proprietà colori campi etichette e textbox 14) Proprietà formattazione campi etichette e textbox 15) Personalizzare le impostazioni predefinite per i database 16) Definizione di una costante 17) Apertura applicazione con Shell 18) Esegui command01 da command02 19) Passare un recordset ad una funzione 2 - Esempio base ADO/DAO 3 - Invio e@mail di gruppo 4 - Riorganizzare il campo priorità di una sottotabella 5 - Invio e@mail singola 6 - Oggi si festeggia (ricorrenze all'aperture di Access) 7 - Copia dati in nuova tabella 8 - Quante volte ricorre un carattere in una stringa 9 - Dimensiona le colonne di una SSTAB 10 - Funzione GestioneLoghi(Me.Report.Name) 11 - Aprire il FORM Windows per sfogliare le cartelle e solezionare un file (PDF) 12 - Leggere dati da un foglio EXCEL collegato come tabella 13 - Abilita Maiuscolo 14 - Scrivendo un carattere nella cella VERDE nella ROSSA esce il corrispettivo n ASCII 15 - Contatori su FORM / Progressivo elaborazione

16 - Funzioni Nz, CtrlSeNULL, CtrlSeZERO, CtrlSeVUOTO, CtrlSeVUOTOeZERO 17 - Funzioni MASSIMO e MINIMO su un array 18 - Leggi dati da foglio EXCEL (.xlsx) 19 - Q_ZeroAlSecondoDecimale 20 - Inserire numero progressivo in query di ordinamento 21 - Funzione che ritorna più parametri 22 - Il comando LIKE nel codice VBA 23 - Assegnare via codice il recordsource 24 - Aprire un recordset su un'altro DB 25 - Form ricerca dati 26 - Collegare una tabella da codice (DAO) 27 - Eliminare una tabella da codice (DAO) 28 - Passare il nome della FORM ad una funzione 29 - Funzione GestPagIniFin("Nome_Report") 30 - CancellaRecord("NOME_TAB", "NOME_FORM", CP1, CP2) 31 - Gestione Data Estesa 32 - Copy file da un percorso ad un altro 33 - Assegnare permessi a cartelle - funzione icacls 34 - Query con nome tabella parametrizzato 35 - Scrivere in file Excel xlsx 36 - Apertura e chiusura file di testo (open) 37 - Lettura dati di un file di testo (input/Line Input) 38 - Scrittura dati in un File di testo (print/write) 39 - Esempi funzione timer 40 - Compatta e ripristina database 41 - Funzione collegata tabelle database anni diversi 42 - Copia campi tipo ALLEGATO 43 - Duplica record 44 - Set db [CurrentDb, OpenDatabase()] 45 - Errore Access: query danneggiata 46 - Trova record in FORMS/Vai al record 47 - Macro/Vba 32/64 bit 48 - Aprire DB Access da altro DB Access 49 - Funzione Sleep per ritardare esecuzione codice S1 - Script1 - Cancellazione file e directory con più di N giorni

BLOG ACCESS EXPERT (ENG) 10 errori database di Microsoft Access che influenzano le prestazioni Database multiutente in rete, ottimizzazione/query lato server MS Access code (Alessandro Baraldi)

1 - TIPS & TRICKS

1.a) VBA: codice per andare all'ultimo record all'apertura di una maschera: DoCmd.RunCommand acCmdRecordsGoToLast

1.b) VBA: codice per compattare e ripristinare il DB (NON FUNZIONA): DoCmd.RunCommand acCmdCompactDatabase questo però sembra funzionare anche in ACCESS 2016: ' Menu Strumenti SendKeys "(%(S))", False ' Pulsante utilità database SendKeys "u", False ' Pulsante compatta e ripristina DB SendKeys "o", False

1.c) VBA: è come premere il pulsante AGGIORNA RECORD: DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70

2) VBA: inserire un VAI A CAPO (INVIO): Rst1!CAMPO1 & vbCrLf & Rst1!CAMPO2

3) ACCESS 2013: per azzerare un campo contatore si può svuotare la tabella e fare un COMPATTA E RIPRISTINA, oppure cancelare il campo contatore e ricrearlo

4) Trasformare il mouse in clessidra: Screen.MousePointer = 11 ' MOUSE CLESSIDRA Screen.MousePointer = 0 ' MOUSE NORMALE

5) Dalla finestra immediata di Access digitando: ?Currentdb.TableDefs("NOME_TABELLLA").Fields.Count

mi da il totale dei campi contenuti PS: il programma deve essere in ESECUZIONE!

6) MsgBox con sceltra SI/NO/ANNULLA: Dim Messaggio, Stile, Titolo as String Messaggio = "RICHIESTA CHE VIENE MOSTRATA ALL'UTENTE" & Chr(13) Stile = vbYesNo + vbCritical + vbDefaultButton2 Titolo = "ATTENZIONE" Risposta = MsgBox(Messaggio, Stile, Titolo) If Risposta = vbYes Then ..... else exit sub end if

7) Sintassi nella costruzione di un nome etichetta con variabile: Me("PARTE_FISSA" & VARIABILE & "PARTE_FISSA").Caption Sintassi nella costruzione di un nome TABELLA con variabile: Rst1.Open "SELECT * FROM T_PARTE1_" & Rst2!T_PARTE2, CurrentProject.Connection, adOpenDynamic, adLockOptimistic se Rst2!T_PARTE2 = "TEST" selezionerò i record dalla tabella: T_PARTE1_TEST

8) Query per ottenere una colonna con un numero progressivo. Nell'esempio partiamo dalla creazione di una tabella di test: CREATE TABLE test (id int, nome text); Inseriamo dei dati: INSERT INTO Test (Id, Nome) VALUES (9,"Ciccio"); INSERT INTO Test (Id, Nome) VALUES (5,"Pippo"); INSERT INTO Test (Id, Nome) VALUES (3,"Lillo"); E finalmente ecco la query per ottenere le due colonne più una terza colonna con un numero progressivo SELECT Id, Nome, (SELECT Count(*) + 1 FROM Test t2 WHERE t2.id < test.id) AS Progressivo FROM Test ORDER BY Id; Nella slide sotto l'esempio ricostruito sull'ACCESS 2013 Fatture.accdb:

9) ACCESS 2013: visualizzare gli oggetti nascosti: tasto destro sull'area sinistra in un posto vuoto sotto MODULI. Si apre la form:

10) Inserire un campo contatore progressivo in un report o query (per tabella vedi punto 8)

11) Sintassi WHERE con campo DATA "HAVING data >= #" & Forms!M_STAMPE!DAL & "# AND data <= #" & Forms!M_STAMPE!AL & "# AND ...

12) Creare un sottoreport che si "formatta" in orizzontale Per creare una situazione del genere non bisogna impostare NESSUNA proprietà ma aprire il report/sottoreport e selezionare il menù:

si aprirà il form:

dove impostiamo quante volte il sottoreport si ripeterà orizzontalmente (vedi ad es. report CRI)

13) Proprietà colori campi etichette e textbox BackColor = è il colore dello sfondo del controllo ForeColor = è il colore del testo del controllo Codici colori: vbYellow = 65535 vbRed = 255 vbBlue = 16711680 vbGreen = 65280 vbWhite = 16777215 vbBlack = 0 vbCyan = 16776960 vbMagenta = 16711935

14) Proprietà formattazione campi etichette e textbox il GRASSETTO è gestito dalla funzione: FontBold PS: la proprietà FontWeight, può essere utilizzata per impostare lo spessore della linea per il testo di un controllo. La proprietà FontBold consente di velocizzare l'applicazione del formato grassetto al testo, mentre la proprietà FontWeight semplifica la gestione dell'impostazione dello spessore della linea per il testo. il SOTTOLINEATO è gestito dalla funzione: FontUnderline l'ITALICO è gestito dalla funzione: FontItalic

15) Personalizzare le impostazioni predefinite per i database Sono parte delle Opzioni di Access. Di seguito il link dal supporto Office: link

16) Definizione di una costante Public Const PercorsoTXT = "C:\PERCORTO_TXT\"

17) Apertura applicazione con Shell ' ESEMPIO APERTURA PROGRAMMA CALCOLATRICE Call Shell("C:\Windows\WinSxS\wow64_microsoft-windows-calc_31bf3856ad364e35_10.0.17134.1_none_999337e4b8471fe2\CALC.EXE", 1) ' ESEMPIO APERTURA PROGRAMMA PROMPT DEL DOS Call Shell("C:\Windows\WinSxS\wow64_microsoft-windows-commandprompt_31bf3856ad364e35_10.0.17134.1_none_7ae1fd66b7e7b154\cmd.exe")

18) Esegui commando da un altro commando Se ad esempio voglio eseguire il Comando200 dal Comando300 nello stesso form: call Comando200_Click() su due form diversi faremo: call Forms("NOME_FORM").NomeComando_Click (NON FUNZIONA, da verificare)

19) Passare un recordset ad una funzione Public Function FUNZIONE(RST1 As Variant, RST2 As Variant, RST3 As Variant, .... (Vedi DB Demografici)

2 - Esempio base ADO/DAO Function ADO() Dim Rst1 As New ADODB.Recordset Rst1.CursorLocation = adUseClient Rst1.Open "NOME_TABELLA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst1.MoveFirst Rst1.Find "[NOME_CAMPO] = '" & Me.NOME_CAMPO & "'" Me.NOME_CAMPO = Rst1![NOME_CAMPO] Set Rst1 = Nothing End Function

Function DAO1() Dim rs1 As Recordset, rs2 As Recordset Set rs1 = CurrentDb.OpenRecordset("NOME_TABELLA_1", dbOpenDynaset) Set rs2 = CurrentDb.OpenRecordset("NOME_TABELLA_2", dbOpenDynaset) rs1.MoveFirst rs2.MoveFirst While rs1.EOF = False rs2.MoveFirst rs2.FindFirst "CAMPO = '" & rs1![CAMPO] & "'" If rs2.NoMatch = True Then MsgBox "CAMPO = " & rs1!CAMPO End If rs1.MoveNext Wend rs1.Close rs2.Close End Function Function DAO2() Dim Schede As Recordset, Percorsi As Recordset, Anag As Recordset, Certificato As Recordset, NewDB As Database Dim Ultimo As Long Dim i As Integer Set Percorsi = CurrentDb.OpenRecordset("Select * from Percorsi", dbOpenSnapshot) Percorsi.MoveFirst Set Anag = CurrentDb.OpenRecordset("Select * from Anagrafe", dbOpenDynaset) ' LEGGO NEL CAMPO [SCHEDE] DELLA TABELLA [Percorsi], AD ES. CONTENTE IL VALORE: F:\PACCESS\Schede.mdb Set NewDB = OpenDatabase(Percorsi![Schede]) ' LA STRINGA DI CODICE SOPRA EQUIVALE ALLA STRINGA: Set NewDB = OpenDatabase("F:\PACCESS\Schede.mdb") Set Schede = NewDB.OpenRecordset("Select * from Schede Where (date() - DATA) = 8 AND VIDIM = TRUE ", dbOpenSnapshot) If Schede.RecordCount > 0 Then Schede.MoveFirst While Schede.EOF = False Set Certificato = CurrentDb.OpenRecordset("Select * from CPM Order By numero", dbOpenDynaset) Certificato.MoveLast Ultimo = certificato!numero Certificato.MoveFirst Certificato.FindFirst "Commessa = '" & Schede!commessa & "/" & Schede!Posizione & "'" If Certificato.NoMatch = False Then Certificato.Close GoTo .... Else Certificato.AddNew Certificato!Num = Ultimo + 1 Certificato!pag = 1 .... Certificato.Update Certificato.Close .... End Function

3 - Invio di e@mail di gruppo Public Function InvioMailGruppo() Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Dim ListaIndEmail As String Dim UltimoIndirizzo As Integer Dim ContaIndirizzi As Integer On Error GoTo Errori Rst1.CursorLocation = adUseClient Rst2.CursorLocation = adUseClient Rst1.Open "SELECT * FROM [Q_Anag_x_invio_email] WHERE [INVIO_MAIL] = true", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst2.Open "T_CAMPI_MAIL", CurrentProject.Connection, adOpenDynamic, adLockOptimistic UltimoIndirizzo = Rst1.RecordCount ContaIndirizzi = 1 ListaIndEmail = "" Rst1.MoveFirst While Not Rst1.EOF If ContaIndirizzi = UltimoIndirizzo Then ListaIndEmail = ListaIndEmail & Rst1!Numero Else ListaIndEmail = ListaIndEmail & Rst1!Numero & ";" End If ContaIndirizzi = ContaIndirizzi + 1 Rst1.MoveNext Wend DoCmd.SendObject , "", "", ListaIndEmail, , , Rst2!OGGETTO2, Rst2!Testo2, False, "" Set Rst1 = Nothing Set Rst2 = Nothing Errori: If Err.Number = 2293 Then MsgBox ("Per inviare devi acconsentire") Exit Function End If End Function

4 - Riorganizzare il campo priorità di una sottotabella Public Function RiorganizzaPriorita() Dim Rst1 As New ADODB.Recordset Dim INCR_PRIORITA As Integer Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM ST1_TITOLO" & TitoloTab & " " & _ "WHERE ID_TP = " & Forms![01_M_PRINCIPALE].ID_TP & " ORDER BY PRIORITA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic INCR_PRIORITA = 5 If Rst1.RecordCount > 0 Then Rst1.MoveFirst While Not Rst1.EOF Rst1!PRIORITA = INCR_PRIORITA Rst1.Update INCR_PRIORITA = INCR_PRIORITA + 5 Rst1.MoveNext Wend Forms![01_M_PRINCIPALE].Refresh Set Rst1 = Nothing End Function

5 - Invio e@mail singola Public Function InviaMail(INDIRIZZO As String, Titolo As String, NOMINATIVO As String) 'DoCmd.SendObject , "", "", "morosini@insor.it", , , "Auguri di buon compleanno", "La Cooperativa Arcobaleno le porge i più sinceri auguri per il suo compleanno. ", False, "" DoCmd.SendObject , "", "", INDIRIZZO, , , "Auguri!" & Titolo & " " & NOMINATIVO, "La Cooperativa Arcobaleno le porge i più sinceri auguri per il suo compleanno. ", False, "" End Function

6 - Oggi si festeggia (ricorrenze all'aperture di Access) Public Function OggiSiFesteggia2() Dim Rst1 As New ADODB.Recordset Dim GIORNO As String Dim GIORNO1 As String Dim GIORNO2 As String Dim Mese As String Dim Festeggiati As String On Error GoTo Errori Rst1.CursorLocation = adUseClient GIORNO = Day(Date) Mese = Month(Date) ' Se è Venerdì mostrami anche gli anniversari di Sabato e Domenica If Weekday(Date) = 6 Then If GIORNO = 27 And Mese = 2 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0227"" or MESE_GIORNO=""0228"" or MESE_GIORNO=""0301""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 29 And Mese = 4 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0429"" or MESE_GIORNO=""0430"" or MESE_GIORNO=""0501""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 29 And Mese = 6 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0629"" or MESE_GIORNO=""0630"" or MESE_GIORNO=""0701""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 29 And Mese = 9 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0929"" or MESE_GIORNO=""0930"" or MESE_GIORNO=""1001""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 29 And Mese = 11 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1129"" or MESE_GIORNO=""1130"" or MESE_GIORNO=""1201""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 1 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0130"" or MESE_GIORNO=""0131"" or MESE_GIORNO=""0201""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 3 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0330"" or MESE_GIORNO=""0331"" or MESE_GIORNO=""0401""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 5 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0530"" or MESE_GIORNO=""0531"" or MESE_GIORNO=""0601""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 7 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0730"" or MESE_GIORNO=""0731"" or MESE_GIORNO=""0801""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 8 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0830"" or MESE_GIORNO=""0831"" or MESE_GIORNO=""0901""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 10 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1030"" or MESE_GIORNO=""1031"" or MESE_GIORNO=""1101""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 12 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1230"" or MESE_GIORNO=""1231"" or MESE_GIORNO=""0101""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 28 And Mese = 2 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0228"" or MESE_GIORNO=""0301"" or MESE_GIORNO=""0302""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 4 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0430"" or MESE_GIORNO=""0501"" or MESE_GIORNO=""0502""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 6 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0630"" or MESE_GIORNO=""0701"" or MESE_GIORNO=""0702""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 9 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0930"" or MESE_GIORNO=""1001"" or MESE_GIORNO=""1002""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 30 And Mese = 11 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1130"" or MESE_GIORNO=""1101"" or MESE_GIORNO=""1202""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 1 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0131"" or MESE_GIORNO=""0201"" or MESE_GIORNO=""0202""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 3 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0331"" or MESE_GIORNO=""0401"" or MESE_GIORNO=""0402""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 5 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0531"" or MESE_GIORNO=""0601"" or MESE_GIORNO=""0602""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 7 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0731"" or MESE_GIORNO=""0801"" or MESE_GIORNO=""0802""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 8 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""0831"" or MESE_GIORNO=""0901"" or MESE_GIORNO=""0902""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 10 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1031"" or MESE_GIORNO=""1101"" or MESE_GIORNO=""1102""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic ElseIf GIORNO = 31 And Mese = 12 Then Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = ""1231"" or MESE_GIORNO=""0101"" or MESE_GIORNO=""0102""", _ CurrentProject.Connection, adOpenDynamic, adLockOptimistic Else If Len(Trim(Mese)) = 1 Then Mese = "0" & Mese End If If Len(Trim(GIORNO)) = 1 Then GIORNO = "0" & GIORNO GIORNO1 = "0" & GIORNO + 1 If Len(GIORNO1) > 2 Then GIORNO1 = GIORNO + 1 End If GIORNO2 = "0" & GIORNO + 2 If Len(GIORNO2) > 2 Then GIORNO2 = GIORNO + 2 End If ElseIf Len(Trim(GIORNO)) = 2 Then GIORNO = GIORNO GIORNO1 = GIORNO + 1 If Len(GIORNO1) > 2 Then GIORNO1 = Right(GIORNO + 1, 2) End If GIORNO2 = GIORNO + 2 If Len(GIORNO2) > 2 Then GIORNO2 = Right(GIORNO + 2, 2) End If End If Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr WHERE MESE_GIORNO = '" & Mese & GIORNO & "' or _ MESE_GIORNO = '" & Mese & GIORNO1 & "' or MESE_GIORNO = '" & Mese & GIORNO2 & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic End If Else If Len(Trim(Mese)) = 1 Then Mese = "0" & Mese End If If Len(Trim(GIORNO)) = 1 Then GIORNO = "0" & GIORNO End If Rst1.Open "SELECT * FROM Q_Ann_Comp_Ricorr_2 WHERE MESE_GIORNO = '" & Mese & GIORNO & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic End If Festeggiati = "" If Rst1.RecordCount > 0 Then Rst1.MoveFirst End If While Not Rst1.EOF ' SE IL GIORNO DELLA SETTIMANA E' VENERDI' (WEEKDAY=6) If Weekday(Date) = 6 Then Festeggiati = Festeggiati & "Il " & Rst1![GIORNO] & " " & Rst1![Mese] & ": " & Rst1![COSA_FESTEGGIANO] & " di " & Rst1![NOMINATIVO] & Chr(13) 'Festeggiati = Festeggiati & AggiuntaGiorniOre Rst1.MoveNext Else Festeggiati = Festeggiati & Rst1![COSA_FESTEGGIANO] & " di " & Rst1![NOMINATIVO] & Chr(13) 'Festeggiati = Festeggiati & AggiuntaGiorniOre Rst1.MoveNext End If Wend If Rst1.RecordCount <> 0 And Weekday(Date) = 6 Then If GIORNO = 27 And Mese = 2 Then MsgBox ("Oggi Venerdi 27 febbraio, domani Sabato 28 febbraio e Domenica 1 marzo si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 29 And Mese = 4 Then MsgBox ("Oggi Venerdi 29 aprile, domani Sabato 30 aprile e Domenica 1 maggio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 29 And Mese = 6 Then MsgBox ("Oggi Venerdi 29 giugno, domani Sabato 30 giugno e Domenica 1 luglio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 29 And Mese = 9 Then MsgBox ("Oggi Venerdi 29 settembre, domani Sabato 30 settembre e Domenica 1 ottobre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 29 And Mese = 11 Then MsgBox ("Oggi Venerdi 29 novembre, domani Sabato 30 novembre e Domenica 1 dicembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 1 Then MsgBox ("Oggi Venerdi 30 gennaio, domani Sabato 31 gennaio e Domenica 1 febbraio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 3 Then MsgBox ("Oggi Venerdi 30 marzo, domani Sabato 31 marzo e Domenica 1 aprile si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 5 Then MsgBox ("Oggi Venerdi 30 maggio, domani Sabato 31 maggio e Domenica 1 giugno si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 7 Then MsgBox ("Oggi Venerdi 30 luglio, domani Sabato 31 luglio e Domenica 1 agosto si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 8 Then MsgBox ("Oggi Venerdi 30 agosto, domani Sabato 31 agosto e Domenica 1 settembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 10 Then MsgBox ("Oggi Venerdi 30 ottobre, domani Sabato 31 ottobre e Domenica 1 novembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 12 Then MsgBox ("Oggi Venerdi 30 dicembre, domani Sabato 31 dicembre e Domenica 1 gennaio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 28 And Mese = 2 Then MsgBox ("Oggi Venerdi 28 febbraio, domani Sabato 1 marzo e Domenica 2 marzo si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 4 Then MsgBox ("Oggi Venerdi 30 aprile, domani Sabato 1 maggio e Domenica 2 maggio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 6 Then MsgBox ("Oggi Venerdi 30 giugno, domani Sabato 1 luglio e Domenica 2 luglio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 9 Then MsgBox ("Oggi Venerdi 30 settembre, domani Sabato 1 ottobre e Domenica 2 ottobre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 30 And Mese = 11 Then MsgBox ("Oggi Venerdi 30 novembre, domani Sabato 1 dicembre e Domenica 2 dicembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 1 Then MsgBox ("Oggi Venerdi 31 gennaio, domani Sabato 1 febbraio e Domenica 2 febbraio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 3 Then MsgBox ("Oggi Venerdi 31 marzo, domani Sabato 1 aprile e Domenica 2 aprile si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 5 Then MsgBox ("Oggi Venerdi 31 maggio, domani Sabato 1 giugno e Domenica 2 giugno si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 7 Then MsgBox ("Oggi Venerdi 31 luglio, domani Sabato 1 agosto e Domenica 2 agosto si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 8 Then MsgBox ("Oggi Venerdi 31 agosto, domani Sabato 1 settembre e Domenica 2 settembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 10 Then MsgBox ("Oggi Venerdi 31 ottobre, domani Sabato 1 novembre e Domenica 2 novembre si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) ElseIf GIORNO = 31 And Mese = 12 Then MsgBox ("Oggi Venerdi 31 dicembre, domani Sabato 1 gennaio e Domenica 2 gennaio si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) Else If Mese = 1 Then Mese = "Gennaio" ElseIf Mese = 2 Then Mese = "Febbraio" ElseIf Mese = 3 Then Mese = "Marzo" ElseIf Mese = 4 Then Mese = "Aprile" ElseIf Mese = 5 Then Mese = "Maggio" ElseIf Mese = 6 Then Mese = "Giugno" ElseIf Mese = 7 Then Mese = "Luglio" ElseIf Mese = 8 Then Mese = "Agosto" ElseIf Mese = 9 Then Mese = "Settembre" ElseIf Mese = 10 Then Mese = "Ottobre" ElseIf Mese = 11 Then Mese = "Novembre" ElseIf Mese = 12 Then Mese = "Dicembre" End If MsgBox ("Oggi Venerdi " & CInt(GIORNO) & ", domani Sabato " & CInt(GIORNO + 1) & " e Domenica " & CInt(GIORNO + 2) & " " & Mese & " si festeggia (o si ricorda):" & _ Chr(13) & Chr(13) & Festeggiati) End If ElseIf Rst1.RecordCount <> 0 And Weekday(Date) <> 6 Then MsgBox ("Oggi " & Date & " si festeggia (o si ricorda):" & Chr(13) & Chr(13) & Festeggiati) Else MsgBox ("Oggi " & Date & " non si festeggia (o si ricorda) niente.") End If Set Rst1 = Nothing Errori: If Err.Number = 3021 Then MsgBox ("Oggi " & Date & " non si festeggia (o si ricorda) niente.") PrimoAccesso = False End If

7 - Copia dati in nuova tabella Public Function CopiaDatiInNewTab() Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Dim Rst3 As New ADODB.Recordset Dim IDTESTA As Double Dim InizCorpo As String On Error GoTo Errori Rst1.CursorLocation = adUseClient Rst2.CursorLocation = adUseClient Rst3.CursorLocation = adUseClient Rst1.Open "DATI", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst2.Open "DATI_TESTA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst3.Open "DATI_CORPO", CurrentProject.Connection, adOpenDynamic, adLockOptimistic 'DoCmd.OpenQuery "Q_SVUOTA_TAB_DATI ' PARTE INSERIMENTO RECORD DI TESTA Rst2.AddNew Rst1.MoveFirst While Not Rst1.EOF If Mid(Rst1!CAMPO1, 1, 4) = "DATE" And IsNull(Rst1!CAMPO2) Then Rst2!DATA = Mid(Rst1!CAMPO1, 5) Rst1.MoveNext ElseIf IsNull(Rst1!CAMPO1) And Not IsNull(Rst1!CAMPO2) And Mid(Rst1!CAMPO2, 1) <> "Lunghezza tot./LENGTH" Then Dim CAMPO As String CAMPO = Mid(Rst1!CAMPO2, 1, 4) Select Case CAMPO Case "TIME" Rst2!ORA = Mid(Rst1!CAMPO2, 5) Case "OPER" Rst2!OPERATORE = Mid(Rst1!CAMPO2, 11) Case "PROV" Rst2!PROVA = Mid(Rst1!CAMPO2, 11) Case "CLIE" Rst2!CLIENTE = Mid(Rst1!CAMPO2, 9) End Select Rst1.MoveNext ElseIf IsNull(Rst1!CAMPO1) And Mid(Rst1!CAMPO2, 1) = "Lunghezza tot./LENGTH" Then Rst1.MoveLast ElseIf Mid(Rst1!CAMPO1, 1, 3) = "END" Then Rst1.MoveNext End If Wend Rst2.Update IDTESTA = Rst2!ID_TESTA ' PARTE INSERIMENTO RECORD DEL CORPO Rst1.MoveFirst InizCorpo = "Lunghezza tot./LENGTH" Rst1.Find "[CAMPO2] = '" & InizCorpo & "'" While Not Rst1.EOF And IsNull(Rst1!CAMPO1) Rst3.AddNew Rst3!ID_TESTA = IDTESTA Rst3!COLONNA1 = Rst1!CAMPO2 'DESCRIZIONE Rst3!COLONNA2 = Rst1!CAMPO3 'NOMINALE Rst3!COLONNA3 = Rst1!Campo4 'RILEVATO Rst3!COLONNA4 = Rst1!Campo5 'TOLLERANZA+ Rst3!COLONNA5 = Rst1!Campo6 'TOLLERANZA- Rst3!COLONNA6 = Rst1!campo7 'DEVIAZIONE Dim ValTolMax, ValTolMin, ValDEV, RangeTOT, RangePARZ As Single ValTolMax = CSng(Rst1!Campo5) ValTolMin = CSng(Rst1!Campo6) ValDEV = CSng(Rst1!campo7) RangeTOT = ValTolMax - ValTolMin RangePARZ = RangeTOT / 8 Select Case ValDEV Case ValTolMin To ValTolMin + RangePARZ Rst3![F-TOLL] = "----" Case ValTolMin + RangePARZ To ValTolMin + RangePARZ * 2 Rst3![F-TOLL] = "---" Case ValTolMin + RangePARZ * 2 To ValTolMin + RangePARZ * 3 Rst3![F-TOLL] = "--" Case ValTolMin + RangePARZ * 3 To ValTolMin + RangePARZ * 4 Rst3![F-TOLL] = "-" Case ValTolMin + RangePARZ * 4 To ValTolMin + RangePARZ * 5 Rst3![F-TOLL] = "+" Case ValTolMin + RangePARZ * 5 To ValTolMin + RangePARZ * 6 Rst3![F-TOLL] = "++" Case ValTolMin + RangePARZ * 6 To ValTolMin + RangePARZ * 7 Rst3![F-TOLL] = "+++" Case ValTolMin + RangePARZ * 7 To ValTolMax Rst3![F-TOLL] = "++++" Case Is > ValTolMax Rst3![F-TOLL] = ValDEV - ValTolMax Case Is < ValTolMin Rst3![F-TOLL] = ValTolMin + ValDEV End Select Rst3.Update Rst1.MoveNext Wend Set Rst1 = Nothing Set Rst2 = Nothing Set Rst3 = Nothing Errori: If Err.Number = -2147217900 Then MsgBox ("ATTENZIONE! Manca il file DEFINITIVO.STA nella cartella " & PercFileSTA) End If End Function

8 - Quante volte ricorre un carattere in una stringa Public Function QuanteVolte(car As String, str As String) As Long If Len(car) <> 1 Then Err.Raise 5 ' car DEVE essere 1 carattere ! QuanteVolte = Len(str) - Len(Replace(str, car, "", , , vbTextCompare)) End Function

9 - Dimensiona le colonne di una SSTAB Public Function RegolaColonne(Numero As Byte) Dim DimDATA As Integer Dim DimCheck As Integer DimDATA = 1040 DimCheck = 580 Forms![01_M_PRINCIPALE]("SM1_TITOLO" & Numero)!NOME_CAMPO.ColumnWidth = DimDATA Forms![01_M_PRINCIPALE]("SM1_TITOLO" & Numero)!NOME_CAMPO.ColumnWidth = DimCheck End Function

10 - Funzione GestioneLoghi(Me.Report.Name) Call GestioneLoghi(Me.Report.Name) Public Function GestioneLoghi(NomeReport As String) Reports(NomeReport)!ImmLOGO1.Picture = "C:\PERCORSO\Logo1.jpg" Reports(NomeReport)!ImmLOGO2.Picture = "C:\PERCORSO\Logo2.jpg" Reports(NomeReport)!ImmLOGO3.Picture = "C:\PERCORSO\Logo3.jpg" ...... End Function

11 - Sfoglia le cartelle di C: 'APRE SOLO FILE PDF ..... da verificare Public Function SFOGLIA_CARTELLE() Dim sh As Object, obj As Object, cNomefile As String, fso As Object Set sh = CreateObject("Shell.Application") On Error Resume Next Set obj = sh.BrowseForFolder(Me.Hwnd, "Selezionare un file", 16385, 17) If Err.Number <> 0 Then Set obj = Nothing End If On Error GoTo 0 If obj Is Nothing Then cNomefile = "" Else With obj cNomefile = .ParentFolder.ParseName(.Title).Path End With Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(cNomefile) Then cNomefile = "" End If Set fso = Nothing End If Set sh = Nothing If cNomefile <> "" Then txtCasella.Value = cNomefile End If End Sub

12 - Leggere dati da un foglio EXCEL collegato come tabella Public Function LeggiDatiFoglioEXCEL() Dim Rst1 As New ADODB.Recordset Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim A, B, C, D As Integer Set xlApp = CreateObject("Excel.Application") xlApp.Visible = False 'Set xlBook = xlApp.Workbooks.Open(CurrentProject.Path & "\FileDaBanca.xls") Set xlBook = xlApp.Workbooks.Open("C:\Users\riccardo_morosini\Desktop\CANONI_BRENO\PROVA_CANONI.xlsx") Rst1.CursorLocation = adUseClient Rst1.Open "T_TMP_FOGLI", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount > 0 Then Rst1.MoveFirst Set xlSheet = xlBook.Worksheets(NomeFoglio) A = 18 While A <= 60 ' VERIFICO PARTENDO DALLA CELLA [G18]=QUANTITA' SE C'E' UN VALORE If xlSheet.Cells(A, 7) <> "" Then ' SE C'E' If xlSheet.Cells(A, 4) <> "" Then Rst1.AddNew Rst1!CLIENTE = xlSheet.Cells(3, 6) 'F3 Rst1!RIFERIMENTO = xlSheet.Cells(2, 6) 'F2 Rst1!CODICE_PANTHERA = xlSheet.Cells(2, 10) 'J2 Rst1!CODICE1 = xlSheet.Cells(A, 4) 'D&"A" Rst1!CODICE2 = xlSheet.Cells(A, 5) 'E&"A" Rst1!DESCRIZIONE = xlSheet.Cells(A, 6) 'F&"A" Rst1!QUANTITA = xlSheet.Cells(A, 7) 'G&"A" Rst1!CANONE = xlSheet.Cells(A, 95) 'CQ&"A" Rst1!DATA_CONTRATTO = xlSheet.Cells(11, 7) 'G11 Rst1.Update Else ' GENERO UN FILE TXT CONTENENTE IL CLIENTE E LA RIGA CON IL PROBLEMA File_Anomalie = Trim(Rst1!CLIENTE) & ";" & Trim(Rst1!RIFERIMENTO) & ";CODICE1 NON PRESENTE" Print #1, File_Anomalie End If End If A = A + 1 Wend Chiudi: xlBook.Close SaveChanges:=False xlApp.Quit Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing Set Rst1 = Nothing End Function

13 - Abilita Maiuscolo Option Compare Database Option Explicit ' NON MODIFICARE IL NOME DELLA MACRO AUTOEXEC 'Questo modulo consente di applicare una sorta di Protezione e/o 'impostazione di AVVIO in modo Automatico 'Si può utilizzare lanciandola da un Menù sotto Password 'oppure inserendo un controllo nascosto in una Form. 'Consente di Modificare in un solo colpo tutte le proprietà 'del menù di AVVIO compreso ALLOW_BYPASS_KEY ed eventualmente 'la Macro AUTOEXEC. 'Startup properties 'Private Const strAppTitle As String = "ESEMPIO DISABILITAZIONE TASTO MAIUSCOLO" Private Const strAppTitle As String = "INSOR" Private Const strStartUpForm As String = "M_LOGIN" 'Private Const strStartUpMenuBar As String = "mnuPrincipale" Private Const strStartUpMenuBar As String = "" Private Const strStartUpShortcutMenuBar As String = vbNullString Private Const strAppIcon As String = vbNullString Private Const blnStartUpShowDBWindow As Boolean = False Private Const blnStartUpShowStatusBar As Boolean = False Private Const blnAllowShortcutMenus As Boolean = False Private Const blnAllowFullMenus As Boolean = False Private Const blnAllowBuiltInToolbars As Boolean = False Private Const blnAllowToolbarChanges As Boolean = False Private Const blnAllowBreakIntoCode As Boolean = False Private Const blnAllowSpecialKeys As Boolean = False Private Const blnAllowBypassKey As Boolean = False Public Function Secure() On Error Resume Next Call ChangeProperty("AppTitle", dbText, strAppTitle) Call ChangeProperty("StartUpForm", dbText, strStartUpForm) Call ChangeProperty("StartUpMenuBar", dbText, strStartUpMenuBar) Call ChangeProperty("StartupShortcutMenuBar", dbText, strStartUpShortcutMenuBar) Call ChangeProperty("AppIcon", dbText, strAppIcon) Call ChangeProperty("StartUpShowDBWindow", dbBoolean, blnStartUpShowDBWindow) Call ChangeProperty("StartUpShowStatusBar", dbBoolean, blnStartUpShowStatusBar) Call ChangeProperty("AllowShortcutMenus", dbBoolean, blnAllowShortcutMenus) Call ChangeProperty("AllowFullMenus", dbBoolean, blnAllowFullMenus) Call ChangeProperty("AllowBuiltInToolbars", dbBoolean, blnAllowBuiltInToolbars) Call ChangeProperty("AllowToolbarChanges", dbBoolean, blnAllowToolbarChanges) Call ChangeProperty("AllowBreakIntoCode", dbBoolean, blnAllowBreakIntoCode) Call ChangeProperty("AllowSpecialKeys", dbBoolean, blnAllowSpecialKeys) Call ChangeProperty("AllowBypassKey", dbBoolean, blnAllowBypassKey) If CurrentDb.Containers("Scripts").Documents("$Autoexec").Name = "$Autoexec" Then _ EnableAutoExec End Function Public Function UnSecure() On Error GoTo Errori 'Call ChangeProperty("AppTitle", dbText, "My Application is UnSecured") Call ChangeProperty("AppTitle", dbText, strAppTitle) 'Call ChangeProperty("StartUpForm", dbText, vbNullString) 'Call ChangeProperty("StartUpMenuBar", dbText, vbNullString) 'Call ChangeProperty("StartupShortcutMenuBar", dbText, vbNullString) Call ChangeProperty("AppIcon", dbText, vbNullString) Call ChangeProperty("StartUpShowDBWindow", dbBoolean, True) Call ChangeProperty("StartUpShowStatusBar", dbBoolean, True) Call ChangeProperty("AllowShortcutMenus", dbBoolean, True) Call ChangeProperty("AllowFullMenus", dbBoolean, True) Call ChangeProperty("AllowBuiltInToolbars", dbBoolean, True) Call ChangeProperty("AllowToolbarChanges", dbBoolean, True) Call ChangeProperty("AllowBreakIntoCode", dbBoolean, True) Call ChangeProperty("AllowSpecialKeys", dbBoolean, True) Call ChangeProperty("AllowBypassKey", dbBoolean, True) If CurrentDb.Containers("Scripts").Documents("Autoexec").Name = "Autoexec" Then _ DisableAutoExec Errori: If Err.Number = 3265 Then Exit Function End If End Function Public Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Boolean Dim prp As Property On Error GoTo Change_Err If Len(varPropValue) > 0 Then CurrentDb.Properties(strPropName) = varPropValue Else CurrentDb.Properties.Delete strPropName End If ChangeProperty = True Change_Bye: Set prp = Nothing Exit Function Change_Err: Select Case Err Case 3265 'Item not found in this collection. Resume Next Case 3270 'prop not found With CurrentDb Set prp = .CreateProperty(strPropName, varPropType, varPropValue) .Properties.Append prp End With Resume Next Case Else ChangeProperty = False Resume Change_Bye End Select End Function Public Function DisableAutoExec() As Boolean Dim docCiclo As DAO.Document Dim dbs As DAO.Database Set dbs = CurrentDb DisableAutoExec = False For Each docCiclo In dbs.Containers!Scripts.Documents 'Scorre l'insieme Documents del database per verificare la presenza della Macro se esiste la Rinomina If docCiclo.Name = "Autoexec" Then DoCmd.Rename "_Autoexec", acMacro, "Autoexec" DisableAutoExec = True End If Next docCiclo Set dbs = Nothing End Function

Private Function EnableAutoExec() As Boolean Dim docCiclo As DAO.Document Dim dbs As DAO.Database Set dbs = CurrentDb EnableAutoExec = False For Each docCiclo In dbs.Containers!Scripts.Documents 'Scorre l'insieme Documents del database per verificare la presenza della Macro ' se esiste la Rinomina If docCiclo.Name = "_Autoexec" Then DoCmd.Rename "Autoexec", acMacro, "_Autoexec" EnableAutoExec = True End If Next docCiclo Set dbs = Nothing End Function Private Sub BLOCCA_Click() Secure DoCmd.Close End Sub Private Sub OK_Click() If Me.Password = "1234" Then Me.SBLOCCA.Enabled = True Me.BLOCCA.Enabled = True End If End Sub Private Sub SBLOCCA_Click() UnSecure DoCmd.Close End Sub

14 - Scrivendo un carattere nella cella VERDE nella ROSSA esce il corrispettivo n ASCII

Option Compare Database Dim NumTastiPremuti As Integer Public Function Form_KeyDown(KeyCode As Integer, Shift As Integer) Me.COdTastoDigitato = KeyCode Me.ValTastoDigitato = Chr(KeyCode) NumTastiPremuti = NumTastiPremuti + 1 End Sub Public Function Form_KeyUp(KeyCode As Integer, Shift As Integer) If NumTastiPremuti = 1 Then InizializzaVar1 = KeyCode ElseIf NumTastiPremuti = 2 Then InizializzaVar2 = KeyCode ElseIf NumTastiPremuti = 3 Then InizializzaVar3 = KeyCode End If If InizializzaVar1 = "17" And InizializzaVar2 = "16" And InizializzaVar3 = "27" Then MsgBox "Hai premuto CTRL+SHIFT" NumTastiPremuti = 0 InizializzaVar1 = "" InizializzaVar2 = "" InizializzaVar3 = "" ElseIf InizializzaVar1 = "17" And InizializzaVar2 = "16" And InizializzaVar3 = "77" Then MsgBox "Hai premuto CTRL+SHIFT+M" NumTastiPremuti = 0 InizializzaVar1 = "" InizializzaVar2 = "" InizializzaVar3 = "" Else End If End Sub Private Sub Form_Open(Cancel As Integer) InizializzaVar1 = "" InizializzaVar2 = "" InizializzaVar3 = "" Me.COdTastoDigitato = "" Me.ValTastoDigitato = "" NumTastiPremuti = 0 DoCmd.Maximize End Sub

15 - Contatori su FORM / Progressivo elaborazione numPassi = 1 numPasso = numPasso + 1 Forms!M_NOME_FORM![NOME TEXTBOX].Value = "Elabora tabelle: Bonifica I.C.I. (Passo: " & numPasso & "/" & numPassi & ")" Forms!M_NOME_FORM.Repaint Forms!M_NOME_FORM![NOME_LABEL].Caption = "Importa nuove commesse (record: " & RecordAttuale & "/" & TOTNuoveColate & ")" Forms!M_NOME_FORM.Repaint

16 - Funzioni CtrlSeNULL, CtrlSeZERO, CtrlSeVUOTO, CtrlSeVUOTOeZERO Tutte le funzioni sotto possono essere sostituite dalla funzione di sistema Nz È possibile usare la funzione Nz per restituire zero, una stringa di lunghezza zero (" ") oppure un altro valore specificato quando un Variant è Null. Ad esempio, si può usare questa funzione per convertire un valore Null in un altro valore ed evitare che si propaghi tramite un'espressione. Public Function CtrlSeNULL(CampoControllo As Variant) As Variant If IsNull(Trim(CampoControllo)) Then CtrlSeNULL = 0 Else CtrlSeNULL = Trim(CampoControllo) End If End Function Public Function CtrlSeZERO(CampoControllo As Variant) As Variant If Trim(CampoControllo) = 0 Then CtrlSeZERO = "" Else CtrlSeZERO = Trim(CampoControllo) End If End Function Public Function CtrlSeVUOTO(CampoControllo As Variant) As Variant If Trim(CampoControllo) = "" Then CtrlSeVUOTO = Null Else CtrlSeVUOTO = Trim(CampoControllo) End If End Function Public Function CtrlSeVUOTOeZERO(CampoControllo As Variant) As Variant If Trim(CampoControllo) = "" Or Trim(CampoControllo) = 0 Then CtrlSeVUOTOeZERO = Null Else CtrlSeVUOTOeZERO = Trim(CampoControllo) End If End Function

17 - Funzioni MASSIMO e MINIMO su un array Option Compare Database Public Type MinMaxROFase Min As Single Max As Single RO As Single FASE As String End Type Public Function GetMinMaxROFase(L1 As Single, L2 As Single, L3 As Single, L4 As Single, L5 As Single, L6 As Single, L7 As Single, L8 As Single) As MinMaxROFase Dim emp As MinMaxROFase Dim Minimo As Single, Massimo As Single Dim Valori(7) As Single Dim FASE As String ' POPOLA L'ARRAY DI T1 Valori(0) = CtrlSeNULL(L1) ' 0° Valori(1) = CtrlSeNULL(L2) ' 45° Valori(2) = CtrlSeNULL(L3) ' 90° Valori(3) = CtrlSeNULL(L4) ' 135° Valori(4) = CtrlSeNULL(L5) ' 180° Valori(5) = CtrlSeNULL(L6) ' 225° Valori(6) = CtrlSeNULL(L7) ' 270° Valori(7) = CtrlSeNULL(L8) ' 315° Minimo = 1000 Massimo = -1000 FASE = "" For x = 0 To 7 If Valori(x) < Minimo Then Minimo = Valori(x) If Valori(x) > Massimo Then Massimo = Valori(x) If x = 0 Then FASE = "0°" ElseIf x = 1 Then FASE = "45°" ElseIf x = 2 Then FASE = "90°" ElseIf x = 3 Then FASE = "135°" ElseIf x = 4 Then FASE = "180°" ElseIf x = 5 Then FASE = "225°" ElseIf x = 6 Then FASE = "270°" ElseIf x = 7 Then FASE = "315°" End If End If Next 'MsgBox ("Minimo: " & Minimo & " : Massimo " & Massimo) emp.Min = Minimo emp.Max = Massimo emp.RO = Minimo - Massimo emp.FASE = FASE GetMinMaxROFase = emp End Function

18 - Leggi dati da foglio EXCEL (.xlsx) Public Function LeggiDatiFoglio02(NomeFoglio As String) Dim Rst1 As New ADODB.Recordset Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim A, B, C, D As Integer Set xlApp = CreateObject("Excel.Application") xlApp.Visible = False 'Set xlBook = xlApp.Workbooks.Open(CurrentProject.Path & "\FileDaBanca.xls") Set xlBook = xlApp.Workbooks.Open("C:\Users\riccardo_morosini\Desktop\CANONI_BRENO\PROVA_CANONI.xlsx") Rst1.CursorLocation = adUseClient Rst1.Open "T_TMP_FOGLI", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount > 0 Then Rst1.MoveFirst Set xlSheet = xlBook.Worksheets(NomeFoglio) A = 18 While A <= 60 ' VERIFICO PARTENDO DALLA CELLA [G18]=QUANTITA' SE C'E' UN VALORE If xlSheet.Cells(A, 7) <> "" Then ' SE C'E' If xlSheet.Cells(A, 4) <> "" Then Rst1.AddNew Rst1!CLIENTE = xlSheet.Cells(3, 6) 'F3 Rst1!RIFERIMENTO = xlSheet.Cells(2, 6) 'F2 Rst1!CODICE_PANTHERA = xlSheet.Cells(2, 10) 'J2 Rst1!CODICE1 = xlSheet.Cells(A, 4) 'D&"A" Rst1!CODICE2 = xlSheet.Cells(A, 5) 'E&"A" Rst1!DESCRIZIONE = xlSheet.Cells(A, 6) 'F&"A" Rst1!QUANTITA = xlSheet.Cells(A, 7) 'G&"A" Rst1!CANONE = xlSheet.Cells(A, 95) 'CQ&"A" Rst1!DATA_CONTRATTO = xlSheet.Cells(11, 7) 'G11 Rst1.Update Else ' GENERO UN FILE TXT CONTENENTE IL CLIENTE E LA RIGA CON IL PROBLEMA File_Anomalie = Trim(Rst1!CLIENTE) & ";" & Trim(Rst1!RIFERIMENTO) & ";CODICE1 NON PRESENTE" Print #1, File_Anomalie End If End If A = A + 1 Wend Chiudi: xlBook.Close SaveChanges:=False xlApp.Quit Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing Set Rst1 = Nothing End Function

19 - Q_ZeroAlSecondoDecimale NewC: InStr([C];",") NewC2: Mid([C];InStr([C];",")+1) NewC3: IIf(Len(Mid([C];InStr([C];",")+1))>1;Mid([C];InStr([C];",")+1);Mid([C];InStr([C];",")+1) & "0") NewC4: Mid([C];1;InStr([C];",")) & IIf(Len(Mid([C];InStr([C];",")+1))>1;Mid([C];InStr([C];",")+1);Mid([C];InStr([C];",")+1) & "0")

20 - Inserire numero progressivo in query di ordinamento Sotto la slide della query in questione:

Il risultato sarà:

Il codice è questo: NumIncr: (Select Count (*) FROM T_CTT_CICLO_ST1 as A WHERE [A].[ID_CICLO_CTT] < [T_CTT_CICLO_ST1].[ID_CICLO_CTT])+1 Da verificare perchè non funziona .... Ho risolto il problema creando al tabella T_TEMP con un campo ContRecT_CTT_CICLO_ST1 NUMERICO con valore predefinito = 1 Public Function ContaRecord(numero As Long, pag As Integer) As Integer Dim Rst2 As New ADODB.Recordset Dim ValoreIniziale As Integer Rst2.CursorLocation = adUseClient Rst2.Open "SELECT ContRecT_CTT_CICLO_ST1 FROM T_TEMP", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If PrimoRecord Then Rst2!ContRecT_CTT_CICLO_ST1 = 1 Rst2.Update End If ValoreIniziale = Rst2!ContRecT_CTT_CICLO_ST1 ContaRecord = ValoreIniziale Rst2!ContRecT_CTT_CICLO_ST1 = Rst2!ContRecT_CTT_CICLO_ST1 + 1 Rst2.Update PrimoRecord = False Set Rst2 = Nothing End Function

Nella tabella del sottoreport inseriamo il campo NumIncr che ci restituirà il numero del record corrente

21 - Funzione che ritorna più parametri Nelle parte di dichiarazione delle variabili: Option Compare Database Option Explicit ............................ Public Type NumIDDTTarDTScad NumID As String DTTar As String DTScad As String End Type La funzione sarà: Public Function CercaStrumento(NomeStrumento As String) As NumIDDTTarDTScad Dim Rst1 As New ADODB.Recordset Dim emp As NumIDDTTarDTScad Dim IDMorandini, DataTaratura, DataScadenza As String Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM T_CPU_STRUMENTI WHERE NOME_STRUMENTO = '" & Replace(NomeStrumento, "'", "''") & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount = 1 Then emp.NumID = DaNullaVUOTO(Rst1!NUM_IDENTIFICATIVO_MORANDINI) emp.DTTar = DaNullaVUOTO(Rst1!DATA_TARATURA_STRUMENTO) emp.DTScad = DaNullaVUOTO(Rst1!DATA_SCADENZA_STRUMENTO) Else emp.NumID = "" emp.DTTar = "" emp.DTScad = "" End If CercaStrumento = emp Set Rst1 = Nothing End Function Questa funzione potrà essere usata nel seguente modo all'interno del programma: If Not IsNull(Me.STRUMENTO) Then Me.ETI_NUMERO_ID.Caption = CercaStrumento(Me.STRUMENTO).NumID Me.ETI_DATA_SCA.Caption = CercaStrumento(Me.STRUMENTO).DTScad Me.ETI_DATA_TAR.Caption = CercaStrumento(Me.STRUMENTO).DTTar Else Me.ETI_NUMERO_ID.Caption = "" Me.ETI_DATA_SCA.Caption = "" Me.ETI_DATA_TAR.Caption = "" End If

22 - Il comando LIKE nel codice VBA Questo esempio funziona: Dim Rst1 As New ADODB.Recordset Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM [TABELLA/QUERY] WHERE NOME CAMPO like '%" & Me.PARAMETRO & "%'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic

23 - Assegnare via codice il RecordSsource Si crea un interruttore che gestisce il RecordSource della sottotabella: If Me.Interruttore1 = -1 Then ' Interruttore attivato Me.M_Maschera_ST1.Form.RecordSource = "SELECT campo1, campo2, campo3 WHERE campo1 = " & Me.X & " AND campo2 = " & Me.Y & " AND Not IsNull(Campo3)" ElseIf Me.Interruttore1 = 0 Then ' Interruttore disattivato Me.M_Maschera_ST1.Form.RecordSource = "SELECT campo1, campo2, campo3 WHERE campo1 = " & Me.X & " AND campo2 = " & Me.Y End If

24 - Aprire un recordset su un'altro DB Dim Rst1 As New ADODB.Recordset Rst1.CursorLocation = adUseClient ' Si inserisce il [percorso completo].[nome database].[nome tabella] Rst1.Open "SELECT * FROM F:\CARTELLA1\CARTELLA2\NOME_DATABASE.accdb.NOME_TABELLA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic PS: non funziona se c'è già una tabella/query con quel nome! ' Vediamo un esempio più complesso DoCmd.RunSQL "DELETE * FROM T_TEMP_ElenchiDiagrammiInCiclo" Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM Tabella1 ORDER BY ANNO", CurrentProject.Connection, adOpenDynamic, adLockOptimistic While Not Rst1.EOF Rst2.CursorLocation = adUseClient Rst2.Open "INSERT INTO Tabella2 ( Campo1, Campo2, Campo3, Campo4, Campo5, ANNO) " & _ "SELECT Campo1, Campo2, Campo3, Campo4, Campo5, " & Rst1!ANNO & " " & _ "FROM (C:\CARTELLA1" & Rst1!ANNO & ".accdb.TABELLA1 LEFT JOIN C:\CARTELLA1" & Rst1!ANNO & ".accdb.TABELLA2 .." & _ "LEFT JOIN C:\CARTELLA1" & Rst1!ANNO & ".accdb.TABELLA2 ON (....) " & _ "WHERE ((Not (Campo1) Is Null)) AND .....", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst1.MoveNext Wend

25 - Form ricerca dati Si crea una form non associata ad alcuna tabella e si creano i combobox per la ricerca dei dati, impostando come valore predefinito * All'interno di questa form si crea una sottoform con recordsource associato alla tabella dove vogliamo cercare i dati. Sulla query metteremo nei campi di ricerca il nome delle combobox (ad es: Forms![NOME_FORM]!NOME_COMBOBOX)

26 - Collegare una tabella da codice (DAO) Dim DATABASE As DAO.Database Dim n As Integer, TableArray() As String Dim TFileName As String, LinkedTable As TableDef, i As Integer Dim TFileName2016 As String, LinkedTable2016 As TableDef Set DATABASE = CurrentDb ' Database esterno TFileName = "F:\forge\DATABASE\DATABASE.accdb" DoCmd.Hourglass True n = 4 ReDim TableArray(1 To n) ' Tabelle esistenti sul database esterno... TableArray(1) = "T_CPP" TableArray(2) = "T_CPM" TableArray(3) = "T_CPU" TableArray(4) = "T_CTT" ' ... che si vogliono collegare al database corrente con lo stesso nome For i = 1 To n Set LinkedTable = DATABASE.CreateTableDef(TableArray(i)) LinkedTable.Connect = ";DATABASE=" & TFileName LinkedTable.SourceTableName = TableArray(i) DATABASE.TableDefs.Append LinkedTable Next i DATABASE.TableDefs.Refresh DoCmd.Hourglass False

27 - Eliminare una tabella collegata ....... For I = 1 To n On Error Resume Next CurrentDb.Execute "DROP TABLE " & TableArray(I) Next I CurrentDb.TableDefs.Refresh .......

28 - Passare il nome della FORM ad una funzione EF = GestioneDescrizioneANAGRAFE(Me.Report.Name) Public Function GestioneDescrizioneANAGRAFE(NomeReport As String) ' GESTIONE CAMPO DESCRIZIONE ANAGRAFE If Reports(NomeReport)!ANNO_CERTIFICATO = Replace(Forms!inizio!EtiANNO.Caption, " ", "") Then If (Reports(NomeReport)!FORGIATO_TIPO = "" Or IsNull(Reports(NomeReport)!FORGIATO_TIPO)) Then Reports(NomeReport)!DESCRIZIONE_ITALIA.Visible = True Reports(NomeReport)!FORGIATO_TIPO.Visible = False Else Reports(NomeReport)!DESCRIZIONE_ITALIA.Visible = False Reports(NomeReport)!FORGIATO_TIPO.Visible = True End If If Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE = "" Or _ IsNull(Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE) Then Reports(NomeReport)!DESCRIZIONE_DIMENSIONI_EFF.Visible = False Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE.Visible = False Else Reports(NomeReport)!DESCRIZIONE_DIMENSIONI_EFF.Visible = True Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE.Visible = True End If Else Reports(NomeReport)!DESCRIZIONE_ITALIA.Visible = True Reports(NomeReport)!FORGIATO_TIPO.Visible = False Reports(NomeReport)!DESCRIZIONE_DIMENSIONI_EFF.Visible = False Reports(NomeReport)!FORGIATO_DIMENSIONE_EFFETTIVE.Visible = False End If End Function

29 - Funzione GestPagIniFin("Nome_Report") Call GestPagIniFin("Nome_Report") Public Function GestPagIniFin(NomeReport As String) If PagIniziale = 0 And PagFinale = 0 Then Reports(NomeReport).GestNumPag.Caption = Reports(NomeReport).Page & " / " & Reports(NomeReport).Pages ElseIf PagIniziale <> 0 And PagFinale = 0 Then Reports(NomeReport).GestNumPag.Caption = PagIniziale & " / " & Reports(NomeReport).Pages ElseIf PagIniziale = 0 And PagFinale <> 0 Then Reports(NomeReport).GestNumPag.Caption = Reports(NomeReport).Page & " / " & PagFinale ElseIf PagIniziale <> 0 And PagFinale <> 0 Then Reports(NomeReport).GestNumPag.Caption = Reports(NomeReport).Page + PagIniziale - 1 & " / " & PagFinale Else End If End Function

30 - CancellaRecord("NOME_TAB", "NOME_FORM", CP1, CP2) Call CancellaRecord("NOME_TAB", "NOME_FORM", CP1, CP2) ' CP=Chiave Primaria Public Function CancellaRecord(NomeTab As String, NomeForm As String, CP1 As Integer, CP2 As Integer) On Error GoTo ERRORI Messaggio = "SELEZIONANDO [Sì] CANCELLERAI IL CERTIFICATO N° " & CP1 & "/" & CP2 & Chr(13) & Chr(13) & _ "SELEZIONANDO [No] ANNULLERAI L'OPERAZIONE DI CANCELLAZIONE" Stile = vbYesNo + vbCritical + vbDefaultButton2 Titolo = "ATTENZIONE" Risposta = MsgBox(Messaggio, Stile, Titolo) If Risposta = vbYes Then DoCmd.RunSQL "DELETE * FROM " & NomeTab & " WHERE CP1 = " & CP1 & " AND cP2 = " & CP2 Forms(NomeForm).Requery End If ERRORI: If Err.Number = 3167 Then Forms(NomeForm).Requery End If End Function

31 - Gestione Data Estesa Public Function CreaDataEstesa() As String ' GENERIAMO LA DATA NEL FORMATO GG MESE AA Select Case CByte(Mid(Date, 4, 2)) Case 1 CreaDataEstesa = Mid(Date, 1, 2) & " gennaio " & Mid(Date, 7, 4) Case 2 CreaDataEstesa = Mid(Date, 1, 2) & " febbraio " & Mid(Date, 7, 4) Case 3 CreaDataEstesa = Mid(Date, 1, 2) & " marzo " & Mid(Date, 7, 4) Case 4 CreaDataEstesa = Mid(Date, 1, 2) & " aprile " & Mid(Date, 7, 4) Case 5 CreaDataEstesa = Mid(Date, 1, 2) & " maggio " & Mid(Date, 7, 4) Case 6 CreaDataEstesa = Mid(Date, 1, 2) & " giugno " & Mid(Date, 7, 4) Case 7 CreaDataEstesa = Mid(Date, 1, 2) & " luglio " & Mid(Date, 7, 4) Case 8 CreaDataEstesa = Mid(Date, 1, 2) & " agosto " & Mid(Date, 7, 4) Case 9 CreaDataEstesa = Mid(Date, 1, 2) & " settembre " & Mid(Date, 7, 4) Case 10 CreaDataEstesa = Mid(Date, 1, 2) & " ottobre " & Mid(Date, 7, 4) Case 11 CreaDataEstesa = Mid(Date, 1, 2) & " novembre " & Mid(Date, 7, 4) Case 12 CreaDataEstesa = Mid(Date, 1, 2) & " dicembre " & Mid(Date, 7, 4) End Select End Function

32 - Copy file da un percorso ad un altro Dim PathORIG, PathDEST, File1Nome, File2Nome As String PathORIG = "C:\percorso origine\" PathDEST = "C:\percorso destinazione\" File1Nome = "NomeFileOrigine.lnk" File2Nome = "NomeFileDestinazione.lnk" FileCopy PathORIG & File1Nome, PathDEST & File1Nome FileCopy PathORIG & File2Nome, PathDEST & File2Nome

33 - Assegnare permessi a cartelle - funzione icacls Dim NomeCart As String NomeCart = "TEST" If Dir("\\PERCORSO\" & NomeCart, vbDirectory) = "" Then MkDir ("\\PERCORSO\" & NomeCart) Else 'Kill ("\\PERCORSO\*.*") End If Call Shell("icacls \\192.168.2.2\DATI\Privati\Documenti-TEST\" & NomeCart & " /grant administrator@dominio.locale:(OI)(CI)F /grant user1.pippo@dominio.locale:(OI)(CI)F /grant user2.pluto@dominio.locale:(OI)(CI)F /inheritance:r")

34 - Query con nome tabella parametrizzato Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Dim Rst3 As New ADODB.Recordset Dim Rst4 As New ADODB.Recordset Dim NumeroGIORNI, J As Byte Dim ElencoNomiTAB(31) As String ' 32 RECORD IN TABELLLA [T_NOMI_TABELLE] Rst4.CursorLocation = adUseClient Rst4.Open "SELECT * FROM T_NOMI_TABELLE ORDER BY PRIORITA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst4.MoveFirst J = 0 While J < Rst4.RecordCount ElencoNomiTAB(J) = Rst4!NOME_TABELLA Rst4.MoveNext J = J + 1 Wend J = 0 If Rst2.RecordCount Then Rst2.MoveFirst Rst4.MoveFirst While Not Rst2.EOF Rst3.CursorLocation = adUseClient Rst3.Open "SELECT * FROM anagrafepulsanti WHERE KEY = '" & Rst2!KEY & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic ' SE NON TROVO IL KEY LO CREO If Rst3.RecordCount = 0 Then Rst3.AddNew Rst3!KEY = Rst2!KEY While Not Rst4.EOF NOME_CAMPO = Rst4!CODICE_CERTIFICATO Rst1.CursorLocation = adUseClient Rst1.Open "SELECT COMMESSA FROM " & ElencoNomiTAB(J) & " WHERE commessa = '" & Rst2!KEY & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount > 0 Then Rst3(NOME_CAMPO) = True Else Rst3(NOME_CAMPO) = False Rst1.Close Rst4.MoveNext J = J + 1 Wend ' SE TROVO IL KEY AGGIORNO I CAMPI Else If Forms!INIZIO!CCRicompilaTutto = -1 Or SoloQuestaCommessa Then While Not Rst4.EOF NOME_CAMPO = Rst4!CODICE Rst1.CursorLocation = adUseClient Rst1.Open "SELECT COMMESSA FROM " & ElencoNomiTAB(J) & " WHERE commessa = '" & Rst2!KEY & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount > 0 Then Rst3(NOME_CAMPO) = True Else Rst3(NOME_CAMPO) = False Rst1.Close Rst4.MoveNext J = J + 1 Wend End If End If Rst3.Update Rst3.Close Rst2.MoveNext Wend

35 - crivere in file Excel xlsx Public Function ScriviDatiSuFoglio_Grade1() Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Dim riga, COLONNA, COLONNA_INT As Integer Dim PARAMETRO As String PARAMETRO = "91" Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM TABELLA WHERE CAMPO like '%" & PARAMETRO & "%' ORDER BY CAMPO", CurrentProject.Connection, adOpenDynamic, adLockOptimistic Workbooks.Open FileName:="C:\PERCORSO\FILE_EXCEL.xlsx" riga = 5 COLONNA = 3 COLONNA_INT = 3 If Rst1.RecordCount > 0 Then Rst1.MoveFirst While Not Rst1.EOF Rst2.CursorLocation = adUseClient Rst2.Open "SELECT * FROM TABELLA WHERE CAMPO = '" & Rst1!CAMPO & "'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst2.RecordCount = 1 Then Worksheets("NOME_FOGLIO").Cells(3, COLONNA_INT).Value = Rst2!colata & " " & Rst2!data_colata Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO1) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO2) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO3) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO4) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO5) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO6) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO7) riga = riga + 1 Worksheets("NOME_FOGLIO").Cells(riga, COLONNA).Value = CStr(Rst2!CAMPO8) Else End If riga = 5 COLONNA = COLONNA + 1 COLONNA_INT = COLONNA_INT + 2 Rst2.Close Rst1.MoveNext Wend Workbooks.Close Set Rst1 = Nothing Set Rst2 = Nothing End Function

36 - Apertura e chiusura file di testo (Open) Apertura e chiusura file di testo Per aprire un file di testo si utilizza l'istruzione open Open nomepercorso For modalità [accesso] As [#]numerofile nomepercorso = percorso e nome del file da aprire ES:C:\Prova.log modalità (Obbligatoria) = Parola chiave che specifica la modalità di accesso al file, ovvero Append,Binary, Input, Output o Random. Se non viene specificata, il file verrà aperto in modalità Random. Noi analizzeremo: Input = Apertura file in lettura (se il file non esiste va in errore) Output = Apertura file in scrittura dati (se il file non esiste viene creato, se il file esiste viene sovrascritto) Append = Apertura di un file in scrittura dati (se il file non esiste viene creato,se il file esiste viene accodato il testo al contenuto già esistente) accesso (Facoltativa) = Parola chiave che specifica le operazioni consentite nel file aperto, ovvero: Read, Write o Read Write. numerofile (Obbligatoria) = Numero di file valido compreso tra 1 e 511 inclusi. La funzione FreeFile restituisce il primo numero di file disponibile. Per chiudere il file usare Close [#]numerofile 'Apertura file in Lettura Dim NumeroFIle as integer Open "C:\Pova.txt" for Input As #1 ..... close #1 'Chiusura File 'Apertura file in Scrittura Open "C:\Pova.txt" for output As #1 ..... close #1 'Chiusura File Open "C:\Pova.txt" for append As #1 ..... close #1 'Chiusura File 'Uso del FreeFile Dim Numero as Integer NumeroFIle = FreeFile Open "C:\Pova.txt" for append As #NumeroFIle ...... close #NumeroFIle 'Chiusura File

37 - Lettura dati di un file di testo (input/Line Input) Lettura dati di un file di testo Il file deve essere aperto con modalità Input Vi sono 2 Comandi: Input: Legge i dati da un file ad accesso sequenziale aperto e li assegna a delle variabili. Line Input: Legge una singola riga in un file aperto ad accesso sequenziale e la assegna a una variabile. I dati letti tramite Line Input # vengono in genere scritti su file con Print #. L'istruzione Line Input # consente di leggere tutti i caratteri in un file un carattere per volta, fino al ritorno a capo (Chr(13)) o alla sequenza ritorno a capo–avanzamento riga (Chr(13) + Chr(10)). Le sequenze ritorno a capo–avanzamento riga vengono ignorate e non aggiunte alla stringa di caratteri. Input #numerofile, elencovariabili Line Input #numerofile, elencovariabili elencovariabili = variabile che prende il valore della prima riga del file Dim testo as String Open "C:\Pova.txt" for input As #1 Line Input#1,testo close #1 'Chiusura File

38 - Scrittura dati in un File di testo (print/write) Lettura dati di un file di testo Il file deve essere aperto con modalità Output Vi sono 2 Metodi per scrivere i dati Print: Scrive dati formattati per la visualizzazione in un file ad accesso sequenziale. Write: I dati scritti tramite Write # vengono in genere letti da un file con Input # . I dati numerici vengono sempre scritti utilizzando il punto (.) come separatore decimale. I dati di tipo Boolean vengono stampati i valori #TRUE# o #FALSE# I dati di tipo Stringa vengono stampati i valori tra Virgolette In entrambi i codici vengono aggiunti in automatico i carateeri di andata a capo (Chr(13) + Chr(10)) write#numerofile, elencovariabili oppure Print#numerofile, elencovariabili elencovariabili = Una o più espressioni numeriche o espressioni stringa delimitate da virgole che si desidera scrivere sul file. 'apertura file in Lettura Open "C:\Pova.txt" for Input As #1 Input #1, testo 'Legge la 1° riga del file Input #1, testo 'Legge la 2° riga del file close #1 'Chiusura File 'Lettura competa di un file 'Questo esempio legge un intero file 'Visualizza una finestra per ogni riga contenuta nel file Open "C:\Pova.txt" for Input As #1 do Until EOF(1) Line Input #1, testo 'Legge la riga del file msgbox testo 'Visualizza riga letta loop close #1 'Chiusura File 'Apertura file in Scrittura Open "C:\Pova.txt" for output As #1 write #1, "Sono a casa" 'Scrive la 1° riga del file write #1, "Seconda Riga" 'Scrive la 2° riga del file close #1 'Chiusura File

39 - Esempi funzione timer Public Function TestTimer() Dim PauseTime, Start, Finish, TotalTime If (MsgBox("Press Yes to pause for 5 seconds", 4)) = vbYes Then PauseTime = 5 ' Set duration. Start = Timer ' Set start time. Do While Timer > Start + PauseTime DoEvents ' Yield to other processes. Loop Finish = Timer ' Set end time. TotalTime = Finish - Start ' Calculate total time. MsgBox "Paused for " & TotalTime & " seconds" Else End End If End Function

40 - Compatta e ripristina database Private Sub CompattaERipristina_Click() Dim sDataFile As String, sDataFileTemp As String, sDataFileBackup As String Dim s1 As Long, s2 As Long On Error GoTo ERRORI If Me.CCAnnoCompattazione = "" Or IsNull(Me.CCAnnoCompattazione) Then MsgBox "ATTENZIONE! Selezionare l'anno del database da ripristinare" Exit Sub End If sDataFile = "C:\PERCORSO\" & Me.CCAnnoCompattazione & ".accdb" sDataFileTemp = "C:\PERCORSO\" & Me.CCAnnoCompattazione & "TEMP.accdb" sDataFileBackup = "C:\PERCORSO\" & Me.CCAnnoCompattazione & "BACKUP " & Format(Now, "YYYY-MM-DD HHMMSS") & ".accdb" DoCmd.Hourglass True 'get file size before compact Open sDataFile For Binary As #1 s1 = LOF(1) Close #1 'backup data file FileCopy sDataFile, sDataFileBackup 'only proceed if data file exists If Dir(sDataFileBackup) <> "" Then 'compact data file to temp file On Error Resume Next Kill sDataFileTemp On Error GoTo 0 DBEngine.CompactDatabase sDataFile, sDataFileTemp If Dir(sDataFileTemp, vbNormal) <> "" Then 'delete old data file data file Kill sDataFile 'copy temp file to data file FileCopy sDataFileTemp, sDataFile 'get file size after compact Open sDataFile For Binary As #1 s2 = LOF(1) Close #1 DoCmd.Hourglass False 'MsgBox "Compact complete " & vbCrLf & vbCrLf _ & "Size before: " & Round(s1 / 1024 / 1024, 2) & "Mb" & vbCrLf _ & "Size after: " & Round(s2 / 1024 / 1024, 2) & "Mb", vbInformation Else DoCmd.Hourglass False MsgBox "ERROR: Unable to compact data file" End If Else DoCmd.Hourglass False MsgBox "ERROR: Unable to backup data file" End If DoCmd.Hourglass False MsgBox "FINE COMPATTAZIONE, DATABASE RECUPERATO, VERIFICARE" ERRORI: If Err.Number = 3343 Then MsgBox "IL DATABASE NON ESISTE!" DoCmd.Hourglass False Else DoCmd.Hourglass False End If End Sub

41 - Funzione collegata tabelle database anni diversi Public Function ModificaAnnoDB(ANNO As Integer) Dim Rst1 As New ADODB.Recordset Dim DATABASE As DAO.Database Dim n As Integer, TableArray() As String Dim TFileName As String, LinkedTable As TableDef, I As Integer DoCmd.Hourglass True n = 9 ReDim TableArray(1 To n) ' Tabelle esistenti sul database esterno... TableArray(1) = "Tabella1" TableArray(2) = "Tabella2" TableArray(3) = "Tabella3" TableArray(4) = "Tabella4" TableArray(5) = "Tabella5" TableArray(6) = "Tabella6" TableArray(7) = "Tabella7" TableArray(8) = "Tabella8" TableArray(9) = "Tabella9" ' ... che si vogliono collegare al database corrente con lo stesso nome For I = 1 To n On Error Resume Next CurrentDb.Execute "DROP TABLE " & TableArray(I) Next I CurrentDb.TableDefs.Refresh Set DATABASE = CurrentDb ' Database esterno TFileName = "C:\PERCORSO\NOME_DATABASE" & ANNO & ".accdb" DoCmd.Hourglass True ReDim TableArray(1 To n) ' Tabelle esistenti sul database esterno... TableArray(1) = "Tabella1" TableArray(2) = "Tabella2" TableArray(3) = "Tabella3" TableArray(4) = "Tabella4" TableArray(5) = "Tabella5" TableArray(6) = "Tabella6" TableArray(7) = "Tabella7" TableArray(8) = "Tabella8" TableArray(9) = "Tabella9" ' ... che si vogliono collegare al database corrente con lo stesso nome For I = 1 To n Set LinkedTable = DATABASE.CreateTableDef(TableArray(I)) LinkedTable.Connect = ";DATABASE=" & TFileName LinkedTable.SourceTableName = TableArray(I) DATABASE.TableDefs.Append LinkedTable Next I DATABASE.TableDefs.Refresh ' AGGIUNGO L'ANNO NELL'APPOSITA TABELLA DoCmd.RunSQL "DELETE * FROM T_ANNO_DB" Rst1.CursorLocation = adUseClient Rst1.Open "SELECT ANNO FROM T_ANNO_DB", CurrentProject.Connection, adOpenDynamic, adLockOptimistic ' MEMORIZZO L'ANNO CORRETTO NELLA TABELLA [T_ANNO_DB] If Rst1.RecordCount = 0 Then Rst1.AddNew If ANNO = 9999 Then Rst1!ANNO = "T E S T" Else Rst1!ANNO = Mid(ANNO, 1, 1) & " " & Mid(ANNO, 2, 1) & " " & Mid(ANNO, 3, 1) & " " & Mid(ANNO, 4, 1) End If Rst1.Update End If ' REIMPOSTO L'ANNO CORRETTO SULL'ETICHETE [ANNO] DELLA HOME PAGE If ANNO = 9999 Then Me.EtiANNO.Caption = "T E S T" Else Me.EtiANNO.Caption = Rst1!ANNO End If Rst1.Close DoCmd.Hourglass False Forms!INIZIO.Refresh Set Rst1 = Nothing End Function

42 - Copia campi tipo ALLEGATO Public Function CopiaAllegato(NomeCampo As String, NomeTabella As String, numero As Integer, pag As Integer, TipoCiclo As String) ' CODICE PER LA COPIA DELL'ALLEGATO Dim rsSource As DAO.Recordset Dim rsDest As DAO.Recordset Dim rsPicturesSource As DAO.Recordset Dim rsPicturesDest As DAO.Recordset Dim strPath As String If Dir("C:\PERCORSO\_temp", vbDirectory) = "" Then MkDir ("C:\PERCORSO\_temp") Else Kill ("C:\PERCORSO\_temp\*.*") End If strPath = "C:\PERCORSO\\_temp" Set rsSource = CurrentDb.OpenRecordset("SELECT * FROM " & NomeTabella & " WHERE numero = " & numero & " AND pag = " & pag & " AND TIPO_CICLO = '" & TipoCiclo & "'") Set rsDest = CurrentDb.OpenRecordset("SELECT * FROM " & NomeTabella & " WHERE numero = " & numero & " AND pag = " & pag & " AND TIPO_CICLO = '" & TipoCiclo & "'") Set rsPicturesSource = rsSource.Fields(NomeCampo).Value While Not rsPicturesSource.EOF ' rsPicturesSource.Fields("FileData").SaveToFile strPath & "\" & rsPicturesSource.Fields("FileName") ' SALVO CON UN NOME CHE DEFINISCO IO PER NON AVER 2 O PIU' FILE CON LO STESSO NOME rsPicturesSource.Fields("FileData").SaveToFile strPath & "\Disegno" & I & Right(rsPicturesSource.Fields("FileName"), 4) rsDest.Edit Set rsPicturesDest = rsDest.Fields(NomeCampo).Value rsPicturesDest.AddNew ' rsPicturesDest.Fields("FileData").LoadFromFile strPath & "\" & rsPicturesSource.Fields("FileName") rsPicturesDest.Fields("FileData").LoadFromFile strPath & "\Disegno" & I & Right(rsPicturesSource.Fields("FileName"), 4) rsPicturesDest.Update rsDest.Update rsPicturesSource.MoveNext I = I + 1 Wend Kill ("C:\PERCORSO\_temp\*.*") RmDir ("C:\PERCORSO\_temp") rsSource.Close rsDest.Close Set rsSource = Nothing Set rsPicturesSource = Nothing Set rsPicturesDest = Nothing Set rsDest = Nothing End Function

43 - Duplica record Private Sub ComDuplicaREC_Click() Dim Rst1 As New ADODB.Recordset Dim Rst2 As New ADODB.Recordset Messaggio = "DUPLICARE IL RECORD?" & Chr(13) Stile = vbYesNo + vbCritical + vbDefaultButton2 Titolo = "ATTENZIONE" Risposta = MsgBox(Messaggio, Stile, Titolo) If Risposta = vbYes Then ' TROVO IL NUMERO PIU' ALTO DEL CAMPO CHIAVE PRIMARIA/INDICE E LO AUMENTO DI 1 Rst1.CursorLocation = adUseClient Rst1.Open "SELECT numero FROM TABELLA ORDER BY numero desc", CurrentProject.Connection, adOpenDynamic, adLockOptimistic MaxNumCert = Rst1!numero Rst1.Close NumRecordTabella = CurrentDb.TableDefs("TABELLA").Fields.Count Rst1.CursorLocation = adUseClient Rst1.Open "SELECT * FROM TABELLA WHERE numero = " & Me.numero, CurrentProject.Connection, adOpenDynamic, adLockOptimistic Rst2.CursorLocation = adUseClient Rst2.Open "SELECT * FROM TABELLA", CurrentProject.Connection, adOpenDynamic, adLockOptimistic If Rst1.RecordCount = 1 Then Rst2.AddNew Rst2!numero = MaxNumCert + 1 For PosCampo = 1 To NumRecordTabella If Not IsNull(Rst1.Fields(PosCampo)) Then On Error Resume Next Rst2.Fields(PosCampo) = Rst1.Fields(PosCampo) Else Rst2.Fields(PosCampo) = Null End If Next PosCampo Rst2.Update MsgBox "RECORD DUPLICATO" End If Rst1.Close Rst2.Close Forms!M_MASCHERA.Requery DoCmd.RunCommand acCmdRecordsGoToLast End If Set Rst1 = Nothing Set Rst2 = Nothing End Sub

44 - Set db [CurrentDb, OpenDatabase()] Dim db As DAO.Database Set db = CurrentDb Set db = OpenDatabase("C:\PERCORSO\DBAccess.accdb")

45 - Errore Access: query danneggiata A causare il problema sono gli aggiornamenti: - KB4484127 per Windows a 64 bit - KB4484119 per Windows a 32 bit

46 - Trova record in FORMS/Vai al record ' CHIUDENDO E RIAPRENDO FUNZIONA DoCmd.Close DoCmd.OpenForm "M_CPU_SP_master", acNormal, , "DISEGNO = '" & DisegnoORIGINALE & "-BIS" & "'" ' OPPURE Dim rs As Object Set rs = Me.Recordset.Clone rs.FindFirst "[disegno] = '" & DisegnoORIGINALE & "-BIS" & "'" If Not rs.EOF Then Me.Bookmark = rs.Bookmark

47 - Macro/Vba 32/64 bit Riguarda l'errore: Errore di Run-Time-214741848 (80010108) Metodo 'EOF' dell'oggetto _Recordset' non riuscito.

48 - Aprire DB Access da altro DB Access Call Shell(SysCmd(acSysCmdAccessDir) & "MSAccess.exe " & Chr(34) & ".....\.......\.....\NomeFile.accdb" & Chr(34), vbMaximizedFocus) DoCmd.Quit acSave

49 - Funzione Sleep per ritardare esecuzione codice Si inserisce il codice seguente nel modulo API e si crea la funzione Sleep1Sec (per creare una funzione che rallenta l'esecuzione 1s) Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Sub SleepMilliSeconds(pnMilliseconds As Long) Sleep pnMilliseconds End Sub Call SleepMilliSeconds(1000) ' FERMO L'ESECUZIONE PER 1 Sec che poi richiameremo nelle funzioni che vogliamo rallentare

50 -

S1 - Script1 - Cancellazione file e directory con più di N giorni FORFILES /P "C:\--PERCORSO--\" /M *.* /D -180 /C "CMD /C DEL @PATH" FORFILES /P "C:\--PERCORSO--\" /D -180 /C "cmd /C if @isdir==TRUE rmdir @path /S /Q"