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

1.后台打开Excel

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

vbnet 复制代码

Sub openexcel(exl_name As String)
    If Dir(addr, 16) = Empty Then
        file_error = True
        Exit Sub
    End If
    Set fso = CreateObject("Scripting.FileSystemObject").GetFolder(addr & "\")
    file_name = ""
    For Each file In fso.Files
        If InStr(file.Name, exl_name & ".") > 0 And exl_name <> "" And InStr(file.Name, "$") < 1 Then
            file_name = file.Name 'fso.path
            'Debug.Print file.Name
        End If
    Next
    Set fso = Nothing
    If InStr(file_name, "xlsm") > 0 And InStr(file_name, "蝶阀") > 0 Then
        vba_s = True
    Else
        vba_s = False
    End If
    If file_name <> "" Then
        str_path = addr & "\" & file_name
        'Debug.Print str_path
        If IsWbOpen1(str_path) Then '判断excel是否已经打开
        Else
            Set wb = GetObject(str_path)
            Application.Windows(wb.Name).Visible = False
            find_if_open = True
        End If
    Else
        MsgBox "报错:工作区中不存在该文件"
        file_error = True
        Exit Sub
    End If

2.判断文件是否已打开

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

vbnet 复制代码

Function IsWbOpen1(strPath As String) As Boolean
    '如果目标工作簿已打开则返回TRUE，否则返回FALSE
    Dim oi As Integer
    For oi = Workbooks.Count To 1 Step -1
        If Workbooks(oi).FullName = strPath Then Exit For
    Next
    If oi = 0 Then
        IsWbOpen1 = False
    Else
        IsWbOpen1 = True
    End If
End Function

3.生成新Excel

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

vbnet 复制代码

Public Sub export_excel(control As Office.IRibbonControl)
    Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim newFileName As String
    shtn = 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:=False
    End With
    ' 清理
    Set sourceSheet = Nothing
    Set targetWorkbook = Nothing
    Set sourceWorkbook = Nothing
End Sub

4.延时

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

vbnet 复制代码

Public Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
'------------延时------------
Sub delay1(T As Single) '秒级的延时
    Dim time1 As Single
    time1 = Timer
    Do
    DoEvents
    Loop While Timer - time1 < T
End Sub

Sub delay(T As Single) '毫秒级的延时(需要引用dll)
    Dim time1 As Single
    time1 = timeGetTime
    Do
    DoEvents
    Loop While timeGetTime - time1 < T
End Sub
'------------延时------------

5.链接Access数据库

vbnet 复制代码

Sub ExportDataToAccess(arrFileds As Variant, datas As Variant, sheetName As String)
    Dim conString$, sqlString$
    Dim cnn, rst
    Set 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, _
        adLockOptimistic
    rst.AddNew arrFileds, datas     '数组插入到Access
    cnn.Close   ' 关闭连接对象
End Sub

6.调节图片长宽比

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

vbnet 复制代码

'--------------------------调整图片长宽比---------------------------
Sub change_sacle(shp As Shape, scal As Double) 'scale为长宽比，推荐值1.5
    If shp.Type = 13 Then '当shape对象类型是图片的时候，才开始统计（图片的值13）
        Dim xCrop As Object, xl As Double, xt As Double
        shp.ScaleHeight 0.995, msoTrue, msoScaleFromTopLeft
        shp.ScaleWidth 1.05, msoTrue, msoScaleFromTopLeft
        shp.PictureFormat.Crop.PictureOffsetX = 0
        shp.PictureFormat.Crop.PictureOffsetY = 0
        shp.PictureFormat.Crop.ShapeWidth = shp.PictureFormat.Crop.PictureWidth
        shp.PictureFormat.Crop.ShapeHeight = shp.PictureFormat.Crop.PictureHeight
        If 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 xl
                Set xCrop = shp.PictureFormat.Crop '返回一个Crop对象
                With xCrop '设置裁剪格式
                    '.ShapeLeft = shp.Left + xl '裁剪左边
                    .ShapeWidth = .PictureWidth - 2 * xl '裁剪宽度
                    .PictureOffsetX = 0
                    .PictureOffsetY = 0
                End With
            Else '高了，裁剪上下
                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 = 0
                End With
            End If
        End If
    End If
End Sub
'--------------------------调整图片长宽比---------------------------

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

vbnet 复制代码

'------------获取一段函数运行时间------------
Sub GetRunTime()
    Dim i As Long
    Dim dteStart As Date
    Dim 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
'------------获取一段函数运行时间------------

持续更新中......