Hi:
I'd forgotten to said that PP is 2003 version. And here is the code:
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Column constants
Public Const COL_HOTEL = "A"
Public Const COL_ESTRELLAS = "H"
Public Const COL_POBLACION = "B"
Public Const COL_PROVINCIA = "C"
Public Const COL_PAIS = "D"
Public Const COL_FECHAS = "E"
Public Const COL_TALONES = "F"
Public Const COL_REGIMEN = "G"
Sub Auto_Open()
Dim app_Excel As New Excel.Application
Dim wb_Libro As Excel.Workbook
Dim ws_Hoja As Worksheet
Dim lng_Linea As Long
Dim app_PowerPoint As New PowerPoint.Application
Dim pre_Ofertas As Presentation
Dim sld_Diapositiva As Slide
Dim str_Plantilla As String
Dim obj_FSO As New FileSystemObject
Dim str_Hotel As String, str_Estrellas As String, _
str_Poblacion As String, str_Provincia As String
Dim str_Pais As String, str_Fechas As String, _
str_Talones As String, str_Regimen As String
Dim str_EtiquetaTalones As String
Dim lng_ColorTalones As Long
On Error GoTo ctrl_Errores
' Get a reference to your add-in.
If AddIns.Count > 0 Then
With AddIns(AddIns.Count)
' Create the registry key in HKEY_CURRENT_USER.
.Registered = msoTrue
' Set the AutoLoad value in the registry.
.AutoLoad = msoTrue
' Makes sure that the add-in is loaded.
.Loaded = msoTrue
End With
End If
'The Excel worksheet has column headers, so the 1st line
'to read is the sheet's 2nd line
lng_Linea = 2
'Creating new presentation
Set pre_Ofertas = app_PowerPoint.Presentations.Add
'Adding a blank slide to the presentation
pre_Ofertas.Slides.Add 1, ppLayoutBlank
'Setting transition properties
With pre_Ofertas.Slides.Range.SlideShowTransition
.AdvanceTime = 5
.EntryEffect = ppEffectRandom
End With
'Setting Slide Show Settings and running it
With pre_Ofertas.SlideShowSettings
.Run
.AdvanceMode = ppSlideShowManualAdvance
.ShowWithAnimation = msoTrue
End With
'Hidding mouse cursor
pre_Ofertas.SlideShowWindow.View.PointerType = _
ppSlideShowPointerAlwaysHidden
Do
'Copyin Excel's workbook (this workbook has the data)
obj_FSO.CopyFile "\\server\folder\hotels.xls", _
"\\server\folder\hotels1.xls", True
'Opening the copy
Set wb_Libro = app_Excel.Workbooks.Open("\\server\folder\hotels1.xls", _
ReadOnly:=True)
Set ws_Hoja = wb_Libro.Worksheets(1)
'If the sheet's current line is blank then return to the 2nd line
If ws_Hoja.Range("A" & lng_Linea).Value = "" Then
lng_Linea = 2
GoTo NuevaVuelta
End If
'Reading the data and charging it onto variables
With ws_Hoja
str_Hotel = ws_Hoja.Range(COL_HOTEL & lng_Linea).Value
str_Estrellas = ws_Hoja.Range(COL_ESTRELLAS & lng_Linea).Value
str_Poblacion = ws_Hoja.Range(COL_POBLACION & lng_Linea).Value
str_Provincia = ws_Hoja.Range(COL_PROVINCIA & lng_Linea).Value
str_Pais = ws_Hoja.Range(COL_PAIS & lng_Linea).Value
str_Fechas = ws_Hoja.Range(COL_FECHAS & lng_Linea).Value
str_Talones = ws_Hoja.Range(COL_TALONES & lng_Linea).Value
str_Regimen = ws_Hoja.Range(COL_REGIMEN & lng_Linea).Value
'Setting plural or singular label
If CInt(str_Talones) = 1 Then
str_EtiquetaTalones = "Talón/Noche"
Else
str_EtiquetaTalones = "Talones/Noche"
End If
End With
'Closing workbook
wb_Libro.Close
'Deleting copy
obj_FSO.DeleteFile "\\server\folder\hotels1.xls", True
'Diferent colors in check number function
Select Case CInt(str_Talones)
Case 1 'Rosa
lng_ColorTalones = RGB(254, 194, 215)
Case 2 'Azul
lng_ColorTalones = RGB(184, 208, 246)
Case 3 'Amarillo
lng_ColorTalones = RGB(252, 254, 176)
Case 4 'Verde
lng_ColorTalones = RGB(146, 216, 136)
Case 5 'Naranja
lng_ColorTalones = RGB(247, 196, 105)
Case Else 'Blanco
lng_ColorTalones = RGB(255, 255, 255)
End Select
'Creating slide
Set sld_Diapositiva = ActivePresentation.Slides.Add(1, ppLayoutText)
'Applying template to the slide
sld_Diapositiva.ApplyTemplate "\\server\folder\hotels.pot"
'If there are three slide the 2dn will be deleted
If pre_Ofertas.Slides.Count > 2 Then ActivePresentation.Slides(2).Delete
'Writing data onto title
sld_Diapositiva.Shapes.Title.TextFrame.TextRange.Text = str_Hotel & " " & _
str_Estrellas & vbCrLf & _
str_Poblacion & " (" & _
str_Provincia & ") " & _
str_Pais & vbCrLf & _
str_Talones & " " & str_EtiquetaTalones
'Formatting tittle text
With sld_Diapositiva.Shapes(1).TextFrame.TextRange
.Characters(1, Len(str_Hotel & " " & str_Estrellas)).Font.Bold = msoTrue
.Characters(Len(str_Hotel) + 2, Len(str_Estrellas)).Font.Name = "Wingdings 2"
.Characters(Len(str_Hotel) + 2, Len(str_Estrellas)).Font.Color.RGB = RGB(255, 230, 0)
.Characters(Len(str_Hotel & " " & str_Estrellas) + 1, _
Len(sld_Diapositiva.Shapes(1).TextFrame.TextRange.Text)).Font.Bold = msoFalse
.Characters(Len(.Text) - Len(str_Talones & " " & str_EtiquetaTalones) + 1, _
Len(str_Talones & " " & str_EtiquetaTalones)).Font.Color.RGB = lng_ColorTalones
.Characters(Len(.Text) - Len(str_Talones & " " & str_EtiquetaTalones) + 1, _
Len(str_Talones & " " & str_EtiquetaTalones)).Font.Bold = msoTrue
End With
'Writing data onto text and formatting it
With sld_Diapositiva.Shapes(2).TextFrame.TextRange
.Text = "Fechas: " & str_Fechas & vbCrLf & _
"Régimen: " & str_Regimen
.Characters(Len("Fechas: ") + 1, Len(str_Fechas)).Font.Bold = msoTrue
.Characters(Len("Fechas: ") + Len(str_Fechas) + Len("Régimen: ") + 2, _
Len(str_Regimen)).Font.Bold = msoTrue
End With
'Moving to the created slide
pre_Ofertas.SlideShowSettings.Run.View.GotoSlide 1
'Waiting 20 seconds
DoEvents
Sleep 20000
'Seeking if the slide show is ended
If Not pre_Ofertas.SlideShowWindow.View.State = ppSlideShowRunning Then
pre_Ofertas.SlideShowWindow.View.Exit
FinDePresentacion:
pre_Ofertas.Slides(1).Delete
pre_Ofertas.Close
Exit Do
End If
'Adding 1 to the worksheet line counter
lng_Linea = lng_Linea + 1
NuevaVuelta:
Loop
FinDeProcedimiento:
'Quitting and emptying
Set ws_Hoja = Nothing
Set wb_Libro = Nothing
app_Excel.Quit
Set app_Excel = Nothing
Set obj_FSO = Nothing
app_PowerPoint.Quit
Set app_PowerPoint = Nothing
Exit Sub
ctrl_Errores:
If Err.Number = 1004 Then
pre_Ofertas.SlideShowWindow.View.Exit
ElseIf Err.Number = -2147188160 Then
Resume FinDePresentacion
Else
MsgBox Err.Number & ": " & Err.Description, vbOKOnly, "bas_Ventas.Auto_Open"
End If
Resume FinDeProcedimiento
End Sub
--
Un Saludo
Urpiano Cedazo
Y fue Urpiano Cedazo (
[email protected]) quien en el mensaje
[email protected], planeando sobre su teclado, hizo un picado y tecleó:
