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
6条答案
按热度按时间fjnneemd1#
看看ClumsyLeaf cloud explorer。让我们像FTP客户端一样上传文件到blob。或者Azure Storage Explorer。同样的想法。
两者都允许您从目录中选择文件并一次性上传。从未尝试过10000，但它应该工作。
vktxenjb2#
Cloud Storage Studio也相当不错。
http://cerebrata.com/Products/CloudStorageStudio/
你可以免费试用30年，所以没有风险。特别是如果它是一次性的交易。
vsaztqbk3#
你可以使用windows azure powershell从azure存储上传/下载多个文件。
要上载多个文件，可以使用以下命令行。
要下载多个Blob，可以使用以下命令行。
有关详细信息，请参阅MSDN页面。
http://msdn.microsoft.com/en-us/library/dn408487.aspx
http://msdn.microsoft.com/en-us/library/dn408562.aspx
wvmv3b1j4#
我发现现有的工具要么是付费软件，要么是因为使用的线程太少而速度太慢。TBH即使是我试过的付费应用程序也相当慢，但Azure API真的很简单，所以我最终编写了自己的命令行工具，它被称为azupload：
https://github.com/bviktor/azupload
它是免费的，在MIT许可下发布，有C#和Java两个版本，所以你可以很容易地在Windows和Linux上部署它。
C#版本使用内部的.NET调度器来启动新线程（在我的组件上通常是10个左右），而Java版本则根据您的指定启动任意多个线程。它的性能相当好，我已经用700张图片（总大小为20 MiB）和100个线程进行了测试，它在8秒内完成了上传。
当然，你必须找到一个平衡点。如果你启动太多的线程，它最终会因为Java VM的开销而变慢。而且，如果你上传大文件，用100个线程上传是没有意义的，因为在这种情况下，瓶颈将是带宽，而不是像许多小文件那样的事务开销。此外，如果你上传许多文件，JVM打开文件的速度会比关闭文件的速度快，所以过一段时间你会遇到
Too many open files异常（对我来说，13 k文件@100个线程就发生了这种情况）。因此，作为一个经验法则，文件越小，线程越多，但你可能应该在50个左右停止。非常感谢您提供反馈！
cbjzeqam5#
1.显式选项：
========用于选择粘贴格式的枚举=====枚举eFormat
=======================================================================
m0rkklqb6#
您可以创建自己的PowerShell/cmd脚本，并在脚本中使用Az Cli命令来上载文件：az存储blob批量上载
步骤：
1.从Microsoft安装Az CLI：https://learn.microsoft.com/en-us/cli/azure/install-azure-cli
1.从Azure Blob存储获取帐户密钥和名称凭据：https://learn.microsoft.com/en-us/azure/storage/common/storage-account-keys-manage?tabs=azure-portal
1.配置Az Cli命令以根据您的要求上载文件： www.example.comhttps://learn.microsoft.com/en-us/cli/azure/storage/blob?view=azure-cli-latest#az-storage-blob-upload-batch
例如：