Attribute VB_Name = "NetServer"
        Option Explicit
        
'*********************************************************
'       ho tolto ScriviMain.bas e OldScriviCal
'                    12 giugno 2025
'*********************************************************
        
Public Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal Cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
 Public Const HWND_TOPMOST = -1
 Public Const HWND_NOTOPMOST = -2

Public Const SW_SHOWNORMAL = 1
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
        Public Type NOTIFYICONDATA
          cbSize As Long
          hwnd As Long
          uId As Long
          uFlags As Long
          ucallbackMessage As Long
          hIcon As Long
          szTip As String * 64
        End Type

Global Ty As NOTIFYICONDATA
Global MY_Email As String

Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public DatiCalendario As Boolean
Global Modalita As Integer   ' serve a caricare
                          '1   PC RicordaPC.html
                          '2   PORTATILE RicordaPortatile.html
                          '3 VECCHIO Ricorda.html originale
                          Public NomeFileHTML As String
Global OrchideeJquery As Boolean
                      ' 1 = jquery in forma Dialog,
                      ' 2 =  in pagina html
                      
'Public Declare Function ShellExecute Lib "shell32.dll" _
'    Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
'    ByVal lpFile As String, ByVal lpParameters As String, _
'    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
                      
                      
Global TestOrchidea As Boolean
Global myCalendarioSchede As Boolean
Global ParaRicordaPC As String
Global ParaRicordaPortatile As String
Global ParaRicorda As String
    Global percorso As String
    Global ScriviImportante As Boolean
   Global Nobottoni  As Boolean
   Global ComandaBody As Boolean
Global Mesi(12) As String
Global MyErr As Long
Global Tipomenu As Long  '1 calendario con menu cascata, 2 calendario con bottoni grigi, 3 calendario originali con Button
Global MyMeseGlobal As String
Global Minim As Boolean
Global Stringa, Criterio As String
Global MFrase As Integer
Global MMinimizza As Boolean
Global Ricorrenza As Boolean
Global AppRevision As Long
Public Const MF_REMOVE = &H1000&
Public Const SC_CLOSE = &HF060
Public Const MAX_PATH = 260
Public MyConfiguraEsci As Boolean
Global CreaMySanti As Boolean

Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function GetWindowsDirectory& Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long)

 Global RecordsetVuoto As Boolean     ' se la tabella calendario è vuota, deve andare prima di tutto a riempire il form frmConfigura
Global MenuSuono As Boolean
Global DataSistema As Date
Global ComputerIlvo As Boolean
Global NNote As Boolean
Global Bisestile As Boolean
Global Giorni(31, 8) As Variant
Global MesePrecedente, MeseSuccessivo As String
Dim TotaleGiorni, NumeroGiorno As Long
Global DbAzienda As Connection
Global DbName As String

Global DatiProvider As Long  ' 0 Oracle
                
 Global NOmostraExplorer As Boolean
 Global Sovrapponi As Boolean  ' scrive e sovrappone ASP
 
Global NomeDatabaseProgetto As String
Global PercorsoDatabaseProgetto As String

  Global MenuMenu As String       ' picture su memu di MenuPDF.vb
  Global MenuForm As String       ' picture su tutti i menu dei form
  Global FormPicture As String     ' picture sui form
  Global MenuPicture As String     ' picture su MenuPDF.vb
  Global NomeFileNoEstensione As String ' nome dell'applicazione da generare
 Global Escludi As String ' Serve per effettuare la scelta dei form SELEZIONATI da inserire su MenuPDF.vb
 Global TipoDataBase As String
 Global MyDirPath As String
 
 Global InizioOraLegale As String
 Global FineOraLegale As String
  
 Global LarghezzaSchermo As Long
 Global RicNomeDB As String
 Global RicPercorsoDB As String
 
 Global ZMasterNewApp As Boolean
 
 Global RicercaText As String ' serve per ricordarsi il nome del progetto database da recuperare
 Global OggiPiena As Boolean   ' se c'e un record seleziona TAB1
 Global CalendarioMensile As Boolean   ' per stampare solo il mese incorso
 
         Public Type TipoProvider
          NomeServer As String
          Autenticazione As String
          NomeUtente As String
          Password As String
          NomeDatabase As String
          TipoProvider As String
         End Type
 Global TypProvider As TipoProvider
 
 Global ScriviTuttoProgetto As Boolean
 
 
 Global MyDataHTML As String
Global MyFineMese As Long
Global XX As Long
Global NomeGiorno As String

Global LeggiRPTBoolean As Boolean
Global IconePicture2008() As Variant

Global ScriviAltroModello As String  ' serve per scrivere con un altro A_A_Modello.frm
Global NomeModello As String ' Contiene il nome del modello che si andrà a ricercare da utilizzare come template

Global SetNomeProgetto As String
 Global ContaWhatsThisHelpID As Long  ' Numera WhatsThisHelpID
Global DEMO As Boolean
Dim Tipo(), LNome(), Lcampo(), MrecCampo() As Variant ' PER LA STAMPA DI MODULI TXT
Dim Striscia, Intest As String
Global SetNomeForm As String
Global MNomeForm As String
Global MNomeHelp As String
Global MenuEx_per_XP As Boolean  ' serve per stabilire se bisogna creare il menu per XP o Windows 2000
 Global Destinazione, Sorgente As String
Global MAvvio As Boolean
Global PathDataAziendale As String
Global DirWindows As String
  Global strDBLocation As String
  Global strDBName As String
  Global Cnn1 As Connection
  Global GeneraInteroProgetto As Boolean
  Global GridTrue As Boolean
