MReza_Motaffaf
New Member
دوستان مدت ها بود دنبايش مي گشتم و خودم هم برنامه هاي زيادي در موردش نوشتم اما بخوبي اين يكي نيست شما هم امتحانش كنيد
راستي از دوستان تقاضا دارم اگر برنامه اي و يا Active X براي فارسي نويسي در vb دارند دريغ نكنند من را هم ياري دهيد
Function mil2shams(miladi_mm_dd_yyyy As String) As String
Dim iran(12), CHRIS(12)
CHRIS(1) = 31: CHRIS(2) = 28: CHRIS(3) = 31
CHRIS(4) = 30: CHRIS(5) = 31: CHRIS(6) = 30
CHRIS(7) = 31: CHRIS(8) = 31: CHRIS(9) = 30
CHRIS(10) = 31: CHRIS(11) = 30: CHRIS(12) = 31
For i = 1 To 12: iran(i) = 31 - (i \ 7) - (i \ 12): Next
mo = Val(Left(miladi_mm_dd_yyyy, 2))
miladi_mm_dd_yyyyy1 = Val(Mid(miladi_mm_dd_yyyy, 4, 2))
Year1 = Val(Mid(miladi_mm_dd_yyyy, 7, 4))
leap1 = Int((Year1 - 1) / 400)
leap2 = Year1 - 1 - 400 * leap1
leap3 = leap2 \ 100
leap4 = leap2 Mod 100
leap5 = leap4 \ 4
CHRIS(2) = 28
If ((Year1 Mod 4) = 0 And (Year1 Mod 100) <> 0) Or _
(Year1 Mod 400) = 0 Then CHRIS(2) = 29
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy1
For i = 1 To mo - 1
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 + CHRIS(i)
Next i
miladi_mm_dd_yyyyy1num = 365 * (Year1 - 1) + _
miladi_mm_dd_yyyyy11 + 97 * leap1 + 24 * leap3 + leap5
miladi_mm_dd_yyyyy1num = miladi_mm_dd_yyyyy1num - 221056!
iry1 = Int(miladi_mm_dd_yyyyy1num / 12053)
iry2 = miladi_mm_dd_yyyyy1num - 12053 * iry1
iry = 33 * iry1 - 16
If iry2 > 365 Then iry = iry + 1: iry2 = iry2 - 365
iry3 = iry2 \ 1461
iry4 = iry2 Mod 1461
iry5 = iry4 \ 365
iry6 = iry4 Mod 365
iry = iry + 1 + 4 * iry3 + iry5
iran(12) = 29
esfand = (8 * iry + 22) / 33 - 0.001
esfand = esfand - Int(esfand)
If esfand > 0.77 Then iran(12) = 30
For i = 1 To 12
If iry6 > iran(i) Then iry6 = iry6 - iran(i) _
Else irm = i: miladi_mm_dd_yyyyy11 = iry6: Exit For
Next i
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 + 5
If miladi_mm_dd_yyyyy11 > iran(irm) Then
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 - iran(irm)
irm = irm + 1
If irm > 12 Then irm = 1: iry = iry + 1
End If
eirmiladi_mm_dd_yyyye = 3 * irm - 3
If irm > 7 Then eirmiladi_mm_dd_yyyye = _
eirmiladi_mm_dd_yyyye - irm + 7
girmiladi_mm_dd_yyyye = (8 * iry + 22) / 33 - 0.001
cirmiladi_mm_dd_yyyye = Int(girmiladi_mm_dd_yyyye) _
+ iry + eirmiladi_mm_dd_yyyye - miladi_mm_dd_yyyyy11 + 3
cirmiladi_mm_dd_yyyye = cirmiladi_mm_dd_yyyye Mod 7
If irm < 10 Then mo = "0" + LTrim(Str(irm)) Else _
mo = LTrim(Str(irm))
If miladi_mm_dd_yyyyy11 < 10 Then d = "0" + _
LTrim(Str(miladi_mm_dd_yyyyy11)) Else _
d = LTrim(Str(miladi_mm_dd_yyyyy11))
mil2shams = LTrim(Str(iry)) + "/" + mo + "/" + d
End Function
Private Sub Form_Load()
MsgBox "Emrooz=" + mil2shams(Format(Now, "mm/dd/yyyy")), _
vbInformation _
, "Miladi-miladi_mm_dd_yyyyte -> Shamsi-miladi_mm_dd_yyyyte"
End Sub
----------------------------------------------------------------------------------------------------
Public Function shams2mil(iran_YyyyMmDd As String)
'yyyy/mm/dd in latin-number
y = Val(Left(iran_YyyyMmDd, 4))
m = Val(Mid(iran_YyyyMmDd, 6, 2))
d = Val(Right(iran_YyyyMmDd, 2))
If m < 10 Or (m = 10 And d < 11) Then _
y = y + 621 Else y = y + 622
Select Case m
Case 1: If d < 12 Then m = 3: d = d + 20 Else m = 4: d = d - 11
Case 2: If d < 11 Then m = 4: d = d + 20 Else m = 5: d = d - 10
Case 3: If d < 11 Then m = 5: d = d + 21 Else m = 6: d = d - 10
Case 4: If d < 10 Then m = 6: d = d + 21 Else m = 7: d = d - 9
Case 5, 6, 8: If d < 10 Then m = m + 2: d = d + 22 Else _
m = m + 3: d = d - 9
Case 7: If d < 9 Then m = 9: d = d + 22 Else m = 10: d = d - 8
Case 9: If d < 10 Then m = 11: d = d + 21 Else m = 12: d = d - 9
Case 10: If d < 11 Then m = 12: d = d + 21 Else m = 1: d = d - 10
Case 11: If d < 12 Then m = 1: d = d + 20 Else m = 2: d = d - 11
Case 12: If d < 10 Then m = 2: d = d + 19 Else m = 3: d = d - 9
End Select
shams2mil = Right("00" + Mid(Str(m), 2), 2) + _
"-" + Right("00" + Mid(Str(d), 2), 2) + "-" + Right(Str(y), 4)
End Function
Private Sub Form_Load()
MsgBox "1356/01/09" + " = " + shams2mil("1356/01/09"), _
vbInformation, "Shamsi-date -> Miladi-date"
End Sub
راستي از دوستان تقاضا دارم اگر برنامه اي و يا Active X براي فارسي نويسي در vb دارند دريغ نكنند من را هم ياري دهيد
Function mil2shams(miladi_mm_dd_yyyy As String) As String
Dim iran(12), CHRIS(12)
CHRIS(1) = 31: CHRIS(2) = 28: CHRIS(3) = 31
CHRIS(4) = 30: CHRIS(5) = 31: CHRIS(6) = 30
CHRIS(7) = 31: CHRIS(8) = 31: CHRIS(9) = 30
CHRIS(10) = 31: CHRIS(11) = 30: CHRIS(12) = 31
For i = 1 To 12: iran(i) = 31 - (i \ 7) - (i \ 12): Next
mo = Val(Left(miladi_mm_dd_yyyy, 2))
miladi_mm_dd_yyyyy1 = Val(Mid(miladi_mm_dd_yyyy, 4, 2))
Year1 = Val(Mid(miladi_mm_dd_yyyy, 7, 4))
leap1 = Int((Year1 - 1) / 400)
leap2 = Year1 - 1 - 400 * leap1
leap3 = leap2 \ 100
leap4 = leap2 Mod 100
leap5 = leap4 \ 4
CHRIS(2) = 28
If ((Year1 Mod 4) = 0 And (Year1 Mod 100) <> 0) Or _
(Year1 Mod 400) = 0 Then CHRIS(2) = 29
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy1
For i = 1 To mo - 1
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 + CHRIS(i)
Next i
miladi_mm_dd_yyyyy1num = 365 * (Year1 - 1) + _
miladi_mm_dd_yyyyy11 + 97 * leap1 + 24 * leap3 + leap5
miladi_mm_dd_yyyyy1num = miladi_mm_dd_yyyyy1num - 221056!
iry1 = Int(miladi_mm_dd_yyyyy1num / 12053)
iry2 = miladi_mm_dd_yyyyy1num - 12053 * iry1
iry = 33 * iry1 - 16
If iry2 > 365 Then iry = iry + 1: iry2 = iry2 - 365
iry3 = iry2 \ 1461
iry4 = iry2 Mod 1461
iry5 = iry4 \ 365
iry6 = iry4 Mod 365
iry = iry + 1 + 4 * iry3 + iry5
iran(12) = 29
esfand = (8 * iry + 22) / 33 - 0.001
esfand = esfand - Int(esfand)
If esfand > 0.77 Then iran(12) = 30
For i = 1 To 12
If iry6 > iran(i) Then iry6 = iry6 - iran(i) _
Else irm = i: miladi_mm_dd_yyyyy11 = iry6: Exit For
Next i
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 + 5
If miladi_mm_dd_yyyyy11 > iran(irm) Then
miladi_mm_dd_yyyyy11 = miladi_mm_dd_yyyyy11 - iran(irm)
irm = irm + 1
If irm > 12 Then irm = 1: iry = iry + 1
End If
eirmiladi_mm_dd_yyyye = 3 * irm - 3
If irm > 7 Then eirmiladi_mm_dd_yyyye = _
eirmiladi_mm_dd_yyyye - irm + 7
girmiladi_mm_dd_yyyye = (8 * iry + 22) / 33 - 0.001
cirmiladi_mm_dd_yyyye = Int(girmiladi_mm_dd_yyyye) _
+ iry + eirmiladi_mm_dd_yyyye - miladi_mm_dd_yyyyy11 + 3
cirmiladi_mm_dd_yyyye = cirmiladi_mm_dd_yyyye Mod 7
If irm < 10 Then mo = "0" + LTrim(Str(irm)) Else _
mo = LTrim(Str(irm))
If miladi_mm_dd_yyyyy11 < 10 Then d = "0" + _
LTrim(Str(miladi_mm_dd_yyyyy11)) Else _
d = LTrim(Str(miladi_mm_dd_yyyyy11))
mil2shams = LTrim(Str(iry)) + "/" + mo + "/" + d
End Function
Private Sub Form_Load()
MsgBox "Emrooz=" + mil2shams(Format(Now, "mm/dd/yyyy")), _
vbInformation _
, "Miladi-miladi_mm_dd_yyyyte -> Shamsi-miladi_mm_dd_yyyyte"
End Sub
----------------------------------------------------------------------------------------------------
Public Function shams2mil(iran_YyyyMmDd As String)
'yyyy/mm/dd in latin-number
y = Val(Left(iran_YyyyMmDd, 4))
m = Val(Mid(iran_YyyyMmDd, 6, 2))
d = Val(Right(iran_YyyyMmDd, 2))
If m < 10 Or (m = 10 And d < 11) Then _
y = y + 621 Else y = y + 622
Select Case m
Case 1: If d < 12 Then m = 3: d = d + 20 Else m = 4: d = d - 11
Case 2: If d < 11 Then m = 4: d = d + 20 Else m = 5: d = d - 10
Case 3: If d < 11 Then m = 5: d = d + 21 Else m = 6: d = d - 10
Case 4: If d < 10 Then m = 6: d = d + 21 Else m = 7: d = d - 9
Case 5, 6, 8: If d < 10 Then m = m + 2: d = d + 22 Else _
m = m + 3: d = d - 9
Case 7: If d < 9 Then m = 9: d = d + 22 Else m = 10: d = d - 8
Case 9: If d < 10 Then m = 11: d = d + 21 Else m = 12: d = d - 9
Case 10: If d < 11 Then m = 12: d = d + 21 Else m = 1: d = d - 10
Case 11: If d < 12 Then m = 1: d = d + 20 Else m = 2: d = d - 11
Case 12: If d < 10 Then m = 2: d = d + 19 Else m = 3: d = d - 9
End Select
shams2mil = Right("00" + Mid(Str(m), 2), 2) + _
"-" + Right("00" + Mid(Str(d), 2), 2) + "-" + Right(Str(y), 4)
End Function
Private Sub Form_Load()
MsgBox "1356/01/09" + " = " + shams2mil("1356/01/09"), _
vbInformation, "Shamsi-date -> Miladi-date"
End Sub
