VBA实战(Excel)(4)：实用功能整理

1.后台打开Excel

用于查数据，工作中要打开多个表获取数据再关闭的场景，利用此函数可以将excel表格作为后台数据库查询，快速实现客户要求，缺点是运行效率不够高。

Sub openexcel(exl_name As String)If Dir(addr, 16) = Empty Thenfile_error = TrueExit SubEnd IfSet fso = CreateObject("Scripting.FileSystemObject").GetFolder(addr & "\")file_name = ""For Each file In fso.FilesIf InStr(file.Name, exl_name & ".") > 0 And exl_name <> "" And InStr(file.Name, "$") < 1 Thenfile_name = file.Name 'fso.path'Debug.Print file.NameEnd IfNextSet fso = NothingIf InStr(file_name, "xlsm") > 0 And InStr(file_name, "蝶阀") > 0 Thenvba_s = TrueElsevba_s = FalseEnd IfIf file_name <> "" Thenstr_path = addr & "\" & file_name'Debug.Print str_pathIf IsWbOpen1(str_path) Then '判断excel是否已经打开ElseSet wb = GetObject(str_path)Application.Windows(wb.Name).Visible = Falsefind_if_open = TrueEnd IfElseMsgBox "报错:工作区中不存在该文件"file_error = TrueExit SubEnd If

2.判断文件是否已打开

避免重复打开客户已经打开的文件，提升体验和效率

Function IsWbOpen1(strPath As String) As Boolean'如果目标工作簿已打开则返回TRUE，否则返回FALSEDim oi As IntegerFor oi = Workbooks.Count To 1 Step -1If Workbooks(oi).FullName = strPath Then Exit ForNextIf oi = 0 ThenIsWbOpen1 = FalseElseIsWbOpen1 = TrueEnd If
End Function

3.生成新Excel

针对需要把结果生成一张新表格的客户

Public Sub export_excel(control As Office.IRibbonControl)Dim sourceWorkbook As WorkbookDim targetWorkbook As WorkbookDim sourceSheet As WorksheetDim newFileName As Stringshtn = Sheets("参数").Cells(2, 2)' 设置源工作簿和工作表Set sourceWorkbook = ThisWorkbook ' 当前工作簿Set sourceSheet = sourceWorkbook.Sheets("扭矩查询") ' 要导出的工作表名称' 创建新的工作簿Set targetWorkbook = Workbooks.Add' 拷贝工作表到新工作簿sourceSheet.Copy before:=targetWorkbook.Sheets(1)' 设置新工作簿的文件名newFileName = shtn & "factory-" & Format(Now(), "YYYYMMDDhhmmss") & ".xlsx" ' 新文件名' 保存新工作簿With targetWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & newFileName, FileFormat:=xlOpenXMLWorkbook.Close SaveChanges:=FalseEnd With' 清理Set sourceSheet = NothingSet targetWorkbook = NothingSet sourceWorkbook = Nothing
End Sub

4.延时

针对需要等待的场景，比如等待加载

Public Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
'------------延时------------
Sub delay1(T As Single) '秒级的延时Dim time1 As Singletime1 = TimerDoDoEventsLoop While Timer - time1 < T
End SubSub delay(T As Single) '毫秒级的延时(需要引用dll)Dim time1 As Singletime1 = timeGetTimeDoDoEventsLoop While timeGetTime - time1 < T
End Sub
'------------延时------------

5.链接Access数据库

Sub ExportDataToAccess(arrFileds As Variant, datas As Variant, sheetName As String)Dim conString$, sqlString$Dim cnn, rstSet cnn = CreateObject("ADODB.Connection")  ' 创建连接对象Set rst = CreateObject("ADODB.Recordset")   ' 创建记录集对象conString = "provider=Microsoft.ace.OLEDB.12.0;Data Source=" & ThisWorkbook.path _& "\test.accdb;"cnn.Open conString  ' 连接Access数据库rst.Open "select * from " & sheetName & " where 1=2", cnn, adOpenDynamic, _adLockOptimisticrst.AddNew arrFileds, datas     '数组插入到Accesscnn.Close   ' 关闭连接对象
End Sub

6.调节图片长宽比

此函数能调节插入图片的长宽比，通过等边距裁剪，使图片在Excel中排版统一

'--------------------------调整图片长宽比---------------------------
Sub change_sacle(shp As Shape, scal As Double) 'scale为长宽比，推荐值1.5If shp.Type = 13 Then '当shape对象类型是图片的时候，才开始统计（图片的值13）Dim xCrop As Object, xl As Double, xt As Doubleshp.ScaleHeight 0.995, msoTrue, msoScaleFromTopLeftshp.ScaleWidth 1.05, msoTrue, msoScaleFromTopLeftshp.PictureFormat.Crop.PictureOffsetX = 0shp.PictureFormat.Crop.PictureOffsetY = 0shp.PictureFormat.Crop.ShapeWidth = shp.PictureFormat.Crop.PictureWidthshp.PictureFormat.Crop.ShapeHeight = shp.PictureFormat.Crop.PictureHeightIf shp.Width / shp.Height - scal > 0.05 Or scal - shp.Width / shp.Height > 0.05 Then '允许一些误差防止无限裁剪
'                    Debug.Print "执行"If shp.Width / shp.Height > scal Then '宽了，裁剪左右xl = (shp.Width - shp.Height * scal) / 2'Debug.Print xlSet xCrop = shp.PictureFormat.Crop '返回一个Crop对象With xCrop '设置裁剪格式'.ShapeLeft = shp.Left + xl '裁剪左边.ShapeWidth = .PictureWidth - 2 * xl '裁剪宽度.PictureOffsetX = 0.PictureOffsetY = 0End WithElse '高了，裁剪上下xt = (shp.Height - shp.Width / scal) / 2'Debug.Print xt
'                    Debug.Print "高了"Set xCrop = shp.PictureFormat.Crop '返回一个Crop对象With xCrop '设置裁剪格式'.ShapeTop = shp.Top + xt '裁剪顶部.ShapeHeight = .PictureHeight - 2 * xt '裁剪高度.PictureOffsetX = 0.PictureOffsetY = 0End WithEnd IfEnd IfEnd If
End Sub
'--------------------------调整图片长宽比---------------------------

7.获取一段函数的运行时间

'------------获取一段函数运行时间------------
Sub GetRunTime()Dim i As LongDim dteStart As DateDim strTime As String'Application.ScreenUpdating = False'关闭屏幕刷新dteStart = Timer'---------运行过程主体-------
MkDir "D:\Bomad\Assembly"'---------运行过程主体-------strTime = Format((Timer - dteStart), "0.00000")MsgBox "运行过程: " & strTime & "秒"'Application.ScreenUpdating = True'打开屏幕刷新
End Sub
'------------获取一段函数运行时间------------

持续更新中......