Printable View
نقل قول:
نوشته شده توسط ساران سافت
سلام دوست عزیز ساران سافت
با تشکر از کدهایی که ارائه نمودید
من وقتی ای کد ها را در ویبی paste می کنم چند خط قرمز به معنای خطا در نگارش کد بیسیک دیده می شود و سوالی که از محضر حضرتعالی دارم اینست که کد < که مکرر در این قطعه کد آمده است به چه معناست مثلا :
If N < 10 Then
ممنونم اگر پاسخ دهید.
[QUOTE=vbadvanced]تابع زیر برای تبدیل اعداد به حروف نوشته شده. میدونم دیگه داره تو این تاپیک یه کم زیاد میشه. اما میتونید با این یکی اعدا شمارشی هم داشته باشید که تو هیچکدوم از قبلیا ندیدم. (مثلا سوم، سی ام. چهل و پنجم و ...)!!
........
دوست عزیز سلام
من پس از پیست کردن کد خطا به شکل زیر می دهد:
tStr = tStr & _
ممنون
حالشو ببرید
برای تبدیل تاریخ میلادی به شمسی shamsi.ocx دارم هر کسی مایل بود با من تماس بگیره براش می فرستم
طرز کار:
کامپونت رو به vb6 معرفی کرده
روی فرم پیاده کنید
بعد مثلا Text1 خود را به تاریخ روز تبدیل کنید اینگونه:
Text1=shamsi1.m2s(8,date)
برای نمایش تاریخ هشت مدل دارد که من مدل هشتم را انتخاب کردم
موفق باشید
یا علی
[QUOTE=seyd1061]برای تبدیل تاریخ میلادی به شمسی shamsi.ocx دارم هر کسی مایل بود با من تماس بگیره براش می فرست
سلام سید
برای من لطف کنید بفرستید
ممنون
mohammad.daneshvar@gmail.com
یادم رفت بگم
به ایمیل نامه بزنید seyd1061@gmail.com
دوست عزیز seyd1061 اگر مایلید به دیگران کمک کنید فایل مورد اشاره رو همینجا آپلود کنید. ممنون از همکاریتون
سلامنقل قول:
نوشته شده توسط mhddns
کاراکتر های نام برده را با کاراکتر کوچکتر (>) تعویص کنید
مسعود جان این کد چطوری به کار ببریم
اگر می تونی جواب را برام به این آدرس بفرست
onlyvahid_m2006@yahoo.com متشکرم
منظورتون کدام کد هست؟نقل قول:
مسعود جان این کد چطوری به کار ببریم
از همتون ممنونم
موفق باشید
آیا می شه توی vb یه برنامه نوشت که همه ی unicode ها را چاپ کرد.؟؟؟؟؟؟؟؟؟؟؟؟
با تشکر
سلام
یه Dll می زارم که تاریخ جاری سیستم رو به تاریخ شمسی تبدیل می کنه.
برای ایجاد تاریخ شمسی در vbمی شه بیشتر توضیح بدید.
نحوه اجرای برنامه در 98 رو توضیح بدین.
سورس کد در ایکس پی نوشته شده است.
پیغام خطا : unicode.dll not found
مطالب عالیست ولی بعضی از کدها در HTML درست دیده نمیشوند.
با تشکر
سلام دوستان.
در ایکس پی بعد از نصب برنامه های که فارسی هستند و right to left در اونها استفاده شده می خواستم بدونم چطور میشه که کاربر تنظیمات مربوط به regional setting رو انجام نده. در واقع می خواستم با کد نویسی یا نصب فایلهایی که وظیفه انجام این کار را دارند (روش دوم بهتره) می تونیم این کار رو انجام بدیم یا نه. لطفا راهنماییم کنید. خیلی فوری
بابا یکی نیست جواب ما رو بده ؟؟
پستهای قبلی رو خیلی وقته که فرستادم. ولی هنوز جواب نگرفتم
--------------------------------------------------------------------------------
http://www.barnamenevis.org/sh...ad.php?t=37686
احساس کردم شاید این تاپیک که در قسمت access وجود داره بدرد خیلی از دوستان که با vb کار میکنن بخوره فایل ضمیمه رو از لینک دانلود کنین که شامل:
یک فانکشن که داخل محیط اکسس نوشته شده با add کردن اون به پروژه های vb هم میتونین ازش استفاده کنین تمام شرایط msgbox رو داره علاوه بر این که vbyes و vbno و همگی فارسی.
اینم کدش برا دوستانی که access برروی desktopشون نصب نیست .
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
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(hwndOwner, Prompt, Tiltle, Buttons)
End Function
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If uMsg = HCBT_ACTIVATE Then
SetDlgItemText wParam, vbYes, "Èáå"
SetDlgItemText wParam, vbNo, "뒄"
SetDlgItemText wParam, vbIgnore, "áÛæ"
SetDlgItemText wParam, vbOK, "ÊÇííÏ"
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
امیدوارم به درد بخوره
با سلام و تشکر از شما آقای sarami
باز هم مثل همیشه کارتون درسته
جناب meh_source منظورت اگه راست به چپ کردن پنجره اصلی نرم افزار هاست که باید عرض کنم این تغییرات به کمک Resource Hacker انجام میشه
با سلام خدمت آقای sarami
من برنامه را دیدم خیلی خیلی عالی بود . لطفاً اگر میشود در مورد Hook به من توضیح دهید البته چون من خیلی مبتدی هستم یه جوری بگید که من بفهمم . و دیگر اینکه برنامه یک مشکل دارد مشکل این است که Message Box حالت Modal ندارد چه طوری میتوان این مشکل را حل کرد ؟
با با تورو خدا جواب من را بدهید .
تابع adad نوشتن اعداد 15 رقمی به حروف فارسی نوشته اقای حمید ازادی
' *********** 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 ***********
تاریخ شمسی ایام هفته تبدیل تاریخ سیستم به شمسی و..........
در صورت استفاده از این ماجول ، فیلدهای از نوع تاریخ را باید از نوع 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.mojtabco.persianblog.com
ضمن تشکر از جناب آقای مسعود غیبی بخاطر سورس کد تبدیل عدد به حروف،
تبدیل تاریخ میلادی به شمسی و برعکس یک فرمول ساده است که می توان در کد برنامه نوشت فقط باید مراقب سال های کبیسه بود، فارسی کردن صفحه کلید و نصب فونت های فارسی در ویندوز اکس پی هم که با استفاده از ستینگ کنترل پنل ویندوز براحتی امکان پذیر است کافی است در اپشن تنظیمات زبان همه جا زبان را فارسی و کشور را ایران انتخاب کنید، فقط به همکاران گرامی توصیه می کنم اگر می خواهید محصول نرم افزاری خود را تکثیر کرده و بصورت سی دی ارائه نمایید فقط از فوت های Tahoma و Times New Romand استفاده کنید تا اپراتورهای غیر حرفه ائی با مشکلات مربوط به حروف گ پ چ ژ مواجه نشوند این دو فونت در صورتیکه حتی هیچگونه فارسی سازی روی ویندوز نصب نشده باشد تقریبا روی کلیه نگارش های اکس پی بخوبی عمل می کنند ، در مورد راست به چپ بودن فرم ها ، لیبل ها و ... که مشکلی نیست کافی است خاصیت Right to Left فرم، لیبل، کلید و ... را در حالت Ture تنظیم نماید خود به خود همه چیز حل می شود توصیه می کنم قبل از شورع طراحی و قراردادن ابجکت های مورد نیاز روی فرم، به محض ایجاد فرم Right to Left را Ture کنید. مشکل اساسی در ویندوز اکس پی سورت صحیح فارسی است هنگامی که یک لیست را سورت می کنید بدلیل کد حرف پ که مقدار درستی ندارد کلیه کلماتی که با پ شروع می شوند بجای اینکه بعد از ب و قبل از ت قرار گیرند در آخر لیست قرار می گیرند البته با نصب بعضی فارسی سازها این مشکل حل می شود ولی چطور می توان بدون استفاده از فارسی ساز و نوشتن کد اضافی در سورس برنامه ویندوز را طوری تنظیم کرد که حرف پ را در جای خود بشناسد.
دوست عزیز
شما می توانید با استفاده از یک فایل به نام kbdfa.dll که آرایش صحیح حروف فارسی را در خود جای داده این مشکل را حل کنید
گفتنی است این فایل در خود ویندوز موجود است اما شما باید نسخه تصحیح شده آن را استفاده نمایید
اگر به این فایل نیاز داشتید اعلام کنید تا برایتان بفرستم
سلام.
دوست عزیز VBHAMED اگر لطف کنید و نسخه اصلاح شده فایل مذکور را، در صورتیکه مشکل سورت صحیح فارسی در ویندوز اکس پی با استفاده از آن حل می شود، ارسال فرمائید. سپاسگزار شما خواهم بود.
E-Mail: m09123878011@Yahoo.com
سلام دوست عزیز
فایل مورد نظر را برایتان فرستادم
توجه نمایید که برای سورت صحیح فارسی اگر از ADO استفاده می کنید حتما باید از JET4.0 به بعد را به کار ببرید
و اگر از DAO استفاده می کنیدۀ خاصیت Connect آن باید روی ACCESS2000 باشد ولی اگر ACCESS2000 را در لیست نداشت می بایست Service Pack 5.0 را روی ویژوال بیسیک نصب نمایید
دوستان با سلام
2 تا مشکل دارم؛
اول اینکه من قابلیت فارسی سیستم عامل رو فعال کردم (ویندوز XP) ویژوال بیسیک هم کامل نصب شده اما وقتی فارسی تایپ می کنم بصورت ؟؟؟ نمایش داده میشه، اشکال از کجای کار هست؟
دوم اینکه من یه برنامه نوشتم حالا اگه بخام قابلیت XP Style رو بهش اضافه کنم چه کدی رو باید به برنامه اضافه کنم؟ (اون کد xml رو هم دارم ولی نمی دونم کاربردش چیه!)
اگه کسی بتونه کمک کنه واقعا ممون میشم....
برای مشکل فارسی به توصیه های نوشته شده در همین تاپیک عمل کنید.
سوال دومتون با اینکه ربطی به این تاپیک نداره ولی پاسخ میدم. در بخش جستجوی سایت عبارت manifest رو در بخش وی بی سرچ کنید. برای مثال در آدرس زیر به پاسخ سوالتون می رسید : http://www.barnamenevis.org/sh...light=manifest
دوستان سلام
با عرض پوزش از اساتید
یه کنترل تاریخ شمسی که خودم نوشتم براتون گذاشتم
تاریخ جاری سیستم رو به شمسی نشون میده ،البته خیلی ساده هستش اما درست کار میکنه امیدوارم به دردتون بخوره
طرز کار:
مثلا برای قرار دادن تاریخ شمسی درون یک textbox
Text1.text = Miracle1.Shamsi
Miracle اسم کنترل تاریخ هستش و برای سایر استفاده ها مثل database و غیره هم دقیقا مثل بالا عمل میشه.
موفق باشید
جواد جان مشکل فارسیت مال برنامه ویژوال بیسیکهنقل قول:
نوشته شده توسط Javad583
باید به روش زیر عمل کنی
ویژوال بیسیک رو اجرا می کنی=> از منوها Toolsرو انتخاب بعد Options رو میزنی
بعد از تب های بالا Editor Format رو انتخاب می کنی و تمام خطها رو به Courier New تبدیل می کنی بعد مشکلت حل میشه
در مورد مشکل دومت متاستفم و لی یک ocx هست که تمام اشکال xp رو داره
من می خواهم ارمنی تایپ کنم چه کنم پروژه دارم کمک کمک کمک کمک
با عرض سلام و خسته نباشیدنقل قول:
نوشته شده توسط بابک زواری
لطفا کد تایپ فارسی در ویندوز بدون تغییر زبان را برای من نیز بفرستید
زیرا بعضی از کدها دیده نمی شوند
لطفا به تازه واردین نیز نگاهی بیاندازید :چشمک:
asfar_nikoo@yahoo.com
جناب آقای غیبی سلام
ممنونم از راهنمایی و نمونه کدی که برای "تبدیل صفحه کلید به فارسی در VB " گذاشته‌اید. سوالی که من برام پیش اومده اینست که، وقتی وارد برنامه خود می‌شویم کیبورد فارسی میشود، حالا چطور میتوان کیبورد رو به حالت Default برگرداند؟؟؟
Fixer2006 عزیز تا اونجایی به یادم میاد اگر در کد مربوطه به جای مقدار 00000429 از 00000409 استفاده کنید، زبان مورد استفاده به انگلیسی تغییر پیدا کند.
سلام
من می خواستم بدونم چطور میشه treeview رو در VB6 right to left کرد
با تشکر
اول جستجو کنید بعد سوالتون رو مطرح کنید:نقل قول:
من می خواستم بدونم چطور میشه treeview رو در VB6 right to left کرد
http://www.barnamenevis.org/sh...ad.php?t=19193
من این دو تا کد رو تو یه ماژول کپی کردم درسته؟نقل قول:
نوشته شده توسط مسعود غیبی
اگه درسته ارور می ده ارورش هم از 429 هست مشکلش کجاست؟
نباید اروری بده
خوب مال من ارور می ده حالا چیکار کنم؟
دقیقا چه اروری می ده؟ شاید اینطوری بشه فهمید مشکل از کجاست
این ارور رو می ده
compile error:
invalid outside procedure
به طور مشخص نمیشه نظری داد ولی در گوگل سرچ کنید شاید به نتیجه ای مورد نظر برسید
http://www.google.com/search?sourcei...e+procedure%22
(البته در این شکی نیست که مشکل از کد تغییر زبان نیست)
خسته نباشی.
مرسی
من یک فارسی ساز بزای TextBox دارم ببینید :
Private Sub NameTxt_KeyPress(KeyAscii As Integer)
farsi = "آبپتثجچحخدذرزسشصضطظعغفقک لمنوهیئءؤ"
latin = "Hhf`je[]ponbvc\sawqxzuytr;'glk,idmM<"
For n = 1 To 36
If KeyAscii = Asc(Mid(latin, n)) Then
KeyAscii = Asc(Mid(farsi, n))
Exit For
End If
Next n
End Sub
سلام دوستان . من به یک مشکل خیلی مهم برخورد کردم . مشکلم اینه که داخل ListBox و Combobox نمی تونم فارسی بنویسم .البته با تکست باکس و لیبل ها مشکلی ندارم ولی مشکل اصلیم همین لیست باکسه . در ضمن از وینذوز ایکس پی هم استفاده می کنم و تو کل این تاپیک هم گشتم ولی متاسفانه چیزی پیدا نکردم . خیلی ممنون میشم جوابمو بدید چون واقعا" نیاز دارم ممنون .