Global Directory As String   ' stringa contenente la directory dove scrivere il progetto

 Global VerFicaLink(6) As Boolean   ' 3 sono per le tabelle Storico/anni ed altre 3 sono per le Tabelle Contabilità ORIGINALE
Global LinkAnnoContabile(15) As Long ' vengono salvati gli anni di gestione collegati a PrinaNota ect.
Global MFile As String
 Global ObjAccess As Access.Application
Global MFiltro As String
Global i, M, C, MyId As Long
 Global MprogettoForm As String

Global FrmPrDett As Long  ' se è true deve mettere nel form 2 picture ed i campi dentro di esse
Global ScriviPrincDett As Boolean

Global ChiudiCanvasXP As Boolean

Global MaxID As Long
Global Index As Long
Global MTop As Double
Global Const MHeight = 285
Global MLeft As Double
Global Colonna As Integer
Global Larghezza As Double
Global TabIndex As Long
Global NColonne As Long
Global Form_Semplice_Dettaglio As Long   ' (0) = Semplice - (1) = dettaglio (2) Sottomaschera
Global Rs As New Recordset

        Public Type FormPrincDettagli
          Progetto As String
          NomeForm As String
          RecordSetPrincipale As String
          RecordSetDettaglio As String
          SqlCampi As String
          RelCampoSetPrincipale As String
          Tipo As String
          RelCampoDettaglio As String
        End Type

Global FrmPD As FormPrincDettagli

    
 
             Private Type BrowseInfo
               hOwner As Long
               pIDLRoot As Long
               pszDisplayName As String
               lpszTitle As String
               ulFlags As Long
               lpfn As Long
               lParam As Long
               iImage As Long
             End Type

        Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
        Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long 'ITEMIDLIST
        Private Const BIF_RETURNONLYFSDIRS = &H1




Public Const HWND_BROADCAST As Long = &HFFFF&

Public Const WM_WININICHANGE As Long = &H1A

Public Declare Function GetProfileString Lib "kernel32" _
  Alias "GetProfileStringA" _
 (ByVal lpAppName As String, _
  ByVal lpKeyName As String, _
  ByVal lpDefault As String, _
  ByVal lpReturnedString As String, _
  ByVal nSize As Long) As Long

Public Declare Function WriteProfileString Lib "kernel32" _
  Alias "WriteProfileStringA" _
 (ByVal lpszSection As String, _
  ByVal lpszKeyName As String, _
  ByVal lpszString As String) As Long

Public Declare Function SendMessage Lib "user32" _
  Alias "SendMessageA" _
 (ByVal hwnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  lParam As Any) As Long
  
         
  
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_RETURNFSANCESTORS = &H8
 Private Const BIF_STATUSTEXT = &H4
 Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long


  
     Public DbAz As Connection
     Public Riavvia As Boolean   ' serve a riavviare il form
    ' **************************************************
    ' Variabili Colori Pagina HTML
     Public ColoreRiga1 As String
     Public ColoreRiga2 As String
     Public Chiaro1 As String
     Public Chiaro2 As String
'
'*****************************************************************************************

Function Replica(ByVal Chr As String, ByVal Num As Long) As String
'*****************************************************************************************
            Dim i As Long
            Dim Mstr As String
            For i = 1 To Num
            Mstr = Mstr & Chr
            Next
            Replica = Mstr
End Function


'*********************************************************
'*                                                       *
Public Function DestraDec(ByVal Mstringa As String, ByVal Mspaz As Long) As String
'*                                                       *
'*********************************************************
   If Len(Mstringa) = Mspaz Then
         DestraDec = Mstringa
         Exit Function
   End If
Dim C As Long
'c = InStr(1, MStringa, ",")
    If Mstringa <> "0" Then
          Mstringa = Format(CDbl(Mstringa), "###,###,###,###.00")
    End If
    Do While Len(Mstringa) < Mspaz
          Mstringa = " " & Mstringa
    Loop
    DestraDec = Mstringa
End Function



           '*********************************************************
          '*                                                       *
          Public Function Destra(ByVal Stringa As String, ByVal spazio As Long)
          '*                                                       *
          '*********************************************************
          Dim DifferenzaSpazio As Integer
               If IsNull(Stringa) Then
                Stringa = " "
               End If
                If Len(Stringa) > spazio Then
                 Stringa = Mid(Stringa, 1, spazio)
                End If
           DifferenzaSpazio = spazio - Len(Stringa)
           Destra = Space(DifferenzaSpazio) & Stringa
           End Function



          '*********************************************************
          '*                                                       *
          Public Function Sinistra(ByVal Stringa As String, ByVal spazio As Long)
          '*                                                       *
          '*********************************************************
          On Error Resume Next
          Dim DifferenzaSpazio As Integer
               If Len(Stringa) > spazio Then
                Stringa = Mid(Stringa, 1, spazio)
               End If
           DifferenzaSpazio = spazio - Len(Stringa)
           Sinistra = Stringa & Space(DifferenzaSpazio)
           End Function



Public Sub Main()

