Catalogo delle funzioni, articoli e risorse utili

Author

Message

Topic Search

Topic Options

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 15/Apr/2011 at 17:46

Funzione n.003 Legge il numero di serie di Windows e il nome dell'utente registrato

§LeggeDatiComputer
Funzione
Win32
Luky
§Legge il numero di serie di Windows e il nome dell'utente registrato.§

§Public Function LeggeDatiComputer()
Dim objOS As Object
Dim NumeroSerie, User, Organization As String
For Each objOS In GetObject( _
        "winmgmts:").InstancesOf("Win32_OperatingSystem")
        'MsgBox objOS.SerialNumber
       NumeroSerie = objOS.SerialNumber
       User = objOS.RegisteredUser
Next
MsgBox NumeroSerie & " " & User
    Set objOS = Nothing
End Function§

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 17/Apr/2011 at 08:35

Funzione n.004 crea e scrive una chiave di registro

§ScriveRegistro
Funzione
Registro
Luky
§Crea una cartella, una sottocartella e una chiave, nel registro. Scrive il valore della chiave. Adatto a nascondere e confrontare la password del db.§
Cartella
c1
Sottocartella
c4
NomeChiave
Nuova
ValoreChiave
Ciao

§Public Function ScriveRegistro(Cartella, Sottocartella, NomeChiave, ValoreChiave)
Dim fso, objOS, WshShell As Object
Dim Registro As String
Set WshShell = CreateObject("Wscript.Shell")
On Error GoTo 5000
'Cerca di leggere il valore della chiave, se non ci riesce genera errore e la scrive ex novo.
Registro = WshShell.RegRead("HKCU\Software\Microsoft\" & Cartella & "\" & Sottocartella & "\" & NomeChiave & "")
MsgBox "Chiave già presente"
Exit Function
5000
WshShell.RegWrite "HKCU\Software\Microsoft\" & Cartella & "\" & Sottocartella & "\" & NomeChiave & "", ValoreChiave, "REG_SZ"
MsgBox "Creazione chiave andata a buon fine"

End Function§

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 17/Apr/2011 at 08:37

Funzione n. 005 Creare una tabella

§CreaTabella
Sub
Tabella
Luky
§Crea un tabella con due campi.
Altre parole riservate: INTEGER,  REFERENCES, UNIQUE,  FOREIGN KEY, ON DELETE CASCADE,§
NomeTabella
Tabella9
Campo1
Cognome
TipoCampo1
CHAR(4)
Campo2
Datanascita
TipoCampo2
date
§Public Sub CreaTabella(NomeTabella, Campo1, TipoCampo1, Campo2, TipoCampo2)
On Error GoTo 5000
DoCmd.RunSQL "CREATE TABLE  " & NomeTabella & "(" & Campo1 & " " & TipoCampo1 & ", " & Campo2 & " " & TipoCampo2 & ")"
MsgBox "Tabella creata"
Exit Sub
5000
MsgBox "Tabella già presente o errore  sql"
End Sub§

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 19/Apr/2011 at 14:34

Funzione n.006 Copia una cartella in un'altra posizione.

§CopiaCartella
Sub
FileCartelle
Luky
§Copia una cartella.
Origine e Destinazione con \ finale. Es: C:\Users\Luc\Desktop\§
NomeCartella
Nuova Cartella
Origine
C:\Users\Luc\Desktop\
Destinazione
C:\

§Public Sub CopiaCartella(NomeCartella, Origine, Destinazione)
Dim fso As Object
Dim result As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
If Not (fso.FolderExists(Destinazione & NomeCartella)) Then
    result = fso.CopyFolder(Origine & NomeCartella, Destinazione, True)
    MsgBox "Copia cartella andata a buon fine"
Else
      MsgBox "Cartella già presente"
End If
End Sub§

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 19/Apr/2011 at 14:34

Funzione n.007 Ricerca una stringa in un predeterminato campo di una tabella.

§OperatoreLike
Sub 
Ricerca
Luky
§Ricerca una stringa in un predeterminato campo di una tabella.§
NomeTabella
Funzioni
NomeCampo
Funzione
OggettoRicerca
trova
 

§Public Sub OperatoreLike(NomeTabella, NomeCampo, OggettoRicerca)
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
Dim Ricerca As String
'In ADO usare % non *
rst.Open "SELECT " & NomeCampo & " FROM " & NomeTabella & " WHERE Funzione Like " & "'%" & OggettoRicerca & "%'" & "  ", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
While Not rst.EOF
   Ricerca = Ricerca & vbCrLf & rst.Fields(0)
   rst.MoveNext
Wend
MsgBox Ricerca
rst.Close
'--------------------
'sette forme Funzionanti in sqlQuery di access
'SELECT Funzioni.Funzione FROM Funzioni WHERE Funzione Like ('*azzeratabella*')
'SELECT Funzione FROM Funzioni WHERE Funzione Like '*azzera*'
'SELECT Funzioni.Funzione FROM Funzioni WHERE Funzione Like ("*azzeratabella*")
'SELECT Funzione FROM Funzioni WHERE Funzione Like ("" & "*" & [forms]![Menù]![Targomento3] & "*" & "")
'SELECT Funzioni.Funzione FROM Funzioni WHERE Funzione Like (Chr(42) & "Azzeratabella" & Chr(42))
'SELECT Funzione FROM Funzioni WHERE Funzione Like ("" & Chr(42) & [forms]![Menù]![Targomento3] & Chr(42) & "");
'SELECT Funzioni.Funzione FROM Funzioni WHERE Funzione Like ("" & Chr(42) & "Azzeratabella" & Chr(42) & "")
'---------------------
End Sub§

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 19/Apr/2011 at 14:36

Funzione n.008 Esegue un'applicazione

§EseguiApplicazione
Sub
Win32
Luky
§Manda in escuzione un'applicazione.
Il percorso senza \ finale.§
Percorso
C:\Users\Luc\Desktop
NomeFile
Applausi
Estensione
MP3

§Public Sub EseguiApplicazione(Percorso, NomeFile, Estensione)
CreateObject("Shell.Application").ShellExecute Percorso & "\" & NomeFile & "." & Estensione
End Sub§

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 20/Apr/2011 at 23:59

Funzione n. 009 Sposta una maschera popup

§MoveSizeMaschera
Sub
Form
Luciano
§Se non è aperta apre una maschera popup e poi la sposta nella posizione voluta.
Per testare il funzionamento, settare la proprietà popup= no di questa maschera (Menù).§
NomeMaschera
Masch_Categorie
Dallalto
1000
DaSinistra
4000

§Public Sub MoveSizeMaschera(NomeMaschera As String, Dallalto As Long, DaSinistra As Long)
       DoCmd.OpenForm NomeMaschera
       DoCmd.SelectObject acForm, NomeMaschera, False
       DoCmd.MoveSize DaSinistra, Dallalto
End Sub§

Edited by Luciano - 04/Mar/2013 at 11:22

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 21/Apr/2011 at 00:00

Funzione n.010 Chiude tutte le maschere tranne la corrente

§ChiudiOgniMaschera
Sub
Form
Luky
§Chiude ogni maschera esclusa la corrente maschera.§

§Public Sub ChiudiOgniMaschera()
Dim dbs, obj As Object
Dim Maschera As String
Set dbs = Application.CurrentProject
For Each obj In dbs.AllForms
        If obj.IsLoaded = True Then
           If obj.Name <> "Menù" Then
'Se la sub risiede nel modulo della stessa maschera utilizzare la forma universale Me.Name al posto di "Menù"
               Maschera = obj.Name
               DoCmd.Close acForm, Maschera
        End If
      End If
    Next obj
End Sub§

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 21/Apr/2011 at 00:01

Funzione n.011 Chiude tutte i reports

§ChiudiOgniReports
Sub
Report
Luky
§Chiude tutti i reports.§

§Public Sub ChiudiOgniReports()
Dim dbs, obj As Object
Set dbs = Application.CurrentProject
For Each obj In dbs.AllReports
        If obj.IsLoaded = True Then
               DoCmd.Close acReport, obj.Name
      End If
    Next obj
End Sub§

Dio è Amore e Pace
Catalogo funzioni

Luciano

Utente Onorario

Joined: 05/Giu/2010
Location: Italy
Status: Offline
Points: 1972

Posted: 21/Apr/2011 at 15:27

Funzione n.012 Creazione di un messaggio (Msgbox)

§Messaggio
Sub
Form
Luky
§Assembla  un messaggio   con titolo e stile predeterminato.
Usare la forma con costanti vbYesNo+vbCritical+vbDefaultButton2
(senza spazi)   Oppure con valore numerico 4+16+256  (senza spazi)§
Messaggio
Continuare?
Stile
 4+16+2562
Titolo
Attenzione errore
 

§Public Sub Messaggio(Messaggio, Stile, Titolo)
Dim Response, MyString
Dim somma As Integer
If IsNull(Forms!Menù.TArgomento1.Value) Or IsNull(Forms!Menù.TArgomento2.Value) Or IsNull(Forms!Menù.TArgomento3.Value) Then MsgBox "Manca almeno un parametro": Exit Sub
Stile = Trim(Stile)
Stile = "+" & Stile & "+"
If IsNumeric(Left(Stile, 2)) Then
    If InStr(Stile, "+0+") > 0 Then somma = somma + 0
    If InStr(Stile, "+1+") > 0 Then somma = somma + 1
    If InStr(Stile, "+2+") > 0 Then somma = somma + 2
    If InStr(Stile, "+3+") > 0 Then somma = somma + 3
    If InStr(Stile, "+4+") > 0 Then somma = somma + 4
    If InStr(Stile, "+5+") > 0 Then somma = somma + 5
'''''''''''
    If InStr(Stile, "+16+") > 0 Then somma = somma + 16
    If InStr(Stile, "+32+") > 0 Then somma = somma + 32
    If InStr(Stile, "+48+") > 0 Then somma = somma + 48
    If InStr(Stile, "+64+") > 0 Then somma = somma + 64
'''''''''''
    If InStr(Stile, "+0+") > 0 Then somma = somma + 0
    If InStr(Stile, "+256+") > 0 Then somma = somma + 256
    If InStr(Stile, "+512+") > 0 Then somma = somma + 512
    If InStr(Stile, "+768+") > 0 Then somma = somma + 768
'''''''''''
    If InStr(Stile, "+0+") > 0 Then somma = somma + 0
    If InStr(Stile, "+4096+") > 0 Then somma = somma + 4096
'''''''''''
    If InStr(Stile, "+16384+") > 0 Then somma = somma + 16384 '
    If InStr(Stile, "+65536+") > 0 Then somma = somma + 65536 '
    If InStr(Stile, "+524288+") > 0 Then somma = somma + 524288 '
    If InStr(Stile, "+1048576+") > 0 Then somma = somma + 1048576 '
Else
    'solo il pulsante OK.
    If InStr(Stile, "+vbOKOnly+") > 0 Then somma = somma + 0
    ' OK e Annulla.
    If InStr(Stile, "+vbOKCancel+") > 0 Then somma = somma + 1
    ' Termina, Riprova, e Ignora.
    If InStr(Stile, "+vbAbortRetryIgnore+") > 0 Then somma = somma + 2
    ' Sì, No e Annulla.
    If InStr(Stile, "+vbYesNoCancel+") > 0 Then somma = somma + 3
    ' Sì e No.
    If InStr(Stile, "+VbYesNo+") > 0 Then somma = somma + 4
    ' Riprova e Annulla.
    If InStr(Stile, "+vbRetryCancel+") > 0 Then somma = somma + 5
    'icona di messaggio critico.
    If InStr(Stile, "+vbCritical+") > 0 Then somma = somma + 16
    'icona di richiesta di avviso.
    If InStr(Stile, "+vbQuestion+") > 0 Then somma = somma + 32
    'icona di messaggio di avviso.
    If InStr(Stile, "+vbExclamation+") > 0 Then somma = somma + 48
    'icona di messaggio di informazione.
    If InStr(Stile, "+vbInformation+") > 0 Then somma = somma + 64
    'Il primo pulsante è il predefinito.
    If InStr(Stile, "+vbDefaultButton1+") > 0 Then somma = somma + 0
    'Il secondo pulsante è il predefinito.
    If InStr(Stile, "+vbDefaultButton2+") > 0 Then somma = somma + 256
     'Il terzo pulsante è il predefinito.
    If InStr(Stile, "+vbDefaultButton3+") > 0 Then somma = somma + 512
    'Il quarto pulsante è il predefinito
    If InStr(Stile, "+vbDefaultButton4+") > 0 Then somma = somma + 768
    'Finestra di messaggio a scelta obbligatoria nelapplicazione. utente deve rispondere alla finestra di messaggio prima di poter continuare a lavorare nelapplicazione corrente.
    If InStr(Stile, "+vbApplicationModal+") > 0 Then somma = somma + 0
    'Finestra di messaggio a scelta obbligatoria nel sistema. Tutte le applicazioni vengono sospese fino a quando l'utente non risponde alla finestra di messaggio.
    If InStr(Stile, "+vbSystemModal+") > 0 Then somma = somma + 4096
    'Aggiunge un pulsante della Guida nella finestra di messaggio.
    If InStr(Stile, "+vbMsgBoxHelpButton+") > 0 Then somma = somma + 16384
    'Specifica che la finestra di messaggio è in primo piano.
    If InStr(Stile, "+vbMsgBoxSetForeground+") > 0 Then somma = somma + 65536
    'Il testo è allineato a destra.
    If InStr(Stile, "+vbMsgBoxRight+") > 0 Then somma = somma + 524288
    'Specifica che il testo viene visualizzato da destra a sinistra per i sistemi ebraico e arabo.
    If InStr(Stile, "+vbMsgBoxRtlReading+") > 0 Then somma = somma + 1048576
End If
'Costanti:vbOK 1 OK; vbCancel 2 Annulla; vbAbort 3 Termina; vbRetry 4 Riprova; vbIgnore 5 Ignora: vbYes 6 Sì; vbNo 7
Response = MsgBox(Messaggio, somma, Titolo)
If Response = vbYes Then MsgBox ("Hai scelto Sì")          ' Esegue un'azione.
If Response = vbNo Then MsgBox ("Hai scelto No")          ' Esegue un'azione.
If Response <> vbNo And Response <> vbYes Then MsgBox ("Altra scelta")
End Sub§

Edited by Luky

Dio è Amore e Pace
Catalogo funzioni