一步步教你制作、使用dll（1）

w8899

Sub 一键清除数据库()
    On Error Resume Next
    a = InputBox("将要清除全部数据!" & vbNewLine & "请输入密码", "密码输入")
    If Format(a, "#") <> Format("14358899") Then
        MsgBox " 您输入的密码不正确!"
        Exit Sub
    End If
    X = MsgBox("确认清除！执行清除后，数据库所有数据将清除且不能恢复，点“是”继续，“否”取消操作！", vbYesNo)
    If X = vbYes Then
        Close
    Else
        Exit Sub
    End If
    Dim j
    With Sheet4
        .Range("A2:U65536") = ""
        MsgBox "已清除所有数据!"
    End With
End Sub

Sub 一键清除预算单数据()
    On Error Resume Next
    a = InputBox("将要清除全部数据!" & vbNewLine & "请输入密码", "密码输入")
    If Format(a, "#") <> Format("14358899") Then
        MsgBox " 您输入的密码不正确!"
        Exit Sub
    End If
    X = MsgBox("确认清除！执行清除后，数据库所有数据将清除且不能恢复，点“是”继续，“否”取消操作！", vbYesNo)
    If X = vbYes Then
        Close
    Else
        Exit Sub
    End If
    Dim j
    With Sheet23
        .Range("A2:U65536") = ""
        MsgBox "已完成!"
    End With
End Sub

Sub 导入ACCESS数据库()
    '引用Microsoft ActiveX Data Objects 2.x Library
    Dim cnn As New ADODB.Connection, rs As New ADODB.Recordset, SQL As String, strMsg As String
    '    cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\数据库.accdb"
    Dim DatabaseFuPass As String: DatabaseFuPass = ThisWorkbook.Path & "\数据库1.accdb"
    Const myPass As String = "14358899"
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & myPass & ";Data Source=" & DatabaseFuPass
    SQL = "SELECT A.* FROM [Excel 12.0;Database=" & ThisWorkbook.FullName & ";].[数据库$A1:U" & Sheets("数据库").Range("b" & Sheets("数据库").Rows.Count).End(xlUp).Row _
        & "] A LEFT JOIN (Select * From 数据库) D ON A.单号=D.单号  WHERE D.单号 IS NULL"
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount > 0 Then
        SQL = "INSERT INTO 数据库 " & SQL
        cnn.Execute SQL
        strMsg = rs.RecordCount & "条记录已添加到数据库！"
    Else
        strMsg = "没有发现可以插入的记录！"
    End If
    MsgBox strMsg, vbInformation, "提示"
    rs.Close: cnn.Close
    Set rs = Nothing: Set cnn = Nothing
End Sub

Sub 删除再导入ACCESS数据库()
    On Error Resume Next
    a = InputBox("您将要清除所有数据重新导入新数据!" & vbNewLine & "请输入密码", "密码输入")
    If Format(a, "#") <> Format("14358899") Then
        MsgBox " 您输入的密码不正确!"
        Exit Sub
    End If
    X = MsgBox("确认要进行数据删除？执行删除后，所有数据将清零，并导入新的全部数据到ACCESS数据库，点“是”继续，“否”取消操作！", vbYesNo)
    If X = vbYes Then
        Close
    Else
        Exit Sub
    End If

    '   引用Microsoft ActiveX Data Objects 2.x Library
    Dim cnn As New ADODB.Connection, rs As New ADODB.Recordset, SQL As String, strMsg As String
    Dim DatabaseFuPass As String: DatabaseFuPass = ThisWorkbook.Path & "\数据库1.accdb"
    Const myPass As String = "14358899"
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & myPass & ";Data Source=" & DatabaseFuPass
    ' 清除旧数据
    SQL = "delete * from 数据库"
    cnn.Execute SQL
    ' -----------
    SQL = "SELECT A.* FROM [Excel 12.0;Database=" & ThisWorkbook.FullName & ";].[数据库$A1:U" & Sheets("数据库").Range("b" & Sheets("数据库").Rows.Count).End(xlUp).Row _
        & "] A LEFT JOIN (Select * From 数据库) D ON A.单号=D.单号  WHERE D.单号 IS NULL"
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    ' 导入数据
    SQL = "INSERT INTO 数据库 " & SQL
    cnn.Execute SQL
    strMsg = rs.RecordCount & "条记录已添加到数据库！"
    MsgBox strMsg, vbInformation, "提示"
    rs.Close: cnn.Close
    Set rs = Nothing: Set cnn = Nothing

End Sub

Sub 二维码()
    Call UserForm9.Show
End Sub