MyDirPath = App.Path

 If Dir(App.Path & "\INI", vbDirectory) = "" Then
             MkDir App.Path & "\INI"
         End If
  
 On Error Resume Next
        If Dir(App.Path & "\INI\ColoreGriglia.ini") <> "" Then
           Open App.Path & "\INI\ColoreGriglia.ini" For Input As #1
             Line Input #1, Stringa          ' #A8FFA8 -/- RGB(168.255.168)
            Line Input #1, ColoreRiga1 '##A8FFA8
             Line Input #1, Stringa            '0:
             Line Input #1, Stringa           '168:
             Line Input #1, Stringa            '255:
             Line Input #1, Stringa            '168:
             Line Input #1, Stringa              '****************************
             Line Input #1, Stringa             '#00A800 -/- RGB(0.168.0)
            Line Input #1, ColoreRiga2       '##00A800
            Line Input #1, Stringa           '0:
           Line Input #1, Stringa            '0:
            Line Input #1, Stringa           '168:
            Line Input #1, Stringa           '0:
             Close #1
        Else
            ColoreRiga1 = "#FFFF99"
            ColoreRiga2 = "#FFFFFF"
            Chiaro1 = ""
            Chiaro2 = ""
        End If
  
        If Err.Number > 0 Then
        MsgBox "File Colori.ini corrotto, Ricompilazione in esecuzione ", vbCritical, "KO"
        Shell "Explorer.exe " & App.Path & "\ColoriNew.exe", vbNormalFocus
        End
        End If


ApriDBAzienda
MenuRadio.Show 1


End Sub


     Public Function ApriDatabase() As Boolean
'*****************************************************************************************

            MyDirPath = App.Path

             'Dim DbName As String
             DbName = MyDirPath & "\database\Frequenze.mdb"      'Menu.TextPercorso.Text    ' "D:\Procedure\Frequenze Radio\database\Frequenze.mdb"

             If Dir(DbName) = "" Then
             MsgBox "Percorso o database inesistente ... controllare prego ", vbCritical, "Errore !!"
            ' Menu.TextPercorso.SetFocus
             ApriDatabase = False
             Exit Function
             End If

               On Error Resume Next
                     Set DbAz = New Connection
                     DbAz.CursorLocation = adUseClient
