已解决，30元求助用于筛选整理，替换邮箱账号的脚本

ws1870

联系qq2017427822
支付方式可 支付宝，微信，QQ
具体报酬30元，也可具体谈

要求是，从同文件夹的所有txt里顺序处理内容。
1. 没有@的行后面加上@youxiang.com
2. aa.替换成qy.
3.  .con替换为.com
4重复账号只保留一个
然后顺序保存到一个目录下，每200个账号新存一个txt，命名规则是当天日期-起始数字-结束数字.txt 如：20191207-201-400.txt

希望可以添加注释以供学习

ws1870

回复 2# a20150604


    谢谢您了，您加我QQ吧

a20150604

回复 1# ws1870

' 调试信息控制开关
Const DEBUG_SW = False

' 分组数
Const GROUP_NUMBER = 200

' 输出目录名称, 不要加 \
Const OUTPUT_DIR_NAME = "output"

' 没有 @ 的行后面要加上的 域名
Const SUPPLEMENT_DOMAIN = "@youxiang.com"

Const ForReading = 1, ForWriting = 2

Public output_path
Public fso, input_file, output_file

Public arr_replace_src, arr_replace_dest, arr_replace_ubound

Public all_files_text

Public dic_account

Public yyyyMMdd

Public vbLf, vbCr, vbCrLf

CALL main

Sub main()
    vbLf = Chr(10)
    vbCr = Chr(13)
    vbCrLf = vbCr & vbLf
    
    ' 分隔字符, 勿改
    GAP_CHR = Chr(30)
    
    ' 替换表, 一行一个, 最后一行结尾不要有 ,
    arr_replace_rule = Array( _
        "aa." & GAP_CHR & "qy.", _
        ".con" & GAP_CHR & ".com" _
        )
    
    ' 将替换规则解析为 两个数组 替换源字符串数组 和 替换目标字符串数组
    replace_src_strs = ""
    replace_dest_strs = ""
    For Each ele In arr_replace_rule
        arr = Split(ele, GAP_CHR)
        replace_src_strs = replace_src_strs & GAP_CHR & arr(0)
        replace_dest_strs = replace_dest_strs & GAP_CHR & arr(1)
    Next
    arr_replace_src = Split(Mid(replace_src_strs, 2), GAP_CHR)
    arr_replace_dest = Split(Mid(replace_dest_strs, 2), GAP_CHR)
    arr_replace_ubound = UBound(arr_replace_src)
    
    
    ' 账号字典, 用于去除重复账号
    Set dic_account = CreateObject("Scripting.Dictionary")
    
    ' 用于计时的变量
    Dim dttm1, dttm2
    dttm1 = Now
    
    ' 当前日期时间
    dttm = Now
    yyyyMMdd = Year(dttm) & "" & Right("0" & Month(dttm), 2) & "" & Right("0" & Day(dttm), 2)
    
    ' 文件系统对象
    
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 脚本对象 和 当前目录
    Set obj_wsc_shell = CreateObject("wscript.shell")
    HostFolder = obj_wsc_shell.CurrentDirectory & "\"
    
    ' 自动建立输出目录, 如果其不存在的话
    output_path = HostFolder & OUTPUT_DIR_NAME & "\"
    If (Not fso.FolderExists(output_path)) Then
        fso.CreateFolder (output_path)
    End If
    
    
    DOUBLE_QUOTES = Chr(34)
    obj_wsc_shell.Run "cmd /c mshta vbscript:msgbox(" & DOUBLE_QUOTES & "运行中, 请等待..." & DOUBLE_QUOTES & "," & vbOKOnly & "," & DOUBLE_QUOTES & "提示" & DOUBLE_QUOTES & ")(window.close)", 0
    
    
    ' 用于读取所有源文件的数据合并保存在内存中, 以待处理
    all_files_text = ""
    
    sum_files = 0
    cnt_file = 0
    last_percent = 0
    
    ' 遍历目录 读取所有源文件
    do_count_files = False
    Call DoFolder(fso.GetFolder(HostFolder), sum_files, do_count_files)
    
   
    ' 处理并输出数据
    Call process_and_output
    
    ' 关闭 等待 对话框
    obj_wsc_shell.Run "taskkill /f /im cmd.exe", 0
    obj_wsc_shell.Run "taskkill /f /im mshta.exe", 0
    
    
    dttm2 = Now
    WScript.Echo "DONE, 用时 " & DateDiff("s", dttm1, dttm2) & " 秒"
    ' Debug.Print "DONE, 用时 " & DateDiff("s", dttm1, dttm2) & " 秒"
    WScript.Quit
    
