آرشیو سورس های کاربردی و بدردبخور

اینکار خیلی آسونه. یک پروژه جدید باز کنید و تو فرمتون یک Command Button و یک TextBox بذارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید.

Private Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" (ByVal Dest As  String, ByVal AppName As String, ByVal CalledParty As String, ByVal Comment As  String) As Long 





Private Sub Command1_Click() 

     tapiRequestMakeCall Text1.Text, "", "", "" 

End Sub 

حالا برنامه رو اجرا کنید و تو TextBox شماره تلفن رو وارد کنید و کلید Command1 رو بزنید، میبینید که شماره گیری توسط خود ویندوز انجام میشه و احتیاجی نیست که شما کاری انجام بدید. موفق باشید.

پخش فایلهای MP3 از درون برنامه شما

یک پروژه جدید باز کنید و تو فرمتون یک TextBox و دو تا Command Button بزارید بعد از Command Button اول یک کپی بگیرید و Paste کنید تا آرایه ساخته بشه و بعد کد زیر رو تو قسمت جنرال فرمتون کپی کنید و برنامه رو اجرا کنید

 

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA"  (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal  uReturnLength As Long, ByVal hwndCallback As Long) As Long 





Dim  isPlaying As Boolean 

Dim Mp3File As String 





Private Sub  Command1_Click(Index As Integer) 

    Mp3File = Chr$(34) + Trim(Text1.Text) +  Chr$(34) 

    Select Case Index 

        Case 0 

             mciSendString "open " + Mp3File, 0&, 0&, 0& 

             mciSendString "play " + Mp3File, "", 0&, 0& 

            isPlaying =  True 

        Case 1 

            mciSendString "close " + Mp3File,  0&, 0&, 0& 

            isPlaying = False 

    End Select  

End Sub 





Private Sub Command2_Click() 

    Unload Me 

End  Sub 





Private Sub Form_Load() 

    Command1(0).Caption = "Start"  

    Command1(1).Caption = "Stop" 

    Command2.Caption = "Exit" 

End  Sub 





Private Sub Form_Unload(Cancel As Integer) 

    If isPlaying  = True Then 

        mciSendString "close " + Mp3File, 0&, 0&, 0&  

    End If 

End Sub 



حالا تو TextBox آدرس یک فایل MP3 رو وارد کنید و دکمه Start رو بزنید، موسیقی پخش  میشه، به همین سادگی. لازم به ذکره که این کد بارها و بارها تست شده و هیچ گونه  مشکلی نداره اگر کسی به مشکلی برخورد در قسمت نظرات مطرح کنه. سربلند باشید...

یک پروژه جدید باز کنید و توش یک Label بزارید و کدهای زیر رو تو قسمت جنرال فرمتون کپی کنید:

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA"  (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal  lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As  Long 





Private Sub Form_Load() 

    Label1.Caption =  "www.barnamenevis.org" 

End Sub 





Private Sub Label1_Click()  

    Link Label1.Caption 

End Sub 





Public Function Link(ByVal  URL As String) As Long 

    Link = ShellExecute(0&, vbNullString, URL,  vbNullString, vbNullString, vbNormalFocus) 

End Function 

حالا برنامتون رو اجرا كنيد و روي Label كليك كنيد تا وارد سايت مربروطه بشه، به همين سادگي. سربلند باشید.

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

شفاف سازی فرم:

این کار خیلی آسونه ، یک پروژه جدید باز کنید و تو قسمت جنرال فرمتون کدهای زیر رو کپی کنید.

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

Private Declare Function  SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal  nIndex As Long, ByVal dwNewLong As Long) As Long 

Private Declare Function  SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As  Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long 





Private  Sub Command1_Click() 

    Dim Retval As Long 

    Retval =  GetWindowLong(hWnd, -20) 

    Retval = Retval Or 524288 

    SetWindowLong  hWnd, -20, Retval 

    SetLayeredWindowAttributes hWnd, 0, Val(Text1.Text), 2  

End Sub 





Private Sub Form_Load() 

    Text1.Text = 100 

     Command1_Click 

