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

[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

دانلود نمونه برنامه (http://www.box.net/public/80piy276rl)

[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, "&Egrave;&aacute;&aring;"
SetDlgItemText wParam, vbNo, "&Icirc;&iacute;&Ntilde;"
SetDlgItemText wParam, vbIgnore, "&aacute;&Ucirc;&aelig;"
SetDlgItemText wParam, vbOK, "&Ecirc;&Ccedil;&iacute;&iacute;&Iuml;"

UnhookWindowsHookEx MSGHOOK.hHook

End If

MsgBoxHookProc = False

End Function
دانلود نمونه برنامه (http://www.box.net/public/nb73sfi7yq)

با اجازه استاد صارمی با توجه به بروز مشکلاتی در بکارگیری ماجول فوق در مواقعی که فرم یا گزارش اکتیو برای استفاده از 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 = "&iacute;˜&Ocirc;&auml;&Egrave;&aring;"
Case 2
strWeekDay = "&Iuml;&aelig;&Ocirc;&auml;&Egrave;&aring;"
Case 3
strWeekDay = "&Oacute;&aring; &Ocirc;&auml;&Egrave;&aring;"
Case 4
strWeekDay = "چ&aring;&Ccedil;&Ntilde;&Ocirc;&auml;&Egrave;&aring;"
Case 5
strWeekDay = "پ&auml;&Igrave;&Ocirc;&auml;&Egrave;&aring;"
Case 6
strWeekDay = "&Igrave;&atilde;&Uacute;&aring;"
Case 7
strWeekDay = "&Ocirc;&auml;&Egrave;&aring;"
End Select

Select Case Mid(Hijri_ShortDate, 3, 2)
Case 1
strMonth = "&Yacute;&Ntilde;&aelig;&Ntilde;&Iuml;&iacute;&auml;"
Case 2
strMonth = "&Ccedil;&Ntilde;&Iuml;&iacute;&Egrave;&aring;&Ocirc;&Ecirc;"
Case 3
strMonth = "&Icirc;&Ntilde;&Iuml;&Ccedil;&Iuml;"
Case 4
strMonth = "&Ecirc;&iacute;&Ntilde;"
Case 5
strMonth = "&atilde;&Ntilde;&Iuml;&Ccedil;&Iuml;"
Case 6
strMonth = "&Ocirc;&aring;&Ntilde;&iacute;&aelig;&Ntilde;"
Case 7
strMonth = "&atilde;&aring;&Ntilde;"
Case 8
strMonth = "&Acirc;&Egrave;&Ccedil;&auml;"
Case 9
strMonth = "&Acirc;&ETH;&Ntilde;"
Case 10
strMonth = "&Iuml;&iacute;"
Case 11
strMonth = "&Egrave;&aring;&atilde;&auml;"
Case 12
strMonth = "&Ccedil;&Oacute;&Yacute;&auml;&Iuml;"
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) &lt;> 0) Then u = 0
ys = ym - 622
X = ys - 22
X = X Mod 33
If ((X Mod 4) = 0 And X &lt;> 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 &lt; 10 Then ms = ms + 1
d1 = d(mm - 1)
If (i = 1 And mm > 2) Then d1 = d1 - 1
If (i = 2 And mm &lt; 3) Then d1 = d1 - 1
p1 = P(mm - 1)
If (i = 1 And mm > 2) Then p1 = p1 + 1
If (i = 2 And mm &lt; 4) Then p1 = p1 + 1
If (dm > 0 And dm &lt;= 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") &amp; eNumber

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

For i = 1 To Len(eNumber) Step 3
'
tNo = Mid(eNumber, i, 3)
If tNo &lt;> "000" Then

'Convert The First Digit Of Group --> `5`12
tStr = tStr &amp; _
DigitToText(Mid(tNo, 1, 1) &amp; "00")

'If the Second Digit is &lt;1> Then We Have a number between _
Ten and Nineteen;
If Mid(tNo, 2, 1) = "1" Then '--> 5`12`
tStr = tStr &amp; _
DigitToText(Mid(tNo, 2, 2))
Else 'elsewhere, do normal method
tStr = tStr &amp; _
DigitToText(Mid(tNo, 2, 1) &amp; "0") '--> 5`2`6
tStr = tStr &amp; _
DigitToText(Mid(tNo, 3, 1))
End If
'if u know greater values then >>>>>>>>>>>>>>>>>>>>just Add it below
tStr = tStr &amp; Choose(k, "", "هزار ", "میلیون ", "میلیارد ", "تریلیون ") '&lt;&lt;&lt; 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) &amp; "وم" 'is `سهم` true?! ;)
ElseIf Right(eNumber, 2) = "30" Then
tStr = Left(tStr, Len(tStr) - 1) &amp; "‌ام" 'and u know `سیم` is wrong! ;)
Else
tStr = RTrim(tStr) &amp; "م" 'make countable strings like `دوازدهم`,`پنجم`, etc...
End If
End If

'This is Result!! ;)
NoToText = IIf(m_isNeg, "منفی ", "") &amp; 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)) &amp; 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 &amp; "نیم"
Else
'convert the decimal part of number to text
sResult = sResult &amp; _
NoToText(CDbl(eDecimal))
'add extra suffix at end of string, depending to number of decimal places
sResult = sResult &amp; _
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 (http://barnamenevis.org/forum/member.php?u=10720)

[mohsenna30ri]

اگر تو کدنویسی یا اجرای نرم افزارهای فارسی بجای حروف فارسی علامت سوال می بینید :
این راه حل بدردت می خوره
http://barnamenevis.org/forum/showthread.php?t=55431

[TEHRAne.abas]

لطفا برای ماژول تاریخ یک مثال بیاورید که چگونگی استفاده را نشان دهد

با تشکر

[شاپرک]

برای پیدا کردن مثال بهتره از امکان جستجو ی این سایت استفاده کنی .
بالای صفحه یک نوار آبی رنگ هست که یکی از منو ها جستجو است .

[majid325]

اگر تو کدنویسی یا اجرای نرم افزارهای فارسی بجای حروف فارسی علامت سوال می بینید :
این راه حل بدردت می خوره
http://barnamenevis.org/forum/showthread.php?t=55431

لینک بالا دوست عزیز فعال نیست!

[mahtabi]

لینک نمونه تبدبل MSGBOX کار نمی کند

[mohsenna30ri]

ک خبر فوق العاده ، مسرت بخش و با حال برای همه اکسس نویسان
برنامه اجرای تاریخ هجری شمسی در اکسس ویندوز ایکس پی به بازار آمد
http://barnamenevis.org/forum/showthread.php?t=69758

[mazizi]

سلام در هنگام مرتب سازی بر اساس حروف الفبای فارسی حرف "ک" در انتهای ستون بعد از حرف "ی" قرار می گیرد چکار کنم تا اصلاح شود.

[mohsenna30ri]

متاسفانه حروف الفبای فارسی به دو صورت ارائه شده که این مشکلات را بوجود اورده است
در یک نوع حرف "پ" در سمت راست صفحه کلید است که این نوع مسئله ساز می باشد برای مثال در این نوع حرف "ی" واقعی با گرفتن شیفت "X" نوشته می شود و حرف ژ با شیفت "C" نوشته می شود خلاصه در این نوع تعریف صفحه کلید حروف "ک" و "ی" استاندارد تعریف نمی شوند و در نتیجه در سورت در انتها قرار می گیرند ولی با تعریف لایه صفحه کلید جدید این مشکلات حل می شود
شما می توانید در یک برنامه ویرایشگر مثلا ورد تمام حروف ی قدیمی را به جدید تبدیل کنید
توجه : در ویندوز شما حرف ی اصلی فارسی با شیفت "X" نوشته می شود که علامت مشخصه آن دو نقطه در زیر "ی" است
شما می توانید جهت تعریف لایه صفحه کلید فارسی جدید به مشکل خود پایان دهید اغلب فارسی سازهای صفحه کلید اینکار را انجام می دهند
راحت ترین کار از نظر من کپی کردن فایل ضمیمه در سیستم 32 ویندوزتان می باشد البته در حالت Safe mode
9357

[shahabrayane]

با سلام .
اگه حمل بر پر رویی نیست ممکنه یه برنامه ساده که در اون از این ماژول تبدیل عدد به حرف استفاده شده برایم بفرستید تا بهتر بتونم ازش استفاده کنم .
بی نهایت سپاسگزارم

[rezavb2005]

سلام خسته نباشید دستتون درد نکن یعنی با این kbdfa.dll کارمون راه می افته یا باید از فارسی ساز های مثلا مریم استفاده کرد؟؟؟؟؟؟؟؟؟؟؟؟:تشویق::تشو� �ق::تشویق:

[mohsenna30ri]

برای اینکه فایل مورد نظر رو باید تو حالت Safe mode کپی کنید یک کم مشکله واسه همین می تونید از نرم افزار زیر استفاده کنید که جهت جایگزینی فایل های ویندوز در حالت عادی است :قهقهه::قهقهه:

بعد از اجرا - اول فایل اوژینال ویندوز مسیر اصلی رو داخل پنجره برنامه انداخته و کلید اینتر بزنید و سپس فایل جایگزین را داخل پنجره درگ کده و سپس تایید کنید :لبخندساده::لبخندساده:
واسه اجرای تقویم فارسی تو اکسس هم می توانید به این آدرس مراجعه کنید که در حال بحثیم
آدرس تقویم فارسی در اکسس:
http://barnamenevis.org/forum/showthread.php?p=425188


نرم افزار جایگزین کردن فایلهای ویندوز :
http://barnamenevis.org/forum/attachment.php?attachmentid=12424&d=1195879522

[hbahjat]

با سلام خدمت دوستان عزیز
کمی خواستم بدونم کسی مبدل تاریخ شمسی به میلادی را نداره !
اگه کسی داره لطفا بذاره ممنون .

[mahmoud.golzar]

دوستان عزیز آیا کسی میتونه دستوری پیدا کنه که وقتی با فرم های اکسس کار میکنم دیگه در نوار taskbar اثری از فرم باز شده نباشه

[shaghaghi]

از منوی Tools گزینه Options را انتخاب کرده در برگه View تیک چک باکس Windows In Taskbar را بردارید

[mahmoud.golzar]

از منوی Tools گزینه Options را انتخاب کرده در برگه View تیک چک باکس Windows In Taskbar را بردارید

از راهنمایی تون ممنون ولی میخوام با vba این کار انجام بشه.

[shaghaghi]

ولی میخوام با vba این کار انجام بشه.
می بایستی فرم مورد نظر را به حالت dialog باز کنید با این فرمت:
DoCmd.OpenForm "Form1", , , , , acDialog

[hamedMohammad]

سلام دوستان عزیز
من در ساختن منوی راست به چپ در اکسس نیاز به راهنمایی شما عزیزان دارم .
خیلی ممنون میشم اگه فوری راهنایی کنید .http://www.barnamenevis.org/forum/images/icons/icon7.gif

[yekabar]

ممنون از تمامی دوستان
دوستان ایا امکان داره در اکسس منوهای طراحی کرد که در سمت چپ و راست برنامه قرار بگیره ؟

[mahdif123]

با سلام

دوستان عزيز مرا در اين مورد راهنمايي كنيد .
سورس كدي دارم كه تاريخ هجري شمسي آقاي حميد آزاد مي باشد اما فكر ميكنم براي ورود تاريخ از سال 1300 تا سال 1900 مي باشد آيا مي شود كاري كرد مقدار آن بيشتر شود يعني قبل از 1300 و بعد از 1900 .

----------نمونه سورس--------------------------


Option Compare Database
'Use openSource program.

' ************************************************** ***********
' برنامه نويس حميد آزاد
' 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/2001#
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

[nabeel]

ضمن سلام
چندی پیش توی سایت http://fa.farsiweb.ir مطلب زیر رو خوندم که خوندنش جهت اطلاعات عمومی بد نیست .
البته این مورد بی ارتباط با بحث قبلی هم نیست .

قانون ایران به‌وضوح بیان می‌کند که در محاسبهٔ تقویم باید از سال خورشیدی حقیقی استفاده کرد، که این کار نیازمند محاسبات نجومی برای تعیین نقطهٔ اعتدال فروردین و ظهر شرعی است. مشکل اینجاست که قانون محاسبهٔ تقویم که در سال ۱۳۰۴ شمسی (۱۹۲۵میلادی) تصویب شده، مبهم است. مهمترین مشکل این است که قانون، محل مشاهدهٔ ظهر شرعی را، که برای تعیین روز اول سال ایرانی استفاده می‌شود، مشخص نمی‌کند.

این مسئله باعث شده که تعدادی از ستاره‌شناسان (از جمله رینگولد و دِرشویتز) نصف‌النهاری از تهران، و بقیه (از جمله ایرج‌ ملک‌پور) نصف‌النهار ۵۲٫۵ شرقی را (نصف‌النهاری که ساعت استاندارد ایران را تعیین می‌کند) به عنوان محل تشخیص اولین روز سال در نظر بگیرند. به همین دلیل هیچ‌کس واقعاً نمی‌داند که آیا سال ۱۴۶۹ شمسی کبیسه خواهدبود یا نه. درنتیجه، جز در شرایطی که قانون اصلاح شده و نصف‌النهاری مشخص شود، هر الگوریتمی که مدعی باشد که برای سال ۱۴۶۹ یا سال‌های بعد از آن کاربرد دارد، مکانی را به عنوان محل مشاهده فرض می‌کند که نباید فرض کند.

همچنین، قبل از سال ۱۳۰۴ شمسی، طول ماه‌های ایرانی با طول فعلی آنها متفاوت بود. برای مثال، همهٔ سال‌ها حداقل یک ماه ۳۲ روزه داشتند. به همین دلیل، همهٔ الگوریتم‌هایی که طول فعلی ماه‌ها را پیش فرض قرارمی‌دهند نتایج غلطی برای سال ۱۳۰۳ شمسی و سال‌های قبل از آن به‌دست می‌دهند. مشکلات ذکر شده در بالا عملاً هر الگوریتمی (که بدون جدول داده‌ها برای تعداد روزها در ماه‌های سال ۱۳۰۴ و قبل از آن، کارمی‌کند) را محدود به دورهٔ زمانی سال‌های ۱۴۶۸-۱۳۰۴ شمسی می‌کند. در تقویم لینوکس شریف ۲ یکی از پراستفاده‌ترین الگوریتم‌های محاسباتی ۳۳ ساله به کار برده ‌شده‌است. این الگوریتم در سراسر دورهٔ ۱۴۶۸-۱۳۰۴ با تقویم رسمی (نجومی) شمسی مطابقت دارد. همچنین این همان الگوریتمی است که در دو نرم‌افزار بین‌المللی، دات نت مایکروسافت و مونوی ناوِل به کار رفته است.

لازم به ذکر است که تقویم ایرانی با الگوریتم محاسباتی ۲۸۲۰ ساله، که بوسیلهٔ احمد بیرَشک و سایرین پیشنهاد داده‌ شده، نسبت به تقویم ۳۳ ساله دقت کمتری دارد: اول این که زودتر از دورهٔ ۳۳ ساله در مطابقت با تقویم نجومی رسمی شکست می‌خورد (اولین شکست در سال ۲۰۲۵ میلادی است)، و دوم این که قاعدهٔ پیشنهاد شده در الگوریتم۲۸۲۰ ساله براساس سال میانگین استوایی پی‌ریزی شده، نه سال میانگین اعتدال فروردین.

فارسی‌وب درحال کار برای گسترش کُد تقویم استاندارد شمسی خود به سال‌های قبل از ۱۳۰۴ شمسی است، و اطلاعاتی درمورد تقویم ایرانی واقعی مورد استفاده در سال‌های ۱۳۰۳-۱۲۳۰ شمسی در ایران جمع‌آوری کرده است. ما از هرگونه اطلاعاتی در زمینهٔ تقویم ایرانی مورد استفاده قبل از این دوره استقبال می‌کنیم.

با تشکر
امیدوارم که مفید بوده باشه

[Fardeen Safdari]

سلام خدمت تمام کسانیکه که در تهیه این معلومات سهم داشته اند.


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

[smderfan]

سلام
شما می تونید برای رفع این مشکل تنظیمات فارسی را در قسمت Regional and Language Options انجام دهید.

[Fardeen Safdari]

برادر عزیز از ارسال پیام تان جهان سپاس!
من مطابق رهنمائی شما عمل نمودم اما نتیجه نداد و بعدا راه حل آنرا به طریقه ذیل دریافت نمودم:
بعد از باز کردن Module به مینو تولز رفته فرمان آپشن را انتخاب کردم در قسمت پنجره Edit Format فانت را تبدیل به تایمز نیو رومان نمودم مشکل حل گردید. باز هم از پیام شما خیلی ممنون

[ghahremanimehdi]

سلام
من یک جدول دارم و یک فرم .و یک فیلد دارم که میخوام تاریخ فارسی وارد بشه داخلش
البته من آماتور هستم .
درباره ی تبدیل تاریخهای انگلیسی به فارسی که کدهاش رو در صفحه ی اول گذاشتید میخوام بدونم چطور باید استفاده کنمش؟آیا میشه date picker انگلیسی رو به فارسی تبدیل کرد ؟
میشه یک نمونه از فیلد تاریخ فارسی برام بذارید .

[mohsenna30ri]

حل مشکل تاريخ هجري شمسي تو ايکس پي به سادگي
فايل kbdfa.dll مربوط به اصلاح صفحه کليد و
فايل OLEAUT32.DLL مربوط به تبديل تاريخ هجري قمري به شمسي تو اکسس
( البته تو ويندوز ايکس پي)
که فايل مربوط به اصلاح صفحه کليد فارسي kbdfa.dll تو ويندوز 7 هم امتحان کردم جواب داد اما
فايل OLEAUT32.DLL تو ويندوز 7 جواب نمي ده
جهت انجام اين replace مي توانيد از نرم افزار مربوط به اينکار بنام replacer استفاده کنيد يا در محيط safe mode جابجايي اين فايلها را انجام دهيد که تو همين سايت وجود دارد
راهنما:
http://barnamenevis.org/forum/showthread.php?t=51987
http://barnamenevis.org/forum/showthread.php?p=425188

فايل:
http://barnamenevis.org/forum/attachment.php?attachmentid=9357&d=1182584372

[hamid_193]

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

[ali_zali]

تابع تبدیل تاریخ :

یه سوال
توابعی که میشه با این ماژول استفاده کرد رو کسی جایی لیست شده و آماده داره؟

[ghahremanimehdi]

حل مشکل تاريخ هجري شمسي تو ايکس پي به سادگي
فايل kbdfa.dll مربوط به اصلاح صفحه کليد و
فايل OLEAUT32.DLL مربوط به تبديل تاريخ هجري قمري به شمسي تو اکسس
( البته تو ويندوز ايکس پي)
که فايل مربوط به اصلاح صفحه کليد فارسي kbdfa.dll تو ويندوز 7 هم امتحان کردم جواب داد اما
فايل OLEAUT32.DLL تو ويندوز 7 جواب نمي ده
جهت انجام اين replace مي توانيد از نرم افزار مربوط به اينکار بنام replacer استفاده کنيد يا در محيط safe mode جابجايي اين فايلها را انجام دهيد که تو همين سايت وجود دارد
راهنما:
http://barnamenevis.org/forum/showthread.php?t=51987
http://barnamenevis.org/forum/showthread.php?p=425188

فايل:
http://barnamenevis.org/forum/attachment.php?attachmentid=9357&d=1182584372

این روش خوب جواب میده (حتی تو ویستا)
ولی بعدش مشکلاتی رو بوجود میاره:
موقع نصب Sqlserver و ِdreamweaver دائما ارور میداد که oleaut32 خراب شده حالا خدا میدونه کجاها به مشکل بر میخوره.

[ghasemshami]

ممنون از دوستان گرامی از نمونه هاتون

[amirzazadeh]

تقويم فارسي با قابليت ثبت سال به صورت چهار رقمي

دوستان نمونه ضميمه در واقع ماژول اصلاح شده آقاي آزادي ميباشد كه به صورت سئوال توسط آقاي ali190 مطرح شده بود اميدوارم به دردتون بخوره.
...........................
موفق باشيد

[7skies]

سلام .فایل زیر ماژولی داره که تاریخ شمسی رو به میلادی تبدیل می کنه. ولی فرمت نمایش سال میلادی به صورتYYYY/MM/DD هستش. هر کاری کردم نشد که بر عکس باشه یعنی DD/MM/YYYY.کسی از دوستان هست که بتونه راهنمایی کنه. هرچی property رو تغییر دادم نشد. خواستم ماژول رو دستکاری کنم.خراب شد.:خجالت:

[moalla]

تقويم فارسي با قابليت ثبت سال به صورت چهار رقمي

دوستان نمونه ضميمه در واقع ماژول اصلاح شده آقاي آزادي ميباشد كه به صورت سئوال توسط آقاي ali190 مطرح شده بود اميدوارم به دردتون بخوره.
...........................
موفق باشيد

خیلی خیلی ممنون
خیلی دنبال همچین چیزی میگشتم و یه مشتری گیر داده بود که باید از اینها تو قسمت انتخاب تاریخ باشه
البته یکم سنگین اجرا میشه
کسی نمونه دیگه ای مشابه این سراغ داره؟

[e20005ir]

سلام
با توجه به اينكه براي تقويم فارسي نو فيلد تاريخ روي text تعبيه ميشه اگه بخوايم يه محدوده تاريخ را مشخص كنيم چطور ميشه اينكار را كرد؟
همون حالت برابر با دستور between مدد نظرمه

[payman_xxp]

سلام دوستان

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

بنا به اعلام سایت سازنده این برنامه قابل اجرا در تمام سیستم عاملهای ویندوز اعم از xp-vista-7 هستش.

http://barnamenevis.org/forum/showthread.php?t=227399

[morynf]

با سلام خدمت دوستان گرامي علي الخصوص آقاي امير زاده
من در برنامه از توابع آقاي ميداني (Persian Date) براي تاريخ استفاده كردم همچنين از Farsi Date picker گذاشته شده در پست هاي بالا ولي چون مبناي كار آن توابع اقاي آزادي است دچار اشكال شدم از جنابعالي و ساير دوستان درخواست دارم در صورت امكان فايل پيوست را اصلاح نمايند تا دوستاني كه از اين توابع استفاده مي كنند نيز بتوانند با Date picker كار كنند .
ممنون و سپاس گذار

[ARData]

خیلی خیلی ممنون
خیلی دنبال همچین چیزی میگشتم و یه مشتری گیر داده بود که باید از اینها تو قسمت انتخاب تاریخ باشه
البته یکم سنگین اجرا میشه
کسی نمونه دیگه ای مشابه این سراغ داره؟

دوست عزيز ماژول آقاي آزادي در عصر حجر مونده ... شما چرا از فايل CPSD_PDC.Dll براي اينکار استفاده نمي کنيد ؟

[amirzazadeh]

محاسبه چندمين هفته و چندمين روز از سال در تاريخ هاي شمسي:
براي انجام اين كار دو تابع زير به توابع آقاي آزادي اضافه شده:

Function SalRooz(ByVal F_date As Long) As Long
SalRooz = Rooz(F_date)
If Mah(F_date) > 1 Then SalRooz = (Mah(F_date) - 1) * 31 + Rooz(F_date)
If Mah(F_date) > 6 Then SalRooz = 186 + (Mah(F_date) - 7) * 30 + Rooz(F_date)
If Mah(F_date) > 11 Then SalRooz = 336 + Rooz(F_date)
End Function
Function WeekOfYear(ByVal F_date As Long) As Long
If SalRooz(F_date) Mod 7 = 0 Then
WeekOfYear = SalRooz(F_date) \ 7
Else
WeekOfYear = SalRooz(F_date) \ 7 + 1
End If
End Function
.............................
موفق باشيد

[maryamrad]

ممکن است چه مشکلی وجود داشته باشد
اگر یک کد تبدیل اعداد به حروف در یک سیستم کار کند اما همان فایل در سیستم دیگری ، مشکل داشته باشد یعنی #name? را نمایش دهد !! مشکل کجاست!!

[stabesh]

با سلام
همان طور كه مي دانيد كاراكترهاي ي ( ی ) و ك ( ک ) دو كد دارند يكي براي فارسي و يكي براي عربي . چون بعضي از كامپيوترها كيبورد استاندارد فارسي ندارند ( مثل مال من ) از كد عربي استفاده مي كنند كه در زمان جستجو و مرتب سازي باعث اشتباه مي شود مشکل ایجاد می کند بنابراين ما توابعي نوشتيم تا در موقع ورود اطلاعات به جاي ی و ک فارسی ، ي و ك عربي را جايگزين كند .
در ضمن چند تا تابع هم براي چك كردن فارسی بودن و انگليسي بودن نوشتيم .
شايد به درد شما هم بخورد .

[stabesh]

با سلام
یک راه حل برای راست چین کردن Treeview و Toolbarو Progressbar و Statusbar پیدا کردم اینجا ندیده بودمش
اول باید یک ماژول تعریف کرد


Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Const GW_CHILD = 5
Public Const WS_EX_LAYOUTRTL = &H400000
Public Const GWL_EXSTYLE = (-20)

سپس باید در onload فرم کدهای زیر رو نوشت


Private Sub Form_Load() 'On Form Load you need to set the mirroring for the controls
Dim OldLong As Long
'For Form
OldLong = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
SetWindowLong Me.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL
InvalidateRect hwnd, 0, False
'For List
OldLong = GetWindowLong(List1.hwnd, GWL_EXSTYLE)
SetWindowLong List1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL
InvalidateRect hwnd, 0, False
'For The StatusBar
OldLong = GetWindowLong(StatusBar1.hwnd, GWL_EXSTYLE)
SetWindowLong StatusBar1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL
InvalidateRect hwnd, 0, False
'For TreeView
Dim nodX As Node
Set nodX = TreeView1.Nodes.Add(, , "R", "Root")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C1", "Child 1")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C2", "Child 2")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C3", "Child 3")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C4", "Child 4")
nodX.EnsureVisible
OldLong = GetWindowLong(TreeView1.hwnd, GWL_EXSTYLE)
SetWindowLong TreeView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL
InvalidateRect hwnd, 0, False
'For ListView
OldLong = GetWindowLong(ListView1.hwnd, GWL_EXSTYLE)
SetWindowLong ListView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL
InvalidateRect hwnd, 0, False
'For ProgressBar
ProgressBar1.Value = 50
OldLong = GetWindowLong(ProgressBar1.hwnd, GWL_EXSTYLE)
SetWindowLong ProgressBar1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL
InvalidateRect hwnd, 0, False
'For ToolBar
mhwnd = GetWindow(Toolbar1.hwnd, GW_CHILD)
OldLong = GetWindowLong(mhwnd, GWL_EXSTYLE)
SetWindowLong mhwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL
InvalidateRect hwnd, 0, False
End Sub



