1.Option Explicit:
======== Enumerations for choosing the format in which it will be inserted ===== Enum eFormat
Picture = 1 Chart = 2 Table = 3 End Enum
==================================================== =======================
Sub pGeneratePPT_Click() Dim lngWksCount As Long Dim lngLoopFirst As Long Dim lngLoopSecond As Long Dim lngSlide As Long Dim objTemplate As Object If MsgBox("Please click OK to generate the slide or click CANCEL to exit from the existing process.", vbOKCancel, "WARNING!") = vbCancel Then MsgBox "You have selected CANCEL please click the 'PPT converter' button again to convert into power point.", vbInformation, "Generation of slide presentation has been cancelled." GoTo lblExit End If lngWksCount = ThisWorkbook.Worksheets.Count Set objTemplate = Wks_INDEX.OLEObjects("objPPTTemplate") For lngLoopFirst = 1 To lngWksCount With ThisWorkbook.Worksheets(lngLoopFirst) For lngLoopSecond = 1 To .ChartObjects.Count If .ChartObjects(lngLoopSecond).Visible = True Then lngSlide = lngSlide + 1 Call fPPTGenerator(objTemplate, .Name, lngSlide, Chart, .ChartObjects(lngLoopSecond).Name) End If Next lngLoopSecond End With Next lngLoopFirst MsgBox "Done!", vbInformation lblExit: lngWksCount = Empty lngLoopFirst = Empty lngLoopSecond = Empty lngSlide = Empty Set objTemplate = Nothing End Sub Function fPPTGenerator(objOLEObject As Object, strSheetName As String, lngSlide As Long, enumPasteAs As eFormat, _ strRangeOrChartName As String, Optional dblLeftInInches As Double, Optional dblTopInInches As Double, _ Optional dblHeightInInches As Double, Optional dblWidthInInches As Double) Dim lngLoopFirst As Long Dim lngLoopSecond As Long Dim objSlide As Object 'PowerPoint.Slide Dim objTemplate As Object 'Embbed File for template Dim objLayout As Object Dim objMainObject As Object Dim varPicture As Variant Dim lngStatus As Long Dim objShape As Object Dim strPathTemplate As String Dim objFileSystem As Object Dim objFile As Object Dim strFileName As String Dim objPresTemp As Object Dim blnOpen As Boolean Dim objPPT As Object Dim objPres As Object Dim blnNoError As Boolean Dim blnTemplateNotFound As Boolean lngStatus = Application.ScreenUpdating Application.ScreenUpdating = False On Error GoTo lblNewPPT '****If the presentation is already open or not**** Set objPPT = GetObject(, "Powerpoint.Application") Set objPres = objPPT.presentations(1) blnOpen = True '************************************************** lblNewPPT: '****If the presentation is not opened already**** If blnOpen = False Then On Error GoTo 0: On Error GoTo -1: Err.Clear Set objPPT = CreateObject("Powerpoint.Application") Set objPres = objPPT.presentations.Add End If '************************************************** Set objFileSystem = CreateObject("Scripting.FileSystemObject") '**********Setting or adding the slides*********** If objPres.slides.Count <> lngSlide Then Set objLayout = objPres.Designs(1).SlideMaster.CustomLayouts(1) Set objSlide = objPres.slides.Addslide(lngSlide, objLayout) Else Set objSlide = objPres.slides(lngSlide) End If '************************************************** '*******Opening the embbed file in the editing mode********* objOLEObject.Verb Verb:=xlEditBox objPPT.WindowState = 2 '************************************************** '*****Open the presentation and saving it at the workbook path***** Set objPresTemp = objPPT.activepresentation objPresTemp.SaveAs ThisWorkbook.Path & "\Template.pot" objPresTemp.Close '************************************************** objPPT.WindowState = 2 For Each objFile In objFileSystem.getfolder(ThisWorkbook.Path).Files If Right(objFile.Name, 3) = "pot" Then strFileName = objFile.Name blnTemplateNotFound = False Exit For Else blnTemplateNotFound = True End If Next If blnTemplateNotFound = False Then objPres.ApplyTemplate FileName:=ThisWorkbook.Path & "\Template.pot" 'Applying the Template to the new presentation Else MsgBox "Please embed the template in the" & vbNewLine & "'Microsoft Powerpoint 93-2003 Template' (*.pot) Format!", vbCritical blnNoError = False GoTo lblExit: End If Kill ThisWorkbook.Path & "\" & strFileName 'Deleting the template thereafter applying For lngLoopFirst = 1 To objSlide.Shapes.Count 'Removing the extra shapes on the new slide objSlide.Shapes(lngLoopFirst).Delete If objSlide.Shapes.Count > 0 Then lngLoopFirst = lngLoopFirst - 1 Else Exit For End If Next objPPT.Visible = True Select Case enumPasteAs Case Picture: On Error GoTo lblErrorPic Set objMainObject = ThisWorkbook.Worksheets(strSheetName).Shapes(strRangeOrChartName) objMainObject.CopyPicture Format:=xlPicture Set varPicture = objSlide.Shapes.PasteSpecial(2) varPicture.LockAspectRatio = False blnNoError = True lblErrorPic: If blnNoError = False Then MsgBox "Shape object not Found!" & vbNewLine & vbNewLine & "Worksheet: " & strSheetName & _ vbNewLine & "Shape: " & strRangeOrChartName, vbCritical On Error GoTo 0: On Error GoTo -1: Err.Clear GoTo lblExit End If Case Chart: On Error GoTo lblErrorChart Set objMainObject = ThisWorkbook.Worksheets(strSheetName).Shapes(strRangeOrChartName) objMainObject.Copy objPPT.Activate objSlide.Select objPPT.ActiveWindow.View.Paste Set varPicture = objSlide.Shapes(1) blnNoError = True lblErrorChart: If blnNoError = False Then MsgBox "Chart not Found!" & vbNewLine & vbNewLine & "Worksheet: " & strSheetName & vbNewLine _ & "Chart: " & strRangeOrChartName, vbCritical On Error GoTo 0: On Error GoTo -1: Err.Clear GoTo lblExit End If Case Table: On Error GoTo lblError Set objMainObject = ThisWorkbook.Worksheets(strSheetName).Range(strRangeOrChartName) objMainObject.Copy objPPT.Activate objSlide.Select objPPT.ActiveWindow.View.Paste For Each objShape In objSlide.Shapes If Ucase(Left(objShape.Name, 5)) = "TABLE" Then Set varPicture = objSlide.Shapes(objShape.Name) Exit For End If Next blnNoError = True lblError: If blnNoError = False Then MsgBox "Range Not Found!" & vbNewLine & vbNewLine & "Range: " & strRangeOrChartName & _ vbNewLine & "Worksheet: " & strSheetName, vbCritical On Error GoTo 0: On Error GoTo -1: Err.Clear GoTo lblExit End If End Select With varPicture If dblLeftInInches <> 0 Then .Left = dblLeftInInches * 72 Else .Left = 33 End If If dblTopInInches <> 0 Then .Top = dblTopInInches * 72 Else .Top = 118 End If If dblHeightInInches <> 0 Then .Height = dblHeightInInches * 72 Else .Height = 360 End If If dblWidthInInches <> 0 Then .Width = dblWidthInInches * 72 Else .Width = 655 End If End With objPPT.ActiveWindow.View.Zoom = 100 ' objPres.SaveAs ThisWorkbook.Path & "\PPT_" & Format(Now(), "dd_mmm_yyyy") & ".pptx" lblExit: objPPT.WindowState = 2 lngLoopFirst = Empty lngLoopSecond = Empty Set objSlide = Nothing Set objTemplate = Nothing Set objLayout = Nothing Set objMainObject = Nothing Set varPicture = Nothing Set objShape = Nothing strPathTemplate = Empty Set objFileSystem = Nothing Set objFile = Nothing strFileName = Empty Set objPresTemp = Nothing blnOpen = Empty Set objPres = Nothing Application.ScreenUpdating = lngStatus lngStatus = Empty If blnNoError = False Then objPPT.Quit End End If End Function ====================================== Option Explicit Option Compare Text Private adoConn As Object Private adoRset As Object Private Const mc_strModuleName As String = "modExportExcelDataToAccess" Private Const strMsgBoxTitle As String = "Uploader" Private Const strDbName As String = "Test.mdb" Sub test() Call ExportDataIntoAccess( _ db_FullPath:=ThisWorkbook.Path & Application.PathSeparator & strDbName, _ db_tblName:="Test" & CLng(Timer), _ xl_FileFullPath:=ThisWorkbook.FullName, _ xl_SheetName:="Sheet1", _ xl_DataRange:="$A$1:$E$200000", _ xl_HeaderYes:=True, _ blnDelTableExistingData:=True) End Sub Sub ExportDataIntoAccess( _ ByVal db_FullPath As String, _ ByVal db_tblName As String, _ ByVal xl_FileFullPath As String, _ ByVal xl_SheetName As String, _ ByVal xl_DataRange As String, _ ByVal xl_HeaderYes As Boolean, _ Optional blnDelTableExistingData As Boolean = False) Dim wbkWorkBook As Workbook Dim wksWorkSheet As Worksheet Dim varData As Variant Dim lngLoopD As Long Dim lngLoopA As Long Dim lngLoop As Long Dim lngFldsCount As Long Dim lngLastCol As Long Dim lngLastRow As Long Dim strSQL As String Dim strTemp As String Dim lngCounter As Long Dim dblSum As Double Dim dbFlds() As String Dim dataFlds As Variant Dim varFound As Variant Dim rngFirstCell As Range Dim rngData As Range Dim strAddress As String Dim lngScreenUp As Long Dim lngCalc As Long Dim dtTime As Date dtTime = Time Const DataTypeNumeric As String = "Single" Const DataTypeString As String = "varchar(255)" Const DataTypeDateTime As String = "DateTime" 'Setting Table Name If Left(db_tblName, 1) <> "[" Then db_tblName = "[" & db_tblName End If If Right(db_tblName, 1) <> "]" Then db_tblName = db_tblName & "]" End If 'Checking file path is correct. If Not IsFileExists(xl_FileFullPath) Then Exit Sub 'Disabling Application Level Events With Application .EnableEvents = 0 lngCalc = .Calculation lngScreenUp = .ScreenUpdating '.ScreenUpdating = 0 .DisplayAlerts = 0 .Calculation = xlCalculationManual End With 'Checking if given file and sheet is available or not On Error Resume Next If Not IsFileOpen(xl_FileFullPath) Then Set wbkWorkBook = Workbooks.Open(xl_FileFullPath) ElseIf LCase(ThisWorkbook.FullName) = LCase(xl_FileFullPath) Then Set wbkWorkBook = ThisWorkbook Else If IsFileOpen(xl_FileFullPath) Then MsgBox "File is already open. Please save file and close it first to upload data.", vbCritical, strMsgBoxTitle GoTo QuickExit Else Set wbkWorkBook = Workbooks.Open(xl_FileFullPath) End If End If Set wksWorkSheet = wbkWorkBook.Worksheets(CStr(xl_SheetName)) 'Error handling If Err.Number <> 0 Then MsgBox "Worksheet '" & xl_SheetName & " doesn't exists", vbInformation Err.Clear: On Error GoTo 0 GoTo QuickExit End If Call OpenDB(db_FullPath) With wksWorkSheet 'Data Range Set rngData = .Range(xl_DataRange) 'checking for header if available If xl_HeaderYes Then dataFlds = Application.Transpose(Application.Transpose(rngData.Resize(1))) Else adoRset.Open "Select * From " & db_tblName & " Where 1=2", adoConn, 3, 3 ReDim datafld(1 To adoRset.Fields.Count) For lngLoop = 0 To adoRset.Fields.Count - 1 Select Case adoRset.Fields(lngLoop).Type Case 202 'adVarWChar datafld(lngLoop + 1) = 202 'advarWChar Case 4 'adSingle datafld(lngLoop + 1) = 4 'adSingle Case 5 'adDouble datafld(lngLoop + 1) = 5 'adDouble Case 7 'adDate datafld(lngLoop + 1) = 7 'adDate End Select Next lngLoop End If varData = rngData End With If LCase(wbkWorkBook.FullName) <> LCase(xl_FileFullPath) Then wbkWorkBook.Close (0) On Error GoTo 0 'Checking if table is already exist or not. If Not blnTableExistsInDB(CStr(db_tblName)) Then 'Creating table If xl_HeaderYes Then If IsArray(varData) And IsArray(dataFlds) Then strTemp = "Create Table " & CStr(db_tblName) & vbLf & "(" ReDim datafld(1 To UBound(dataFlds, 1)) For lngLoopD = 1 To UBound(dataFlds, 1) If IsNumeric(varData(2, lngLoopD)) And Len(varData(2, lngLoopD)) Then strTemp = strTemp & vbLf & IIf(lngLoopD = 1, "[" & dataFlds(lngLoopD) & "]", ",[" & dataFlds(lngLoopD) & "]") & " " & DataTypeNumeric datafld(lngLoopD) = 5 'adDouble ElseIf IsDate(varData(2, lngLoopD)) Then strTemp = strTemp & vbLf & IIf(lngLoopD = 1, "[" & dataFlds(lngLoopD) & "]", ",[" & dataFlds(lngLoopD) & "]") & " " & DataTypeDateTime datafld(lngLoopD) = 7 'adDate Else strTemp = strTemp & vbLf & IIf(lngLoopD = 1, "[" & dataFlds(lngLoopD) & "]", ",[" & dataFlds(lngLoopD) & "]") & " " & DataTypeString datafld(lngLoopD) = 202 'advarWChar End If Next lngLoopD strTemp = strTemp & vbLf & ")" adoConn.Execute Replace(strTemp, "''", "Null") End If Else If IsArray(varData) Then strTemp = "Create Table " & CStr(db_tblName) & vbLf & "(" For lngLoopD = 1 To UBound(varData, 2) If IsNumeric(varData(2, lngLoopD)) And Len(varData(2, lngLoopD)) Then strTemp = strTemp & vbLf & IIf(lngLoopD = 1, "[Field" & lngLoopD & "]", ",[Field" & lngLoopD & "]") & " " & DataTypeNumeric ElseIf IsDate(varData(2, lngLoopD)) Then strTemp = strTemp & vbLf & IIf(lngLoopD = 1, "[Field" & lngLoopD & "]", ",[Field" & lngLoopD & "]") & " " & DataTypeNumeric Else strTemp = strTemp & vbLf & IIf(lngLoopD = 1, "[Field" & lngLoopD & "]", ",[Field" & lngLoopD & "]") & " " & DataTypeString End If Next lngLoopD strTemp = strTemp & vbLf & ")" adoConn.Execute Replace(strTemp, "''", "Null") End If End If Else 'Delete existing data from the table. If blnDelTableExistingData Then strSQL = "Delete * FROM " & CStr(db_tblName) adoConn.Execute strSQL End If End If 'Inserting data into the table row by row. On Error GoTo EarlyExit If IsArray(varData) Then For lngLoopD = LBound(varData) + 1 To UBound(varData, 1) strTemp = "INSERT INTO " & CStr(db_tblName) & " VALUES (" For lngLoopA = 1 To UBound(datafld) If datafld(lngLoopA) = 5 Or datafld(lngLoopA) = 4 Then 'adDouble 'adSigle If Not IsEmpty(varData(lngLoopD, lngLoopA)) Then strTemp = strTemp & vbLf & IIf(lngLoopA = 1, varData(lngLoopD, lngLoopA), "," & varData(lngLoopD, lngLoopA)) ElseIf IsEmpty(varData(lngLoopD, lngLoopA)) Then strTemp = strTemp & vbLf & IIf(lngLoopA = 1, "NULL", ",NULL") End If ElseIf datafld(lngLoopA) = 7 Then 'adDate varData(lngLoopD, lngLoopA) = Replace(varData(lngLoopD, lngLoopA), "#", "") varData(lngLoopD, lngLoopA) = Evaluate("=VALUE(""" & varData(lngLoopD, lngLoopA) & """)") strTemp = strTemp & vbLf & IIf(lngLoopA = 1, varData(lngLoopD, lngLoopA), "," & varData(lngLoopD, lngLoopA)) ElseIf datafld(lngLoopA) = 202 Then 'advarWChar varData(lngLoopD, lngLoopA) = Replace(varData(lngLoopD, lngLoopA), "'", "''") varData(lngLoopD, lngLoopA) = Replace(varData(lngLoopD, lngLoopA), """", """""") strTemp = strTemp & vbLf & IIf(lngLoopA = 1, "'" & varData(lngLoopD, lngLoopA) & "'", ",'" & varData(lngLoopD, lngLoopA) & "'") End If 'Debug.Print strTemp Next lngLoopA strTemp = strTemp & ")" 'Debug.Print "ROW: " & lngLoopD ' & ":" & strTemp Call StatusBar(lngLoopD & " Out Of " & UBound(varData) - 1 & " Records inserted into " & db_tblName & " ...") adoConn.Execute Replace(strTemp, "''", "Null") Next lngLoopD Call StatusBar(lngLoopD & "Records are inserted successfully." & vbLf & "Process Started at " & dtTime & " and Finished at " & Time) MsgBox lngLoopD & "Records are inserted successfully." & vbLf & "Process Started at " & dtTime & " and Finished at " & Time, vbInformation, strMsgBoxTitle Call StatusBar(, False) End If EarlyExit: If Err.Number <> 0 Then MsgBox "Error