End Sub 

تو TextBox یک عدد از 0 تا 255 وارد کنید و کلید Command1 رو بزنید و شاهد شفاف شدن فرم باشید. شما همیشه سربلندید ... مگر نه؟

برای اینکار دو روش وجود داره؛ روش اول اینه که برنامه رو در پوشه Startup کپی کنیم که روش جالبی نیست چون کاربر میتونه به اون پوشه به و فایل رو پاک کنه و امّا روش دوّم (قابل توجّه ویروس نویسا) اینه که برنامه رو تو لیست برنامه های Startup در رجیستری ذخیره کنیم که روش مطمئن و بهتریه چون کاربر نمیدونه برنامه کجا قرار داره و از کجا اجرا میشه مگر اینکه از طریق رجیستری و یا برنامه System Configuration Utility (تایپ msconfig در Run ویندوز) متوجه مسیر برنامه بشه که خب خوشبختانه همه اینکارو بلد نیستن.

به ترتیب روش اول و بعد روش دوّم رو آموزش میدم. برای اجرای برنامه در Startup از طریق روش اول باید درایوی رو که ویندوز اونجا نصب شده و بدونید که من این کارو با توابع API انجام دادم. یک پروژه جدید باز کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias  "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long  





Dim strSource As String, strDest As String 





Private Sub  Form_Load() 

    If App.PrevInstance = True Then End 

    strSource =  App.Path & IIf(Len(App.Path) > 0, "\", Empty) 

    strSource =  strSource & App.EXEName & ".exe" 

    strDest = WinDrive &  "Documents and Settings\All Users\Start Menu\Programs\Startup\" 

    FileCopy  strSource, strDest & App.EXEName & ".exe" 

End Sub  





Private Function WinDrive() As String 

    Dim strDrive As String  

    strDrive = Space(500) 

    A = GetWindowsDirectory(strDrive,  Len(strDrive)) 

    strDrive = Left(strDrive, 3) 

    WinDrive = strDrive  

End Function 

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

ولی روش دوّم، برای اینکار باید توابعی رو تعریف کنیم که با رجیستری سر و کار دارن و من این کارو برای راحتی شما انجام دادم. یک پروژه جدید باز کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA"  (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long  

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias  "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal  Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As  Long 

Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias  "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long  

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long)  As Long 

Private Declare Function RegOpenKey Lib "advapi32.dll" Alias  "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long)  As Long 

Private Const HKEY_LOCAL_MACHINE = &H80000002 

Private Const  REG_SZ = 1 





Dim strAppPath As String 





Private Sub  Command1_Click() 

    AddToRun App.Title, strAppPath 

End Sub  





Private Sub Command2_Click() 

    RemoveFromRun App.Title 

End  Sub 





Private Sub Form_Load() 

    Command1.Caption = "Add to Run"  

    Command2.Caption = "Remove from Run" 

    strAppPath =  IIf(Len(App.Path) > 3, App.Path & "\", App.Path) 

    strAppPath =  strAppPath & App.EXEName & ".exe" 

End Sub  





'--------------------------------------------- 





Private  Sub AddToRun(ProgramName As String, FileToRun As String) 

    Call  SaveString("Software\Microsoft\Windows\CurrentVers  ion\Run", ProgramName,  FileToRun) 

End Sub 





Private Sub RemoveFromRun(ProgramName As  String) 

    Call  DeleteValue("Software\Microsoft\Windows\CurrentVer  sion\Run", ProgramName)  

End Sub 





Private Sub SaveString(strPath As String, strValue As  String, strdata As String) 

    Dim keyhand As Long 

    Dim r As Long  

    r = RegCreateKey(HKEY_LOCAL_MACHINE, strPath, keyhand) 

    r =  RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata)) 

     r = RegCloseKey(keyhand) 

End Sub 





Private Function  DeleteValue(ByVal strPath As String, ByVal strValue As String) 

    Dim  keyhand As Long 

    Dim r As Long 

    r = RegOpenKey(HKEY_LOCAL_MACHINE,  strPath, keyhand) 

    r = RegDeleteValue(keyhand, strValue) 

    r =  RegCloseKey(keyhand) 