من فقط برای treeview استفادش کردم اگر برای بقیه هم مثال درست کردم آپلود میکنم
منبع سئوال 8 : http://www.microsoft.com/middleeast/msdn/faq.aspx

[royasaz_bam]

سلام و بسیار ممنون از توابع ذکر شده فقط خواهش داشتم اگر میشه در مورد تابع تبدیل عدد به حرف نحوه بکارگیری این تابع را با مثال توضیح دهید ممنون میشم اخه من تا بحال با ماجواها کارنکردم

[navbas]

سلام
در اکسس 2007 سورت به صورت عربی انجام میشه. یعنی حرف "ه" در مرتب سازی قبل از "واو" قرار می‌گیره
در حالیکه در توالی زبان فارسی حروف به صورت "ن" "واو" "ه" "ی" هستن.
کسی از دوستان راه حلی برای حلی این مشکل داره؟

[Younestalebi]

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

[mojahed.morteza]

خواهشا يه نمونه بزارين
ما كه خيلي مبتدي هستيم كمي مشكل داريم در دركش

[sajjad_kochekian]

دوستان تا حالا کسی منوی راست به چپ فارسی داشته
من می خواهم منو ها از سمت راست شروع بشه ظاهرا مشکل داره
اگر دوستان کسی می تونه کمک کنه
http://barnamenevis.org/showthread.php?322117