Sub 进存销宏菜单()
    Dim mCaidan As Menu
    MenuBars(xlWorksheet).Reset
    Set mCaidan = MenuBars(xlWorksheet).Menus.Add("【进存销功能菜单】")
    With mCaidan.MenuItems
        .Add "二维码", "二维码"
        .Add "系统初始化", "X_初始化"
        .Add "导入ACCESS数据库", "导入ACCESS数据库"
        .Add "删除再导入ACCESS数据库", "删除再导入ACCESS数据库"
        .Add "插入批注", "插入批注"
        .Add "系统备份", "X_文件备份"
        .Add "日历", "日历"
        .Add "更新库存", "B_一键更新库存"
        .Add "显示隐藏工作表", "显示隐藏工作表"
        .Add "清除数据库", "一键清除数据库"
        .Add "清除预算单数据", "一键清除预算单数据"
    End With
End Sub

Sub 隐藏工作表()
    On Error Resume Next
    a = InputBox("将要将要隐藏部份工作表!" & vbNewLine & "请输入密码", "密码输入")
    If Format(a, "#") <> Format("14358899") Then
        MsgBox " 您输入的密码不正确!"
        Exit Sub
    End If
    X = MsgBox("确认隐藏！执行隐藏，你自定的部份工作表将隐藏不可见，点“是”继续，“否”取消操作！", vbYesNo)
    If X = vbYes Then
        Close
    Else
        Exit Sub
    End If
    Sheet1.Visible = 2
    'Sheet2.Visible = 2
    'Sheet3.Visible = 2
    Sheet4.Visible = 2
    Sheet5.Visible = 2
    'Sheet6.Visible = 2
    Sheet7.Visible = 2
    Sheet8.Visible = 2
    Sheet9.Visible = 2
    Sheet10.Visible = 2
    Sheet11.Visible = 2
    Sheet12.Visible = 2
    Sheet13.Visible = 2
    Sheet14.Visible = 2
    Sheet15.Visible = 2
    'Sheet16.Visible = 2
    Sheet17.Visible = 2
    Sheet18.Visible = 2
    Sheet19.Visible = 2
    Sheet20.Visible = 2
    Sheet21.Visible = 2
    'Sheet22.Visible = 2
    Sheet23.Visible = 2
    Sheet24.Visible = 2
    'Sheet25.Visible = 2
    Sheet26.Visible = 2
    'Sheet27.Visible = 2
    MsgBox "已按你的要求隐藏了部份工作表"
End Sub

Sub 显示工作表()
    On Error Resume Next
    a = InputBox("将要显示全部工作表!" & vbNewLine & "请输入密码", "密码输入")
    If Format(a, "#") <> Format("14358899") Then
        MsgBox " 您输入的密码不正确!"
        Exit Sub
    End If
    X = MsgBox("确认要显示？执行显示后，所有工作表将显示，点“是”继续，“否”取消操作！", vbYesNo)
    If X = vbYes Then
        Close
    Else
        Exit Sub
    End If
    Sheet1.Visible = -1
    Sheet2.Visible = -1
    'Sheet3.Visible = -1
    Sheet4.Visible = -1
    Sheet5.Visible = -1
    'Sheet6.Visible = -1
    Sheet7.Visible = -1
    Sheet8.Visible = -1
    Sheet9.Visible = -1
    Sheet10.Visible = -1
    Sheet11.Visible = -1
    Sheet12.Visible = -1
    Sheet13.Visible = -1
    Sheet14.Visible = -1
    Sheet15.Visible = -1
    'Sheet16.Visible = -1
    Sheet17.Visible = -1
    Sheet18.Visible = -1
    Sheet19.Visible = -1
    Sheet20.Visible = -1
    Sheet21.Visible = -1
    'Sheet22.Visible = -1
    Sheet23.Visible = -1
    Sheet24.Visible = -1
    'Sheet25.Visible = -1
    Sheet26.Visible = -1
    'Sheet27.Visible = -1
    MsgBox "已显示全部工作表"
End Sub

Sub 显示隐藏工作表()
    Static i&   '声明为静态变量
    i = i + 1
    Select Case i
        Case 1: 显示工作表

        Case 2: 隐藏工作表

        Case Else: 显示工作表: i = 1
    End Select
End Sub

Sub 插入批注()
    Dim Rng As Range
    For Each Rng In Intersect(Sheet1.UsedRange, Sheet1.Range("a:a"))
        Rng.ClearComments
        If Dir(ThisWorkbook.Path & "\图片\" & Rng.Value & ".jpg") <> "" Then
            Rng.AddComment
            With Rng.Comment
                .Visible = False
                .Shape.Fill.UserPicture ThisWorkbook.Path & "\图片\" & Rng.Value & ".jpg"
                .Shape.Height = 193
                .Shape.Width = 300
            End With
        End If
    Next
    MsgBox "图片插入已完成！"
End Sub


能否将以上代码封装一下？

zz16326556

封装碰到难点了，进来学习下

346590775

为什么我的调用显示是    编译错误，无法找到工程或者库

笨鸟飞不高

mark

gwjkkkkk

谢谢分享。。。

hb662868

谢谢分享，小白先学习再送花

sjwxsdj

现在才看到，学习了

hhhhhhhhhhss

踩个脚印，学习ing

SAI200707

ActiveX部件不能创建对象,应该如何处理