End Function 

اگه برنامه اجرا بشه، مسیر فایل اجرایی برنامه در رجیستری ذخیره شده و در هر بار اجرای برنامه همراه برنامه های دیگه اجرا میشه. به همین سادگی. با سربلندی.

با این کار پنجره برنامه شما از همه پنجره ها سربلند تر می شه!

Always on top این اصطلاحیه که به اون میگیم . درسته!
خوب خیلی آسونه...
یک پروزه جدید باز کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Const HWND_TOPMOST = -1 

Const HWND_NOTOPMOST = -2 

Const SWP_NOSIZE =  &H1 

Const SWP_NOMOVE = &H2 

Const SWP_NOACTIVATE = &H10  

Const SWP_SHOWWINDOW = &H40 

Private Declare Sub SetWindowPos Lib  "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long,  ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)  





Private Sub SetTopMost(frm As Form, ByVal blnMod As Boolean) 

     If blnMod Then 

        SetWindowPos frm.hWnd, HWND_TOPMOST, 0, 0, 0, 0,  SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE 

    Else 

         SetWindowPos frm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or  SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE 

    End If 

End Sub  





Private Sub Check1_Click() 

    Call SetTopMost(Me, Check1.Value)  

End Sub 

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

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

یک پروژه جدید باز کنید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long  

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)  



Private Sub Form_Load() 

    BlockInput True 

    Sleep 5000 

     BlockInput False 

End Sub 

به محض شروع برنامه، تمام وروردیها به مدّت 5 ثانیه قفل میشن و بعد از اون دوباره به حالت اول برمیگردن. در اینجا تابع Sleep فقط برای اتلاف وقت به کار رفته و استفاده دیگه ای نداره. سعی کنید با استفاده بجا و درست از این برنامه ، سربلندی خود را به همه اثبات کنید!

خوب اینم آسونه ...

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

یک پروژه جدید باز کنید و داخل فرمتون یک شئ Shape بذارید و کد زیر رو تو قسمت جنرال فرمتون کپی کنید :

Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA"  (ByVal hWnd As Long, ByVal nIndex As Long) As Long 

Private Declare Function  SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal  nIndex As Long, ByVal dwNewLong As Long) As Long 

Private Declare Function  SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As  Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long 





Const  LWA_COLORKEY = &H1 

Const GWL_EXSTYLE = (-20) 

Const WS_EX_LAYERED =  &H80000 

Const BM_SETSTATE = &HF3 





Private Sub Form_Load()  

    Dim Ret As Long 

    Dim CLR As Long 

    Me.BackColor = RGB(1, 1,  1)  ' تعیین رنگ پس زمینه فرم 

    CLR = Me.BackColor 

    Ret =  GetWindowLong(Me.hWnd, GWL_EXSTYLE) 

    Ret = Ret Or WS_EX_LAYERED 

     SetWindowLong Me.hWnd, GWL_EXSTYLE, Ret 

    SetLayeredWindowAttributes  Me.hWnd, CLR, 0, LWA_COLORKEY 

End Sub 

طرز کار : قسمتهای مشکی رنگ فرم رو حذف میکنه به همین سادگی حالا اگه بر حسب اتفاق شما مجبورید که از رنگ مشکی به عنوان پس زمینه فرمتون استفاده کنید باید در اون قسمتی که رنگ پس زمینه فرم تعیین میشه (به کد نگاه کنید) رنگ سفبد رو تعیین کنید یعنی Me.BackColor = RGB (255, 255, 255) به همین سادگی. در واقع این کد رنگی رو که شما تعیین میکنید رو از هر جای فرم حذف میکنه حتی اگه اون رنگ در وسط فرم باشه که در این صورت وسط فرم خالی میشه و هر چیزی که در پشت فرم قرار داره رو میشه از اون سوراخ دید. یک سربلندی دیگر.

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

با اين روش شما مي تونيد محتويات يك فايل رو به اندازه دلخواه (تعداد بايت) از يك سايت بخوانيد.
نمونه زير براي خواندن 1000 بايت اول ايندكس سايت مايكروسافت هست.

Const INTERNET_OPEN_TYPE_DIRECT = 1

Const INTERNET_OPEN_TYPE_PROXY = 3

Const INTERNET_FLAG_RELOAD = &H80000000

Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer

Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer

Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long



Private Sub Form_Load()

Dim hOpen As Long, hFile As Long, sBuffer As String, Ret As Long

sBuffer = Space(1000)

hOpen = InternetOpen("XxxxX.100110", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)

hFile = InternetOpenUrl(hOpen, "http://www.microsoft.com/index.htm", vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)

InternetReadFile hFile, sBuffer, 1000, Ret

InternetCloseHandle hFile

InternetCloseHandle hOpen

MsgBox sBuffer

End Sub

موفق باشيد/

نمايش پنجره Shutdown

Private Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal YourGuess As Long) As Long

Private Sub Form_Load()

SHShutDownDialog 0

End Sub

میخوام پنجره های برنامه ای که تو VB6.0 نوشتم تم ایکس پی یا ویستا به خودشون بگیرن!
صبر کنید...
محیط ویژوال بیسیك 6.0، محیط ویندوز 98 هست یعنی ذاتش ماله 98 و ویندوزهای قدیمیه،
و نمیشه تو اون از ابزار های ایکس پی به همین راحتی استفاده کرد مگر با ocx های آماده که اونا هم پاسخ گوی تمامی قطعات برنامتون نیستند. انتظاری جز این نمیشه ازش داشت. ولی یه سوال:
آیا چیز غیر ممکنی هم برای برنامه نویسی مثل شما وجود دارد؟

این کار نه با توابع API و نه با کد نویسی ، امکان پذیر نیست، ولی با یه ترفند ساده عملیه...


لطفا" مراحل زیر رو مو به مو انجام بدید!

برنامه Notepad ویندوز رو اجرا کنید و کد زیر رو تو اون کپی کنید...

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>

<assembly  xmlns="urn:schemas-microsoft-com:asm.v1"  manifestVersion="1.0">

<assemblyIdentity

    version="1.0.0.0"

    processorArchitecture="X86"

    name="PROJECT NAME"

     type="win32"

/>

<dependency>

    <dependentAssembly>

        <assemblyIdentity

            type="win32"

             name="Microsoft.Windows.Common-Controls"

            version="6.0.0.0"

             processorArchitecture="X86"

             publicKeyToken="6595b64144ccf1df"

            language="*"

        />

     </dependentAssembly>

</dependency>

</assembly>

به جای PROJECT NAME که با حروف درشت نوشته شده نام برنامتونو بنویسید و اون رو با نام project1.exe.MANIFEST
کنار فایلی اجرائی که می خواید درست کنید ،ذخیره کنید ( توضیح اینکه در این نام گذاری به جای project1 نام برنامه ویژوال بیسیکی که نوشتید رو بذارید)


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

اول پروژه برنامتون رو باز كنید (.vbp). حالا از منوی Project گزینه Components… رو انتخاب كنید و Microsoft Windows Common Control 5.0 رو علامت بزنید تا به پروژتون اضافه بشه. حالا یكی از كنترلهای اونو مثلاً StatusBar و یا كنترل ProgressBar رو به فرمی كه در اول اجرای برنامه نمایش داده میشه اضافه كنید. مثلاً اگر برنامه شما با Splash Screen شروع میشه باید یكی از این كنترلها رو درون فرمتون قرار بدید (Progress Bar بهتره) ولی اگه برناتون تنها یك فرم داره (فرم اصلی) باید یكی از این كنترلها رو به همون فرم اضافه كنید. توجه داشته باشید كه اینكار ضروریه. بعد از اینكار از برنامتون یك فایل اجرایی بگیرید و دوباره فایلش رو اجرا كنید.

سبز باشید...

خیلی ساده :

با استفاده از کد زير در فرم اصلي برنامه تان مي توانيد از اجراي مجدد (Duplicate) برنامه جلوگيري کنيد

Private Sub Form_Load() 

 If  App.PrevInstance = True Then 

 Dim Result As Integer 

 Result =  MsgBox("برنامه در حال اجراست", vbInformation, "Warnnig") 

 Unload Me 

 End  If 

 End Sub

تمام...

ابتدا بر روی فرم یک کادر تصویر قرار داده و مشخصه picture آن را مقدار دهی می کنیم .

Option Explicit 



Private Sub Form_Load() 

    Picture1.Visible = False 

End Sub 



Private Sub Form_Paint() 

    Dim wid As Single 

    Dim hgt As Single 

    Dim X As Single 

    Dim Y As Single 

        wid = Picture1.ScaleWidth 

        hgt = Picture1.ScaleHeight 

        Y = 0 

        Do While Y < ScaleHeight 

            X = 0 

            Do While X < ScaleWidth 

                PaintPicture Picture1.Picture, X, Y, wid, hgt 

                X = X + wid 

            Loop 

                Y = Y + hgt 

        Loop 

End Sub 

ممکنه شما بخواهید یه برنامه فاکتور برای شرکتتون بنویسید.در این صورت نیاز دارید تا جمع کل مبلغ فاکتورتون رو به صورت حروفی بنویسید:

برای مثال اگر شما مبلغ 120000 را وارد کردید برنامه برای شما چاپ کند :
صد و بیست هزار ریال.

يك پروژه جديد باز كنيد و دو TextBox و يك Module به برنامه اضافه كنيد و كد زير رو تو Module كپي كنيد :

Const strHezar = " هزار" 

Const strMilion = " ميليون" 

Const strMiliyard = " ميليارد" 

Const strTrilion = " تريليون" 

Const strTriliyard = " تريليارد" 

Const strBilion = " بيليون" 

Const strBiliyard = " بيليارد" 

Const va = " و " 



