Popular blog tags

Excel VBA代码封装成Dll(VB6.0)： VBA 代码的转换

Published
Created: Sunday, June 13, 2021 12:24:59 PM Latest updated:Friday, October 22, 2021 3:40:36 PM views(1572)

Converting to VB6 is easy

1.Create a VB6 DLL project. Search on the web for instructions how to do this and how to expose methods, classes, and functions.

2.Add a reference to "Microsoft Office Excel ## library".

3.In a procedure of the project that will be exposed as a method in the DLL

 

1.操作 工作表


Excel.Application对象是Excel对象模型的顶层，表示整个Excel应用程序.

Dim E As Excel.Application
Set E = GetObject(, "Excel.Application")

If an instance of Microsoft Excel is running when this code is executed, you have access to the running instance's object model through the xlApp variable. 

If multiple instances of Microsoft Excel are running, GetObject attaches to the instance that is launched first. If you then close the first instance, another call to GetObject attaches to the second instance that was launched, and so forth.

You can attach to a specific instance if you know the name of an open document in that instance. For example, if an instance of Excel is running with an open workbook named Book2, the following code attaches successfully to that instance even if it is not the earliest instance that was launched:

Set xlApp = GetObject("Book2").Application

detail：https://docs.microsoft.com/en-us/office/troubleshoot/office-suite-issues/getobject-createobject-behavior

an ActiveX EXE example

Add Microsoft Excel 14.0 Object Library

Option Explicit
Sub Main()
    Dim sPath As String
    Dim ExcelApp As Excel.Application '定义ExcelApp为Excel程序对象
    Dim bCreatApp As Boolean
    Dim wWB As Workbook
   
    sPath = App.Path & "" '获取当前Exe文件所在文件夹
    On Error Resume Next '遇到出错时执行下一语句
    Set ExcelApp = GetObject(, "Excel.Application") '获取已经打开的Excel程序
    bCreatApp = ExcelApp Is Nothing '判断是否获取了Excel程序，如果ExcelApp是Nothing时表示Excel程序没有被运行
    On Error GoTo 0 '恢复出错时提示错误并停止执行功能
    If bCreatApp Then '没有运行Excel程序时
        Set ExcelApp = CreateObject("Excel.Application") '运行Excel程序
        ExcelApp.Visible = True '将Excel程序界面显示出来
    End If
    With ExcelApp '在Excel程序里
        If bCreatApp Then
            Set wWB = .Workbooks.Add '新建一个Excel工作簿
            With wWB '在新建的Excel工作簿内
                With .Sheets(1) '在第一个表内
                    .[A1] = .[A1] + 1
                End With
                .SaveAs sPath & "VB6测试程序(By.Micro).xlsx" '保存工作簿
                .Close '关闭工作簿
            End With
        Else
            Set wWB = .Workbooks.Open(sPath & "VB6测试程序(By.Micro).xlsm") '打开已有的工作簿
            .Run "测试程序" '运行工作簿内已有过程
            wWB.Close True '关闭并保存工作簿
        End If
        If bCreatApp Then .Quit '如果原本没有运行Excel程序时关闭Excel程序
    End With
End Sub

 

Proceed with your normal VBA code, with one modification:

Globally accessed objects such as ActiveSheet or ActiveWorkbook or Sheets must become E.ActiveSheet, E.ActiveWorkbook and E.Sheets.

    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
    
    Set xlApp = GetObject(, "Excel.Application")    '表示为EXCEL对象
    Set xlBook = xlApp.ActiveWorkbook
    Set xlsheet = xlApp.ActiveSheet    '使xlSheet表示为EXCEL的当前工作表

如果 Microsoft Excel 的多个实例正在运行，GetObject 将附加到首先启动的实例。 如果随后关闭第一个实例，则对 GetObject 的另一个调用将附加到已启动的第二个实例，以此类推。

如果您知道特定实例中打开的文档的名称，可以附加到该实例。 例如，如果 Excel 实例与名为 Book2 的打开工作簿一起运行，则以下代码将成功附加到该实例，即使该实例不是启动的最早实例：

Set xlApp = GetObject("Book2").Application

detail:https://docs.microsoft.com/zh-cn/office/troubleshoot/office-suite-issues/getobject-createobject-behavior

 

 

2.Selection

VB6

Selection Add xlApp

3210      sht1.Activate