[farshid_mi]

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

در حال حاضر نسخه ارتقا یافته آن به پیوست همین پست ارائه می گردد که شامل یک فایل اکسس و کدها می باشد.
در فایل اکسس چندین مثال کاربردی تاریخ شمسی و تبدیل عدد به حروف ارائه شده است.

عدم به هم ریختن حروف فارسی و عدم نیاز به تنظیم کنترل پنل
افزودن حرف میم به آخر تابع تبدیل تاریخ به حروف در Access (ششم مهر ....)
فایل راهنمای کامل PDF به همراه چندین مثال کاربردی از تبدیل تاریخ به حروف / محاسبه سنوات Access برای کاربرانی که نحوه استفاده از کدها را نمی دانند.

فایل PDF آن را می توانید از اینجا (http://www.farsaran.ir/node/134) دریافت کنید (اگر یافت نشد از قسمت جستجوی سایت استفاده نمایید)

[u.2u.4u]

ممنون. ولی سوال من این است که آیا از 1400 به بعد هم این تابع جواب می دهد؟

[aftab_mahtab]

با سلام خدمت همگي دوستان و اساتيد
راستش من حسابي گير كردم ، n تا فانكشن ديدم كه براي تبديل تاريخ ميلادي به شمسي هست ولي نميدونم چرا تاريخ 2012/03/16 رو اشتباه تبديل ميكنن ، خواهشن اگه كسي تابه درست حسابي براي تبديل تاريخ ميلادي به شمسي داره بهم بده .(فقط يه فانكشن براي اين كار ميخوام ) مرسي ، يه دنيا ممنون

[ahmmad]

اگر تو کدنویسی یا اجرای نرم افزارهای فارسی بجای حروف فارسی علامت سوال می بینید :
این راه حل بدردت می خوره
http://barnamenevis.org/showthread.php?t=55431

صفحه مورد نظر پيدا نشد ولي بايد تنظيمات زبان ويندوز رو تو قسمت Advance روي Persian قرار دهند.

[NasimBamdad]

سلام

من یک DataBase دارم که با Access 95 ساخته شده است . متاسفانه وقتی که با Office 2003 و یا 2007 بازش می کنم ، اطلاعاتش خرچنگ ، قورباقه شده . یعنی Encoding اش بهم خورده .

وقتی هم از منوی tools اون رو تبدیل به یک دیتابیس 2007 می کنم ، بازم فرقی نداره و خرچنگ قورباقه هست .

آیا راهی هست که DataBase رو خوند ؟ چه طوری Encoding اش رو درست کنیم ؟

[NasimBamdad]

خبری نشد دوستان ؟ کسی نظری نداره ؟

[IMANAZADI]

سلام
دوستان راهنمایی میخوام
چرا وقتی تو vba به فارسی مینویسیم وقتی کد اجرا میشه بصورت حروف ناخوانا نمایشداده میشه
مثل تابع msgbox "سلام"

[RESMAILY]

به نام خدا
باسلام قبلا در اينمورد بحث شده است. مشكل از دو نقطه است و معمولا در ويندوز سون پيش مي ايد.
1- فونت مورد استفاده سيستم . يعني اغلب وقتي فونت مورد استفاده سيستم را در Appearance تغيير دهيد مشكل حل مي شود
2 - موضوع مربوط به كاركتر هاي يونيكد. وگرنه در كنترل پنل و بخش Regional and Languege و فلان و در تب Advanced فارسي را انتخاب كنيد.
تنشاله مشكل حل مي شود.

[basirtex]

دوستان لطفا راهنمایی بفرمایید در Access 2010 برای اینکه دیتا بیس ما هنگام باز شدن در یک فرم مشخص باز شود چه کنیم ؟
مثلا با دبل کلیک کردن روی آیکن دیتا بیس، وارد فرم ثبت نام شود در حالت فول اسکرین
مانند اتوران نرم افزار های مختلف
چگونه امکان پذیر است
با تشکر

[brave_ie]

برای این کار برید توی access options
بعد توی current database
بعد توی فیلد display form فرم مورد نظرتون رو انتخاب کنید

[hamid-nice]

سلام
خوب ، ما پیام ها را فارسی کردیم و ... با پنجره open file dialog با دگمه های open و cancel و save چه کنیم ؟ آیا این ها را می شه فارسی کرد ؟ اگر می شه لطف کنید نمونه ای بذارید

اگه نمی شه شما تا حالا چه می کردید ؟ قسمتی از برنامه فارسی و قسمتی انگلیسی بود ؟ چه راهکار دیگه ای را بکار
می گیرید ؟

با تشکر

[RESMAILY]

به نام خدا
با سلام. می شود. در همین تاپیک بگردید پیدا می کنید.

[hamid-nice]

به نام خدا
با سلام. می شود. در همین تاپیک بگردید پیدا می کنید.


سلام
من هر چی تو این تاپیک گشتم که نبود
شاید شما خوب متوجه خواسته من نشدید

اگه من اشتباه میکنم لطفا بگید در کدوم پست هست ؟ اگه نیست و شما می گید می شه لطفا فایلی را که گذاشتم اصلاح فرمایید که خیلی منتظر حل این مساله هستم

با تشکر

[RESMAILY]

به نام خدا
با سلام. اين هم نمونه. مي توانيد آن را توسعه هم بدهيد. من حداقل سه چهار تاپيك در خاطر دارم كه در اين باره گفتگويي شد. در تاپيك برنامه هاب كاربردي هم يكي دو نمونه وجود دارد. چند ساعتي وقت بگذاريد چيز هاي ديگري هم بدست مي ايد.

[hamid-nice]

سلام

ببین دوست گرامی من پستی که زدم برای فارسی کردن پیام ها نبود که این در همین تاپیک و .... وجود داره

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

شما لطف کن فایل را بردار یک نگاهی یکن و اگه فایلی برای این کار داری بذار که این تاپیک جای این را خالی داره و به درد خیلی ها هم خواهد خورد

با تشکر

[RESMAILY]

به نام خدا
با سلام. البته می بخشید که درست دقت نکرده بودم. در مورد دیالوگ باکس و غیره هم گمان کنم که باید خودمان دست به کارشویم و فرم مورد نظررا درست کنیم.(سعی می کنم شما هم سعی بفرمایید) ولی نشدنی نیست. الآن درخاطر ندارم یک از دوستان (شاید اقای دستگردی بود) که روی ویندوز تسلط بیشتری داشت نمونه هایی ر ا در این موارد حل کرده بود. لذا مجددا ا ز شما و خوانندگان تاپیک پوزش و غیره.

[RESMAILY]

به نام خدا
با سلام. برای آن چیزی که شما می خواهید ابزاری در vb وجود دارد که ظاهرا در vba وجود ندارد. اما یکی از راههایی که می شود به هدف مورد نظرتان برسید استفاده از treeview است. (راههای دیگری هم به احتمال زیاد هست) نمونه پیوست را نگاهی بکنید. می توانید آن را بصورتی دلخواه توسعه بدهید و تکمه و برچسب و غیره را اضافه بفرمایید. موفق باشید

[hamid-nice]

سلام

چطور می شه آدرس فایلی را که در این پنجره انتخاب می کنیم در یک text box قرار داد یا به نوعی برگردوند چرا که ما از این مساله در کدها استفاده های زیادی
می کنیم
ضمنا چطور می شه یک دگمه در فرم در زیر پنجره قرار داد که نمایان بشه

اگه شما می تونی یک نمونه لطف کنید بذارید در غیر اینصورت فکر کنم بهتره روی نمونه ای که گذاشتم کار کنید یا راه حل دیگری ارایه دهید

با تشکر منتظر پاسختون هستم

[RESMAILY]

به نام خدا
با سلام. به نظرم کار ساده ای باشد. شما در رویداد "دبل کلیک" treeview الآن یک Msgbox را به عنوان پاسخ دریافت می کنید. آیا نمی شود یک تکست باک اضافه کرد و پاسخ "دبل کلیک" را انتقال اطلاعات "گره"(=Node) یا "زیر گره" مربوطه به داخل تکست باکس درنظر گرفت؟ سپس تکمه و غیره هم به هر شکل اضافه نمود؟
به هرحال در اولین فرصت من هم سعی می کنم این موارد را اضافه نمایم. شماهم کمک کنید.

[hamid-nice]

با سلام و تشکر

منتظر یک نمونه حرفه ای از شما هستم

اما در مورد فارسی سازی دو مورد مهم دیگر هست
1- وقتی از فیلد های Attachment در فرم استفاده می کنیم و روی آن دبل کلیک میکنیم تا فایل ها را اضافه یا کم کنیم یک پنجره باز می شود که تماما انگلیسی است

2- همچنین وقتی از فیلد های textbox که رویداد Allow value List edit آن را yes می کنیم در هنگام وارد کردن متنی یک امکان ویرایش متن های لیست آن را می دهد که این پنجره هم کاملا انگلیسی است

آیا راهی برای فارسی کردن اینها سراغ دارید؟

با تشکر فراوان

[hamid-nice]

سلام
سوال در مورد استفاده از تابع تبدیل تاریخ میلادی به شمسی که در پست 1# ارایه شده است
( البته من از ماژول اصلاح شده جناب آزادي توسط احمد ميرزازاده به تاريخ 1388/7/22 استفاده کردم که سال را 4 رقمی می اندازه )

1- می خوام در فرمی که یک فیلد تاریخ دارم کاربر وقتی می خواد تاریخ را وارد کنه input mask به صورت 01/01/1392 باشه ولی وقتی وارد کرد اتوماتیک به صورت
1392/01/01 نمایش بده کجا ها و چه تنظیماتی باید انجام بدم ؟

در صورتی که ما طبق گفته کاربرد این تابع فیلدهای تاریخ را number تعریف کرده ا یم

من هر کار کردم نتونستم راهی پیدا کنم و در هر دو حالت ورود و نمایش به 1392/01/01 میشه

2- وقتی خاصیت validation rule را برای textbox تعریف می کنم و مقداری را در textbox آن وارد می کنم دیگه اجازه پاک کردن و خالی کردن اون را نمیده و پیغام error میده اشکال کارم کجاست یا اینکه این ماژول این مشکل را داره ؟ و استفاده از اون کلا مشکلی نداره ؟

خیلی ممنون میشم کسی راهکار یا نمونه ای ارایه کنه

با تشکر

[hamid-nice]

سلام به همه دوستان

کسی نیست که به این سوال هام پاسخ بده ؟

[mhkavian]

با سلام
کامل ترین نمونه تابع تبدیل عدد به حروف که امکان تبدیل اعداد در نمای علمی رو هم به حروف داره .
می تونید از آدرس زیر دریافت کنید .
http://mantis.ir/access-knowledge/access-articles/itemlist/category/82-function-access-articles.html

[majid_tiger]

به نام خدا
با سلام. اين هم نمونه. مي توانيد آن را توسعه هم بدهيد. من حداقل سه چهار تاپيك در خاطر دارم كه در اين باره گفتگويي شد. در تاپيك برنامه هاب كاربردي هم يكي دو نمونه وجود دارد. چند ساعتي وقت بگذاريد چيز هاي ديگري هم بدست مي ايد.

سلام ، من ویندوزم 7 / 64 بیتیه این ماژول در قسمت AddressOf خطای Type Mismatch میده باید چه تغییری در سورس بدم ؟

[Rasool-GH]

سلام
از این تاپیک هم کمک بگیرید . ماژول جناب ازادی با کمی تغییرات در مورد تاریخ 2012 هم مشکل نداره

http://barnamenevis.org/showthread.php?322266-%D9%85%D8%A7%DA%98%D9%88%D9%84-%DA%A9%D8%A7%D9%85%D9%84-%D8%AA%D8%A7%D8%B1%DB%8C%D8%AE-%D8%B4%D9%85%D8%B3%DB%8C-%D8%AF%D8%B1-%D8%A7%DA%A9%D8%B3%D8%B3-%D8%A8%D8%A7-VBA

[afshin3a]

سلام دوستان!
من یه دیتابیس توی اکسس دارم که اطلاعاتش با "میل مرج Mail merge" به ورود 2013 وارد میشه. مشکلم اینه که حرف "ی" فارسي رو نميشناسه و در Word 2013 اونو به صورت علامت ؟ می نویسه.
(عکس زیر را ببنید!)
.
.
.

129589
.
.
می دونم که با Replace کردن حرف "ي" عربی (با زدن Shift+X) با "ی" فارسی و تغيير تمام "ي" ها در دیتابیس مشکلم به صورت موقتی حل میشه ولی می خواستم بدونم که کسی راه حل اساسی برای حل این مشکل نداره؟ مثلا خاصیت یک فرم رو جوری تغییر بدیم که هر وقت من "ی" فارسی رو تایپ کردم اون به صورت اتوماتیک تبدیلش کنه به "ي" عربی. تو هیچ انجمنی نتونستم جوابی برای این سوال پیدا کنم، امیدوارم شما بتونید منو کمک کنید!

[dashali2]

جواب شما توی پست 49 همین تاپیکه :لبخندساده:

[daroghe20]

با سلام خدمت دوستان ..

سوال : در ارتباط با unstable بودن یا ثبات نداشتن فونت در فرم ها ست بخصوص Navigation form .

هر بار که فونتها رو در navigation فرم تغییر میدم بعد از close و open کردن مجدد برنامه فونتها عوض میشن و آن چیزی نیستند که من انتخاب کردم...!!

چرا؟؟راه کار دوستان برای stable ماندن فونتها چیست ؟؟ ممنون

[babak4401]

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

[ahmadfm2]

سلام دوستان
من میخواستم بدونم چطور می شه تاریخ رو به حروف نوشت البته محدودیت سال1399 را نداشته باشه خیلی ممنون میشم یکی جواب بده:تشویق:

[pcseven]

به روزرسانی ماژول تبدیل تاریخ شمسی (رفع مشکل 1400 و سال چهار رقمی)



Option Compare Database

Public Function Rooz(F_Date As Long) As Integer
'??? ???? ??? ????? ?? ??? ?? ????? ?? ??????????
Rooz = F_Date Mod 100
End Function
'*******************************************
Function mah(F_Date As Long) As Integer
'??? ???? ??? ????? ?? ??? ?? ????? ?? ??????????
mah = Int((F_Date Mod 10000) / 100)
End Function
'*******************************************
Public Function Sal(F_Date As Long) As Integer
'??? ???? ??? ????? ?? ??? ?? ????? ?? ??????????
Sal = Int(F_Date / 10000)
End Function
'*******************************************
Public Function Kabiseh(ByVal OnlySal As Variant) As Integer
'????? ???? ??? ?????? ???
'??? ???? ????? ???? ??? ?? ??????????
'??? ??? ????? ???? ??? ?? ? ????? ??????? ??? ?? ?? ????????
Kabiseh = 0
If OnlySal >= 1375 Then
If (OnlySal - 1375) Mod 4 = 0 Then
Kabiseh = 1
Exit Function
End If
ElseIf OnlySal <= 1370 Then
If (1370 - 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 Integer
' ??? ???? ?????? ?? ??? ????? ?? ?? ??? ????? ???? ???? ????? ?? ???
' ?? ???? ?????? False ???? ??????? ???? True ??? ????? ????? ????
ValidDate = True
S = Sal(F_Date)
m = mah(F_Date)
R = Rooz(F_Date)
'********
If F_Date < 13100101 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 Integer
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 = 13791012
Miladi_mabna = #1/1/2001#
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 Integer
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) & " " & 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 Integer) 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, 6))
End Function