Public Function Horoof(ByVal strAdad As String) As String 

    strHoroofAshar = Array("", " دهم", " صدم", " هزام", " ده هزارم", " صد هزارم", " ميليونم", " ده ميليونم", " صد ميليونم", " ميلياردم", " ده ميلياردم", " صد ميلياردم", " تريليونم", " ده تريليونم", " صد تريليونم", " تريلياردم", " ده تريلياردم", " صد تريلياردم", " بيليونم", " ده بيليونم", " صد بيليونم", " بيلياردم", " ده بيلياردم", " صد بيلياردم") 

    intAshar = InStr(strAdad, ".") 

    intTedadAshar = Len(strAdad) – intAshar 

    Dim strAns As String, strLeft As String, strRight As String 

    If intAshar > 0 Then 

        strLeft = Tabdil(Left(strAdad, intAshar - 1)) 

        strRight = Tabdil(Right(strAdad, Len(strAdad) - intAshar)) 

        strAns = IIf(Val(Left(strAdad, intAshar - 1)) = 0, "", strLeft & " مميز ") & strRight 

        If intTedadAshar <22>= 4 Then 

        intS = Val(Right(strAadad, 3))  ' sadgan 

        intH = Val(Left(Right(strAadad, 6), Len(Right(strAadad, 6)) - 3))  ' hezargan 

    End If 

    If intLen >= 7 Then intM1 = Val(Left(Right(strAadad, 9), Len(Right(strAadad, 9)) - 6)) ' miliongan 

    If intLen >= 10 Then intM2 = Val(Left(Right(strAadad, 12), Len(Right(strAadad, 12)) - 9)) ' miliyardgan 

    If intLen >= 13 Then intT1 = Val(Left(Right(strAadad, 15), Len(Right(strAadad, 15)) - 12)) ' triliongan 

    If intLen >= 16 Then intT2 = Val(Left(Right(strAadad, 18), Len(Right(strAadad, 18)) - 15)) ' triliyardgan 

    If intLen >= 19 Then intB1 = Val(Left(Right(strAadad, 21), Len(Right(strAadad, 21)) - 18)) ' bilion 

    If intLen >= 22 Then intB2 = Val(Left(Right(strAadad, 24), Len(Right(strAadad, 24)) - 21)) ' biliyard 

    Select Case intLen 

        Case 1 To 3 'Sadgan 

            strHoroof = Tabdil_3Ragham(strAadad) 

        Case 4 To 6 ' Hezargn 

            strHoroof = Tabdil_3Ragham(intH) & strHezar & IIf(strAadad Mod 1000 = 0, "", va & (Tabdil_3Ragham(strAadad Mod 1000))) 

        Case 7 To 9 ' Miliongan 

            strHoroof = Tabdil_3Ragham(intM1) & strMilion & IIf(intH = 0, "", va & Tabdil_3Ragham(intH) & strHezar) & IIf(intS = 0, "", va & Tabdil_3Ragham(intS)) 

        Case 10 To 12 ' Miliyardgan 

            strHoroof = Tabdil_3Ragham(intM2) & strMiliyard & IIf(intM1 = 0, "", va & Tabdil_3Ragham(intM1) & strMilion) & IIf(intH = 0, "", va & Tabdil_3Ragham(intH) & strHezar) & IIf(intS = 0, "", va & Tabdil_3Ragham(intS)) 

        Case 13 To 15 '  Triliongan 

            strHoroof = Tabdil_3Ragham(intT1) & strTrilion & IIf(intM2 = 0, "", va & Tabdil_3Ragham(intM2) & strMiliyard) & IIf(intM1 = 0, "", va & Tabdil_3Ragham(intM1) & strMilion) & IIf(intH = 0, "", va & Tabdil_3Ragham(intH) & strHezar) & IIf(intS = 0, "", va & Tabdil_3Ragham(intS)) 

        Case 16 To 18 '  Triliyardgan 

            strHoroof = Tabdil_3Ragham(intT2) & strTriliyard & IIf(intT1 = 0, "", va & Tabdil_3Ragham(intT1) & strTrilion) & IIf(intM2 = 0, "", va & Tabdil_3Ragham(intM2) & strMiliyard) & IIf(intM1 = 0, "", va & Tabdil_3Ragham(intM1) & strMilion) & IIf(intH = 0, "", va & Tabdil_3Ragham(intH) & strHezar) & IIf(intS = 0, "", va & Tabdil_3Ragham(intS)) 

        Case 19 To 21 '  Bilion 

            strHoroof = Tabdil_3Ragham(intB1) & strBilion & IIf(intT2 = 0, "", va & Tabdil_3Ragham(intT2) & strTriliyard) & IIf(intT1 = 0, "", va & Tabdil_3Ragham(intT1) & strTrilion) & IIf(intM2 = 0, "", va & Tabdil_3Ragham(intM2) & strMiliyard) & IIf(intM1 = 0, "", va & Tabdil_3Ragham(intM1) & strMilion) & IIf(intH = 0, "", va & Tabdil_3Ragham(intH) & strHezar) & IIf(intS = 0, "", va & Tabdil_3Ragham(intS)) 

        Case 22 To 24 '  Biliyard 

            strHoroof = Tabdil_3Ragham(intB2) & strBiliyard & IIf(intB1 = 0, "", va & Tabdil_3Ragham(intB1) & strBilion) & IIf(intT2 = 0, "", va & Tabdil_3Ragham(intT2) & strTriliyard) & IIf(intT1 = 0, "", va & Tabdil_3Ragham(intT1) & strTrilion) & IIf(intM2 = 0, "", va & Tabdil_3Ragham(intM2) & strMiliyard) & IIf(intM1 = 0, "", va & Tabdil_3Ragham(intM1) & strMilion) & IIf(intH = 0, "", va & Tabdil_3Ragham(intH) & strHezar) & IIf(intS = 0, "", va & Tabdil_3Ragham(intS)) 

        Case Is > 24 

            strHoroof = "عدد بزرگتر از محدوده بيليارد است" 

    End Select 

    Tabdil = strHoroof 

End Function 



