بسم الله الرحمن الرحيم
إخوانى الأعزاء :
هذه الدالة من إنشائي و يمكنك من خلالها تغيير أرقام المحمول في الملفات من نوع (VCF) و هى VCard Files لتكون 11 رقم وفق التعديلات الأخيرة في شركات المحمول في مصر
و هذه هى الدالة
Change Mob Number By CaptinFlent
Public Function ChangeNewMOB(FileName As String, SAVEorNO As Boolean, Optional SavePlace As String) As String
Dim DATAIN As String
Dim L As Long, i As Long, L2 As Long, i2 As Long
Dim LL As String, LL15 As String, BB As String, EE As String, ALLL As String
Dim MOB As String, NEWMOB As String
On Error Resume Next
If SavePlace = "" Then SavePlace = FileName
Open FileName For Input As #1
DATAIN = Input(LOF(1), 1)
Close #1
L = InStr(1, DATAIN, "cell", vbTextCompare)
L2 = L + 5
i = InStr(L, DATAIN, "tel", vbTextCompare)
If i = 0 Then
i = InStr(L, DATAIN, "X-CLASS", vbTextCompare)
End If
i2 = i - 2
MOB = Mid(DATAIN, L2, i2 - L2)
LL = Left(MOB, 3)
LL15 = Left(MOB, 4)
If Len(MOB) = 10 Then
If LL = "011" Then
NEWMOB = "0111" & Right(MOB, 7)
End If
If LL = "014" Then
NEWMOB = "0114" & Right(MOB, 7)
End If
If LL = "012" Then
NEWMOB = "0122" & Right(MOB, 7)
End If
If LL = "017" Then
NEWMOB = "0127" & Right(MOB, 7)
End If
If LL = "018" Then
NEWMOB = "0128" & Right(MOB, 7)
End If
If LL = "010" Then
NEWMOB = "0100" & Right(MOB, 7)
End If
If LL = "016" Then
NEWMOB = "0106" & Right(MOB, 7)
End If
If LL = "019" Then
NEWMOB = "0109" & Right(MOB, 7)
End If
ElseIf Len(MOB) = 11 Then
If LL15 = "0150" Then
NEWMOB = "0120" & Right(MOB, 7)
End If
If LL15 = "0151" Then
NEWMOB = "0101" & Right(MOB, 7)
End If
If LL15 = "0152" Then
NEWMOB = "0112" & Right(MOB, 7)
End If
End If
Kill (SavePlace)
BB = Left(DATAIN, L2 - 1)
EE = Right(DATAIN, (Len(DATAIN) - i) + 1)
ALLL = BB & NEWMOB & vbCrLf & EE
If SAVEorNO = True Then
Open SavePlace For Output As #1
Print #1, ALLL
Close #1
ElseIf SAVEorNO = False Then
ChangeNewMOB = ALLL
End If
ChangeNewMOB = ALLL
End Function
و فيما يلي شرح الدالة
أولا مخرج الدالة من نوع String و يتم إخراج تركيبة الملف الجديد في ناتج الدالة في النهاية
أما عن مدخلات الدالة فنحتاج 3 مدخلات أحدهم إختيارى
FileName و هنا نقوم بتحديد الملف على القرص الصلب و هو من النوع String
SAVEorNO و هنا نقوم بتحديد إذا كنا نريد أن تقوم الدالة بحفظ الملف أم لا و هو من النوع Boolean
SavePlace و هنا نقوم بتحديد ملف الإخراج على القرص الصلب و هذا هو المدخل الإختياري و إذا لم نحدده فسيقوم مباشرة بأخذ قيمة FileName و هو أيضا من النوع String
Open FileName For Input As #1
DATAIN = Input(LOF(1), 1)
Close #1
L = InStr(1, DATAIN, "cell", vbTextCompare)
L2 = L + 5
i = InStr(L, DATAIN, "tel", vbTextCompare)
If i = 0 Then
i = InStr(L, DATAIN, "X-CLASS", vbTextCompare)
End If
i2 = i - 2
MOB = Mid(DATAIN, L2, i2 - L2)
في الجزء السابق من الكود نقوم بتحميل الملف في المتغير DATAIN ثم نقوم بإستخلاص رقم الموبايل منه و يخزنه في المتغير MOB
LL = Left(MOB, 3)
LL15 = Left(MOB, 4)
If Len(MOB) = 10 Then
If LL = "011" Then
NEWMOB = "0111" & Right(MOB, 7)
End If
If LL = "014" Then
NEWMOB = "0114" & Right(MOB, 7)
End If
If LL = "012" Then
NEWMOB = "0122" & Right(MOB, 7)
End If
If LL = "017" Then
NEWMOB = "0127" & Right(MOB, 7)
End If
If LL = "018" Then
NEWMOB = "0128" & Right(MOB, 7)
End If
If LL = "010" Then
NEWMOB = "0100" & Right(MOB, 7)
End If
If LL = "016" Then
NEWMOB = "0106" & Right(MOB, 7)
End If
If LL = "019" Then
NEWMOB = "0109" & Right(MOB, 7)
End If
ElseIf Len(MOB) = 11 Then
If LL15 = "0150" Then
NEWMOB = "0120" & Right(MOB, 7)
End If
If LL15 = "0151" Then
NEWMOB = "0101" & Right(MOB, 7)
End If
If LL15 = "0152" Then
NEWMOB = "0112" & Right(MOB, 7)
End If
End If
و في الجزء السابق من الكود نقوم بتعديل الرقم وفق التعديلات الأخيرة وفقا لشركات المحمول
BB = Left(DATAIN, L2 - 1)
EE = Right(DATAIN, (Len(DATAIN) - i) + 1)
ALLL = BB & NEWMOB & vbCrLf & EE
و في الجزء السابق من الكود قمنا بنسخ البيانات في الملف قبل الرقم في المتغير BB و البيانات بعد الرقم في المتغير EE
ثم قمنا بإعادة كتابة البيانات كامله مع إدخال رقم المحمول الجديد داخل البيانات داخل المتغير ALLL
If SAVEorNO = True Then
Open SavePlace For Output As #1
Print #1, ALLL
Close #1
ElseIf SAVEorNO = False Then
ChangeNewMOB = ALLL
End If
ChangeNewMOB = ALLL
و في الجزء الأخير من الكود قمنا بحفظ الملف بالرقم الجديد و أيضا قمنا بتعيين البيانات كقيمة مخرجات للدالة
و في المرفقات الدالة مرفقة مع مشروع صممته لتستخدمه و تعدل عليه بما يناسبك
أرجو أن أكون قد وفقت و أرجو أيضا منكم إذا أفادكم المشروع أن تقيموه
و السلام ختام .....