Codice VBA

Funzione Conta Righe in Excel

La funzione permette di contare le righe "non vuote" della colonna di un determinato foglio di Excel. Dim VarRiga as Integer VarRiga = Contarighe("Foglio1", "A") La variabile VarRiga conterrà il numero di righe con valori della colonna A del foglio Foglio1
Public Function Contarighe(NomeFoglio As String, Colonna As String) As Long Dim sh As Worksheet 'dichiarazione delle variabili Set sh = ThisWorkbook.Worksheets(NomeFoglio) With sh Contarighe = .Range(Colonna & .Rows.Count).End(xlUp).Row End With Set sh = Nothing End Function

Comando seleziona file da aprire

Il comando permette di selezionare il file da aprire
Private Sub Comando0_Click()Dim fDialog As ObjectSet fDialog = Application.FileDialog(3) With fDialog .AllowMultiSelect = False .Title = "Seleziona il file da aprire" .InitialFileName = Application.CurrentProject.Path If .Show = -1 Then For Each selezione In .SelectedItems FileDaAprire = selezione Next Else MsgBox "Operazione annullata!", vbInformation GoTo fine Exit Sub End If End With'Apri File ExcelsWorkbooks.Open FileName:=FileDaAprire....End Sub

Riempire matrice con dati di una tabella

Il codice gestisce il riempimento della matrice "MatriceCampiIncrociati" con i dati estratti con una query e di popolare la tabella "00_RedditiTotali" con i dati contenuti nella matrice
Dim DBCorrente As DAO.DatabaseDim Tabella As DAO.RecordsetDim RS_Inform As DAO.RecordsetStrQuery = "SELECT RedditiFabbricati_CI.Codice, RedditiFabbricati_CI.Tipologia FROM RedditiFabbricati_CI;"ReDim MatriceCampiIncrociati(1 To 1000000, 1 To 2)Set RS_Inform = DBEngine(0)(0).OpenRecordset(StrQuery, dbOpenDynaset)ii = 1Do Until RS_Inform.EOF MatriceCampiIncrociati(ii, 1) = Nz(RS_Inform.Fields("[Codice]")) MatriceCampiIncrociati(ii, 2) = Nz(RS_Inform.Fields("[Tipologia]")) RS_Inform.MoveNext ii = ii + 1Loop
RS_Inform.CloseSet RS_Inform = Nothing
Set DBCorrente = CurrentDbSet Tabella = DBCorrente.OpenRecordset("00_RedditiTotali", dbOpenDynaset)
For tt = 1 To ii - 1 Tabella.AddNew 'crea ilnuovo record Tabella.Fields("Codice") = MatriceCampiIncrociati(tt, 1) Tabella.Fields("Tipologia") = MatriceCampiIncrociati(tt, 2) Tabella.Update 'Salva il recordNext tt

Riempire la casella di riepilogo con dati di una query

Il codice gestisce il riempimento di una casella di riepilogo contenuta in un form, con i dati estratti con una query. Inserire in un form la casella di riepilogo "Elenco1" e nella finestra delle proprietà inserire il numero di colonne necessarie.
Elenco1.RowSourceType = "Table/Query"strQuery = "SELECT DATI_ICO_AREA.ID, DATI_ICO_AREA.Anno, DATI_ICO_AREA.Protocollo, DATI_ICO_AREA.Data, DATI_ICO_AREA.Innesco, DATI_ICO_AREA.Struttura, DATI_ICO_AREA.Oggetto, DATI_ICO_AREA.DataAvvioICO, DATI_ICO_AREA.DataFineICO FROM DATI_ICO_AREA WHERE (((DATI_ICO_AREA.DataArchiviazioneICO) Is Not Null))ORDER BY DATI_ICO_AREA.Anno, DATI_ICO_AREA.Data, DATI_ICO_AREA.Protocollo;"Elenco1.RowSource = strQuery

Collegamento tabelle ad un database esterno protetto da password

Il comando gestisce il collegamento delle tabelle ad un Database esterno protetto da password. Inserire tra i firerimenti "microsoft ado ext 6.0 for ddl and security"
Private Sub Comando1_Click()On Error Resume NextDim db As DAO.DatabaseDim TLink As StringDim LinkBE As StringDim rs As DAO.RecordsetLinkBE = "\\26.151.151.01\Cartella\DBConsuntivazione_be.accdb"Set rs = CurrentDb.OpenRecordset("Tabelle_Collegate")Set db = OpenDatabase(LinkBE, False, False, "MS Access;PWD=INSERIRE-PASSWORD")rs.MoveFirstDo Until rs.EOFTLink = rs.Fields(0).ValueCurrentDb.TableDefs.Delete TLinkDoCmd.TransferDatabase acLink, "Microsoft Access", LinkBE, acTable, TLink, TLinkrs.MoveNextLoopdb.CloseSet db = NothingEnd Sub

