1.Опция явная:
======== Перечисления для выбора формата для вставки ===== 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 #:" & Err.Number & vbLf & Err.Description
Err.Clear: On Error GoTo 0
Stop Else
Call StatusBar("", False) End If Erase varData dblSum = Empty dataFlds = Empty QuickExit: With Application
.EnableEvents = 1
.ScreenUpdating = lngScreenUp
.DisplayAlerts = 1
.Calculation = lngCalc End With
Call CloseDB
End Sub
Private Function IsFileExists(ByVal FullFileName As String) As Boolean IsFileExists = False On Error Resume Next
IsFileExists = CBool(Len(Dir(FullFileName))) End Function
Private Sub OpenDB(ByVal strDBPath As String)
Set adoConn = CreateObject("ADODB.Connection") Set adoRset = CreateObject("ADODB.Recordset") adoConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;data source=" & CStr(strDBPath) &
";"
End Sub Private Sub CloseDB()
On Error Resume Next If adoRset.State <> 0 Then adoRset.Close If adoConn.State <> 0 Then adoConn.Close On
Error GoTo 0: Err.Clear
End Sub
Private Function blnTableExistsInDB(strTableName As String) As Boolean
Dim rst As Object Dim strTbl As String
strTbl = strTableName
Set rst = adoConn.OpenSchema(20) 'adSchemaTables
If Left(strTbl, 1) = "[" And Right(strTbl, 1) = "]" Then
strTbl = Mid(strTbl, 2, Len(strTbl) - 2) End If
rst.Filter = "TABLE_TYPE='TABLE' and TABLE_NAME='" & strTbl & "'" On Error Resume Next blnTableExistsInDB =
(Ucase(rst.Fields("TABLE_NAME").Value) = Ucase(strTbl)) On Error
GoTo 0 If Err.Number <> 0 Then blnTableExistsInDB = False Set
rst = Nothing
End Function
Private Function IsFileOpen(ByVal FileName As String)
Dim iFilenum As Long Dim iErr As Long
On Error Resume Next iFilenum = FreeFile() Open FileName For Input Lock Read As #iFilenum Close iFilenum iErr
= Err On Error GoTo 0
Select Case iErr Case 0: IsFileOpen = False Case 70: IsFileOpen = True Case Else: Error iErr End Select
End Function
Private Sub StatusBar(Optional strMsg As String = vbNullString, Optional blnShow As Boolean = True)
DoEvents If Not blnShow Then Application.StatusBar = blnShow: Exit Sub Application.StatusBar = strMsg
End Sub