• سورس کدهای ویژوال بیسیک 6
    #1
    Note 
    سلام دوستان
    با اجازه مدیر انجمن تاپیک سورس کد های Visual basic 6 رو ایجاد میکنیم تاهر کی سورسی داره اینجا بذاره و تاپیک جامعی بشه و نظم بهتری هم داشته باشه
     لطفا در این تاپیک هیچ سوالی نپرسید! و فقط سورس بذارید
    .

    آخرین ویرایش: 13-10-2014 ساعت 22:26، توسط SOFTAFZAR
    #2
    Note 
    کد:
    Task: Find free disk space on a computer


    Declarations:

    کد php:
    Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As StringlpSectorsPerCluster As LonglpBytesPerSector As LonglpNumberOfFreeClusters As LonglpTtoalNumberOfClusters As Long) As Long

    Public Type DiskInformation
        lpSectorsPerCluster 
    As Long
        lpBytesPerSector 
    As Long
        lpNumberOfFreeClusters 
    As Long
        lpTotalNumberOfClusters 
    As Long
    End Type 


    Code:

    کد php:
    Dim info As DiskInformation
    Dim lAnswer 
    As Long
    Dim lpRootPathName 
    As String
    Dim lpSectorsPerCluster 
    As Long
    Dim lpBytesPerSector 
    As Long
    Dim lpNumberOfFreeClusters 
    As Long
    Dim lpTotalNumberOfClusters 
    As Long
    Dim lBytesPerCluster 
    As Long
    Dim lNumFreeBytes 
    As Double
    Dim sString 
    As String

    lpRootPathName 
    "c:\"
    lAnswer = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
    lBytesPerCluster = lpSectorsPerCluster * lpBytesPerSector
    lNumFreeBytes = lBytesPerCluster * lpNumberOfFreeClusters
    sString = "
    Number of Free Bytes " & lNumFreeBytes & vbCr & vbLf
    sString = sString & "
    Number of Free Kilobytes" & (lNumFreeBytes / 1024) & "K" & vbCr & vbLf
    sString = sString & "
    Number of Free Megabytes" & Format(((lNumFreeBytes / 1024) / 1024), "0.00") & "MB"

    MsgBox sString 

    #3
    Note 
    کد:
    Task: Determine when your visual basic application gains or loses focus.


    Declarations:
    کد php:
    Option Explicit

    Declare Function CallWindowProc Lib "user32" Alias _
      
    "CallWindowProcA" (ByVal lpPrevWndFunc As Long_
      ByVal hwnd 
    As LongByVal Msg As Long_
      ByVal wParam 
    As LongByVal lParam As Long) As Long

    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
      
    (ByVal hwnd As LongByVal nIndex As Long_
      ByVal dwNewLong 
    As Long) As Long

    Public Const WM_ACTIVATEAPP = &H1C
    Public Const GWL_WNDPROC = -4

    Global lpPrevWndProc As Long
    Global gHW As Long 

    Code:
    کد php:
    'Paste the following code into the code window for Form1:

    Sub Form_Load()
       '
    Store handle to this form's window
       gHW = Me.hWnd

       '
    Call procedure to begin capturing messages for this window
       Hook
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
       
    'Call procedure to stop intercepting the messages for this window
       Unhook
    End Sub

    '
    *********************************
    'Paste the following code into the main module:
    Public Sub Hook()
       '
    Establish a hook to capture messages to this window
       lpPrevWndProc 
    SetWindowLong(gHWGWL_WNDPROC_
         AddressOf WindowProc
    )
    End Sub

    Public Sub Unhook()
       
    Dim temp As Long

       
    'Reset the message handler for this window
       temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
    End Sub 

    #4
    Note 
    کد:
    Task: Make a form stay on top of all other forms.


    Declarations:
    کد php:
    Declare Function SetWindowPosLib "user32" (ByVal hwnd As LongByVal hWndInsertAfter As LongByVal x As LongByVal y As LongByVal cx As LongByVal cy As LongByVal wFlags As Long

    Code:
    کد php:
    'this code makes the window stay on top
    rtn = SetWindowPos(OnTop.hwnd, -2, 0, 0, 0, 0, 3)

    '
    window will not stay on top with this code
    rtn 
    SetWindowPos(OnTop.hwnd, -100003

    #5
    Note 
    کد:
    Task: Check for the existence of a file.

    Code:
    کد php:
    Public Function FileExists(strPath As String) As Integer

        FileExists 
    Not (Dir(strPath) = "")

    End Function 

    #6
    Note 
    کد:
    Task: Find and replace one string with another.

    Code:
    کد php:
    Function FindReplace(SourceStringSearchStringReplaceString)
            
    tmpString1 SourceString
            
    Do Until vFixed
                tmpString2 
    tmpString1
                tmpString1 
    ReplaceFirstInstance(tmpString1SearchString,ReplaceString)
                If 
    tmpString1 tmpString2 Then vFixed True
            Loop
            FindReplace 
    tmpString1
        End 
    Function

        Function 
    ReplaceFirstInstance(SourceStringSearchStringReplaceString)
            
    FoundLoc InStr(1SourceStringSearchString)
            If 
    FoundLoc <> 0 Then
                    ReplaceFirstInstance 
    Left(SourceStringFoundLoc 1) & _
                    ReplaceString 
    Right(SourceString_
                    Len
    (SourceString) - (FoundLoc 1) - Len(SearchString))
            Else
                
    ReplaceFirstInstance SourceString
            End 
    If
        
    End Function 

    #7
    Note 
    کد:
    Task: Creating a flashing form title bar.


    Declarations:
    کد php:
    Private Declare Function FlashWindow Lib "user32" (ByVal hWnd As LongByVal bInvert As Long) As Long 

    Code:
    کد php:
    Dim lngReturnValue As Long
        lngReturnValue 
    FlashWindow(Form1.hWndTrue

    #8
    Note 
    کد:
    Task: Determine if a computer is connected to the Internet


    Declarations:
    کد php:
    Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Anylpcb As LonglpcConnections As Long) As Long
    Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As LonglpStatus As Any) As Long
    '
    Public Const RAS95_MaxEntryName = 256
    Public Const RAS95_MaxDeviceType = 16
    Public Const RAS95_MaxDeviceName = 32
    '
    Public Type RASCONN95
        dwSize 
    As Long
        hRasCon 
    As Long
        szEntryName
    (RAS95_MaxEntryName) As Byte
        szDeviceType
    (RAS95_MaxDeviceType) As Byte
        szDeviceName
    (RAS95_MaxDeviceName) As Byte
    End Type
    '
    Public Type RASCONNSTATUS95
        dwSize As Long
        RasConnState As Long
        dwError As Long
        szDeviceType(RAS95_MaxDeviceType) As Byte
        szDeviceName(RAS95_MaxDeviceName) As Byte
    End Type 

    Code:
    کد php:
    'A call to the function IsConnected returns true if the computer has established a connection to the internet.

    Public Function IsConnected() As Boolean
    Dim TRasCon(255) As RASCONN95
    Dim lg As Long
    Dim lpcon As Long
    Dim RetVal As Long
    Dim Tstatus As RASCONNSTATUS95
    '
    TRasCon(0).dwSize 412
    lg 
    256 TRasCon(0).dwSize
    '
    RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
    If RetVal <> 0 Then
                        MsgBox "ERROR"
                        Exit Function
                        End If
    '
    Tstatus.dwSize 160
    RetVal 
    RasGetConnectStatus(TRasCon(0).hRasConTstatus)
    If 
    Tstatus.RasConnState = &H2000 Then
                             IsConnected 
    True
                             
    Else
                             
    IsConnected False
                             End 
    If

    End Function 

    #9
    Note 
    کد:
    Task: Change the Windows wallpaper.

    Declarations:
    کد php:
    Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As LongByVal uParam As LongByVal lpvParam As AnyByVal fuWinIni As Long) As Long

    Public Const SPI_SETDESKWALLPAPER 20 


    Code:
    کد php:
    Dim lngSuccess As Long
    Dim strBitmapImage 
    As String

    strBitmapImage 
    "c:\windows\straw.bmp"
    lngSuccess SystemParametersInfo(SPI_SETDESKWALLPAPER0strBitmapImage0

    #10
    Note 
    کد:
    Task: Get Windows directory using an API call.

    Declarations:
    کد php:
    Public Const MAX_PATH 260
    Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As StringByVal nSize As Long) As Long 

    Code:
    کد php:
    Dim strBuffer As String
    Dim lngReturn 
    As Long
    Dim strWindowsDirectory 
    As String

    strBuffer 
    Space$(MAX_PATH)
    lngReturn GetWindowsDirectory(strBufferMAX_PATH)
    strWindowsDirectory Left$(strBufferLen(strBuffer) - 1

    ایجاد موضوع جدید     موضوع بسته شده است 

    موضوعات مرتبط با این موضوع...
    موضوع نویسنده پاسخ بازدید آخرین ارسال
    Note دانلود نمونه سولات ویژوال بیسیک SOFTAFZAR 1 2,630 18-12-2015 ساعت 11:30
    آخرین ارسال: majidvajih
    Note ماشین حساب پیشرفته به زبان ویژوال بیسیک SOFTAFZAR 2 4,817 28-01-2015 ساعت 16:36
    آخرین ارسال: xMAN
    Note سوال سورس حذف ایمیل و نمایش آی پی و مک آدرس کامپیوتر moeinmq 1 1,370 24-01-2015 ساعت 18:30
    آخرین ارسال: xMAN
    Note سوال سورس برنامه افزایش ولتاژ قطعات موردنظر moeinmq 0 1,079 25-11-2014 ساعت 18:30
    آخرین ارسال: moeinmq
    Note space در ویژوال بیسیک 6 شهره 1 817 04-10-2014 ساعت 10:42
    آخرین ارسال: Comodo
    Note سورس قطع کردن اتصال به اینترنت با رفرش کردن moeinmq 3 1,181 14-08-2014 ساعت 20:23
    آخرین ارسال: vc3000
    Note ویژوال بیسیک amir7519 1 764 19-07-2014 ساعت 17:36
    آخرین ارسال: C0der
    Note باز و بستن برنامه ها با ویژوال بیسیک Somi 1 834 18-05-2014 ساعت 19:28
    آخرین ارسال: VBProgrammer
    Note سورس مقاسیه عدد Daniel 0 462 18-04-2014 ساعت 18:21
    آخرین ارسال: Daniel
    Note آدرس یاب رایگان + سورس amirali 7 2,135 10-04-2014 ساعت 08:45
    آخرین ارسال: AppDev

    کاربرانِ درحال بازدید از این موضوع:   1 مهمان