Protezione Database attraverso la disabilitazione del tasto Shift

Il comando disabilita l'utilizzo del tasto Shift all'apertura del Database

Private Sub Comando0_Click()On Error GoTo Err_bDisableBypassKey_Click Dim strInput As String Dim strMsg As String Beep strMsg = "Vuoi abilitare il Bypass Key?" & vbCrLf & vbLf & "Digitare la password per abilitare il Bypass Key." strInput = InputBox(Prompt:=strMsg, Title:="Disable Bypass Key Password") If strInput = "INSERIREPASSWORD" Then SetProperties "AllowBypassKey", dbBoolean, True Beep MsgBox "Il tasto Shift è abilitato." & vbCrLf & vbLf & "Il tasto Shift consentirà agli utenti di ignorare le opzioni di avvio al successivo avvio del database", vbInformation, "Imposta proprietà di avvio" Else Beep SetProperties "AllowBypassKey", dbBoolean, False MsgBox "Password non corretta" & vbCrLf & vbLf & "Il tasto Shift è disabilitato." & vbCrLf & vbLf & "Il tasto Shift NON consentirà agli utenti di ignorare le opzioni di avvio al successivo avvio del database.", vbCritical, "Password non corretta" Exit Sub End If Exit_bDisableBypassKey_Click: Exit Sub Err_bDisableBypassKey_Click: MsgBox "Runtime Error # " & Err.Number & vbCrLf & vbLf & Err.Description Resume Exit_bDisableBypassKey_ClickEnd Sub

Bloccare i menù di Access

Il comando (reperito su internet) disabilita l'utilizzo del tasto Shift all'apertura del DatabaseInserire in un modulo rinominato "Secure" il seguente codice (Secure1 per bloccare i menù, UnSecure per sbloccare i menù).

Option Compare DatabaseOption 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 propertiesPrivate Const strAppTitle As String = "TITOLO APPLICAZIONE"Private Const strStartUpForm As String = "Menu"Private Const strStartUpMenuBar As String = "mnuPrincipale"Private Const strStartUpShortcutMenuBar As String = vbNullStringPrivate Const strAppIcon As String = vbNullStringPrivate Const blnStartUpShowDBWindow As Boolean = FalsePrivate Const blnStartUpShowStatusBar As Boolean = FalsePrivate Const blnAllowShortcutMenus As Boolean = FalsePrivate Const blnAllowFullMenus As Boolean = FalsePrivate Const blnAllowBuiltInToolbars As Boolean = FalsePrivate Const blnAllowToolbarChanges As Boolean = FalsePrivate Const blnAllowBreakIntoCode As Boolean = FalsePrivate Const blnAllowSpecialKeys As Boolean = FalsePrivate Const blnAllowBypassKey As Boolean = False
Public Function Secure1() 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 _ ' EnableAutoExecEnd Function
Public Function UnSecure() ' Call ChangeProperty("AppTitle", dbText, "My Application is UnSecured") 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 _ ' DisableAutoExecEnd Function

Private 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 = TrueChange_Bye: Set prp = Nothing Exit FunctionChange_Err: Select Case Err Case 3265 'Item not found in this collection. 'Do Nothing Resume Next Case 3270 'prop not found With CurrentDb Set prp = .CreateProperty(strPropName, varPropType, varPropValue) .Properties.Append prp End With Resume Next Case Else 'unknown error ChangeProperty = False Resume Change_Bye End SelectEnd Function
Public Function SetProperties(strPropName As String, varPropType As Variant, varPropValue As Variant) As IntegerOn Error GoTo Err_SetProperties 'Dim db As Database, prp As Property Dim db As DAO.Database, prp As DAO.Property Set db = CurrentDb db.Properties(strPropName) = varPropValue SetProperties = True Set db = Nothing Exit_SetProperties: Exit Function Err_SetProperties: If Err = 3270 Then 'Property not found Set prp = db.CreateProperty(strPropName, varPropType, varPropValue) db.Properties.Append prp Resume Next Else SetProperties = False MsgBox "Runtime Error # " & Err.Number & vbCrLf & vbLf & Err.Description Resume Exit_SetProperties End If End Function

Google Sites

Report abuse