End Sub

Sub process_and_output()
    Dim regEx_CRLF
    Set regEx_CRLF = New RegExp
    regEx_CRLF.Pattern = "[\n\r]+"
    regEx_CRLF.IgnoreCase = True
    regEx_CRLF.Global = True
    
    ' 将合并在一起的所有源数据, 按行分解到一个数组
    all_files_text = regEx_CRLF.Replace(all_files_text, vbLf)
    arr_lines = Split(all_files_text, vbLf)
    
    
    ' 要求是，从同文件夹的所有txt里顺序处理内容。
    ' 1. 没有@的行后面加上@youxiang.com
    ' 2. aa.替换成qy.
    ' 3.  .con替换为.com
    ' 4重复账号只保留一个
    ' 然后顺序保存到一个目录下，每200个账号新存一个txt，命名规则是当天日期-起始数字-结束数字.txt 如：20191207-201-400.txt
    cnt_account = 0
    For i = LBound(arr_lines) To UBound(arr_lines)
        account = Trim(arr_lines(i))
        If account <> "" Then
            
            ' 执行替换规则
            For j = 0 To arr_replace_ubound
                account = Replace(account, arr_replace_src(j), arr_replace_dest(j))
            Next
            ' 自动补充域名
            If Not (InStr(account, "@") > 0) Then
                account = account & SUPPLEMENT_DOMAIN
            End If
            
            ' 去重
            If Not dic_account.exists(account) Then
                dic_account.Add account, ""
                cnt_account = cnt_account + 1
                If cnt_account Mod GROUP_NUMBER = 1 Then
                    output_txt = account & vbCrLf
                Else
                    output_txt = output_txt & account & vbCrLf
                End If
            End If
            ' 分组输出到文件
            If ((cnt_account > 0) And (cnt_account Mod GROUP_NUMBER = 0) Or (i >= UBound(arr_lines))) Then
                ind_s = ((cnt_account \ GROUP_NUMBER - 1) * GROUP_NUMBER) + 1
                output_file_path = output_path & yyyyMMdd & "-" & ind_s & "-" & cnt_account & ".txt"
                Set output_file = fso.OpenTextFile(output_file_path, ForWriting, True)
                output_file.Write output_txt
                output_file.Close
            End If
        End If
    Next
    
    ' 分组输出到文件, 最后一个组, 数量不足分组标准数
    If ((cnt_account > 0) And (cnt_account Mod GROUP_NUMBER <> 0)) Then
        ind_s = ((cnt_account \ GROUP_NUMBER) * GROUP_NUMBER) + 1
        output_file_path = output_path & yyyyMMdd & "-" & ind_s & "-" & cnt_account & ".txt"
        Set output_file = fso.OpenTextFile(output_file_path, ForWriting, True)
        output_file.Write output_txt
        output_file.Close
    End If
    
End Sub

Sub DoFolder(Folder, ByRef sum_files, ByVal do_count_files)
    If output_path = Folder.Path & "\" Then Exit Sub
    ' 在子目录中递归调用
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        Call DoFolder(SubFolder, sum_files, do_count_files)
    Next
    Dim file
    For Each file In Folder.Files
        Call doFile(file, sum_files, do_count_files)
    Next
End Sub


Sub doFile(ByRef input_file, ByRef sum_files, ByVal do_count_files)
    ' 分解获取 文件名 和 扩展名
    If InStr(input_file.Name, ".") > 0 Then
        arr = Split(input_file.Name, ".")
        ext_name = UCase(arr(UBound(arr)))
        dot_ext_name = "." & ext_name
    Else
        ext_name = ""
        dot_ext_name = ""
    End If
    ' 跳过 非 txt 文件
    If Not ("TXT" = ext_name) Then
        Exit Sub
    End If
    
    If do_count_files Then
        sum_files = sum_files + 1
        Exit Sub
    End If
    ' cnt_file = cnt_file + 1
    ' Percent = Int(cnt_file * 100 / sum_files)
    file_name = Left(input_file.Name, Len(input_file.Name) - Len(dot_ext_name))
    Set input_file_OTF = fso.OpenTextFile(input_file.Path, ForReading)
    all_files_text = all_files_text & input_file_OTF.Readall & vbCrLf
    
End Sub
Sub debug_WriteLine(output_file, debug_txt)
    If Not DEBUG_SW Then Exit Sub
    output_file.WriteLine debug_txt
End Sub
复制代码