مشکلات فارسی و سورس های مربوطه

[sarami]

تو این بخش به حل مشکلات فارسی و سورس های مربوطه پرداخته خواهد شد.تا از پراکندگی اینگونه بحث ها جلوگیری بشه.برای شروع تابع تبدیل تاریخ :

در صورت استفاده از این ماجول ، فیلدهای از نوع تاریخ را باید از نوع Number تعریف کنید. توضیحات بیشتر جهت استفاده از ماجول ، درون خود ماجول نوشته شده است.
برای استفاده از این ماجول ، از دو خط پایین تر تا انتهای متن را در حافظه کپی کرده (Copy) و سپس در یک ماجول جدید در اکسس یا VB قرار دهید (Paste): 



 
' *************************************************************
' برنامه نویس : حمید آزادی 
' Email: azadi1355@yahoo.com
' Web Address: http://try.persianblog.com
' ویرایش سوم : زمستان 1381
' *************************************************************
' 1- تعریف کنید Number(Long) است را بصورت Date فیلدهایی که نوع آنها
' 2- این فیلدها را بصورت 00/00/00 تنظیم کنید InputMask خاصیت
' بدلیل 6 رقمی در نظر گرفتن فیلد تاریخ ، این توابع تا سال 1399 کارایی دارد
' ...
' تاریخ جاری سیستم را به هجری شمسی تبدیل می کند Shamsi() تابع
' بکار ببرید Now() را می توانید در گزارشات بجای تابع Dat() تابع
' :برای جلوگیری از ورود تاریخ غلط به درون یک فیلد بترتیب زیر عمل میکنید
' :بشکل زیر بکار ببرید ValidationRule را در خاصیت ValidDate() تابع
' ValidDate([نام فیلد])=True
' ...
' *************************************************************
 
'*******************************************
' برنامه نویس : حمید آزادی
' Email: azadi1355@yahoo.com
' Web Address: http://try.persianblog.com
' ویرایش سوم : زمستان 1381
'*******************************************
Public Function Rooz(F_Date As Long) As Byte
'این تابع عدد مربوط به روز یک تاریخ را برمگرداند
Rooz = F_Date Mod 100
End Function
'*******************************************
Function Mah(F_Date As Long) As Byte
'این تابع عدد مربوط به ماه یک تاریخ را برمگرداند
Mah = Int((F_Date Mod 10000) / 100)
End Function
'*******************************************
Public Function Sal(F_Date As Long) As Byte
'این تابع عدد مربوط به سال یک تاریخ را برمگرداند
Sal = Int(F_Date / 10000)
End Function
'*******************************************
Public Function Kabiseh(ByVal OnlySal As Variant) As Byte
'ورودی تابع عدد دورقمی است
'این تابع کبیسه بودن سال را برمیگرداند
'اگر سال کبیسه باشد عدد یک و درغیر اینصورت صفر را بر میگرداند
Kabiseh = 0
If OnlySal >= 75 Then
If (OnlySal - 75) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
ElseIf OnlySal <= 70 Then
If (70 - OnlySal) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
End If
 
End Function
'*******************************************
Function ValidDate(F_Date As Long) As Boolean
Dim M, S, R As Byte
' این تابع اعتبار یک عدد ورودی را از نظر تاریخ هجری شمسی بررسی می کند
' را برمی گرداند False واگر نامعتبر باشد True اگر تاریخ معتبر باشد
ValidDate = True
S = Sal(F_Date)
M = Mah(F_Date)
R = Rooz(F_Date)
'********
If F_Date < 100101 Then
ValidDate = False
Exit Function
End If
 
If M > 12 Or M = 0 Or R = 0 Then
ValidDate = False
Exit Function
End If
 
If R > MahDays(S, M) Then
ValidDate = False
Exit Function
End If
End Function
'*******************************************
Public Function AddDay(ByVal F_Date As Long, ByVal add As Integer) As Long
Dim K, M, S, R, Days As Byte
R = Rooz(F_Date)
M = Mah(F_Date)
S = Sal(F_Date)
K = Kabiseh(S)
 
'تبدیل روز به عدد 1 جهت ادامه محاسبات و یا اتمام محاسبه
Days = MahDays(S, M)
If add > Days - R Then
add = add - (Days - R + 1)
R = 1
If M < 12 Then
M = M + 1
Else
M = 1
S = S + 1
End If
Else
R = R + add
add = 0
End If
 
While add > 0
K = Kabiseh(S) 'کبیسه: 1 و غیر کبیسه: 0
Days = MahDays(S, M) 'تعداد روزهای ماه فعلی
Select Case add
Case Is < Days
'اگر تعداد روزهای افزودنی کمتر از یک ماه باشد
R = R + add
add = 0
Case Days To IIf(K = 0, 365, 366) - 1
'اگر تعداد روزهای افزودنی بیشتر از یک ماه و کمتر از یک سال باشد
add = add - Days
If M < 12 Then
M = M + 1
Else
S = S + 1
M = 1
End If
Case Else
'اگر تعداد روزهای افزودنی بیشتر از یک سال باشد
S = S + 1
add = add - IIf(K = 0, 365, 366)
End Select
Wend
AddDay = (S * 10000) + (M * 100) + (R)
 
End Function
 
'***********************************************
Public Function Shamsi() As Long
'تاریخ جاری سیستم را به تاریخ هجری شمسی تبدیل می کند
Dim Shamsi_Mabna As Long
Dim Miladi_mabna As Date
Dim Dif As Long
'در اینجا 80/10/11 با 2002/01/01 معادل قرارداده شده
Shamsi_Mabna = 791012
Miladi_mabna = #1/1/01#
Dif = DateDiff("d", Miladi_mabna, Date)
If Dif < 0 Then
MsgBox "تاریخ جاری سیستم شما نادرست است , آنرا اصلاح کنید."
Else
Shamsi = AddDay(Shamsi_Mabna, Dif)
End If
End Function
'***********************************************
Public Function DayWeek(F_Date As Long) As String
Dim a As String
Dim N As Byte
N = DayWeekNo(F_Date)
Select Case N
Case 0
a = "شنبه"
Case 1
a = "یکشنبه"
Case 2
a = "دوشنبه"
Case 3
a = "سه‌شنبه"
Case 4
a = "چهارشنبه"
Case 5
a = "پنج‌شنبه"
Case 6
a = "جمعه"
End Select
DayWeek = a
End Function
 
'***********************************************
Public Function Dat()
Dim D As Long
D = Shamsi
Dat = DayWeek(D) & " 13" & Sal(D) & "/" & Mah(D) & "/" & Rooz(D)
End Function
 
'***********************************************
Public Function Diff(ByVal FromDate As Long, ByVal To_Date As Long) As Long
'این تابع تعداد روزهای بین دو تاریخ را ارائه می کند
Dim Tmp As Long
Dim S1, M1, r1, S2, m2, r2 As Integer
Dim Sumation As Single
Dim Flag As Boolean
Flag = False
If FromDate = 0 Or IsNull(FromDate) = True Or To_Date = 0 Or IsNull(To_Date) = True Then
Diff = 0
Exit Function
End If
 
If FromDate > To_Date Then
'اگر تاریخ شروع از تاریخ پایان بزرگتر باشد آنها موقتا جابجا می شوند
Flag = True
Tmp = FromDate
FromDate = To_Date
To_Date = Tmp
End If
r1 = Rooz(FromDate)
M1 = Mah(FromDate)
S1 = Sal(FromDate)
r2 = Rooz(To_Date)
m2 = Mah(To_Date)
S2 = Sal(To_Date)
Sumation = 0
 
Do While S1 < S2 - 1 Or (S1 = S2 - 1 And (M1 < m2 Or (M1 = m2 And r1 <= r2)))
'اگر یک سال یا بیشتر اختلاف بود
If Kabiseh((S1)) = 1 Then
If M1 = 12 And r1 = 30 Then
Sumation = Sumation + 365
r1 = 29
Else
Sumation = Sumation + 366
End If
Else
Sumation = Sumation + 365
End If
S1 = S1 + 1
Loop
 
Do While S1 < S2 Or M1 < m2 - 1 Or (M1 = m2 - 1 And r1 < r2)
'اگر یک ماه یا بیشتر اختلاف بود
Select Case M1
Case 1 To 6
If M1 = 6 And r1 = 31 Then
Sumation = Sumation + 30
r1 = 30
Else
Sumation = Sumation + 31
End If
M1 = M1 + 1
Case 7 To 11
If M1 = 11 And r1 = 30 And Kabiseh(S1) = 0 Then
Sumation = Sumation + 29
r1 = 29
Else
Sumation = Sumation + 30
End If
M1 = M1 + 1
Case 12
If Kabiseh(S1) = 1 Then
Sumation = Sumation + 30
Else
Sumation = Sumation + 29
End If
S1 = S1 + 1
M1 = 1
End Select
Loop
 
If M1 = m2 Then
Sumation = Sumation + (r2 - r1)
Else
Select Case M1
Case 1 To 6
Sumation = Sumation + (31 - r1) + r2
Case 7 To 11
Sumation = Sumation + (30 - r1) + r2
Case 12
If Kabiseh(S1) = 1 Then
Sumation = Sumation + (30 - r1) + r2
Else
Sumation = Sumation + (29 - r1) + r2
End If
End Select
End If
 
If Flag = True Then
Sumation = -Sumation
End If
Diff = Sumation
End Function
 
Public Function DayWeekNo(F_Date As Long) As String
'این تابع یک تاریخ را دریافت کرده و مشخص می کند چه روزی از هفته است
'اگر شنبه باشد عدد 0
'اگر 1شنبه باشد عدد 1
'......
'اگر جمعه باشد عدد 6
Dim day As String
Dim Shmsi_Mabna As Long
Dim Dif As Long
'مبنا 80/10/11
Shmsi_Mabna = 801011
Dif = Diff(Shmsi_Mabna, F_Date)
If Shmsi_Mabna > F_Date Then
Dif = -Dif
End If
'با توجه به اینکه 80/10/11 3شنبه است محاسبه میشود day متغیر
day = (Dif + 3) Mod 7
If day < 0 Then
DayWeekNo = day + 7
Else
DayWeekNo = day
End If
End Function
 
 
Function MahName(ByVal Mah_no As Byte) As String
Select Case Mah_no
Case 1
MahName = "فروردین"
Case 2
MahName = "اردیبهشت"
Case 3
MahName = "خرداد"
Case 4
MahName = "تیر"
Case 5
MahName = "مرداد"
Case 6
MahName = "شهریور"
Case 7
MahName = "مهر"
Case 8
MahName = "آبان"
Case 9
MahName = "آذر"
Case 10
MahName = "دی"
Case 11
MahName = "بهمن"
Case 12
MahName = "اسفند"
End Select
End Function
 
Function SalMah(ByVal F_Date As Long) As Integer
'چهار رقم اول تاریخ که معرف سال و ماه است را برمی گرداند
SalMah = Val(Left$(F_Date, 4))
End Function
 