Function MahDays(ByVal Sal As Integer, ByVal mah As Integer) As Integer
'??? ???? ????? ?????? ?? ??? ?? ???? ??????
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 = Mid(D, 1, 4) & "-" & Mid(D, 5, 2) & "-" & Mid(D, 7, 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 Integer

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

[neshomalea]

سلام و ارادت
ماژول MsgBoxFa مسیج باکس فارسی که در این تاپیک بود را باتوجه به اینکه روی ویندوزهای 64 بیتی عمل نمیکرد اصلاح کردم و در ویندوز 64 و 32 بیتی عمل خواهد کرد

Option Compare Database
'----------------------- MsgBoxFa -------------------------
'https://barnamenevis.org/showthread.php?51987-%D9%85%D8%B4%DA%A9%D9%84%D8%A7%D8%AA-%D9%81%D8%A7%D8%B1%D8%B3%DB%8C-%D9%88-%D8%B3%D9%88%D8%B1%D8%B3-%D9%87%D8%A7%DB%8C-%D9%85%D8%B1%D8%A8%D9%88%D8%B7%D9%87&p=1719291&viewfull=1#post1719291
'------------------- مسيج باکس فارسي ----------------------
' مناسب سازي شده براي ويندوز 64 و32 بيت '
' توسط محسن آل آقا اصلاح شده '
' 1400/06/29 '
' Hematalea@gmail '
' MsgBox براي استفاده از اين ماژول کافيست بجاي نوشتن تابع '
' .استفاده کنيد MsgBoxFa از تابع '
' '
' ------------------------------------------------------- '
' Integer را به عنوان MsgBox توجه: اگر در جايي که متغير '
' را حذف کنيد Integer ،تعريف کرده ايد '
' '
' :مثال '
' Dim OutPut As Integer <------------ خطا خواهد داد '
' OutPut = MsgBoxFa(".... '
' '
' Dim OutPut <--- بدون خطا اجرا خواهد شد '
' OutPut = MsgBoxFa(".... '
' '
'------------------------- Msgbox -------------------------
Public Const WH_CBT = 5
Public Const GWL_HINSTANCE = (-6)
Public Const HCBT_ACTIVATE = 5


#If VBA7 Then
Public Type MSGBOX_HOOK_PARAMS
hWndOwner As LongPtr
hHook As LongPtr
End Type


Public Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr
Public Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Public Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As LongPtr) As LongPtr
Public Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal lpString As String) As LongPtr
Public Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
Public Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
#Else
Public Type MSGBOX_HOOK_PARAMS
hWndOwner As Long
hHook As Long
End Type


Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public 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
Public Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Public 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
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
#End If


