ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2343|回复: 8

[求助] 请教各位老师,看一下加载宏是否有病毒

[复制链接]

TA的精华主题

TA的得分主题

发表于 2012-8-15 22:19 | 显示全部楼层 |阅读模式
本帖最后由 wyzdddl 于 2012-8-15 22:22 编辑

下面是Thisworkbook
Private Sub Workbook_AddinInstall()
    Dim myBar As Office.CommandBar
    Dim imgSource As Office.CommandBarButton
    Dim myControl1 As Office.CommandBarButton
    ' Add new command bar.
    Set myBar = Application.CommandBars.Add(Name:="Custom", Position:=msoBarTop, Temporary:=False)
    ' Add 1 buttons to new command bar.
    With myBar
        .Controls.Add Type:=msoControlButton
        .Visible = True
    End With
    ' Paste Bold button face and set State of first button.
    Set myControl1 = myBar.Controls(1)
    Set imgSource = Application.CommandBars.FindControl(msoControlButton, 7433)
    imgSource.CopyFace
    With myControl1
        .PasteFace
        .State = msoButtonDown
        .Caption = "自动粘帖"
        .TooltipText = "自动粘帖切换控制按钮,点击切换。(开)"
        .OnAction = "ButtonStateSwitch"
    End With
End Sub
Private Sub Workbook_AddinUninstall()
    Application.CommandBars("Custom").Delete
End Sub
Private Sub Workbook_Open()
InitializeApp
End Sub


下面是模块

Dim X As New EventClassModule
Public Sub InitializeApp()
    Set X.App = Application
End Sub
Public Sub OpenButton()
With Application.CommandBars("Custom").Controls(1)
    .State = msoButtonDown
    .TooltipText = "自动粘帖切换控制按钮,点击切换。(开)"
End With
End Sub
Public Sub CloseButton()
With Application.CommandBars("Custom").Controls(1)
    .State = msoButtonUp
    .TooltipText = "自动粘帖切换控制按钮,点击切换。(关)"
End With
End Sub

Public Sub ButtonStateSwitch()
With Application.CommandBars("Custom").Controls(1)
    Select Case .State
        Case msoButtonDown
            .State = msoButtonUp
            .TooltipText = "自动粘帖切换控制按钮,点击切换。(关)"
        Case msoButtonUp
            .State = msoButtonDown
            .TooltipText = "自动粘帖切换控制按钮,点击切换。(开)"
    End Select
End With
End Sub
Function GetColumnDescription(ByVal Col As Long) As String
'将一个介入1-256之间(含两边)的数字转化成Excel所表示的列的序号,如"B"表示第2列,"DH"表示第112列
'返回的值为字符型,如果参数col不是数字,或不在1-256的范围内,则返回空字符串
    If Col > 256 Or Col < 1 Or IsNumeric(Col) = False Then
        GetColumnDescription = ""
        Exit Function
    End If
   
    Dim CharArray(26) As Byte   '字母数组
    Dim lFirstChar, lLastChar As Long
    Dim sFirstChar, sLastChar As String
   
    CharArray(1) = Asc("A")
    For i = 2 To 26
        CharArray(i) = CharArray(i - 1) + 1
    Next i
    lFirstChar = Int(Col / 26)
        If Col Mod 26 = 0 Then
        '当lFirstChar是26的整数倍时,sFirstChar指向的是“Z”,但上面的公式却
        '使sFirstChar指向另一个字母,因此要在下面调整过来
            lFirstChar = lFirstChar - 1
            
        End If
        
            If lFirstChar > 0 Then
                sFirstChar = Chr(lFirstChar + 64)
            Else
                sFirstChar = ""
            End If
    lLastChar = Col Mod 26
    If lLastChar <> 0 Then
        sLastChar = Chr(lLastChar + 64)
    Else
        sLastChar = "Z"
    End If
   
    GetColumnDescription = sFirstChar + sLastChar
End Function



下面是类模块
Const WorkbookNameSource = "腾远配件资料.xlsm"
Const WorkbookNameObject = "腾远进销管理系统.xlsm"
Const WorkSheetNameSource = "配件资料"
Const DoubleClickCol = 2 '双击某列时复制内容,此为 B 列
Const ColStartObject = 2 '粘帖内容的起始列,此为 B 列
Const MainWorkSheetRowCount = 149 '主表行的数量(含表头行数)
Const ColStartSource = 1 '复制内容的起始列,此为 A 列
Const ColCount = 5 '复制的列的数量
Public WithEvents App As Application
Private Sub App_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Application.CommandBars("Custom").Controls(1).State = msoButtonDown Then
    If LCase(ActiveWorkbook.Name) = LCase(WorkbookNameSource) Then
        If LCase(Sh.Name) = LCase(WorkSheetNameSource) Then
            If Target.Column = DoubleClickCol Then '如果双击的列等于 DoubleClickCol 列,则...
                Dim OP As Boolean '判断被粘贴的工作表是否打开
                OP = False
                For Each w In Workbooks
                    If LCase(w.Name) <> LCase(WorkbookNameObject) Then
                        OP = True: Exit For
                    End If
                Next w
               
                If OP = True Then
                    Dim RowStartObject As Long
                    With Workbooks(WorkbookNameObject).ActiveSheet
                    
                    RowStartObject = 3
                    Do While RowStartObject > 0 '判断是否为空行
                        If Application.WorksheetFunction.CountA(Range(.Cells(RowStartObject, ColStartObject), .Cells(RowStartObject, ColStartObject))) > 0 Then
                            RowStartObject = RowStartObject + 1
                        ElseIf RowStartObject > MainWorkSheetRowCount Then
                            .Rows(RowStartObject).Insert Shift:=xlShiftDown
                            Exit Do
                        Else
                            Exit Do
                        End If
                    Loop
                    
                    
                    Range(Target.Offset(0, -1), Target.Offset(0, -1)).Copy
                    Range(.Cells(RowStartObject, 9), .Cells(RowStartObject, 9)).PasteSpecial Paste:=xlPasteValues
                    
                    Range(Target.Offset(0, 0), Target.Offset(0, 1)).Copy
                    Range(.Cells(RowStartObject, 2), .Cells(RowStartObject, 3)).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                    
                    Range(Target.Offset(0, 3), Target.Offset(0, 4)).Copy
                    Range(.Cells(RowStartObject, 6), .Cells(RowStartObject, 7)).PasteSpecial Paste:=xlPasteValues
                    Application.CutCopyMode = False
                    End With
                    
                    
