صفحه 1 از 3 123 آخرآخر
نمایش نتایج 1 تا 40 از 88

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

  1. #1

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

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

    در صورت استفاده از این ماجول ، فیلدهای از نوع تاریخ را باید از نوع 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 : دوشنبه 13 شهریور 1385 در 07:28 صبح
    منی که نام شراب از کتاب می شستم
    زمانه کاتب دکان می فروشم کرد.

  2. #2
    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

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

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

  3. #3
    کاربر دائمی آواتار شاپرک
    تاریخ عضویت
    بهمن 1383
    محل زندگی
    ناکجاآباد
    پست
    1,157
    تابع تبدیل عدد به حروف
    نحوه استفاده از تابع :
    تابع 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/

  4. #4

    تاریخ شمسی برا Access Project

    دوستانی که با اکسس پروجکت کار میکنن این نکته رو فراموش نکنن که هیچ گاه برای استفاده از تاریخ به تاریخ سیستم سرویس گیرنده (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;&ar ing;"
    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;&aum l;"
    Case 2
    strMonth = "&Ccedil;&Ntilde;&Iuml;&iacute;&Egrave;&aring;&Oci rc;&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
    منی که نام شراب از کتاب می شستم
    زمانه کاتب دکان می فروشم کرد.

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

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

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

  8. #8

    تبدیل تاریخ

    تابع تبدیل سال میلادی به شمسی
    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

  9. #9
    تابع تبدیل عدد به حروف
    '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

  10. #10

    Function برای تبدیل تاریخ میلادی به شمسی

    یک فانکشن برای دوستانی که با اکسس پروجکت کار میکنن برای تبدیل تاریخ شمسی به میلادی که یکی از کاربران رو سایت گذاشته بودن رو در اینجا نیز کپی میکنم تا مورد استفاده دوسان قرار بگیره شاپرک عزیز قبلا چنین موردی رو خواسته بودن البته فکر میکنم....
    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
    منی که نام شراب از کتاب می شستم
    زمانه کاتب دکان می فروشم کرد.

  11. #11
    کاربر دائمی آواتار mohsenna30ri
    تاریخ عضویت
    تیر 1385
    محل زندگی
    اردکان
    پست
    302
    اگر تو کدنویسی یا اجرای نرم افزارهای فارسی بجای حروف فارسی علامت سوال می بینید :
    این راه حل بدردت می خوره
    https://barnamenevis.org/showthread.php?t=55431

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

    با تشکر

  13. #13
    کاربر دائمی آواتار شاپرک
    تاریخ عضویت
    بهمن 1383
    محل زندگی
    ناکجاآباد
    پست
    1,157
    برای پیدا کردن مثال بهتره از امکان جستجو ی این سایت استفاده کنی .
    بالای صفحه یک نوار آبی رنگ هست که یکی از منو ها جستجو است .

  14. #14
    نقل قول نوشته شده توسط mohsenna30ri مشاهده تاپیک
    اگر تو کدنویسی یا اجرای نرم افزارهای فارسی بجای حروف فارسی علامت سوال می بینید :
    این راه حل بدردت می خوره
    https://barnamenevis.org/showthread.php?t=55431
    لینک بالا دوست عزیز فعال نیست!

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

  16. #16
    کاربر دائمی آواتار mohsenna30ri
    تاریخ عضویت
    تیر 1385
    محل زندگی
    اردکان
    پست
    302

    Cool برنامه اجرای تاریخ هجری شمسی در اکسس ویندوز ایکس پی به بازار آمد

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

  17. #17
    کاربر جدید
    تاریخ عضویت
    خرداد 1386
    محل زندگی
    بیرجند
    پست
    4

    مرتب سازی بر اساس حروف الفبای فارسی

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

  18. #18
    کاربر دائمی آواتار mohsenna30ri
    تاریخ عضویت
    تیر 1385
    محل زندگی
    اردکان
    پست
    302

    Cool

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

  19. #19
    کاربر تازه وارد
    تاریخ عضویت
    مرداد 1386
    محل زندگی
    کرج
    پست
    49
    با سلام .
    اگه حمل بر پر رویی نیست ممکنه یه برنامه ساده که در اون از این ماژول تبدیل عدد به حرف استفاده شده برایم بفرستید تا بهتر بتونم ازش استفاده کنم .
    بی نهایت سپاسگزارم

  20. #20

    تشکر

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

  21. #21
    کاربر دائمی آواتار mohsenna30ri
    تاریخ عضویت
    تیر 1385
    محل زندگی
    اردکان
    پست
    302

    Smile

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

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


    نرم افزار جایگزین کردن فایلهای ویندوز :
    https://barnamenevis.org/attach...4&d=1195879522

  22. #22

    مبدل تاریخ شمسی به میلادی

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

  23. #23
    کاربر تازه وارد آواتار mahmoud.golzar
    تاریخ عضویت
    بهمن 1386
    محل زندگی
    تهران
    پست
    39

    سلام

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

  24. #24
    کاربر دائمی آواتار shaghaghi
    تاریخ عضویت
    اسفند 1386
    محل زندگی
    تهران
    پست
    250

    حدف نمایش فرم اکسس از Taskbar

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

  25. #25
    کاربر تازه وارد آواتار mahmoud.golzar
    تاریخ عضویت
    بهمن 1386
    محل زندگی
    تهران
    پست
    39
    نقل قول نوشته شده توسط shaghaghi مشاهده تاپیک
    از منوی Tools گزینه Options را انتخاب کرده در برگه View تیک چک باکس Windows In Taskbar را بردارید
    از راهنمایی تون ممنون ولی میخوام با vba این کار انجام بشه.

  26. #26
    کاربر دائمی آواتار shaghaghi
    تاریخ عضویت
    اسفند 1386
    محل زندگی
    تهران
    پست
    250
    نقل قول نوشته شده توسط mahmoud.golzar مشاهده تاپیک
    ولی میخوام با vba این کار انجام بشه.
    می بایستی فرم مورد نظر را به حالت dialog باز کنید با این فرمت:
    DoCmd.OpenForm "Form1", , , , , acDialog

  27. #27
    کاربر تازه وارد آواتار hamedMohammad
    تاریخ عضویت
    آبان 1386
    محل زندگی
    تهران
    پست
    53

    Smile نقل قول: مشکلات فارسی و سورس های مربوطه

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

  28. #28
    کاربر جدید آواتار yekabar
    تاریخ عضویت
    بهمن 1386
    محل زندگی
    محله اي خوش آب و هوا
    پست
    12

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

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

  29. #29

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

    با سلام

    دوستان عزيز مرا در اين مورد راهنمايي كنيد .
    سورس كدي دارم كه تاريخ هجري شمسي آقاي حميد آزاد مي باشد اما فكر ميكنم براي ورود تاريخ از سال 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


  30. #30

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

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

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

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

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

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

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


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

  31. #31

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

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


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

  32. #32
    کاربر دائمی آواتار smderfan
    تاریخ عضویت
    اسفند 1384
    محل زندگی
    OFFICE11\MSACCESS
    پست
    721

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

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

  33. #33

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

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

  34. #34

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

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

  35. #35
    کاربر دائمی آواتار mohsenna30ri
    تاریخ عضویت
    تیر 1385
    محل زندگی
    اردکان
    پست
    302

    Smile نقل قول: مشکلات فارسی و سورس های مربوطه

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

    فايل:
    https://barnamenevis.org/attach...7&d=1182584372

  36. #36

    Unhappy نقل قول: مشکلات فارسی و سورس های مربوطه

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

  37. #37

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

    نقل قول نوشته شده توسط sarami مشاهده تاپیک
    تابع تبدیل تاریخ :
    یه سوال
    توابعی که میشه با این ماژول استفاده کرد رو کسی جایی لیست شده و آماده داره؟

  38. #38

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

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

    فايل:
    https://barnamenevis.org/attach...7&d=1182584372
    این روش خوب جواب میده (حتی تو ویستا)
    ولی بعدش مشکلاتی رو بوجود میاره:
    موقع نصب Sqlserver و ِdreamweaver دائما ارور میداد که oleaut32 خراب شده حالا خدا میدونه کجاها به مشکل بر میخوره.

  39. #39
    کاربر تازه وارد
    تاریخ عضویت
    بهمن 1386
    محل زندگی
    اصفهان
    سن
    33
    پست
    96

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

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

  40. #40
    مدیر بخش آواتار amirzazadeh
    تاریخ عضویت
    مهر 1386
    محل زندگی
    تبريز
    پست
    1,947

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

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

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

    DON'T START;OTHERWISE DON'T STOP
    .................................................
    قوانين سايت

صفحه 1 از 3 123 آخرآخر

برچسب های این تاپیک

قوانین ایجاد تاپیک در تالار

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