'need this declared at module level as
'it is used in the call and the hook proc
Public MSGHOOK As MSGBOX_HOOK_PARAMS
#If VBA7 Then
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Tiltle = "", Optional HelpFile, Optional Context) As LongPtr
'Wrapper function for the MessageBox API
Dim hwndThreadOwner As LongPtr
#Else
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Tiltle = "", Optional HelpFile, Optional Context) As Long
Dim hwndThreadOwner As Long
#End If

Dim frmCurrentForm As Form
'On Error Resume Next
Set frmCurrentForm = Screen.ActiveForm
hwndThreadOwner = frmCurrentForm.hwnd


#If VBA7 Then
Dim hInstance As LongPtr
Dim hThreadId As LongPtr
Dim hWndOwner As LongPtr
#Else
Dim hInstance As Long
Dim hThreadId As Long
Dim hWndOwner As Long
#End If
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
#If VBA7 Then
Public Function MsgBoxHookProc(ByVal uMsg As LongPtr, _
ByVal wParam As LongPtr, _
ByVal LParam As LongPtr) As LongPtr
#Else
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal LParam As Long) As Long
#End If
If uMsg = HCBT_ACTIVATE Then

SetDlgItemText wParam, vbYes, ChrW(1576) & ChrW(1604) & ChrW(1607) '"بله"
SetDlgItemText wParam, vbNo, ChrW(1582) & ChrW(1740) & ChrW(1585) ' "خير"
SetDlgItemText wParam, vbIgnore, ChrW(1604) & ChrW(1594) & ChrW(1608) ' "لغو"
SetDlgItemText wParam, vbOK, ChrW(1578) & ChrW(1571) & ChrW(1740) & ChrW(1740) & ChrW(1583) ' "تاييد"
SetDlgItemText wParam, vbCancel, ChrW(1575) & ChrW(1606) & ChrW(1589) & ChrW(1585) & ChrW(1575) & ChrW(1601) ' "انصراف"
SetDlgItemText wParam, vbAbort, ChrW(1606) & ChrW(1575) & ChrW(1578) & ChrW(1605) & ChrW(1575) & ChrW(1605) & _
" " & ChrW(1605) & ChrW(1575) & ChrW(1606) & ChrW(1583) & ChrW(1606) ' "ناتمام ماندن"
SetDlgItemText wParam, vbRetry, ChrW(1578) & ChrW(1604) & ChrW(1575) & ChrW(1588) & _
" " & ChrW(1583) & ChrW(1608) & ChrW(1576) & ChrW(1575) & ChrW(1585) & ChrW(1607) ' "تلاش دوباره"

UnhookWindowsHookEx MSGHOOK.hHook

End If

MsgBoxHookProc = False


End Function

[neshomalea]

..........