'设置气球提示信息
                    Assistant.Visible = True
                    Set bln = Assistant.NewBalloon
                    With bln
                        .Heading = "从 [" & Left(WorkbookNameSource, InStrRev(WorkbookNameSource, ".") - 1) & " - " & Sh.Name & " - " & GetColumnDescription(ColStartSource) & Target.Row & ":" & GetColumnDescription(ColStartSource + ColCount - 1) & Target.Row & "] " & "到 [" & Left(WorkbookNameObject, InStrRev(WorkbookNameObject, ".") - 1) & " - " & Workbooks(WorkbookNameObject).ActiveSheet.Name & " - (" & GetColumnDescription(2) & RowStartObject & ":" & GetColumnDescription(3) & RowStartObject & "," & GetColumnDescription(5) & RowStartObject & ":" & GetColumnDescription(6) & RowStartObject & "," & GetColumnDescription(8) & RowStartObject & ")] 复制数据成功。"
                        .Text = "选择需要进行的操作."
                        .Labels(1).Text = "定位并选定 [" & Left(WorkbookNameObject, InStrRev(WorkbookNameObject, ".") - 1) & "!" & Workbooks(WorkbookNameObject).ActiveSheet.Name & "." & GetColumnDescription(2) & RowStartObject & ":" & GetColumnDescription(8) & RowStartObject & "] 单元格。"
                        .Labels(2).Text = "返回 [" & Left(WorkbookNameSource, InStrRev(WorkbookNameObject, ".") - 1) & "!" & Workbooks(WorkbookNameSource).ActiveSheet.Name & "] 工作表。"
                        .BalloonType = msoBalloonTypeButtons
                        .Mode = msoModeAutoDown
                        .Button = msoButtonSetNone
                        Select Case bln.Show
                            Case 1
                                Workbooks(WorkbookNameObject).Activate
                                Workbooks(WorkbookNameObject).ActiveSheet.Range(GetColumnDescription(2) & RowStartObject & ":" & GetColumnDescription(8) & RowStartObject).Select
                                Workbooks(WorkbookNameObject).ActiveSheet.Range(GetColumnDescription(4) & RowStartObject).Activate
                                Case 2
                                Workbooks(WorkbookNameSource).Activate
                        End Select
                    End With
                    
                    Cancel = True
                Else
                    Dim Msg, Style, Title, Response, MyString
                End If
            End If
        End If
    End If
End If
End Sub
Private Sub App_SheetActivate(ByVal Sh As Object)
'    MsgBox Sh.Name
    If LCase(ActiveWorkbook.Name) = LCase(WorkbookNameSource) And LCase(Sh.Name) = LCase(WorkSheetNameSource) Then
        OpenButton
    Else
        CloseButton
    End If
End Sub
Private Sub App_WorkbookActivate(ByVal Wb As Workbook)
'    MsgBox Wb.Name
    If LCase(Wb.Name) = LCase(WorkbookNameSource) And LCase(ActiveSheet.Name) = LCase(WorkSheetNameSource) Then
        OpenButton
    Else
        CloseButton
    End If
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-8-15 22:21 | 显示全部楼层
求各位老师了,自从用了这个加载宏,就经常被盗号,有人说,这个加载宏有可能有病毒,求教了

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-8-16 07:26 | 显示全部楼层
本帖最后由 wyzdddl 于 2012-8-16 07:27 编辑

怎么没人指教哇!烦请各位了,对我很重要的。请各位高人、老师不吝赐教,先表示谢意

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-8-17 06:55 | 显示全部楼层
本帖最后由 wyzdddl 于 2012-8-20 08:26 编辑

{:soso_e134:}{:soso_e150:}  帮帮忙啊

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-8-20 21:55 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
各位老师别只是看呀,都留个脚印,说几句

TA的精华主题

TA的得分主题

发表于 2012-8-21 10:48 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-8-21 21:37 | 显示全部楼层
kangatang 发表于 2012-8-21 10:48
NONONONONONONONONONO

您好,不知道,您是说代码中没有宏病毒,还是????????

TA的精华主题

TA的得分主题

发表于 2012-8-23 00:28 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-8-24 14:22 | 显示全部楼层
版主都忙啊,没时间,{:soso_e127:}
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 20:20 , Processed in 0.053751 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表