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

[hunghalico]

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 code 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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

‘ 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. ;-)