Function MahDays(ByVal Sal As Byte, ByVal Mah As Byte) As Byte
'این تابع تعداد روزهای یک ماه را برمی گرداند
Select Case Mah
Case 1 To 6
MahDays = 31
Case 7 To 11
MahDays = 30
Case 12
If Kabiseh(Sal) = 1 Then
MahDays = 30
Else
MahDays = 29
End If
End Select
 
End Function
 
Function Make_Date(ByVal F_Date As Long) As String
'یک تاریخ را بصورت یک رشته 10 رقمی با ذکر چهار رقم برای سال ارائه می کند
Dim D As String
D = Trim(Str(F_Date))
If IsNull(F_Date) = True Or F_Date = 0 Then
Make_Date = ""
Else
Make_Date = "13" & Mid(D, 1, 2) & "/" & Mid(D, 3, 2) & "/" & Mid(D, 5, 2)
End If
End Function
 
Function NextMah(ByVal Sal_Mah As Integer) As Integer
If (Sal_Mah Mod 100) = 12 Then
NextMah = (Int(Sal_Mah / 100) + 1) * 100 + 1
Else
NextMah = Sal_Mah + 1
End If
End Function
 
Function PreviousMah(ByVal Sal_Mah As Integer) As Integer
If (Sal_Mah Mod 100) = 1 Then
PreviousMah = (Int(Sal_Mah / 100) - 1) * 100 + 12
Else
PreviousMah = Sal_Mah - 1
End If
End Function
 
 
Function SubtractDay(ByVal F_Date As Long, ByVal Subtract As Long) As Long
'به تعداد روز معینی از یک تاریخ کم کرده و تاریخ حاصله را ارائه میکند
Dim K, M, S, R, Days As Byte
 
R = Rooz(F_Date)
M = Mah(F_Date)
S = Sal(F_Date)
K = Kabiseh(S)
 
'تبدیل روز به عدد 1 جهت ادامه محاسبات و یا اتمام محاسبه
If Subtract >= R - 1 Then
Subtract = Subtract - (R - 1)
R = 1
Else
R = R - Subtract
Subtract = 0
End If
 
While Subtract > 0
K = Kabiseh(S - 1) 'کبیسه: 1 و غیر کبیسه: 0
Days = MahDays(IIf(M >= 2, S, S - 1), IIf(M >= 2, M - 1, 12)) 'تعداد روزهای ماه قبلی
Select Case Subtract
Case Is < Days
'اگر تعداد روزهای کاهش کمتر از یک ماه باشد
R = Days - Subtract + 1
Subtract = 0
If M >= 2 Then
M = M - 1
Else
S = S - 1
M = 12
End If
Case Days To IIf(K = 0, 365, 366) - 1
'اگر تعداد روزهای کاهش بیشتر از یک ماه و کمتر از یک سال باشد
Subtract = Subtract - Days
If M >= 2 Then
M = M - 1
Else
S = S - 1
M = 12
End If
Case Else
'اگر تعداد روزهای کاهش بیشتر از یک سال باشد
S = S - 1
Subtract = Subtract - IIf(K = 0, 365, 366)
End Select
Wend
SubtractDay = (S * 10000) + (M * 100) + (R)
 
End Function

دانلود نمونه برنامه

[sarami]

msgboxفارسی به وسیله این فانکشن کلیه دکمه های برروی msgbox فارسی میشه

Option Compare Database

Option Explicit

Private Const WH_CBT = 5
Private Const GWL_HINSTANCE = (-6)
Private Const HCBT_ACTIVATE = 5

'UDT for passing data through the hook
Private Type MSGBOX_HOOK_PARAMS
   hwndOwner   As Long
   hHook       As Long
End Type

'need this declared at module level as
'it is used in the call and the hook proc
Private MSGHOOK As MSGBOX_HOOK_PARAMS

Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long

Public Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function GetWindowLong Lib "user32" _
   Alias "GetWindowLongA" _
  (ByVal hwnd As Long, _
   ByVal nIndex As Long) As Long

Private Declare Function MessageBox Lib "user32" _
   Alias "MessageBoxA" _
  (ByVal hwnd As Long, _
   ByVal lpText As String, _
   ByVal lpCaption As String, _
   ByVal wType As Long) As Long
   
Private Declare Function SetDlgItemText Lib "user32" _
   Alias "SetDlgItemTextA" _
  (ByVal hDlg As Long, _
   ByVal nIDDlgItem As Long, _
   ByVal lpString As String) As Long
      
Private Declare Function SetWindowsHookEx Lib "user32" _
   Alias "SetWindowsHookExA" _
  (ByVal idHook As Long, _
   ByVal lpfn As Long, _
   ByVal hmod As Long, _
   ByVal dwThreadId As Long) As Long
   
Private Declare Function SetWindowText Lib "user32" _
   Alias "SetWindowTextA" _
  (ByVal hwnd As Long, _
   ByVal lpString As String) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" _
   (ByVal hHook As Long) As Long
    
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Tiltle = "", Optional HelpFile, Optional Context) As Long

  'Wrapper function for the MessageBox API
Dim hwndThreadOwner As Long
'Dim frmCurrentForm As Form
'Set frmCurrentForm = Screen.ActiveForm
'hwndThreadOwner = frmCurrentForm.hwnd

hwndThreadOwner = Application.hWndAccessApp

   Dim hInstance As Long
   
   Dim hThreadId As Long
   Dim hwndOwner As Long
   hwndOwner = GetDesktopWindow()
   hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
   hThreadId = GetCurrentThreadId()

   With MSGHOOK
      .hwndOwner = hwndOwner
      .hHook = SetWindowsHookEx(WH_CBT, _
                                AddressOf MsgBoxHookProc, _
                                hInstance, hThreadId)
   End With

  
  
 MsgBoxFa = MessageBox(hwndThreadOwner, Prompt, Tiltle, Buttons)

