سورس کدهای ویژوال بیسیک 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,197 18-12-2015 ساعت 11:30
آخرین ارسال: majidvajih
Note ماشین حساب پیشرفته به زبان ویژوال بیسیک SOFTAFZAR 2 4,117 28-01-2015 ساعت 16:36
آخرین ارسال: xMAN
Note سوال سورس حذف ایمیل و نمایش آی پی و مک آدرس کامپیوتر moeinmq 1 811 24-01-2015 ساعت 18:30
آخرین ارسال: xMAN
Note سوال سورس برنامه افزایش ولتاژ قطعات موردنظر moeinmq 0 697 25-11-2014 ساعت 18:30
آخرین ارسال: moeinmq
Note space در ویژوال بیسیک 6 شهره 1 672 04-10-2014 ساعت 10:42
آخرین ارسال: Comodo
Note سورس قطع کردن اتصال به اینترنت با رفرش کردن moeinmq 3 957 14-08-2014 ساعت 20:23
آخرین ارسال: vc3000
Note ویژوال بیسیک amir7519 1 598 19-07-2014 ساعت 17:36
آخرین ارسال: C0der
Note باز و بستن برنامه ها با ویژوال بیسیک Somi 1 588 18-05-2014 ساعت 19:28
آخرین ارسال: VBProgrammer
Note سورس مقاسیه عدد Daniel 0 354 18-04-2014 ساعت 18:21
آخرین ارسال: Daniel
Note آدرس یاب رایگان + سورس amirali 7 1,742 10-04-2014 ساعت 08:45
آخرین ارسال: AppDev

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