|
'*********************************** 'stampa un calendario dentro Excel '*********************************** Public Sub ExcellStampaOre(ByVal Anno As Long) Dim X As Long Const xlOpenXMLWorkbook As Long = 51 Dim Exc As Object 'To open Excel Set Exc = CreateObject("Excel.application") 'Creates an object Exc.Visible = True Exc.Workbooks.Add 'Adds a new book. Exc.cells(1, 2).Formula = "Elaborazione turnazioni di lavoro periodo " & Anno Exc.cells(2, 2).Formula = "Procedura elaborata da Paolo Puglisi con la collaborazione di Andrea Amadio!" ' Inserimento dalla 6° riga della matricola e Nominativo Dim Riga As Long Dim Col As Long Riga = 6 Dim DatPrimaryrs As Recordset Set DatPrimaryrs = New Recordset DatPrimaryrs.Open "Select IdUtente, Nominativo, * from Anagrafica where Turnazione = true order by ID", DbAzienda, adOpenStatic, adLockOptimistic Do While Not DatPrimaryrs.EOF Exc.cells(Riga, 1).Formula = DatPrimaryrs!IdUtente 'Add Text to a Cell Exc.cells(Riga, 2).Formula = DatPrimaryrs!Nominativo 'Add Text to a Cell Riga = Riga + 1 DatPrimaryrs.MoveNext Loop Exc.Rows("4:5").Select Exc.Selection.NumberFormat = "@" '************************************************************************************* ' scrittura intestazione con i blocchi settimanali '************************************************************************************* 'Costante Valore Descrizione 'vbUseSystem 0 Viene utilizzata l'impostazione API National Language Support (NLS). 'vbSunday 1 Domenica (impostazione predefinita) 'vbMonday 2 Lunedi' 'vbTuesday 3 Martedi' 'vbWednesday 4 Mercoledi' 'vbThursday 5 Giovedi' 'vbFriday 6 Venerdi' 'vbSaturday 7 Sabato Dim MyDate, MyWeekDay MyDate = "01/01/" & Anno ' Assegna una data. MyWeekDay = Weekday(MyDate) Select Case MyWeekDay Case Is = 1 ' Domenica Exc.cells(4, 3).Formula = "02/01" Exc.cells(5, 3).Formula = "08/01" MyDate = "09/01/" & Anno Case Is = 2 'Lunedi' Exc.cells(4, 3).Formula = "02/01" Exc.cells(5, 3).Formula = "07/01" MyDate = "08/01/" & Anno Case Is = 3 'Martedi' Exc.cells(4, 3).Formula = "02/01" Exc.cells(5, 3).Formula = "06/01" MyDate = "07/01/" & Anno Case Is = 4 'Mercoledi' Exc.cells(4, 3).Formula = "02/01" Exc.cells(5, 3).Formula = "05/01" MyDate = "06/01/" & Anno Case Is = 5 'Giovedi' Exc.cells(4, 3).Formula = "02/01" Exc.cells(5, 3).Formula = "04/01" MyDate = "05/01/" & Anno Case Is = 6 'Venerdi' Exc.cells(4, 3).Formula = "02/01" Exc.cells(5, 3).Formula = "03/01" MyDate = "04/01/" & Anno Case Is = 7 'Sabato Exc.cells(4, 3).Formula = "01/01" Exc.cells(5, 3).Formula = "02/01" MyDate = "03/01/" & Anno End Select Col = 4 '********************** ' colonne Settimanali '********************** Do While Year(MyDate) < (Anno + 1) Exc.cells(4, Col).Formula = Day(MyDate) & "/" & Month(MyDate) MyDate = DateAdd("D", 6, MyDate) Exc.cells(5, Col).Formula = Day(MyDate) & "/" & Month(MyDate) MyDate = DateAdd("D", 1, MyDate) DoEvents Col = Col + 1 Loop '************************************************************************************* Dim ColonneTotale As Long ColonneTotale = Col - 1 Riga = 6 DatPrimaryrs.MoveFirst Dim Rs As New Recordset Do While Not DatPrimaryrs.EOF Rs.Open "Select * from Sequenza where IdUtente = '" & DatPrimaryrs!IdUtente & "' AND gestione = " & Anno & " order by mese", DbAzienda, adOpenStatic, adLockOptimistic Col = 3 DoEvents Do While Not Rs.EOF If Mid(Rs!Turno1, 1, 1) = "M" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioMattina ElseIf Mid(Rs!Turno1, 1, 1) = "N" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioNotturno ElseIf Mid(Rs!Turno1, 1, 1) = "P" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioPomeriggio End If Col = Col + 1 If Col > ColonneTotale Then Exit Do End If If Mid(Rs!Turno2, 1, 1) = "M" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioMattina ElseIf Mid(Rs!Turno2, 1, 1) = "N" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioNotturno ElseIf Mid(Rs!Turno2, 1, 1) = "P" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioPomeriggio End If Col = Col + 1 If Col > ColonneTotale Then Exit Do End If If Mid(Rs!Turno3, 1, 1) = "M" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioMattina ElseIf Mid(Rs!Turno3, 1, 1) = "N" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioNotturno ElseIf Mid(Rs!Turno3, 1, 1) = "P" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioPomeriggio End If Col = Col + 1 If Col > ColonneTotale Then Exit Do End If If Mid(Rs!Turno4, 1, 1) = "M" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioMattina ElseIf Mid(Rs!Turno4, 1, 1) = "N" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioNotturno ElseIf Mid(Rs!Turno4, 1, 1) = "P" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioPomeriggio End If Col = Col + 1 If Col > ColonneTotale Then Exit Do End If If Mid(Rs!Turno5, 1, 1) = "M" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioMattina ElseIf Mid(Rs!Turno5, 1, 1) = "N" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioNotturno ElseIf Mid(Rs!Turno5, 1, 1) = "P" Then Exc.cells(Riga, Col).Formula = DatPrimaryrs!OrarioPomeriggio End If Col = Col + 1 If Col > ColonneTotale Then Exit Do End If DoEvents Rs.MoveNext Loop Riga = Riga + 1 DatPrimaryrs.MoveNext Rs.Close Loop '************************************************************************************* 'You can use the line above, changing coordenates to go to any 'cell and you can also add Formulas Exc.Range("A3:BD" & Riga - 1).BORDERS.Color = RGB(0, 0, 0) 'Use it to 'change the borders. Exc.Columns("A:bd").EntireColumn.AutoFit 'To adjust the 'column's width. Exc.Range("A:BD").Select 'To establish a selection Exc.Selection.NumberFormat = "0" 'Adding different formats Exc.ActiveWorkbook.SaveAs FileName:="C:\Prova\Cartel" & Replace(Time, ":", "") & ".xlsx", FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False Exc.Quit Set Exc = Nothing End Sub |