名： 周XS
常用电话： 138584023515
空格一行
下面又一个联系人
又空格一行
……规律的继续
复制代码

BEGIN:VCARD
VERSION:2.1
N:寒;夜
TEL;CELL:15234567890
TEL;CELL;WORK:13423456789
TEL;VOICE:323456789
TEL;VOICE;WORK:223456789
TEL;PAGER:123456789
EMAIL:123@qq.com
TITLE:管理
X-NICKNAME:开始
ORG:斑竹
X-CLASS:private
END:VCARD
复制代码

@echo off&setlocal enabledelayedexpansion
set k=ENCODING=QUOTED-PRINTABLE;CHARSET=UTF-8:
set 姓=N;%k%0
set 名=N;%k%0
set 常用移动电话=TEL;CELL:1
set 常用电话=TEL;VOICE:2
set 常用传真=TEL;FAX:3
set 住宅电话=TEL;HOME;VOICE:4
set 昵称=X-NICKNAME;%k%5
set 公司=TITLE;%k%6
set 职位=ORG;%k%7
set 公司电话=TEL;VOICE;WORK:8
set 常用详情=NOTE;%k%9
set 备忘=NOTE;%k%9
(for /f "delims=" %%a in ('more +45^<%~fs0') do echo.%%a)>temp_0.vbs
for /f "tokens=1,2* delims=：:        " %%a in ('findstr /n .* "test.txt"') do if "%%b"=="" (call:ye) else if defined %%b (
    if "%%b"=="姓" set m1=%%c
    if "%%b"=="名" set m2=%%c
    set b=!%%b!
    set c=%%c
    if "!b:~-3,1!"=="8" call:gu "!c!"
    for %%d in (!b:~-1!) do if "!n_%%d!"=="" (set n_%%d=!b:~0,-1!!c!) else if defined m1 (set n_%%d=!n_%%d!!c!) else set n_%%d=!c!!n_%%d!
)
del /q temp_*
exit
:ye
(
echo BEGIN:VCARD
echo VERSION:2.1
echo N;%k%!!
for /l %%a in (0,1,9) do if defined n_%%a echo !n_%%a!&set n_%%a=
echo X-CLASS:private
echo END:VCARD
)>"!m1!!m2!.vcf"
set m1=&set m2=
goto:eof
:gu
set/p"=%~1"<nul>temp_1.h
temp_0.vbs temp_1.h>nul
del /q temp_2.h 2>nul
for %%a in (temp_1.h) do >nul fsutil file createnew temp_2.h %%~za
set c=
for /f "skip=4 tokens=2 delims=: " %%a in ('fc /b temp_1.h temp_2.h') do call set c=!c!=%%a
goto:eof
::vbs
aCode = "GB2312"
bCode = "UTF-8"
Set objArgs = WScript.Arguments
If objArgs.Count=0 Then
    MsgBox "请删除...", vbInformation, "提示"
End If
    For I = 0 To objArgs.Count - 1
        FileUrl = objArgs(I)
        Call CheckCode (FileUrl)
        Call WriteToFile(FileUrl, ReadFile(FileUrl, aCode), bCode)
    Next
Function ReadFile(FileUrl, CharSet)
    Dim Str
    Set stm = CreateObject("Adodb.Stream")
    stm.Type = 2
    stm.mode = 3
    stm.charset = CharSet
    stm.Open
    stm.loadfromfile FileUrl
    Str = stm.readtext
    stm.Close
    Set stm = Nothing
    ReadFile = Str
End Function
Function WriteToFile (FileUrl, Str, CharSet)
    Set stm = CreateObject("Adodb.Stream")
    stm.Type = 2
    stm.mode = 3
    stm.charset = CharSet
    stm.Open
    stm.WriteText Str
    stm.SaveToFile FileUrl, 2
    stm.flush
    stm.Close
    Set stm = Nothing
End Function
Function CheckCode (FileUrl)
    Dim slz
    set slz = CreateObject("Adodb.Stream") 
    slz.Type = 1
    slz.Mode = 3
    slz.Open
    slz.Position = 0
    slz.Loadfromfile FileUrl
    Bin=slz.read(2)
    if AscB(MidB(Bin,1,1))=&HEF and AscB(MidB(Bin,2,1))=&HBB Then
       Codes="UTF-8"
       elseif AscB(MidB(Bin,1,1))=&HFF and AscB(MidB(Bin,2,1))=&HFE Then
              Codes="Unicode"
              else
              Codes="GB2312"
    end if
    if not aCode = Codes Then
           MsgBox "文本编码不是ANSI",vbInformation,"错误"
           WScript.Quit
    end if
    slz.Close
    set slz = Nothing
End Function
复制代码