'''                      DbAz.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName ' & 'D:\Procedure\Frequenze Radio\database\Frequenze.mdb
    '               DbAz.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName   & Chr(34) & ";Mode=ReadWrite|Share Deny None;Persist Security Info=False"
DbAz.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName & ";Mode=ReadWrite|Share Deny None;Persist Security Info=False"
                     ApriDatabase = True

  '                   If Err.Number <> 0 Then
  '                         Set DbAz = New Connection
  '                         DbAz.CursorLocation = adUseClient
'                           DbAz.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName & ";Mode=ReadWrite|Share Deny None;Persist Security Info=False"
 '                  DbAz.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName & ";Mode=ReadWrite|Share Deny None;Persist Security Info=False"
                           If Err.Number <> 0 Then
                           Set DbAz = New Connection
                           DbAz.CursorLocation = adUseClient
                           Err.Clear
                Stringa = InputBox("Inserisci la password per accedere al database", "Inserisci la password per accedere al database")
                        If Stringa <> "" Then
                            DbAz.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName & ";Jet OLEDB:Database Password=" & Stringa
                       Else
                            Err.Number = 10
                       End If
                   End If
                   If Err.Number <> 0 Then
                                 MsgBox "Errore nella connessione al Database " & Chr(13) & Err.Number & " " & Err.Description & Chr(13) & "FINE PROCEDURA", vbCritical, "Errore di COnnessione al Database"
                                            'End
                                  ApriDatabase = False
                                  Exit Function
                                  
                   End If
                     ApriDatabase = True

                

            End Function
          '*********************************************************



Public Function fBrowseForFolder(hWndOwner As Long, sPrompt As String, ByVal Opzione) As String
'
' Opzione = 0   ' Solo directory e Driver
' Opzione = 1   ' Solo directory e Driver e Files
'  Opzione = 2   ' computer
'  Opzione = 3   ' stampanti

' Opens the system dialog for browsing for a folder.

'

'Dim iNull As Integer
'Dim lpIDList As Long
'Dim lResult As Long
'Dim sPath As String
'Dim udtBI As BrowseInfo
'
'With udtBI
'.hWndOwner = hWndOwner
'.lpszTitle = lstrcat(sPrompt, "Cerca cartella e Database")
'
'If Opzione = 0 Then ' Solo directory e Driver
'.ulFlags = BIF_RETURNONLYFSDIRS
'ElseIf Opzione = 1 Then ' Solo directory e Driver e Files
'.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_BROWSEINCLUDEFILES
'ElseIf Opzione = 2 Then ' computer
'.ulFlags = BIF_BROWSEFORCOMPUTER
'ElseIf Opzione = 3 Then ' stampanti
'.ulFlags = BIF_BROWSEFORPRINTER
'End If
'End With
'
'lpIDList = SHBrowseForFolder(udtBI)
'
'If lpIDList Then
'sPath = String$(MAX_PATH, 0)
'lResult = SHGetPathFromIDList(lpIDList, sPath)
'Call CoTaskMemFree(lpIDList)
'
'iNull = InStr(sPath, vbNullChar)
'If iNull Then sPath = Left$(sPath, iNull - 1)
'End If
'
'fBrowseForFolder = sPath
End Function
         
         
      Function CalcolaOraLegale(ByVal Anno As Integer)
    Dim Giorno As Integer
    Dim UltimaDomenicaMarzo As Date
    Dim UltimaDomenicaOttobre As Date
   InizioOraLegale = ""
   FineOraLegale = ""
 

    ' Trova l’ultima domenica di marzo
    For Giorno = 31 To 25 Step -1
        If Weekday(DateSerial(Anno, 3, Giorno), vbMonday) = 7 Then
            UltimaDomenicaMarzo = DateSerial(Anno, 3, Giorno)
            Exit For
        End If
    Next Giorno

    ' Trova l’ultima domenica di ottobre
    For Giorno = 31 To 25 Step -1
        If Weekday(DateSerial(Anno, 10, Giorno), vbMonday) = 7 Then
            UltimaDomenicaOttobre = DateSerial(Anno, 10, Giorno)
            Exit For
        End If
    Next Giorno

    ' Assegna i risultati
   

    InizioOraLegale = UltimaDomenicaMarzo
    FineOraLegale = UltimaDomenicaOttobre
    
    
End Function
   
         
         
         
Public Function AddNewID(ByVal NomeTabella As String) As Long
On Error GoTo Errore
AddNewID = 0
Dim Rs2 As Recordset
Set Rs2 = New Recordset
Rs2.Open "SELECT Max(ID) + 1 AS ID FROM " & NomeTabella & ";", DbAzienda, adOpenStatic, adLockOptimistic
AddNewID = Rs2!ID
Errore:

End Function
         
         
    Public Function BrowseFolder(hwnd As Long, szDialogTitle As String) As String
        Dim X As Long, BI As BrowseInfo, dwIList As Long, szPath As String, wPos As Integer
        BI.hOwner = hwnd
        BI.lpszTitle = szDialogTitle
        BI.ulFlags = BIF_RETURNONLYFSDIRS
        dwIList = SHBrowseForFolder(BI)
        szPath = Space$(512)
        X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
        If X Then
           wPos = InStr(szPath, Chr(0))
           BrowseFolder = Left$(szPath, wPos - 1)
        Else
           BrowseFolder = ""
        End If
        
        
    End Function

 Public Function DirWin()
         On Error GoTo Errore
         Dim WinDir As String
         Dim ResultCode As Long
         WinDir = Space$(MAX_PATH)
         ResultCode = GetWindowsDirectory(WinDir, MAX_PATH - 1)
         WinDir = Left$(WinDir, ResultCode)
         DirWin = WinDir
         Exit Function
Errore:
         If Err.Number > 0 Then
        End If
        Err.Clear
 End Function
 
 
 
  

 
 
 

  
       

 



 






 

 


Public Function ScriviWeek(ByVal Mydata As String) As String
'ritorna il giorno della settimana
  Dim MyWek As String
   i = Weekday(Mydata)


      
          If i = 1 Then
          ScriviWeek = "Domenica"   ' */ ) { "
           ElseIf i = 2 Then
           ScriviWeek = "Lunedi"  '*/ ) { "
           ElseIf i = 3 Then
           ScriviWeek = "Martedi"  '*/ ) { "
          ElseIf i = 4 Then
          ScriviWeek = "Mercoledi" '*/ ) { "
          ElseIf i = 5 Then
          ScriviWeek = "Giovedi"  '*/ ) { "
           ElseIf i = 6 Then
           ScriviWeek = "Venerdi"  '*/ ) { "
          ElseIf i = 7 Then
          ScriviWeek = "Sabato" '*/ ) { "
           
          End If
          
          
          
          
End Function





Public Function WeekMese(ByVal mMese As Long) As String
 
 Select Case mMese
        Case Is = 1
        WeekMese = "GENNAIO"
        Case Is = 2
        WeekMese = "FEBBRAIO"
        Case Is = 3
        WeekMese = "MARZO"
        Case Is = 4
        WeekMese = "APRILE"
        Case Is = 5
        WeekMese = "MAGGIO"
        Case Is = 6
        WeekMese = "GIUGNO"
        Case Is = 7
        WeekMese = "LUGLIO"
        Case Is = 8
        WeekMese = "AGOSTO"
        Case Is = 9
       WeekMese = "SETTEMBRE"
        Case Is = 10
        WeekMese = "OTTOBRE"
        Case Is = 11
        WeekMese = "NOVEMBRE"
        Case Is = 12
        WeekMese = "DICEMBRE"
 

       End Select
       
       
       End Function
       
       
       Public Function FineMese(ByVal Mymese As Long, ByVal MyAnno As Long) As Long
          Select Case Mymese
        Case Is = 1
        FineMese = 31
        Case Is = 2
        If IsDate("29/02/" & MyAnno) = True Then
          FineMese = 29
          Else
          FineMese = 28
        End If
        Case Is = 3
        FineMese = 31
        Case Is = 4
        FineMese = 30
        Case Is = 5
        FineMese = 31
        Case Is = 6
       FineMese = 30
        Case Is = 7
        FineMese = 31
        Case Is = 8
        FineMese = 31
        Case Is = 9
       FineMese = 30
        Case Is = 10
        FineMese = 31
        Case Is = 11
        FineMese = 30
        Case Is = 12
        FineMese = 31
 

       End Select
       End Function
       
       
       

 



Public Function MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single, ByVal MForm As Form)
  Static rec As Boolean, msg As Long
  msg = X / Screen.TwipsPerPixelX
  If rec = False Then
    rec = True
    Select Case msg
'      Case WM_LBUTTONDBLCLK:
'        MForm.PopupMenu Menu.MnuTool
'      Case WM_LBUTTONDOWN:
'      MForm.PopupMenu Menu.MnuTool
'      Case WM_LBUTTONUP:
'      MForm.PopupMenu Menu.MnuTool
'      Case WM_RBUTTONDBLCLK:
'         MForm.PopupMenu Menu.MnuTool
'      Case WM_RBUTTONDOWN:
'      Case WM_RBUTTONUP:
'        MForm.PopupMenu Menu.MnuTool
'        Case 513
'        MForm.PopupMenu Menu.MnuTool
    End Select
    
    DoEvents
    
    
    rec = False
  End If
End Function

Public Function ApriMenuIcona()
'Ty.cbSize = Len(Ty)
'  Ty.hwnd = Me.hwnd
'  Ty.uId = 1&
'  Ty.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
'  Ty.ucallbackMessage = WM_MOUSEMOVE
'  Ty.hIcon = Me.Icon
'  Ty.szTip = "Procedura " & App.Comments & Chr$(0)
'  Shell_NotifyIcon NIM_ADD, Ty
'  App.TaskVisible = True 'False
End Function



Public Function QueryUnload(Cancel As Integer, UnloadMode As Integer, MForm As Form)
  Ty.cbSize = Len(Ty)
  Ty.hwnd = MForm.hwnd
  Ty.uId = 1&
  Shell_NotifyIcon NIM_DELETE, Ty
End Function


Public Sub ScriviSuIcona(ByVal Stringa As String)

Stringa = Stringa & Chr(0)
With Ty
  .szTip = ""
  .szTip = Stringa
End With
Shell_NotifyIcon NIM_MODIFY, Ty
End Sub


Public Sub GiornoSettimana(ByVal Mdata As Date, ByVal LeggiGiorni As Boolean)
Dim Fine As Long
Dim i As Long
Dim GiornoSett As String


If LeggiGiorni = True Then
  If Month(Mdata) = 1 Then
   NumeroGiorno = 1
    If Bisestile = True Then
      TotaleGiorni = 366
    Else
      TotaleGiorni = 365
    End If
   End If
End If
  
  
  AzzeraGiorno
  
  If Month(Mdata) = 1 Or _
   Month(Mdata) = 3 Or _
   Month(Mdata) = 5 Or _
   Month(Mdata) = 7 Or _
   Month(Mdata) = 8 Or _
   Month(Mdata) = 10 Or _
   Month(Mdata) = 12 Then
   Fine = 31
   ElseIf Month(Mdata) = 2 And Bisestile = True Then
   Fine = 29
   ElseIf Month(Mdata) = 2 And Bisestile = False Then
   Fine = 28
   Else
   Fine = 30
   End If
  
  For i = 1 To Fine
  
  Select Case Weekday(Mdata)
    Case Is = vbSunday '1 Domenica (predefinita)
        GiornoSett = "Dom"
    Case Is = vbMonday '2 Lunedi
        GiornoSett = "Lun"
    Case Is = vbTuesday '3 Martedi
        GiornoSett = "Mar"
    Case Is = vbWednesday '4 Mercoledi
        GiornoSett = "Mer"
    Case Is = vbThursday '5 Giovedi
        GiornoSett = "Gio"
    Case Is = vbFriday '6 Venerdi
        GiornoSett = "Ven"
    Case Is = vbSaturday '7 Sabato
        GiornoSett = "Sab"
  End Select
   
    If i <= 9 Then
     Giorni(i, 1) = "" & i    ' Numero Giorno
    Else
    Giorni(i, 1) = i     ' Numero Giorno
    End If
    
    Giorni(i, 2) = GiornoSett    ' giorno settimana
    Giorni(i, 3) = Mdata    ' data completa
      
      If GiornoSett = "Dom" Then
      Giorni(i, 4) = True  ' festivo
      Else
       Giorni(i, 4) = False  'NO festivo
      End If
      
      If Month(Mdata) = 1 And i = 1 Then ' 1 GENNAIO Capodanno
        Giorni(i, 4) = True
        Giorni(i, 6) = "Capodanno"
      ElseIf Month(Mdata) = 1 And i = 6 Then ' 6 gennaio epifania
        Giorni(i, 4) = True
        Giorni(i, 6) = "Epifania"
      ElseIf Month(Mdata) = 1 And i = 20 Then ' gennaio Acquario
        Giorni(i, 7) = "Acquario"
      ElseIf Month(Mdata) = 2 And i = 20 Then ' febbraio Pesci
        Giorni(i, 7) = "Pesci"
      ElseIf Month(Mdata) = 3 And i = 20 Then ' 20 marzo Ariete
        Giorni(i, 7) = "Ariete"
        Giorni(i, 8) = "Ricorda Ultima domenica di marzo Ora Legale (aggiungere un ora all'orologio)"
      ElseIf Month(Mdata) = 4 And i = 21 Then ' febbraio Toro
        Giorni(i, 7) = "Toro"
      ElseIf Month(Mdata) = 4 And i = 25 Then ' febbraio Toro
        Giorni(i, 4) = True
        Giorni(i, 6) = "Festa della liberazione"
      ElseIf Month(Mdata) = 4 And i = 29 Then '
        Giorni(i, 6) = "Santa Caterina da Siena Patr. Italia"
      ElseIf Month(Mdata) = 5 And i = 1 Then ' 1 maggio
        Giorni(i, 4) = True
        Giorni(i, 6) = "Festa dei Lavoratori "
      ElseIf Month(Mdata) = 5 And i = 21 Then ' 1 maggio
        Giorni(i, 7) = "Gemelli"
        Giorni(i, 8) = "seconda domenica maggio Festa della Mamma"
      ElseIf Month(Mdata) = 6 And i = 2 Then  '
        Giorni(i, 4) = True
        Giorni(i, 6) = "Festa della repubblica"
      ElseIf Month(Mdata) = 6 And i = 21 Then
        Giorni(i, 7) = "Cancro"
        Giorni(i, 8) = "ricorda 21 giugno Inizio Estate"
      ElseIf Month(Mdata) = 7 And i = 11 Then '
        Giorni(i, 6) = "S. Benedetto da Norcia Patr. Europa"
      ElseIf Month(Mdata) = 7 And i = 23 Then '
        Giorni(i, 7) = "Leone"
      ElseIf Month(Mdata) = 8 And i = 15 Then ' 1 maggio
        Giorni(i, 4) = True
        Giorni(i, 6) = "Ferragosto "
      ElseIf Month(Mdata) = 8 And i = 23 Then '
        Giorni(i, 7) = "Vergine"
      ElseIf Month(Mdata) = 9 And i = 23 Then '
        Giorni(i, 7) = "Bilancia"
        Giorni(i, 8) = "Ricorda 23 inizio autunno"
      ElseIf Month(Mdata) = 10 And i = 4 Then '
        Giorni(i, 6) = "S. Francesco d'assisi Patr. Italia"
      ElseIf Month(Mdata) = 10 And i = 23 Then '
        Giorni(i, 7) = "Scorpione"
        Giorni(i, 8) = " 2 ottobre festa del nonno"
      ElseIf Month(Mdata) = 10 And i = 24 Then '
        Giorni(i, 8) = "31 notte di Halloween"
      ElseIf Month(Mdata) = 10 And i = 25 Then '
        Giorni(i, 8) = "Ultima domenica del mese fine ora legale (togliere un'ora all'orologio)"
      ElseIf Month(Mdata) = 11 And i = 1 Then '
        Giorni(i, 4) = True
        Giorni(i, 6) = "Tutti i Santi"
      ElseIf Month(Mdata) = 11 And i = 22 Then '
        Giorni(i, 7) = "Saggitario"
      ElseIf Month(Mdata) = 11 And i = 4 Then '
        Giorni(i, 6) = "Festa Forze Armate"
      ElseIf Month(Mdata) = 12 And i = 8 Then '
        Giorni(i, 6) = "Immacolata Concezione"
        Giorni(i, 4) = True
      ElseIf Month(Mdata) = 12 And i = 22 Then '
        Giorni(i, 7) = "Capricorno"
      ElseIf Month(Mdata) = 12 And i = 25 Then '
        Giorni(i, 6) = "Natale"
        Giorni(i, 4) = True
      ElseIf Month(Mdata) = 12 And i = 26 Then '
        Giorni(i, 6) = "S. Stefano"
        Giorni(i, 4) = True
      ElseIf Month(Mdata) = 12 And i = 21 Then '
        Giorni(i, 8) = "ricorda inizio Inverno"
      ElseIf Month(Mdata) = 12 And i = 31 Then '
        Giorni(i, 6) = "S. Silvestro"
      End If
      

      If LeggiGiorni = True Then
          Giorni(i, 5) = TotaleGiorni - 1 & " - " & NumeroGiorno
          NumeroGiorno = NumeroGiorno + 1
          TotaleGiorni = TotaleGiorni - 1
      End If

   Mdata = Mdata + 1
   
  Next


End Sub


Sub AzzeraGiorno()
Dim i As Long
  For i = 1 To 31
    Giorni(i, 1) = ""    ' Numero Giorno
    Giorni(i, 2) = ""    ' giorno settimana
    Giorni(i, 3) = ""    ' data completa
    Giorni(i, 4) = False  ' festivo
    Giorni(i, 5) = ""    ' Numero Giorni da trascorrere e numero giorni trascorsi.
    Giorni(i, 6) = ""    ' Festività
    Giorni(i, 7) = ""    ' Oroscopo
    Giorni(i, 8) = ""    ' Ricorda
  Next
End Sub



Public Sub ApriDBAzienda()
  On Error GoTo Errore
'  Close #1
'  If Dir(App.Path & "\INI\GestioneRete.ini") <> "" Then
'  Close #1
'  Open App.Path & "\INI\GestioneRete.ini" For Input As #1
'  Line Input #1, DbName
'  Close #1
'
'  Else
'
' DbName = InputBox("Inserire il percorso e nome del DB", , App.Path & "\Database\appunti.mdb")
'  If Len(Trim(DbName)) = 0 Then
'  MsgBox "Database non trovato - Chiudo programma", vbCritical, "KO"
'  End
'  End If
'
'  If Dir(DbName) = "" Then
'  MsgBox "Database non trovato - Chiudo programma", vbCritical, "KO"
'  Else
'
' Open App.Path & "\INI\GestioneRete.ini" For Output As #1
'  Print #1, DbName
'  Close #1
'
'
'  End If
'
'
' End If
'
' If DbName = "" Or Dir(DbName) = "" Then
' MsgBox "APRIAZIENDA -> dbname vuoto procedura ApriAzienda " & DbName, vbInformation, "KO"
'  End If
'
'
'Mydirpath = App.Path
DbName = App.Path & "\Database\Frequenze.mdb"
  If DbAzienda Is Nothing Then
     Set DbAzienda = New Connection
     DbAzienda.CursorLocation = adUseClient
     DbAzienda.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName '& App.Path & "\Database\Appunti.mdb;"
     

     If Err.Number <> 0 Then
        
        Set DbAzienda = New Connection
        DbAzienda.CursorLocation = adUseClient
DbAzienda.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName & ";Mode=ReadWrite|Share Deny None;Persist Security Info=False"
        If Err.Number <> 0 Then
           MsgBox "Errore nella connessione al Database " & Chr(13) & Err.Number & " " & Err.Description & Chr(13) & "FINE PROCEDURA", vbCritical, "Errore di COnnessione al Database"
'               Menu.MnuNuovo_Click
        End If

    End If

 

 End If
 
 
 
' If DbAzienda.State > 0 Then
'
'
'
'
' Err.Clear
  
  
'  Dim Rs As New Recordset
'
'     If TblExists("myDefault") = False Then
'     Dim tbl As New ADOX.Table
'     Dim cat As New ADOX.Catalog
' Set tbl = CreateObject("ADOX.Table")
'Set cat = CreateObject("ADOX.Catalog")
'
'cat.ActiveConnection = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName & ";"
'
'
'tbl.Name = "myDefault"
'tbl.Columns.Append "Tabella", adVarWChar, 50
'tbl.Columns.Append "myWhere", adVarWChar, 250
'tbl.Columns.Append "CancellaEseguita", adBoolean, 0
'cat.Tables.Append tbl
'Set tbl = Nothing
'Set cat = Nothing
' Rs.Open "Select * from myDefault", DbAzienda, 3, 3
' Rs.AddNew
' Rs!tabella = "Calendario"
' Rs!MyWhere = "Messaggio <> 'Compleanno Puglisi Paolo'"
' Rs.Update
' Rs.AddNew
' Rs!tabella = "Anagrafe"
' Rs!MyWhere = "nominativo <> 'Paolo Puglisi'"
' Rs.Update
'Rs.Close
'
'
' End If
'
'
'
'  Rs.Open "Select * from Calendario", DbAzienda, 3, 3
'
'        If Rs.RecordCount = 1 Then
'        RecordsetVuoto = True
'        End If
'
' End If
'
'
'
'If CreaMySanti = False And ZMasterNewApp = False Then
' CreaSanti
' CreaMySanti = True
'
' If Err.Number > 0 Then
'MsgBox "Procedura apriazienda Errore : " & Err.Description, vbCritical, "KO"
'Err.Clear
'End If
'
'
'
' End If
 
' ScriviAsci
 Exit Sub
Errore:
If Err.Number <> -2147467259 Then
MsgBox "Procedura ApriAzienda -> " & Err.Description, vbCritical, "ko"
End If


End Sub


 


Public Function TblExists(sTable As String) As Boolean
  
  On Error Resume Next
  Dim tdf As TableDef
  Dim MyDb As Database
  Set MyDb = OpenDatabase(DbName)
  Set tdf = MyDb.TableDefs(sTable)

  If Err.Number = 0 Then
    TblExists = True
  Else
    TblExists = False
  End If
End Function

 




Public Function Cancella() As Boolean
  Dim i As Integer
  i = MsgBox("      Sei sicuro di voler cancellare il record?" & Chr(13) & _
 "    Tale cancellazione provvederà a cancellare" & Chr(13) & _
 "a catena anche i record relazionati con il record stesso", vbYesNo + 4096, "... Cancellazione in fase di conferma")

  If i = 6 Then
     Cancella = True
  Else
     Cancella = False
  End If

End Function



Public Function RicercaApostrofo(ByVal Frase As String) As Long
Dim j As Long

  
  j = InStr(1, Frase, "'")
  
  RicercaApostrofo = j


End Function







 



 



Public Function TogliAccento(ByVal Stringa As String) As String
Stringa = Replace(Stringa, "'", " ")
Stringa = Replace(Stringa, "à", "a")
Stringa = Replace(Stringa, "è", "e")
Stringa = Replace(Stringa, "é", "e")
Stringa = Replace(Stringa, "ò", "o")
Stringa = Replace(Stringa, "ì", "i")
Stringa = Replace(Stringa, "ù", "u")
TogliAccento = Stringa


End Function



Public Function PasquaDay(Optional ByVal Y As Integer = 2007) As Date
'***********************************************************************************

'Private Sub Command18_Click()
'Stringa = PasquaDay(2022)
'MsgBox "Pasqua è il giorno " & Stringa
'End Sub

'Func.:   EasterDay (Mod SB-16/02/2007; Mod.:       )
'Desc.:   Restituisce il giorno di Pasqua
'DLL. :
'
'Par. :   Y  Anno
'Ret. :
'***********************************************************************************
Dim M As Integer, n As Integer, A As Integer, B As Integer, C As Integer, D As Integer, E As Integer
Dim ED As String
M = 24: n = 5
A = Y Mod 19
B = Y Mod 4
C = Y Mod 7
D = (19 * A + M) Mod 30
E = (2 * B + 4 * C + 6 * D + n) Mod 7
ED = 22 + D + E
If ED <= 31 Then
  ED = ED & "/03/" & Y
Else
  ED = D + E - 9 & "/04/" & Y
End If
PasquaDay = CDate(ED)

End Function


 

'*********************************************************
    '*                                                       *
    Public Function Centra(ByVal Stringa As String, ByVal spazio As Long) As String
        '*                                                       *
        '*********************************************************
        On Error Resume Next
        Dim DifferenzaSpazio As Integer
        If Len(Stringa) > spazio Then
            Stringa = Mid(Stringa, 1, spazio)
        End If
        DifferenzaSpazio = Int(spazio - Len(Stringa)) / 2
        Centra = Space(DifferenzaSpazio) & Stringa & Space(DifferenzaSpazio)
        If Len(Centra) < spazio Then
            Centra = Space(spazio - Len(Centra)) & Centra
        End If

    End Function


          
           
     

          Public Function Destra2Dec(ByVal Mstringa As String, ByVal Mspaz As Long) As String

               If Len(Mstringa) = Mspaz Then
                     Destra2Dec = Mstringa
                     Exit Function
               End If


                If Mstringa <> "0" Then
                      Mstringa = Format(Mstringa, "###,###,###,##0.00")
                End If


                Do While Len(Mstringa) < Mspaz
                      Mstringa = " " & Mstringa
                Loop

                Destra2Dec = Mstringa
           End Function
           
           
           




          Public Sub Intestazione(ByVal Titolo1 As String, ByVal Titolo2 As String, ByVal RigheBianche As Long)
          On Error Resume Next
          Dim i As Long
          
          Printer.FontSize = 10    ' Imposta le dimensioni in
          Printer.FontName = "Courier New"
          Dim MlenTItolo1, MlenTItolo2, Riga As Long
          MlenTItolo1 = Int(80 - Len(Titolo1)) / 2
          MlenTItolo2 = Int(80 - Len(Titolo2)) / 2
          
         
          i = Printer.CurrentX
          Printer.CurrentX = i + 10
          Printer.Print
          Printer.Print
          Printer.Print
          Printer.Print

          Printer.Print "                               " & Titolo1
          Printer.Print "                               " & Titolo2

               For Riga = 1 To RigheBianche
                Printer.Print
               Next

           End Sub





Public Sub Compatta()
    On Error GoTo GestoreErrori
    Dim CONN As New JRO.JetEngine
    Dim CONN_Sorg As String, CONN_Dest As String
   PathDataAziendale = DbName  ' App.Path & "\Database\_ReportNewVisualBasic6.Mdb"
    Screen.MousePointer = vbHourglass
    If DbAzienda.State > 0 Then
    DbAzienda.Close
    End If
    CONN_Sorg = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbName & ";User ID=;Password=;"
    CONN_Dest = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Temp.mdb" & ";Jet OLEDB:Engine Type=5;"
    CONN.CompactDatabase CONN_Sorg, CONN_Dest
    Set CONN = Nothing
    Kill DbName
    FileCopy App.Path & "\Temp.mdb", App.Path & "\Database\_ReportNewVisualBasic6.Mdb"
    Kill App.Path & "\Temp.mdb"

    Exit Sub

GestoreErrori:
    Screen.MousePointer = vbNormal

End Sub


Public Function TipoCampo(intType As Integer) As String

Select Case intType
          Case 11
                    TipoCampo = "Boolean"
          Case 17
                    TipoCampo = "Byte"
          
          Case 3
                    TipoCampo = "Long"
          
          Case 6
                    TipoCampo = "Currency"   ' valuta
          
          Case 5
                    TipoCampo = "Double"
          
          Case 7
                    TipoCampo = "Date"
          
          Case 202
                    TipoCampo = "Testo"
          
          Case 203
                    TipoCampo = "Memo"
          
          Case 202
                    TipoCampo = "testo"
          Case 205
                    TipoCampo = "OLE"
          Case 131
                    TipoCampo = "Decimale"
          Case Else
                    TipoCampo = "Tipo " & intType & "Non Definito"

End Select



End Function


  
Public Sub OrdinaArray(ByVal Freq2 As Long, ByVal Regione As Long, ByVal Provincia As Long, ByVal Citta As Long, ByVal NomeRadio As Long)

    Dim FreTempo(4, 1) As Variant

    FreTempo(0, 0) = "Freq2"
    FreTempo(0, 1) = Freq2

    FreTempo(1, 0) = "Regione"
    FreTempo(1, 1) = Regione

    FreTempo(2, 0) = "Provincia"
    FreTempo(2, 1) = Provincia

    FreTempo(3, 0) = "Citta"
    FreTempo(3, 1) = Citta

    FreTempo(4, 0) = "NomeRadio"
    FreTempo(4, 1) = NomeRadio

    ' ORDINA
    Call OrdinaSecondaColonna(FreTempo)

    ' MOSTRA RISULTATO
    Call MostraRisultato(FreTempo)

End Sub
Private Sub OrdinaSecondaColonna(ByRef A() As Variant)

    Dim i As Integer, j As Integer
    Dim t0 As Variant, t1 As Variant

    For i = LBound(A, 1) To UBound(A, 1) - 1
        For j = i + 1 To UBound(A, 1)

            ' ORDINA PER COLONNA 1 (numerica)
            If A(i, 1) > A(j, 1) Then

                ' scambia colonna 0 (testo)
                t0 = A(i, 0)
                A(i, 0) = A(j, 0)
                A(j, 0) = t0

                ' scambia colonna 1 (numeri)
                t1 = A(i, 1)
                A(i, 1) = A(j, 1)
                A(j, 1) = t1

            End If

        Next j
    Next i

End Sub
Private Sub MostraRisultato(ByRef A() As Variant)

    Dim i As Integer
    Dim msg As String

    msg = "Risultato ordinato:" & vbCrLf & vbCrLf
Dim Indice As String
    For i = LBound(A, 1) To UBound(A, 1)
        msg = msg & A(i, 0) & "  =  " & A(i, 1) & vbCrLf
        If A(i, 1) > 0 Then
        Indice = Indice & A(i, 0) & ", "
        End If
    Next i
    
    Indice = Trim(Indice)
    
    If Len(Indice) > 0 Then
    If Mid(Indice, Len(Indice), 1) = "," Then
    Indice = Mid(Indice, 1, Len(Indice) - 1)
    End If
    End If
    
    MenuRadio.Risultato.Caption = Trim(Indice)
    
    'MsgBox msg

End Sub
 