End Function


Public Function MsgBoxHookProc(ByVal uMsg As Long, _
                               ByVal wParam As Long, _
                               ByVal lParam As Long) As Long
      
   If uMsg = HCBT_ACTIVATE Then
   
      SetDlgItemText wParam, vbYes, "Èáå"
     SetDlgItemText wParam, vbNo, "뒄"
      SetDlgItemText wParam, vbIgnore, "áÛæ"
      SetDlgItemText wParam, vbOK, "ÊÇííÏ"
      
      UnhookWindowsHookEx MSGHOOK.hHook
               
   End If
   
   MsgBoxHookProc = False

End Function

دانلود نمونه برنامه

با اجازه استاد صارمی با توجه به بروز مشکلاتی در بکارگیری ماجول فوق در مواقعی که فرم یا گزارش اکتیو برای استفاده از hwnd در دسترس نیست چند خط از کد فوق اصلاح شده که قسمت اصلاح شده به رنگ آبی و قسمت های کامنت شده به رنگ سبز مشخص شده

[شاپرک]

تابع تبدیل عدد به حروف
نحوه استفاده از تابع :
تابع Adad که در زیر ارائه شده است یک عدد را بعنوان ورودی گرفته و معادل حروفی آن عدد در زبان فارسی را بعنوان خروجی تولید می کند. مثلا (Adad(1373 مقدار"یکهزار و سیصد و هفتاد و سه" را بعنوان خروجی تولید می کند.برای استفاده از این توابع باید از چند خط پایین تر (Start of Module) تا انتهای این یادداشت را در حافظه کپی (Copy) کرده و در یک ماجول جدید در اکسس یا VB ، Paste کنید . ( توجه داشته باشید که نمایش کدهای نوشته شده در اینجا راست به چپ است که پس از کپی کردن آن در ماجول اکسس بشکل صحیح نمایش داده خواهد شد)

' *********** Start of Module ***********

'توابع تبدیل عدد به معادل حروفی آن در زبان فارسی
'برنامه نویس : حمید آزادی اردکانی
'ویرایش اول : اردیبهشت 1380
' پست الکترونیک : azadi1355@yahoo.com
' آدرس وب : http://try.persianblog.com

Function Adad(ByVal Number As Double) As String
If Number = 0 Then
Adad = "صفر"
End If
Dim Flag As Boolean
Dim S As String
Dim I, L As Byte
Dim K(1 To 5) As Double

S = Trim(Str(Number))
L = Len(S)
If L > 15 Then
Adad = "بسیار بزرگ"
Exit Function
End If
For I = 1 To 15 - L
S = "0" & S
Next I
For I = 1 To Int((L / 3) + 0.99)
K(5 - I + 1) = Val(Mid(S, 3 * (5 - I) + 1, 3))
Next I
Flag = False
S = ""
For I = 1 To 5
If K(I) <> 0 Then
Select Case I
Case 1
S = S & Three(K(I)) & " تریلیون"
Flag = True
Case 2
S = S & IIf(Flag = True, " و ", "") & Three(K(I)) & " میلیارد"
Flag = True
Case 3
S = S & IIf(Flag = True, " و ", "") & Three(K(I)) & " میلیون"
Flag = True
Case 4
S = S & IIf(Flag = True, " و ", "") & Three(K(I)) & " هزار"
Flag = True
Case 5
S = S & IIf(Flag = True, " و ", "") & Three(K(I))
End Select
End If
Next I
Adad = S
End Function


Function Three(ByVal Number As Integer) As String
Dim S As String
Dim I, L As Long
Dim h(1 To 3) As Byte
Dim Flag As Boolean
L = Len(Trim(Str(Number)))
If Number = 0 Then
Three = ""
Exit Function
End If
If Number = 100 Then
Three = "یکصد"
Exit Function
End If

If L = 2 Then h(1) = 0
If L = 1 Then
h(1) = 0
h(2) = 0
End If

For I = 1 To L
h(3 - I + 1) = Mid(Trim(Str(Number)), L - I + 1, 1)
Next I

Select Case h(1)
Case 1
S = "یکصد"
Case 2
S = "دویست"
Case 3
S = "سیصد"
Case 4
S = "چهارصد"
Case 5
S = "پانصد"
Case 6
S = "ششصد"
Case 7
S = "هفتصد"
Case 8
S = "هشتصد"
Case 9
S = "نهصد"
End Select

Select Case h(2)
Case 1
Select Case h(3)
Case 0
S = S & " و " & "ده"
Case 1
S = S & " و " & "یازده"
Case 2
S = S & " و " & "دوازده"
Case 3
S = S & " و " & "سیزده"
Case 4
S = S & " و " & "چهارده"
Case 5
S = S & " و " & "پانزده"
Case 6
S = S & " و " & "شانزده"
Case 7
S = S & " و " & "هفده"
Case 8
S = S & " و " & "هجده"
Case 9
S = S & " و " & "نوزده"
End Select

Case 2
S = S & " و " & "بیست"
Case 3
S = S & " و " & "سی"
Case 4
S = S & " و " & "چهل"
Case 5
S = S & " و " & "پنجاه"
Case 6
S = S & " و " & "شصت"
Case 7
S = S & " و " & "هفتاد"
Case 8
S = S & " و " & "هشتاد"
Case 9
S = S & " و " & "نود"
End Select

If h(2) <> 1 Then
Select Case h(3)
Case 1
S = S & " و " & "یک"
Case 2
S = S & " و " & "دو"
Case 3
S = S & " و " & "سه"
Case 4
S = S & " و " & "چهار"
Case 5
S = S & " و " & "پنج"
Case 6
S = S & " و " & "شش"
Case 7
S = S & " و " & "هفت"
Case 8
S = S & " و " & "هشت"
Case 9
S = S & " و " & "نه"
End Select
End If
S = IIf(L < 3, Right(S, Len(S) - 3), S)
Three = S
End Function

' *********** End Of Module ***********

منبع : http://try.persianblog.com/

[sarami]

دوستانی که با اکسس پروجکت کار میکنن این نکته رو فراموش نکنن که هیچ گاه برای استفاده از تاریخ به تاریخ سیستم سرویس گیرنده (Client) متکی نباشید و حتما تاریخ رو از سمت سذویس دهنده (Server)بخونین تا اگه تاریخ سیستم کاربری تنظیم نبود رکوردهای اشتباه وارد بانک شما نشه.
اینم sp اماده:

CREATE PROCEDURE dbo.sp_Hijri_Date

AS


DECLARE @a datetime
DECLARE @Y int,@M INT,@D INT,@YY int,@MM INT,@DD INT,@T varchar(6)


set @a=getdate()
set @Y =(Year(getdate()))
set @M = (Month(getdate()))
set @D = (Day(getdate()))

If (@M = 1 And @D < 21 )
BEGIN
set @YY = @Y - 622
set @MM = @M + 9
set @DD = @D + 10
End 

If @M = 1 And @D > 20 
BEGIN
set @YY = @Y - 622
set @MM = @M + 10
set @DD = @D - 20
End 

If @M = 2 And @D < 20 
BEGIN
set @YY = @Y - 622
set @MM = @M + 9
set @DD = @D+ 11
End 

If @M = 2 And @D > 19 
BEGIN
set @YY = @Y - 622
set @MM = @M + 10
set @DD = @D - 19
End 

If @M = 3 And @D < 21 
BEGIN
set @YY = @Y - 622
set @MM = @M + 9 
set @DD = @D+ 9
End 

If @M = 3 And @D > 20 
BEGIN
set @YY = @Y- 621
set @MM = @M - 2
set @DD = @D- 20
End 

If @M = 4 And @D < 21 
BEGIN
set @YY = @Y- 621
set @MM = @M - 3
set @DD = @D+ 11
End


If @M = 4 And @D > 20 
BEGIN
set @YY = @Y - 621
set @MM = @M- 2
set @DD = @D - 20
End 
If @M = 5 And @D < 22 
BEGIN
set @YY = @Y - 621
set @MM = @M - 3
set @DD = @D + 10
End 
If @M = 5 And @D > 21 
BEGIN
set @YY = @Y - 621
set @MM = @M - 2
set @DD = @D - 21
End 
If @M = 6 And @D < 22 
BEGIN
set @YY = @Y - 621
set @MM = @M - 3
set @DD = @D + 10
End 

If @M = 6 And @D > 21 
BEGIN
set @YY = @Y - 621
set @MM = @M - 2
set @DD = @D - 21
End 
If @M = 7 And @D < 23 
BEGIN
set @YY = @Y - 621
set @MM = @M - 3
set @DD = @D + 9
End 
If @M = 7 And @D > 22 
BEGIN
set @YY = @Y - 621
set @MM = @M - 2
set @DD = @D - 22
End 
If @M = 8 And @D < 23 
BEGIN
set @YY = @Y- 621
set @MM = @M - 3
set @DD = @D + 9
End 
If @M = 8 And @D > 22 
BEGIN
set @YY = @Y - 621
set @MM = @M - 2
set @DD = @D- 22
End 

If @M = 9 And @D < 23 
BEGIN
set @YY = @Y- 621
set @MM = @M - 3
set @DD = @D + 9
End 
If @M = 9 And @D > 22 
BEGIN
set @YY = @Y - 621
set @MM = @M - 2
set @DD = @D- 22
End 
If @M = 10 And @D < 23 
BEGIN
set @YY = @Y - 621
set @MM = @M - 3
set @DD = @D + 8
End 
If @M = 10 And @D > 22 
BEGIN
set @YY = @Y - 621
set @MM = @M - 2
set @DD = @D - 22
End 
If @M = 11 And @D < 22 
BEGIN
set @YY = @Y - 621
set @MM = @M - 3
set @DD = @D+ 9
End 

If @M = 11 And @D > 21 
BEGIN
set @YY = @Y - 621
set @MM = @M - 2
set @DD = @D- 21
End 
If @M = 12 And @D < 22 
BEGIN
set @YY = @Y- 621
set @MM = @M - 3
set @DD = @D + 9
End 
If @M = 12 And @D > 21 
BEGIN
set @YY = @Y - 621
set @MM = @M - 2
set @DD = @D - 21
End 



If (Right(@Y, 2) % 4 = 0 And @M > 2)
BEGIN

set @DD = @DD+ 1
If @MM <= 6 
BEGIN
If @DD > 31
BEGIN
set @DD = 1
set @MM= @MM + 1
End 
else if @MM > 6 
BEGIN
If @DD > 30 
BEGIN 
set @DD = 1
set @MM= @MM + 1
End
End

If @MM = 12 And @DD= 30 
BEGIN 
set @MM=1
set @dd=1
set @yy=@yy+1
End
end
End 

If (Right(@Y, 2) - 1)%4 = 0 And @M <= 3
BEGIN
If Not ( @M = 3 And @D > 20) 
BEGIN
set @DD= @DD + 1
If @DD = 31 
BEGIN
set @DD = 1
set @MM = @MM + 1
End 
End 
End



SET @T = Right(str(@YY), 2) + Right('00'+(LTRIM(STR(@MM))), 2) + Right('00'+(LTRIM(STR(@DD))), 2) 


select @t as 'Date'




GO

اینم فانکشن تاریخ برا کد نویستون تا بتونین از طریق اون تاریخ سرور رو در کد نویسی داشته باشین

Function Hijri_ShortDate() As String
On Error GoTo Err_Handler
Dim rst As ADODB.Recordset
Dim strsql As String
strsql = "EXECUTE sp_Hijri_Date"
Set rst = New ADODB.Recordset
rst.open strsql, Application.CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic

If Not rst.EOF Then
Hijri_ShortDate = rst.Fields(0)
End If
rst.Close

Exit Function
Err_Handler:
MsgBoxFa Err.Description, , "dateErr"

End Function
Function Hijri_LongDate()
On Error GoTo Err_Handler
Dim Today As Date, strWeekDay As String, strMonth As String
Today = Now
Select Case Weekday(Today)
Case 1
strWeekDay = "í˜ÔäÈå"
Case 2
strWeekDay = "ÏæÔäÈå"
Case 3
strWeekDay = "Óå ÔäÈå"
Case 4
strWeekDay = "چåÇÑÔäÈå"
Case 5
strWeekDay = "پäÌÔäÈå"
Case 6
strWeekDay = "ÌãÚå"
Case 7
strWeekDay = "ÔäÈå"
End Select

Select Case Mid(Hijri_ShortDate, 3, 2)
Case 1
strMonth = "ÝÑæÑÏíä"
Case 2
strMonth = "ÇÑÏíÈåÔÊ"
Case 3
strMonth = "ÎÑÏÇÏ"
Case 4
strMonth = "撄"
Case 5
strMonth = "ãÑÏÇÏ"
Case 6
strMonth = "ÔåÑíæÑ"
Case 7
strMonth = "ãåÑ"
Case 8
strMonth = "ÂÈÇä"
Case 9
strMonth = "ÂÐÑ"
Case 10
strMonth = "Ïí"
Case 11
strMonth = "Èåãä"
Case 12
strMonth = "ÇÓÝäÏ"
End Select
Dim yy As Integer
yy = Left(Hijri_ShortDate, 2)

Hijri_LongDate = strWeekDay & ", " & Right(Hijri_ShortDate, 2) & " " & strMonth & "," & yy
Exit Function
Err_Handler:
MsgBoxFa "err"
End Function

[mohammadgij]

ماژول تبدیل عدد به حروف که به درد بسیاری از دوستان خواهد خورد اما یه مشکل داره و اونم اینه که اگر عددی دارای رقم اعشار باشه جواب 100% غلط از آب در میاد. مثلا عدد (1385.1) رو می دهد (یکصدو سی و هشت هزار و پنج)!!! آخه ماژولی که من استفاده می کنم هم همین مشکل داره ولی باز این ماژول بهتره. فقط کاش Block ها رو با Tab درست گذاشته بودین
کد Msgbox هم محشر بود دستتون درد نکنه
من نمی دونستم می تونم همین جا این اشکال رو مطرح کنم .
و به نظز من بهتره که اشکالات رو اینجا مطرح نکنیم البته هر چی مدیران سایت بگن برای من یکی حجته

[bijanborjian]

تشکر از زحمات و وقت گرانبهای شما
برای دانلود نمونه برنامه ها با مشکل روبرو شدم .

[sarami]

چک شده هیچ مشکلی مشاهده نمیشه . اگه نمی تونین یه ماژول ایجاد کنین و نوشته ها رو کپی کنین داخل ماژول جدید . بعد هرجا میخواین صداش بزنین

[Fazaeli]

تابع تبدیل سال میلادی به شمسی

Function Shamsi(Optional date1 As String, Optional SmallDate1 As Boolean) As String
      '====================================================
      Dim d, P, w, mon, mm, ym, u, v, rp, X, i, ys, ms, dm, p1, d1, ds, DateShamsi
      d = Array(20, 19, 20, 20, 21, 21, 22, 22, 22, 22, 21, 21)
      P = Array(11, 12, 10, 12, 11, 11, 10, 10, 10, 9, 10, 10)
      w = Array("یکشنبه","دوشنبه","سه شنبه","چهارشنبه","پنج شنبه","جمعه","شنبه")
      
      If SmallDate1 = True Then
            mon = Array("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12")
      Else
            mon = Array("اسفند", "بهمن", "دی", "آذر", "آبان", "مهر", "شهریور", "مرداد", "تیر", "خرداد", "اردیبهشت", "فروردین")
      End If
      
      If date1 = "" Then date1 = DateAdd("d", 1, Date)
      
      dm = Day(date1)
      mm = Month(date1)
      ym = Year(date1)
      u = 0
      rp = 0
      If (ym Mod 4) = 0 Then u = 1
      If ((ym Mod 100) = 0 And (ym Mod 400) <> 0) Then u = 0
      ys = ym - 622
      X = ys - 22
      X = X Mod 33
      If ((X Mod 4) = 0 And X <> 32) Then rp = 1
      i = Not (rp - 2) + Not (u - 2) * 2
      X = 0
      If (i = 0 And mm = 3) Then X = 1
      If i = 0 Then i = 3
      ms = (9 + mm) Mod 13
      If ms < 10 Then ms = ms + 1
      d1 = d(mm - 1)
      If (i = 1 And mm > 2) Then d1 = d1 - 1
      If (i = 2 And mm < 3) Then d1 = d1 - 1
      p1 = P(mm - 1)
      If (i = 1 And mm > 2) Then p1 = p1 + 1
      If (i = 2 And mm < 4) Then p1 = p1 + 1
      If (dm > 0 And dm <= d1) Then
             ds = p1 + dm + X - 1
          X = 1
      Else
          ds = dm - d1
          ms = ms + 1
          If ms = 13 Then ms = 1
          X = 2
      End If
      If ((mm = 3 And X = 2) Or mm > 3) Then ys = ys + 1
      ds = Str(ds)
      If Len(Trim(ds)) = 1 Then ds = "0" + Trim(ds)
      If SmallDate1 = True Then
'     اگر سال به صورت دو کارکتری میخواهید خط زیر را از حالت کامنت در آورید
'            Shamsi = Mid(Trim(Str(Ys)), 3, 2) + "/" + Trim(mon(Ms - 1)) + "/" + Trim(Ds)
'     اگر سال به صورت چهار کارکتری میخواهید خط زیر را از حالت کامنت در آورید
            Shamsi = Trim(Str(ys)) + "/" + Trim(mon(ms - 1)) + "/" + Trim(ds)
      Else
            Shamsi = w(Weekday(Date) - 1) + " " + Str(ds) + " " + mon(ms - 1) + " " + Str(ys)
      End If
End Function

[Fazaeli]

تابع تبدیل عدد به حروف

'This Function convert Numbers To Text
Public Function NoToText(eNo As Double, _
                   Optional isCounter As Boolean = False) As String

Dim tStr, tNo, eNumber As String
Dim i, j, k As Double
Dim m_isNeg As Boolean

    'This Number is Negative Or Positive?
    m_isNeg = IIf(Sgn(eNo) = -1, True, False)

    
    If eNo = 0 Then 'This Number is Zero; Don't Continue anymore
        NoToText = IIf(isCounter, "صفرم ", "صفر ")
        Exit Function
    'NOTE: We can delete Following 3 Lines of code to have "یکم" instead of "اول"
    'TODO: we can Make a new optional Argument to ask this from user
    ElseIf (eNo = 1) And isCounter And (Not m_isNeg) Then
        NoToText = "اول "
        Exit Function
    End If

    'TODO: Add Support for decimal Numbers
    'convert input to Absolute value w/o Thousand separators, as a String
    eNumber = Abs(eNo)

    'Add Some Extra Zero at the begining of String
    eNumber = Choose(Len(eNumber) Mod 3, "00", "0") & eNumber

    tStr = ""
    k = Len(eNumber) / 3

    For i = 1 To Len(eNumber) Step 3
    '
        tNo = Mid(eNumber, i, 3)
        If tNo <> "000" Then
            
            'Convert The First Digit Of Group --> `5`12
            tStr = tStr & _
            DigitToText(Mid(tNo, 1, 1) & "00")

            'If the Second Digit is <1> Then We Have a number between _
             Ten and Nineteen;
            If Mid(tNo, 2, 1) = "1" Then '--> 5`12`
                tStr = tStr & _
                DigitToText(Mid(tNo, 2, 2))
            Else 'elsewhere, do normal method
                tStr = tStr & _
                DigitToText(Mid(tNo, 2, 1) & "0")        '--> 5`2`6
                tStr = tStr & _
                DigitToText(Mid(tNo, 3, 1))
            End If
            'if u know greater values then >>>>>>>>>>>>>>>>>>>>just Add it below
            tStr = tStr & Choose(k, "", "هزار ", "میلیون ", "میلیارد ", "تریلیون ") '<<< here before `)`
        End If
        k = k - 1
    
    Next i

    'If in Counting Mode then add appropriate Suffixes to end of string
    If isCounter Then
        If Right(eNumber, 1) = "3" Then
            tStr = Left(tStr, Len(tStr) - 2) & "وم" 'is `سهم` true?! ;)
        ElseIf Right(eNumber, 2) = "30" Then
            tStr = Left(tStr, Len(tStr) - 1) & "‌ام" 'and u know `سیم` is wrong! ;)
        Else
            tStr = RTrim(tStr) & "م" 'make countable strings like `دوازدهم`,`پنجم`, etc...
        End If
    End If

    'This is Result!! ;)
    NoToText = IIf(m_isNeg, "منفی ", "") & Mid(tStr, 3)

End Function


Private Function DigitToText(eNo As String)
Dim tStr As String
Dim tDbl As Double

If eNo = "" Or eNo = "0" Or eNo = "00" Or eNo = "000" Then
    DigitToText = ""
    Exit Function
End If

tDbl = Val(eNo)
Select Case tDbl
    Case Is >= 1000
        tStr = ""
    Case Is >= 900
        tStr = "نهصد"
    Case Is >= 800
        tStr = "هشتصد"
    Case Is >= 700
        tStr = "هفتصد"
    Case Is >= 600
        tStr = "ششصد"
    Case Is >= 500
        tStr = "پانصد"
    Case Is >= 400
        tStr = "چهارصد"
    Case Is >= 300
        tStr = "سیصد"
    Case Is >= 200
        tStr = "دویست"
    Case Is >= 100
        tStr = "صد"
    Case Is >= 90
        tStr = "نود"
    Case Is >= 80
        tStr = "هشتاد"
    Case Is >= 70
        tStr = "هفتاد"
    Case Is >= 60
        tStr = "شصت"
    Case Is >= 50
        tStr = "پنجاه"
    Case Is >= 40
        tStr = "چهل"
    Case Is >= 30
        tStr = "سی"
    Case Is >= 20
        tStr = "بیست"
    Case Is >= 19
        tStr = "نوزده"
    Case Is >= 18
        tStr = "هیجده"
    Case Is >= 17
        tStr = "هفده"
    Case Is >= 16
        tStr = "شانزده"
    Case Is >= 15
        tStr = "پانزده"
    Case Is >= 14
        tStr = "چهارده"
    Case Is >= 13
        tStr = "سیزده"
    Case Is >= 12
        tStr = "دوازده"
    Case Is >= 11
        tStr = "یازده"
    Case Is >= 10
        tStr = "ده"
    Case Is >= 9
        tStr = "نه"
    Case Is >= 8
        tStr = "هشت"
    Case Is >= 7
        tStr = "هفت"
    Case Is >= 6
        tStr = "شش"
    Case Is >= 5
        tStr = "پنج"
    Case Is >= 4
        tStr = "چهار"
    Case Is >= 3
        tStr = "سه"
    Case Is >= 2
        tStr = "دو"
    Case Is >= 1
        tStr = "یک"
    Case Is >= 0
        tStr = ""
End Select
    DigitToText = "و " + tStr + " "
End Function

'ALL RIGHTS RESERVED BY: Mohammad Shiran __________________

وکد زیر برای اعشاری میباشد

Function DecimalToText(eNo As Double, _
                       Optional DecStyle As Boolean = False _
                                                  ) As String
                       
    Dim eFixed As String, eDecimal As String
    Dim sResult As String
    
    'return fixed value of given number as string
    eFixed = Fix(eNo)
    
    'if this number has some decimals
    If (Len(CStr(eNo)) - Len(eFixed)) Then
        'get it as a string, Example: return `125` for `12.125`
        eDecimal = Mid(CStr(eNo), Len(eFixed) + 2)
        'return fixed part as text
        sResult = NoToText(CDbl(eFixed)) & IIf(DecStyle, "و ", "ممیز ")
        'if decimal section is `5` then use `نیم` Instead of `پنج دهم`
        'this is optional, u can remove it if u like
        If eDecimal = 5 Then
            sResult = sResult & "نیم"
        Else
            'convert the decimal part of number to text
            sResult = sResult & _
                      NoToText(CDbl(eDecimal))
            'add extra suffix at end of string, depending to number of decimal places
            sResult = sResult & _
                      Choose(Len(eDecimal), "دهم", "صدم", _
                                            "هزارم", "ده هزارم", _
                                            "صد هزارم", "میلیونیم") ', _
                                             ....
        End If
            
    Else
        'if this number is originally an integer then convert it using normal method
        sResult = NoToText(eNo)
    End If
    'return the result. ;)
    DecimalToText = sResult
    
End Function

[sarami]

یک فانکشن برای دوستانی که با اکسس پروجکت کار میکنن برای تبدیل تاریخ شمسی به میلادی که یکی از کاربران رو سایت گذاشته بودن رو در اینجا نیز کپی میکنم تا مورد استفاده دوسان قرار بگیره شاپرک عزیز قبلا چنین موردی رو خواسته بودن البته فکر میکنم....

CREATE FUNCTION [dbo].[MiladiTOShamsi] (@MDate  DateTime)  
RETURNS Varchar(10)
AS  
BEGIN 
   DECLARE @SYear  as Integer
   DECLARE @SMonth  as Integer
   DECLARE @SDay  as Integer
   DECLARE @AllDays  as float
   DECLARE @ShiftDays  as float
   DECLARE @OneYear  as float
   DECLARE @LeftDays  as float
   DECLARE @YearDay  as Integer
   DECLARE @Farsi_Date  as Varchar(100) 
   SET @MDate=@MDate-CONVERT(char,@MDate,114)

  SET @ShiftDays=466699   +2
  SET @OneYear= 365.24199


   SET @SYear = 0
   SET @SMonth = 0
   SET @SDay = 0
   SET @AllDays  = CAst(@Mdate as Real)

   SET @AllDays = @AllDays + @ShiftDays

  SET @SYear = (@AllDays / @OneYear) --trunc
  SET @LeftDays = @AllDays - @SYear * @OneYear

  if (@LeftDays < 0.5)
  begin
    SET @SYear=@SYear+1
    SET @LeftDays = @AllDays - @SYear * @OneYear
  end;

  SET @YearDay = @LeftDays --trunc
  if (@LeftDays - @YearDay) >= 0.5 
    SET @YearDay=@YearDay+1

  if ((@YearDay / 31) > 6 )
  begin
    SET @SMonth = 6
    SET @YearDay=@YearDay-(6 * 31)
    SET @SMonth= @SMonth+( @YearDay / 30)
    if (@YearDay % 30) <> 0 
      SET @SMonth=@SMonth+1
    SET @YearDay=@YearDay-((@SMonth - 7) * 30)
  end 
  else
  begin
    SET @SMonth = @YearDay / 31
    if (@YearDay % 31) <> 0 
      SET @SMonth=@SMonth+1 
    SET @YearDay=@YearDay-((@SMonth - 1) * 31)
  end
  SET @SDay = @YearDay
  SET @SYear=@SYear+1

 SET @Farsi_Date =   CAST (@SYear   as VarChar(10)) + '/' + CAST (@SMonth   as VarChar(10)) + '/' + CAST (@SDay  as VarChar(10))
 Return @Farsi_Date



END

پست شده توسط Kamyar.Kimiyabeigi