Private Function Tabdil_3Ragham(ByVal intAdad As Integer) As String 

    strYekan = Array("صفر", "يک", "دو", "سه", "چهار", "پنج", "شش", "هفت", "هشت", "نه", "ده", "يازده", "دوازده", "سيزده", "چهارده", "پانزده", "شانزده", "هفده", "هجده", "نوزده") 

    strDahgan = Array("", "ده", "بيست", "سي", "چهل", "پنجاه", "شصت", "هفتاد", "هشتاد", "نود") 

    strSadgan = Array("", "يکصد", "دويست", "سيصد", "چهارصد", "پانصد", "ششصد", "هفتصد", "هشتصد", "نهصد") 

    intY = intAdad Mod 10 

    intD = (intAdad Mod 100) \ 10 

    intS = intAdad \ 100 

    If intD <2> 0 And intD = 0 And intY = 0) Then strHoroof = strSadgan(intS) 

    Else 

        strHoroof = IIf(intS = 0, "", strSadgan(intS) & va) & strDahgan(intD) & IIf(intY = 0, "", va & strYekan(intY)) 

    End If 

    Tabdil_3Ragham = strHoroof 

End Function 

حالا كد زير رو تو قسمت جنرال فرمتون كپي كنيد :

Private Sub Text1_Change() 

    Text2.Text = Horoof(Text1.Text) 

End Sub 

حالا برنامه رو اجرا كنيد. سبز باشید.

سلام

آموزش ساخت برنامه هاي چند زبانه به همراه نمونه 4 زبانه

http://www.barnamenevis.org/sh...d.php?t=149590

نقل قول:

---

نوشته شده توسط Mbt925

OpenFolder

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

دانلود

---

اول باید از زحمتاتون تشکر کنم ولی کدی که من الان مینویسم خیلی ساده و کمه فقط باید از add refrence ,microsoft shell رو اضافه کنین.
dim x as new shell
x.open c:\

يه كد بدرد بخور براي كپي كردن فولدر كه جناب xxxxx.xxxxx زحمتش رو كشيدن، گفتم شايد بدردتون بخوره. ضميمه شد.

دو نمونه که یکی متن رو از جعبه متن، ماشین حساب ویندوز می خونه و نمایش میده و

دیگر متن دلخواه شما رو درش قرار میده

دانلود 1
دانلود 2

http://mbt925.googlepages.com/SetCalcTextScrShot.png

http://mbt925.googlepages.com/GetCalcTextScrShot.png

MBTextGrabber

دریافت متن از پنجره ها
متن برای جعبه متن ها و موجودیت های مشابه متنیه که درونشون نمایش داده میشه
و برای بقیه انواع پنجره ها می تونه عنوانشون یا موارد مشابه باشه.

http://mbt925.googlepages.com/TextGrabberScrShot.png

دانلود

Self Replacer

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

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

دانلود

اینم یه سورس نوار وضعیت از من. خیلی همه ساده است.

Move ScrollBar to end of object

این نمونه اسکرول بار همه اشیاء دارای هندل از قبیل TextBox، ListBox، RichTextBox و ...
رو به انتهای صفحه منتقل می کنه.

دانلود

Get CPU / Bios ID

2-3 تا سورس در این رابطه برای دوستانی که با جستجو مشکل دارن

دانلود

Private Sub Command1_Click()

   

    Dim oXL As Object        ' Excel application

    Dim oBook As Object      ' Excel workbook

    Dim oSheet As Object     ' Excel Worksheet

    Dim oChart As Object     ' Excel Chart

    

    Dim iRow As Integer      ' Index variable for the current Row

    Dim iCol As Integer      ' Index variable for the current Row

    

    Const cNumCols = 10      ' Number of points in each Series

    Const cNumRows = 2       ' Number of Series

    

    ReDim aTemp(1 To cNumRows, 1 To cNumCols)

    

    'Start Excel and create a new workbook

    Set oXL = CreateObject("Excel.application")

    Set oBook = oXL.Workbooks.Add

    Set oSheet = oBook.Worksheets.Item(1)

    

    ' Insert Random data into Cells for the two Series:

    Randomize Now()

    For iRow = 1 To cNumRows

       For iCol = 1 To cNumCols

          aTemp(iRow, iCol) = Int(Rnd * 50) + 1

       Next iCol

    Next iRow

    oSheet.Range("A1").Resize(cNumRows, cNumCols).Value = aTemp

    

    'Add a chart object to the first worksheet

    Set oChart = oSheet.ChartObjects.Add(50, 40, 300, 200).Chart

    oChart.SetSourceData Source:=oSheet.Range("A1").Resize(cNumRows, cNumCols)

    ' Make Excel Visible:

    oXL.Visible = True

    oXL.UserControl = True

        