3220      xlApp.ActiveSheet.Range("e" & maxrow + 1).Resize(n, 32).Select
3230      xlApp.Selection.Copy


3240      sheet5.Activate
3250      maxrow5 = sheet5.Range("e55555").End(xlUp).Row
3260      sheet5.Range("A" & maxrow5 + 1).Select
3270      xlApp.Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                        :=False, Transpose:=False

 

3.Range

VBA

''1-2********************以下将数据排序按 货位，生产编号，箱号，客户批次号升序**************************************

    Shtscan.Sort.SortFields.Clear
    Shtscan.Sort.SortFields.Add Key:=Range("B3:B" & maxrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Shtscan.Sort.SortFields.Add Key:=Range("E3:E" & maxrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Shtscan.Sort.SortFields.Add Key:=Range("C3:C" & maxrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Shtscan.Sort.SortFields.Add Key:=Range("G3:G" & maxrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Shtscan.Sort
        .SetRange Range("A2:AF" & maxrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 '1-2结束****************************************************************

VB6

Add shtScan

'1-2********************以下将数据排序按 货位，生产编号，箱号，客户批次号升序**************************************

    Shtscan.Sort.SortFields.Clear
    Shtscan.Sort.SortFields.Add Key:=Shtscan.Range("B3:B" & maxrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Shtscan.Sort.SortFields.Add Key:=Shtscan.Range("E3:E" & maxrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Shtscan.Sort.SortFields.Add Key:=Shtscan.Range("C3:C" & maxrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Shtscan.Sort.SortFields.Add Key:=Shtscan.Range("G3:G" & maxrow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Shtscan.Sort
        .SetRange Shtscan.Range("A2:AF" & maxrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 '1-2结束****************************************************************

5.Activate

vba

        
3210      sht1_sheetProductionExecution.Activate
3220      ActiveSheet.Range("e" & maxrow_sht1_sheetProductionExecution + 1).Resize(n, 32).Select
3230      Selection.Copy
3240      sheet5_sheetInnerLabel.Activate

 

vb6

 

 

 

see：https://docs.microsoft.com/en-us/office/vba/Language/Reference/user-interface-help/createobject-function

2.There are 3 different properties which could be used to refer to a worksheet:

.Name as Worksheets("SomeNameHere") in Worksheets("SomeNameHere").Range("A1")
.Index as Worksheets(2) in Worksheets(2).Range("A1")
.CodeName as Sheet3 in Sheet3.Range("A1")

To see the difference, run the code below and take a look at the immediate window

Sub TestMe()
    Dim wks As Worksheet
    For Each wks In ThisWorkbook.Worksheets
        Debug.Print wks.Name
        Debug.Print wks.Index
        Debug.Print wks.CodeName
        Debug.Print "-----------------------"
    Next wks
End Sub

 

'
'---------------------------------------------------------------------------
' Used to VB Get Sheet object by Codenames. 根据CodeName获取工作表对象 https://www.spreadsheet1.com/vba-codenames.html
'---------------------------------------------------------------------------
Function GetSheetFromCodeName(oWB As Workbook, sCodename As String) As Object
 
    Dim oSht As Object
 
    For Each oSht In oWB.Sheets
         
        If oSht.CodeName = sCodename Then
            Set GetSheetFromCodeName = oSht
            Exit For
        End If
         
    Next oSht
     
End Function

 

 

 

先引用和创建excel程序，然后利用 Excel对象.子对象.对象或方法的结构 来转换。

例：删除重复数据。

Sub 删除重复数据()

    Dim x As Integer
    Dim arr, d As Object
    Dim el As Object
   
    Set d = CreateObject("scripting.dictionary")     '创建字典对象
    
    With ActiveSheet
        
        arr = Selection
        
        For x = 1 To UBound(arr)     '通过循环把数据装入字典，字典只能获取不重复值
            d(arr(x, 1)) = ""
        Next x
        
        Selection.Clear
        Selection.Cells(1, 1).Resize(d.Count) = Application.Transpose(d.Keys)
   
    End With
   
    Set el = Nothing
 
 End Sub

封装后的代码，涉及Excel中的方法和对象在VB中都要先加el。

Sub 删除重复数据2()
   
    Dim x As Integer
    Dim arr, d As Object
    Dim el As Object
    
    Set d = CreateObject("scripting.dictionary")
    Set el = GetObject(, "Excel.Application")     '创建excel对象
   
    With el.ActiveSheet       'excel程序的activesheet,下面遇到excel中的对象方法、函数都要加上el
        
        arr = el.Selection
        
        For x = 1 To UBound(arr)
            d(arr(x, 1)) = ""
        Next x
   
        el.Selection.Clear
        el.Selection.Cells(1, 1).Resize(d.Count) = el.Transpose(d.Keys)
    
    End With
   
    Set el = Nothing

End Sub

封装、调用后就能在VBA中使用，使用方面和类模块一样：

Sub 引用删除dll()
    Dim sc As New 删除重复模块
     sc.删除重复数据2
     Set sc = Nothing
End Sub

 

2.带参数

在vb中，修改“工程”名称和“类模块”名称为需要的名称。本例中，工程修改为TestDLL，类模块修改为Test。
引用Microsoft Office 11.0 Object Library和Microsoft Excel 11.0 Object Library。
Sub mySub(EApp As Excel.Application, r As Long, c As Integer)
    Dim wb As Excel.Workbook, sh As Excel.Worksheet
    Set wb = EApp.ThisWorkbook
    Set sh = wb.ActiveSheet
　　sh.Cells(r,c)="这是测试文本"
　　'其他的代码
End Sub

在Excel中，在VBA中要引用刚才生成的TestDll.dll。
新建一个模块，在其中定义一个类变量T：
Public T As New TestDll.Test

Sub AAA()
   On Error Resume Next
   T.mySub Application, 3, 7
End Sub

至此，可以在Excel中执行宏AAA，并会在(3,7)单元格得到字符串"这是测试文本"。

http://club.excelhome.net/thread-750345-1-1.html?_dsign=c5bb1e26

 

 

 

Function to reference a sheet codename in any other workbook

Option Explicit
 
Function GetSheetFromCodeName(oWB As Workbook, sCodename As String) As Object
 
    Dim oSht As Object
 
    For Each oSht In oWB.Sheets
         
        If oSht.CodeName = sCodename Then
            Set GetSheetFromCodeName = oSht
            Exit For
        End If
         
    Next oSht
     
End Function
 
Sub Test()
 
    Dim oSht As Object
 
    Set oSht = GetSheetFromCodeName(ActiveWorkbook, "Sheet3")
     
    If Not oSht Is Nothing Then
        '....
    End If
 
End Sub

https://www.spreadsheet1.com/vba-codenames.html

 

vb7

http://www.excelpx.com/thread-325983-1-1.html

名称 类型 描述
PtrSafe  关键字 声明 Declare 语句针对 64 位系统。在 64 位上是必需的。
LongPtr 数据类型 该类型别名映射为 32 位系统上的 Long，或 64 位系统上的 LongLong。
LongLong 数据类型 8 字节的数据类型，只在 64 位系统上可用。数字类型。-9,223,372,036,854,775,808 到 9,223,372,036,854,775,807 范围内的整数。LongLong 只是 64 位平台上的有效声明类型。此外，不能将 LongLong 隐式转换为较小的类型（例如，不能将 LongLong 赋予 Long）。这样做的目的是防止不慎将指针截断。允许显式强制转换，所以在上例中，可以将 CLng 应用于 LongLong，并将结果赋予 Long。（只在 64 位平台上有效。）
^ LongLong 类型声明字符 显式将文字值声明为 LongLong。声明大于最大 Long 值的 LongLong 文字时是必需的（否则它将隐式转换为 double）。
CLngPtr 类型转换函数 将简单表达式转换为 LongPtr。
CLngLng 类型转换函数 将简单表达式转换为 LongLong 数据类型。（只在 64 位平台上有效。）
vbLongLong VarType 常量 VarType 常量。
DefLngPtr DefType 语句 将一系列变量的默认数据类型设置为 LongPtr。
DefLngLng DefType 语句 将一系列变量的默认数据类型设置为 LongLong。

 

#If Vba7 Then
Declare PtrSafe Sub...
#Else
Declare Sub...
#EndIf

 

示例1：
#If VBA7 Then  ' 64位
    Private Declare PtrSafe Function apisndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    Private Declare PtrSafe Function apiPlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#Else
    Private Declare Function apisndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    Private Declare Function apiPlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If

detail：http://www.office-cn.net/article-15049-1.html