Thêm đầu số 3 vào điện thoại cố định

Chào mọi người,

Sắp tới đây có 53 tỉnh thành sẽ bổ sung đầu số 3 vào ngay sau mã tỉnh.
Nếu danh bạ bạn lưu trong điện thoại có nhiều số phải sửa lại thì hơi bị cực phải không?
Nếu bạn có thể lưu danh bạ trong máy thành các file .VCF (vCard) thì thử cách này nhé:

1) Các bạn copy và lưu phần chữ xanh dưới đây thành 1 file .vbs
2) Lưu danh bạ trên điện thoại thành các file .vcf trên máy tính hoặc thẻ nhớ.
3) Chép file .vbs này vào và chạy.

* Cách hoạt động của chương trình:
Nó sẽ đọc từng file .vcf và tìm số điện thoại/fax có mã tỉnh giống như danh mục 53 tỉnh thành, nếu tìm thấy nó sẽ thay số điện thoại/fax ấy bằng [Mã tỉnh] + [Số 3] + [6 số cuối cùng].
Thông thường nó sẽ không thay đổi số đtdđ hoặc những số có mã tỉnh không thuộc danh sách.

Quốc Sản
(Dầu Tiếng - Bình Dương)
quocsan@gmail.com
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Code:

 
‘ COPY FROM HERE and save to a file such as Update.Vbs
Option Explicit
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Const TristateUseDefault = -2
Const TristateTrue = -1
Const TristateFalse = 0
Const DIGIT2PAD = "3"
Const RIGHTPOS = 6 ' From the right
Dim fs, TAG, CODES
TAG = Array("TEL;VOICE", "TEL;FAX")
' AnGiang, BaRiaVungTau, BacLieu, BacKan, BacGiang, BacNinh, BenTre
' BinhDuong, BinhDinh, BinhPhuoc, BinhThuan, CaMau, CaoBang, CanTho, DakLak
' DakNong, DienBien, DongThap, GiaLai, HaGiang, HaNam, HaTinh, HauGiang
' HoaBinh, HungYen, KhanhHoa, KonTum, LaiChau, LangSon, LaoCai, LamDong
' LongAn, NinhBinh, NinhThuan, PhuTho, PhuYen, QuangBinh, QuangNam, QuangNgai, QuangNinh
' QuangTri, SocTrang, SonLa, TayNinh, ThaiBinh, ThaiNguyen, ThuaThienHue, TienGiang
' TraVinh, TuyenQuang, VinhLong, VinhPhuc, YenBai
CODES = Array("076", "064", "0781", "0281", "0240", "0241", "075", _
    "0650", "056", "0651", "062", "0780", "026", "0710", "0500", _
    "0501", "0230", "067", "059", "0219", "0351", "039", "0711", _
    "0218", "0321", "058", "060", "0231", "025", "020", "063", _
    "072", "030", "068", "0210", "057", "052", "0510", "055", "033", _
    "053", "079", "022", "066", "036", "0280", "054", "073", _
    "074", "027", "070", "0211", "029")
Set fs = CreateObject("Scripting.FileSystemObject")
Main
Set fs = Nothing
Sub Main
    ' MsgBox Join(FileList("."), vbCrLf), , "Found VCF"
    DoIt "."
End Sub
Function FileList(folderspec)
    Const SEPA = ","
    Dim f, f1, fc, s, r
    r = ""
    Set f = fs.GetFolder(folderspec)
    Set fc = f.Files
    For Each f1 in fc
        If right(lcase(f1.name), 4) = ".vcf" Then
            r = r & SEPA & f1.name
        End If
    Next
    If Len(r) > 0 Then r = Mid(r, Len(SEPA) + 1)
    FileList = Split(r, SEPA)
End Function
Sub DoIt(folderspec)
    Dim f, fc, S, T, R, sl, i, j, bChanged, cnt, files
    fc = FileList(folderspec)
    r = ""
    cnt = 0
    files = 0
    For Each f in fc
        S = File2String(f)
        T = Split(S, vbCrLf)
        bChanged = False
        For i = 0 To UBound(T)
            For Each sl in TAG        ' "TEL;..."
                If UCase(Left(T(i), Len(sl))) = sl Then
                    T(i) = Replace(T(i), Space(1), "")
                    R = Split(T(i), ":")
                    If UBound(R) >= 1 Then
                        For j = 0 To UBound(CODES)
                            If Left(R(1), Len(CODES(j))) = CODES(j) Then
                                R(1) = CODES(j) & DIGIT2PAD & Right(R(1), RIGHTPOS)
                                bChanged = True
                                cnt = cnt + 1
                                Exit For  ' Ignore other province codes
                            End If
                        Next ' j
                    End If
                    T(i) = Join(R, ":")
                    Exit For ' Ignore other tags in TAG
                End If
            Next ' sl
        Next ' i
        If bChanged Then
            S = Join(T, vbCrLf)
            Call Save2File(S, f)
            files = files + 1
        End If
    Next ' f
    MsgBox cnt & " changes in " & files & " file(s)",, "Result"
End Sub
Function File2String(strFilePath)
    Dim ts
    Err.Clear
    On Error Resume Next
    File2String = ""
    If fs.FileExists(strFilePath) Then
        Set ts = fs.OpenTextFile(strFilePath, ForReading)
        If Err.Number = 0 Then
            File2String = Trim(ts.ReadAll)
            ts.Close
        End If
    End If
    ts.Close
End Function
Sub Save2File(Data, strFileName)
    Dim ts
    Set ts = fs.CreateTextFile(strFileName)
    ' Convert binary data To text And write them To the file
    ts.Write Data
    ts.Close
End Sub
' End of the Script. ;-)