End Sub

                    

این برنامه هم از سایت میکروسافت گرفتم برای نمایش چارت در برنامه excel

Get Folder Size

این نمونه، خیلی ساده حجم پوشه ها رو بدست میاره.

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

دانلود

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

سلام با تشكر از زحمات شما دوستان خوب موفق باشيد اين هم يك برنامه كامل با كد براي شما دوستان به[QUOTE] عنوان تشكر حتما ببينيد . رومنا

نقل قول:

---

hamedromana@yahoo.com

---

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



.:: به درویشی قناعت کن که بزرگی خطر دارد ::.

یه کد جالب از بستن فرم با تایمر

مثال از مدیدریت پرونده ها

اسکرین سرور با VB6

فرم تو خالی

پاک کردن فایلها در VB6

مثال مفید در مورد تغییر رنگ

سلام
برنامه مثلث خیام با استفاده از آرایه

حذف کلمات تکراری از فایل

خیلی از دوستان درخواست چنین نمونه ای رو داشتن.

http://mbt925.googlepages.com/Remove...ileScrshot.jpg

در این نمونه حذف فایل های تکراری به کمک یه جدول درهم سازی انجام میشه.
اگه تعداد کلمات فایل از اندازه جدول کمتر باشه، بهترین روش برای این کار، همین روشه که مرتبه زمانیش
(O(n هست (n : تعداد کلمات)

----
فرمولی که برای درهم سازی استفاده شده بسیار ساده و در عین حال از توزیع خوبی برخورداره.

دانلود

با سلام

یه سورس کد بدردبخور در رابطه با Windows :قهقهه::قهقهه::قهقهه:

یه سورس کد برای کار با Shell32

سلام دوستان :

اینم دو تا سورس کد در رابطه با API

اولیش اطلاعات BIOS رو بهتون میده
دومی هم اطلاعات Memory رو بهتون میده

موفق باشید.:لبخند:

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

اینم دو تا کتاب آموزشی

اولیش در مورد ADO هست و دومی هم درباره MultiMedia

سلام :

دو سورس کد بدردبخور

اولیش اطلاعات همه ی درایو ها رو به شما میده و امکان Print و Save هم داره :لبخند:
دومی هم یه FolderBrowser هست که خیلی بدردبخور هست :قهقهه:

HosSeiN 033 :تشویق::تشویق::تشویق:

بازم سلام یه سوال داشتم :

چرا دیگه کسی هیچ مطلبی آپ نمیکنه ؟؟؟:متفکر:

بازم این تایپک رو راه بندازید HosSeiN 033

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

اولی اطلاعاتی درباره Dispay رو به شما میده
دومی یه TextEfect هست

با عرض سلام مجدد :

اینم 4 تا ScreenSaver خیلی جالبه :لبخند::قهقهه::لبخند:

توصیه می کنم دانلود کنید :بامزه:

با سلام

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

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

این تابع افزودن قابلیت Stretch (کوچک و بزرگ کردن عکس برای جا گرفتن در کادر) برای PictureBox هست

[size=10]Sub picStrech()

    [color=#008000]'Picture1.Picture = Image1(1).Picture[/color]

    Picture1.ScaleMode = 3

    Picture1.AutoRedraw = True

    Picture1.PaintPicture Picture1.Picture, _

        0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _

        0, 0, _

        Picture1.Picture.Width / 26.46, _

        Picture1.Picture.Height / 26.46

    Picture1.Picture = Picture1.Image

End Sub[/size]