超级菜鸟秀新作!!自动发邮件工资表!有需要的直接下!

超级菜鸟秀新作!!自动发邮件工资表!有需要的直接下!

可以自动生成工资条,并将每人的工资明细发到各自的邮箱,(老板够黑的,要求相互之间不知道!1)

最新自动计算个人所得税
 

 已修改，并去掉个人测试信息，（前面附件，并非有意窃取别人工资信息（不好意思啦），只自为了方便自己测试）解决等待响应问题，无论多少个员工，只要点一下就行了．

RySemkRZ.rar (80.3 KB, 下载次数: 15295)

2008-9-14 16:47 上传

点击文件名下载附件
超级菜鸟秀新作!!自动发邮件工资表!有需要的直接下!

还真不错,我要好好学习

请前面己下的，将下面代码中的红色部分注释掉，要不我的邮箱会给涨爆了，这行是我测试时用的邮箱．一楼附件己更新，（解决了一些问题）

Sub mailto()
 Application.ScreenUpdating = False
    Dim objOL As Object
    Dim itmNewMail As Object
    Dim i%, j%, k%, x%, y%
    Dim strbt() As String, strsj() As String, strsum$
   
    Set objOL = CreateObject("Outlook.Application")
    Sheets(1).Activate
    ActiveSheet.Range("a1").Select
    Set tk = ActiveCell.CurrentRegion
    k = tk.Columns.Count - 1
    j = tk.Rows.Count - 1
    ReDim strbt(k - 1)
    For i = 0 To k - 1
        strbt(i) = Trim(Sheets(1).Range("a1").Offset(0, i).Value)
    Next i
    For x = 1 To j - 1
        Set itmNewMail = objOL.CreateItem(olMailItem)
        itmNewMail.Subject = Month(Date) & "月份工资明细"
        itmNewMail.To = Trim(Sheets(3).Range("c" & x + 1))
       ' itmNewMail.cc = "pengjianxiang@hun.picc.com.cn"
         For y = 0 To k - 1
            ReDim strsj(y)
            strsj(y) = Sheets(1).Range("a1").Offset(x, y).Value
            strsum = strsum & strbt(y) & ":      " & strsj(y) & vbCrLf
         Next y
         itmNewMail.body = strsum & vbNewLine & "     以上是你" & Month(Date) & "月份工资明细,如无误,请你于近日到财务部领取!" & vbNewLine & Space(60) & "财务部" & vbNewLine & Space(65) & Date
         itmNewMail.send
         strsum = ""
    Next x
       
Set objOL = Nothing
Set itmNewMail = Nothing
Application.ScreenUpdating = True
End Sub

我用得上,下载学习一下。

看下面这个贴:

找不到工程或库" 解决方案找不到工程或库" 解决方案

http://club.excelhome.net/viewthread.php?tid=304968&replyID=&skin=0

谢谢,"找不到工程或库"已解决。

又出了其他问题。C:\Documents and Settings\abc\桌面\TT截图未命名A.bmp

图片没发上来

问题是：运行时错误“429”，actvex 不能创建对象。