سورس کدهای ویژوال بیسیک 6

بازدید177.7kپست ها136آخرین فعالیت10 سال پیش
0
Task: get GetKeyboardLayout language from a thread

Declarations:

Public Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Code:

Public Sub FindTheardlanguage  ()

Dim TheardId As Long
Dim TheardLang As Long

    TheardId = get_threadId 'call function
    TheardLang = GetKeyboardLayout(ByVal TheardId)
    TheardLang = TheardLang Mod 10000
    
  Select Case TheardLang 
   Case 9721 'english
    'do your stuff
    
   Case 1869 'hebrew
     'do your stuff
   
  End Select
    

End Sub



Public Function get_threadId() As Long
Dim threadid As Long, processid As Long

get_threadId = GetWindowThreadProcessId(winHWND, processid)

End Function
0
Changes the Title Bar on any window to whatever you like.

Delarations:

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Eric Morrison
'July 17, 2000
'Nova Scotia, Canada
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This will change the Title Bar on any window you click on
'after you click the Set TitleBar button
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Enter the following in Module (ClientToScreen uses this type)
'Type PointAPI
'   x as long
'   y as long
'End Type
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Form Items
'1 Text box
'Name=txtString
'
'2 Command Buttons
'Name=cmdSet
'Caption=Set TitleBar
'
'Name=cmdExit
'Caption=E&xit
'
'Extras
'On the Form set the ScaleMode Property to Pixel
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long

Private Declare Function SetCapture Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As PointAPI) As Long

Private Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Dim blnChoose As Boolean

Code:

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdSet_Click()
If txtString = "" Then 'Check see if txtString is empty
    MsgBox "Please enter a Title in text box"
    txtString.SetFocus
    Exit Sub
Else
'Capture the mouse and set blnChoose to True
    blnChoose = True
    intRetVal = SetCapture(hwnd)
End If
End Sub

Private Sub Form_Load()
    blnChoose = False 'Set blnChoose to False
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)

Dim ptPoint As PointAPI
Dim Window As Long

'Determines the screen location when mouse button was pressed
If blnChoose Then
    ptPoint.X = X
    ptPoint.Y = Y
    retVal = ClientToScreen(hwnd, ptPoint)
    
    Window = WindowFromPoint(ptPoint.X, ptPoint.Y)
    
    'Change the Windows Title Bar to the String user enters
    Call SetWindowText(Window, txtString)
End If
End Sub

Private Sub txtString_KeyPress(KeyAscii As Integer)
'Check if user hits the Enter key in txtString box
If KeyAscii = 13 Then
    cmdSet.SetFocus
End If
End Sub
0
Task: Use Function Join in VB6
'Type just a few chars in txtText,like "abc", and click the cmdJoin to see teh result.

Private Sub cmdJoin_Click()
    '
    Dim saTest(5) As String
    Dim sElement As String
    Dim I As Integer
    '
    '
    sElement = txtTest.Text
    '
    For I = 0 To 5
        saTest(I) = sElement
    Next I
    '
    txtTest.Text = Join(saTest, "%")    'each substring is devided by "%".
    '
End Sub
0
Detect DirectX Version

Declarations:

'Add this declarations in module
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long


'Add this is a module
Function GetDirectXVersion() As String
    Dim hndle As Long
    
    Dim resString As String
    Dim strVersion As String
    Dim str As String
    str = "SOFTWARE\Microsoft\DirectX"
    Dim resBinary() As Byte
      
    If RegOpenKeyEx(&H80000002, str, 0, &H20019, hndle) Then Exit Function
      
      
    ReDim resBinary(1023) As Byte
      
    Call RegQueryValueEx(hndle, "Version", 0, 0, resBinary(0), 1024)
      
    resString = Space$(1023)
    CopyMemory ByVal resString, resBinary(0), 1023
      
    RegCloseKey handle
      
    resString = Left(resString, 12)
      
    Select Case resString
        Case "4.02.0095"
            GetDirectXVersion = "1.0"
        Case "4.03.00.1096"
            GetDirectXVersion = "2.0"
        Case "4.04.0068", "4.04.0069"
            GetDirectXVersion = "3.0"
        Case "4.05.00.0155"
            GetDirectXVersion = "5.0"
        Case "4.05.01.1721", "4.05.01.1998"
            GetDirectXVersion = "5.0"
        Case "4.06.02.0436"
            GetDirectXVersion = "6.0"
        Case "4.07.00.0700"
            GetDirectXVersion = "7.0"
        Case "4.07.00.0716"
            GetDirectXVersion = "7.0a"
        Case "4.08.00.0400"
            GetDirectXVersion = "8.0"
        Case "4.08.01.0881", "4.08.01.0810"
            GetDirectXVersion = "8.1"
        Case "4.09.0000.0900"
            GetDirectXVersion = "9.0"
        Case "4.09.00.0900"
            GetDirectXVersion = "9.0"
        Case "4.09.0000.0901"
            GetDirectXVersion = "9.0a"
        Case "4.09.00.0901"
            GetDirectXVersion = "9.0a"
        Case "4.09.0000.0902"
            GetDirectXVersion = "9.0b"
        Case "4.09.00.0902"
            GetDirectXVersion = "9.0b"
        Case "4.09.00.0904"
            GetDirectXVersion = "9.0c"
        Case "4.09.0000.0904"
            GetDirectXVersion = "9.0c"
    End Select
  
End Function

Code:

'Add this to the form
Private Sub command1_Click()
    MsgBox GetDirectXVersion
End Sub
0

تاپیک بالا :winksmiley02:

Task: Sample to Use Dictionary Object in VB6
'From MSDN sample.
'You need to have reference to Microsoft Scripting Runtime first.
'Put a ListBox on your form to accept the result.
'The following code illustrates how to create a Dictionary object:
'
Dim a
Dim d
'
  Set d = CreateObject("Scripting.Dictionary")
  d.Add "a", "Athens"     'Add some keys and items
  d.Add "b", "Belgrade"
  d.Add "c", "Cairo"
  d.Add "d", "Detroit"
  d.Add "e", "Emory"
  d.Add "f", "Fairfax"
  '
  a = d.Items             'Get the items
  '
  For I = 0 To d.Count - 1 'Iterate the array
        List1.AddItem a(I)
    Next
    '
0

با سلام

اگه میشه سورس Find و Replace رو برای یک برنامه مثل نوت پد ویندوز رو قرار بدید

با تشکر

0
<br> > با سلام اگه میشه سورس Find و Replace رو برای یک برنامه مثل نوت پد ویندوز رو قرار بدید با تشکر <br> سلام این تاپیک برای سوال پرسیدن نیست

بفرمایید
[url]http://www.softafzar.net/f18/%D9%BE%D8%B1%D9%88%DA%98%D9%87-find-amp%3B-replace-%D8%A8%D9%87-%D8%B2%D8%A8%D8%A7%D9%86-%D9%88%DB%8C%DA%98%D9%88%D8%A7%D9%84-%D8%A8%DB%8C%D8%B3%DB%8C%DA%A9-551/#post1122[/url]

[url]http://www.softafzar.net/f18/%D8%B3%D9%88%D8%B1%D8%B3-%DA%A9%D8%AF%D9%87%D8%A7%DB%8C-%D9%88%DB%8C%DA%98%D9%88%D8%A7%D9%84-%D8%A8%DB%8C%D8%B3%DB%8C%DA%A9-6-a-143/#post256[/url]

موفق... :happysmiley:

0

Task: Use FileSystemObject to Get Info about a Drive

'You need to have reference to Microsoft Scripting Runtime first.
'Put a ListBox on your form and run the code.
'FileSystecmObject is very powerful in dealing with file system. 
'See VB help for more detailed info.
Private Sub cmdInfo_Click()
    '
    Dim fldr As Folder
    Dim fso As New FileSystemObject
    Dim drv As Drive
    '
    Set drv = fso.GetDrive(fso.GetDriveName("C:"))
    '
    With List1
        .AddItem "Available space: " & FormatNumber(drv.AvailableSpace / 1024, 0) & " BK"
        .AddItem "Drive letter: " & drv.DriveLetter
        .AddItem "Drive type: " & drv.DriveType
        .AddItem "Drive file system: " & drv.FileSystem
        .AddItem "Drive free space: " & FormatNumber(drv.FreeSpace / 1024, 0) & " BK"
        .AddItem "Drive is ready: " & drv.IsReady
        .AddItem "Drive path: " & drv.Path
        .AddItem "Root folder: " & drv.RootFolder
        .AddItem "Serial number: " & drv.SerialNumber
        .AddItem "Share name: " & drv.ShareName
        .AddItem "Total size: " & FormatNumber(drv.TotalSize / 1024, 0) & " BK"
        .AddItem "Volume  name : " & drv.VolumeName
    End With
    '
End Sub
0

Task: Removes duplicate spaces within strings.

Public Function SquishSpaces( ByVal strText As String ) As String

    Const TWO_SPACES As String = "  "
   
    Dim intPos As Integer
    Dim strTemp As String
   
    intPos = InStr(1, strText, TWO_SPACES, vbBinaryCompare)
    Do While intPos > 0
        strTemp = LTrim$(Mid$(strText, intPos + 1))
        strText = Left$(strText, intPos) & strTemp
        intPos = InStr(1, strText, TWO_SPACES, vbBinaryCompare)
    Loop
   
   SquishSpaces = strText   

End Function
0
Option Explicit

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Const RNG_DIFF = 4

Private Sub Form_Resize()
  Dim Outer_rng As Long
  Dim Inner_rng As Long
  Dim Combined_rng As Long
  Dim Wid As Single
  Dim Hgt As Single
  Dim Border_width As Single
  Dim Title_height As Single
  
  If WindowState = vbMinimized Then Exit Sub
  
  
  Wid = ScaleX(Width, vbTwips, vbPixels)
  Hgt = ScaleY(Height, vbTwips, vbPixels)
  Outer_rng = CreateRectRgn(0, 0, Wid, Hgt)

  Border_width = (Wid - ScaleWidth) / 2
  Title_height = (Hgt - Border_width - ScaleHeight)
  Inner_rng = CreateRectRgn(Wid * 0.25, Hgt * 0.25, Wid * 0.75, Hgt * 0.75)
  
  Combined_rng = CreateRectRgn(0, 0, 0, 0)
  CombineRgn Combined_rng, Outer_rng, Inner_rng, RNG_DIFF
  
  SetWindowRgn hWnd, Combined_rng, True
  
  DeleteObject Combined_rng
  DeleteObject Inner_rng
  DeleteObject Outer_rng
  
  
End Sub
0

Task: Obtaining Information Of A File

Declarations:

Option Explicit

' Name:     Obtaining Information Of A File
' Author:   Chong Long Choo
' Email: chonglongchoo@hotmail.com
' Date:     09 September 1999

'<--------------------------Disclaimer------------------------------->
'
'This sample is free. You can use the sample in any form. Use this
'sample at your own risk! I have no warranty for this sample.
'
'<--------------------------Disclaimer------------------------------->

'---------------------------------------------------------------------------------
'How to use
'---------------------------------------------------------------------------------
'    Dim lngDBQ as Long
'    Dim objFileProp As clsFileProp
'    Set objFileProp = New clsFileProp
'    With objFileProp
'        lngDBQ = .FindFileInfo("c:\autoexec.bat")
'        If lngDBQ = 1 Then
'            Debug.Print .FileName
'            Debug.Print Format(.mByte, "#,###,###") & " Bait"
'            Debug.Print .CreationTime
'            Debug.Print .LastAccessTime
'            Debug.Print .LastWriteTime
'            Debug.Print .ReadOnly
'            Debug.Print .Hidden
'            Debug.Print .Archive
'        End If
'    End With

Private Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Private Declare Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal dwHandle As Long, ByVal dwLen As Long, lpData As Any) As Long
Private Declare Function VerLanguageName Lib "kernel32" Alias "VerLanguageNameA" (ByVal wLang As Long, ByVal szLang As String, ByVal nSize As Long) As Long
Private Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" (pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Long, puLen As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800

Private Type FILETIME
   LowDateTime          As Long
   HighDateTime         As Long
End Type

Private Type WIN32_FIND_DATA
   dwFileAttributes     As Long
   ftCreationTime       As FILETIME
   ftLastAccessTime     As FILETIME
   ftLastWriteTime      As FILETIME
   nFileSizeHigh        As Long
   nFileSizeLow         As Long
   dwReserved0          As Long
   dwReserved1          As Long
   cFileName            As String * 260  'MUST be set to 260
   cAlternate           As String * 14
End Type

Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type


Private mvarCompanyName As String
Private mvarFileDescription As String
Private mvarFileVersion As String
Private mvarInternalName As String
Private mvarLegalCopyright As String
Private mvarOriginalFileName As String
Private mvarProductName As String
Private mvarProductVersion As String
Private mvarFileName As String
Private mvarByte As String
Private mvarCreationTime As String
Private mvarLastAccessTime As String
Private mvarLastWriteTime As String
Private mvarReadOnly As Boolean
Private mvarHidden As Boolean
Private mvarSystem As Boolean
Private mvarDirectory As Boolean
Private mvarArchive As Boolean
Private mvarNormal As Boolean
Private mvarTemporary As Boolean
Private mvarCompress As Boolean

Code:

Public Property Get Compress() As Boolean
    Compress = mvarCompress
End Property

Public Property Get Temporary() As Boolean
    Temporary = mvarTemporary
End Property

Public Property Get Normal() As Boolean
    Normal = mvarNormal
End Property

Public Property Get Archive() As Boolean
    Archive = mvarArchive
End Property

Public Property Get Directory() As Boolean
    Directory = mvarDirectory
End Property

Public Property Get System() As Boolean
    System = mvarSystem
End Property

Public Property Get Hidden() As Boolean
    Hidden = mvarHidden
End Property

Public Property Get ReadOnly() As Boolean
    ReadOnly = mvarReadOnly
End Property

Public Property Get LastWriteTime() As String
    LastWriteTime = mvarLastWriteTime
End Property

Public Property Get LastAccessTime() As String
    LastAccessTime = mvarLastAccessTime
End Property

Public Property Get CreationTime() As String
    CreationTime = mvarCreationTime
End Property

Public Property Get mByte() As String
    mByte = mvarByte
End Property

Public Property Get ProductVersion() As String
    ProductVersion = mvarProductVersion
End Property

Public Property Get ProductName() As String
    ProductName = mvarProductName
End Property

Public Property Get OriginalFileName() As String
    OriginalFileName = mvarOriginalFileName
End Property

Public Property Get LegalCopyright() As String
    LegalCopyright = mvarLegalCopyright
End Property

Public Property Get InternalName() As String
    InternalName = mvarInternalName
End Property

Public Property Get FileVersion() As String
    FileVersion = mvarFileVersion
End Property

Public Property Get FileDescription() As String
    FileDescription = mvarFileDescription
End Property

Public Property Get CompanyName() As String
    CompanyName = mvarCompanyName
End Property

Public Property Get FileName() As String
    FileName = mvarFileName
End Property

Public Function FindFileInfo(strFileName As String) As Long
    On Error GoTo GetFileVersionData_Error

    Dim sInfo As String, lSizeof As Long
    Dim lResult As Long, iDelim As Integer, n As Integer, lHandle As Long
    Dim ftime As SYSTEMTIME
    Dim filedata As WIN32_FIND_DATA
    
    If strFileName <> "" Then
        filedata = Findfile(strFileName)
        Call FileTimeToSystemTime(filedata.ftCreationTime, ftime)
        mvarCreationTime = ftime.wDay & "/" & ftime.wMonth & "/" & ftime.wYear & " " & ftime.wHour & ":" & ftime.wMinute & ":" & ftime.wSecond
        Call FileTimeToSystemTime(filedata.ftLastWriteTime, ftime)  ' Determine Last Modified date and time
        mvarLastWriteTime = ftime.wDay & "/" & ftime.wMonth & "/" & ftime.wYear & " " & ftime.wHour & ":" & ftime.wMinute & ":" & ftime.wSecond
        Call FileTimeToSystemTime(filedata.ftLastAccessTime, ftime) ' Determine Last accessed date (note no time is recorded)
        mvarLastAccessTime = ftime.wDay & "/" & ftime.wMonth & "/" & ftime.wYear
        mvarHidden = ((filedata.dwFileAttributes And FILE_ATTRIBUTE_HIDDEN) = FILE_ATTRIBUTE_HIDDEN)
        mvarSystem = ((filedata.dwFileAttributes And FILE_ATTRIBUTE_SYSTEM) = FILE_ATTRIBUTE_SYSTEM)
        mvarReadOnly = ((filedata.dwFileAttributes And FILE_ATTRIBUTE_READONLY) = FILE_ATTRIBUTE_READONLY)
        mvarArchive = ((filedata.dwFileAttributes And FILE_ATTRIBUTE_ARCHIVE) = FILE_ATTRIBUTE_ARCHIVE)
        mvarTemporary = ((filedata.dwFileAttributes And FILE_ATTRIBUTE_TEMPORARY) = FILE_ATTRIBUTE_TEMPORARY)
        mvarNormal = ((filedata.dwFileAttributes And FILE_ATTRIBUTE_NORMAL) = FILE_ATTRIBUTE_NORMAL)
        mvarCompress = ((filedata.dwFileAttributes And FILE_ATTRIBUTE_COMPRESSED) = FILE_ATTRIBUTE_COMPRESSED)
        mvarFileName = UCase$(strFileName)
        If filedata.nFileSizeHigh = 0 Then    ' Put size into text box
            mvarByte = Format$(filedata.nFileSizeLow, "###,###,###") & " bytes"
        Else
            mvarByte = Format$(filedata.nFileSizeHigh, "###,###,###") & " bytes"
        End If
        lHandle = 0
        lSizeof = GetFileVersionInfoSize(strFileName, lHandle)
        If lSizeof > 0 Then
            
            sInfo = String$(lSizeof, 0)
            lResult = GetFileVersionInfo(ByVal strFileName, 0&, ByVal lSizeof, ByVal sInfo)
            If lResult Then
                iDelim = InStr(sInfo, "CompanyName")
                If iDelim > 0 Then
                    iDelim = iDelim + 12
                    mvarCompanyName = Mid$(sInfo, iDelim)
                End If
                
                iDelim = InStr(sInfo, "FileDescription")
                If iDelim > 0 Then
                    iDelim = iDelim + 16
                    mvarFileDescription = Mid$(sInfo, iDelim)
                End If
                
                iDelim = InStr(sInfo, "FileVersion")
                If iDelim > 0 Then
                    iDelim = iDelim + 12
                    mvarFileVersion = Mid$(sInfo, iDelim)
                End If
                
                iDelim = InStr(sInfo, "InternalName")
                If iDelim > 0 Then
                    iDelim = iDelim + 16
                    mvarInternalName = Mid$(sInfo, iDelim)
                End If
                
                iDelim = InStr(sInfo, "LegalCopyright")
                If iDelim > 0 Then
                    iDelim = iDelim + 16
                    mvarLegalCopyright = Mid$(sInfo, iDelim)
                End If
                
                iDelim = InStr(sInfo, "OriginalFilename")
                If iDelim > 0 Then
                    iDelim = iDelim + 20
                    mvarOriginalFileName = Mid$(sInfo, iDelim)
                End If

                iDelim = InStr(sInfo, "ProductName")
                If iDelim > 0 Then
                    iDelim = iDelim + 12
                    mvarProductName = Mid$(sInfo, iDelim)
                End If

                iDelim = InStr(sInfo, "ProductVersion")
                If iDelim > 0 Then
                    iDelim = iDelim + 16
                    mvarProductVersion = Mid$(sInfo, iDelim)
                End If
                FindFileInfo = 1
            Else
                GoTo invalid_file_info_error
            End If
        Else
            GoTo invalid_file_info_error
        End If
    Else
        FindFileInfo = 0
    End If
    
GetFileVersionData_Exit:
    Exit Function
    
GetFileVersionData_Error:
    FindFileInfo = 0
    Resume GetFileVersionData_Exit
    
invalid_file_info_error:
    FindFileInfo = 1
    GoTo GetFileVersionData_Exit
End Function

Private Function Findfile(xstrfilename) As WIN32_FIND_DATA
    Dim Win32Data As WIN32_FIND_DATA
    Dim plngFirstFileHwnd As Long
    Dim plngRtn As Long
    plngFirstFileHwnd = FindFirstFile(xstrfilename, Win32Data)  ' Get information of file using API call
    If plngFirstFileHwnd = 0 Then
        Findfile.cFileName = "Error"                              ' If file was not found, return error as name
    Else
        Findfile = Win32Data                                      ' Else return results
    End If
    plngRtn = FindClose(plngFirstFileHwnd)                      ' It is important that you close the handle for FindFirstFile
End Function
0

Task: List All Active Processes (Class)

Declaration:

Option Explicit

' Name:     List All Active Processes
' Author:   Chong Long Choo
' Email: chonglongchoo@hotmail.com
' Date:     09 September 1999

'<--------------------------Disclaimer------------------------------->
'
'This sample is free. You can use the sample in any form. Use this
'sample at your own risk! I have no warranty for this sample.
'
'<--------------------------Disclaimer------------------------------->

'---------------------------------------------------------------------------------
'How to use
'---------------------------------------------------------------------------------
'    Dim i As Integer
'    Dim objItem As ListItem
'    Dim NumOfProcess As Long
'    Dim objActiveProcess As SQLSysInfo.clsActiveProcess
'    Set objActiveProcess = New SQLSysInfo.clsActiveProcess
'    NumOfProcess = objActiveProcess.GetActiveProcess
'    For i = 1 To NumOfProcess
'        Set objItem = ListView2.ListItems.Add(, , objActiveProcess.szExeFile(i))
'        With objItem
'            .SubItems(1) = objActiveProcess.th32ProcessID(i)
'            .SubItems(2) = objActiveProcess.th32DefaultHeapID(i)
'            .SubItems(3) = objActiveProcess.thModuleID(i)
'            .SubItems(4) = objActiveProcess.cntThreads(i)
'            .SubItems(5) = objActiveProcess.th32ParentProcessID(i)
'        End With
'    Next
'    Set objActiveProcess = Nothing

Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Integer = 260

Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type

Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)

Dim ListOfActiveProcess() As PROCESSENTRY32

Code:

Public Function szExeFile(ByVal Index As Long) As String
    szExeFile = ListOfActiveProcess(Index).szExeFile
End Function

Public Function dwFlags(ByVal Index As Long) As Long
    dwFlags = ListOfActiveProcess(Index).dwFlags
End Function

Public Function pcPriClassBase(ByVal Index As Long) As Long
    pcPriClassBase = ListOfActiveProcess(Index).pcPriClassBase
End Function

Public Function th32ParentProcessID(ByVal Index As Long) As Long
    th32ParentProcessID = ListOfActiveProcess(Index).th32ParentProcessID
End Function

Public Function cntThreads(ByVal Index As Long) As Long
    cntThreads = ListOfActiveProcess(Index).cntThreads
End Function

Public Function thModuleID(ByVal Index As Long) As Long
    thModuleID = ListOfActiveProcess(Index).th32ModuleID
End Function

Public Function th32DefaultHeapID(ByVal Index As Long) As Long
    th32DefaultHeapID = ListOfActiveProcess(Index).th32DefaultHeapID
End Function

Public Function th32ProcessID(ByVal Index As Long) As Long
    th32ProcessID = ListOfActiveProcess(Index).th32ProcessID
End Function

Public Function cntUsage(ByVal Index As Long) As Long
    cntUsage = ListOfActiveProcess(Index).cntUsage
End Function

Public Function dwSize(ByVal Index As Long) As Long
    dwSize = ListOfActiveProcess(Index).dwSize
End Function

Public Function GetActiveProcess() As Long
    Dim hToolhelpSnapshot As Long
    Dim tProcess As PROCESSENTRY32
    Dim r As Long, i As Integer
    hToolhelpSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
    If hToolhelpSnapshot = 0 Then
        GetActiveProcess = 0
        Exit Function
    End If
    With tProcess
        .dwSize = Len(tProcess)
        r = ProcessFirst(hToolhelpSnapshot, tProcess)
        ReDim Preserve ListOfActiveProcess(20)
        Do While r
            i = i + 1
            If i Mod 20 = 0 Then ReDim Preserve ListOfActiveProcess(i + 20)
            ListOfActiveProcess(i) = tProcess
            r = ProcessNext(hToolhelpSnapshot, tProcess)
        Loop
    End With
    GetActiveProcess = i
    Call CloseHandle(hToolhelpSnapshot)
End Function
0

Task: Count elapsed time between two time.

Function ElapsedTime(tStart, tStop) As String
' *******************************************************************
' Function Name : ElapsedTime                                       *
' Created By    : Herry Hariry Amin                                 *
' Email         : h2arr@cbn.net.id                                  *
' Language      : VB4, VB5, VB6                                     *
' Example       : sYourVariable = ElapsedTime(tStartTime,tStopTime) *
' *******************************************************************
Dim dtr, dtl, jml As Long
    
    dtl = (Hour(tStart) * 3600) + (Minute(tStart) * 60) + (Second(tStart))
    dtr = (Hour(tStop) * 3600) + (Minute(tStop) * 60) + (Second(tStop))

    If tStop < tStart Then
       jml = 86400
    Else
       jml = 0
    End If
    jml = jml + (dtr - dtl)
    
    ElapsedTime = Format(Str(Int((Int((jml / 3600)) Mod 24))), "00") + ":" + Format(Str(Int((Int((jml / 60)) Mod 60))), "00") + ":" + Format(Str(Int((jml Mod 60))), "00")
     
End Function
0

برنامه ای بنویسید که ده عدد را گرفته تعیین کند کدام زوج و کدام فرد است.

Private Sub Command13_Click() '16

Cls

Dim i As Integer, n As Integer

For i = 1 To 10

n = InputBox("Enter the num")

Print n; Tab(10); IIf(n Mod 2 = 0, "Even", "Odd")

Next

End Sub
0

برنامه ای بنویسید که مجموع اعداد زوج و فرد 0 تا 100 را محاسبه کرده و جداگانه چاپ کند.

Private Sub Command14_Click()

Dim i As Integer, s As Integer

For i = 0 To 100 Step 2

s = s + i

Next

MsgBox Prompt:=s, Title:="Events"

s = 0

For i = 1 To 100 Step 2

s = s + i

Next

MsgBox Prompt:=s, Title:="Odds"

End Sub
0

برنامه ای بنویسید که 20 عدد را خوانده، بزرگترین و کوچکترین آنها را نمایش دهد.

Private Sub Command15_Click()

Dim min As Integer, max As Integer, n As Integer, i As Integer

For i = 1 To 20

n = InputBox("Enter a num")

If i = 1 Then min = n

If n > max Then max = n

If n < min Then min = n

Next

MsgBox "Max: " & max & " Min: " & min

End Sub
0

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

Private Sub Command16_Click()

Cls

Dim i As Integer, b As Boolean, t As Integer, c As Integer

For i = 10 To 99

b = True

t = i

Do While t > 0 And b

If t Mod 10 = 0 Then b = False

t = t \ 10

Loop

If b Then

c = c + 1

Print i;

If c Mod 20 = 0 Then Print

End If

Next

MsgBox "Total: " & c

End Sub
0

برنامه ای بنویسید که یک عدد را خوانده، اول بودن آن را تعیین نماید و پیغام مناسبی چاپ کند.

Private Sub Command6_Click()

Cls

Dim i As Integer, n As Integer, t As Boolean

n = InputBox("Enter a num:")

t = True

i = 2

Do While i <= n / 2 And t

If n Mod i = 0 Then t = False

i = i + 1

Loop

If t Then

Print "Prim"

Else: Print "not prim"

End If

End sub
0

برنامه ای بنویسید که یک عدد را گرفته و فاکتوریل آن را محاسبه و چاپ کند.

Private Sub Command19_Click()

Dim i As Integer, f&

f = 1

For i = 1 To InputBox("Enter a number to reach its single factorial:")

f = f * i

Next

MsgBox f

End Sub
0

برنامه ای بنویسید که عدد N را خوانده و مجموع ارقام آن را نشان دهد.

Private Sub Command21_Click() '25

Dim n As Integer, s As Integer

n = InputBox("Enter the num:")

While n > 0

s = s + n Mod 10

n = n \ 10

Wend

MsgBox s
0

برنامه ای بنویسید که یک عدد صحیح مثبت را خوانده جذر آن را نمایش دهد.

Private Sub Command23_Click()

Cls

Dim n As Integer, i As Integer, s As Integer, c As Integer

n = InputBox("Enter a natural number to get its square root (without sqr() function)")

i = 1

While s < n

s = s + i

i = i + 2

c = c + 1

Wend

If s > n Then

Print "Near "; (s / c) - 1

Else: Print "Really "; s / c

End If

'Or use n ^ 0.5 equation

End Sub
0

برنامه ای بنویسید که یک عدد حد اقل چهارقمی مثبت را خوانده، مغلوب آن را نمایش دهد.

Private Sub Command22_Click()

Cls

Dim n As Integer, i As Integer

n = InputBox("Enter the num:")

While n > 0

i = n Mod 10

Print CStr(i);

n = n \ 10

Wend

End Sub
0

برنامه ای بنویسید که 20 جمله اول سری فیبوناچی را نمایش دهد.

Private Sub Command24_Click()

Cls

Dim a As Integer, b As Integer, c As Integer, i As Integer

a = 1

For i = 1 To InputBox("Enter number of fibonacci series you want to make", , 20)

c = a + b

Print c

a = b

b = c

Next

End Sub
0

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

Private Sub Command1_Click()

Cls

Dim s As String

s = InputBox("")

For i = 1 To Len(s)

Select Case Mid(s, i, 1)

Case "A" To "Z"

u = u + 1

Case "a" To "z"

l = l + 1

End Select

Next

Print "horuf kuchak"; l

Print "horufe bozorg"; u

End Sub
0

برنامه ای بنویسید که بدون استفاده از تابع Replace، کار این تابع را شبیه سازی کند.

Private Sub Command3_Click()

Cls

Dim s As Integer, f As Integer, r As Integer, p1 As Integer, p2 As Integer, i As Integer

s = InputBox("Enter string")

f = InputBox("Find")

r = InputBox("Replace with")

Do Until InStr(1, s, f) = 0

i = InStr(1, s, f)

p1 = Mid(s, 1, i - 1)

p2 = Mid(s, i + Len(f))

s = p1 + r + p2

Loop

Print s

End Sub
0

Task: Create Database Through Visual Basic.

Private Sub Command1_Click()
On Error GoTo procerror
Screen.MousePointer = 11
Dim dbname As String
dbname = GetDBName()
If Len(dbname) > 0 Then
   CreateDB dbname
End If
procexit:
Screen.MousePointer = 0
Exit Sub
procerror:
MsgBox Err.Description
Resume procexit

End Sub

Public Function GetDBName() As String
On Error GoTo procerror
Dim filename As String
cd.DefaultExt = "mdb"
cd.DialogTitle = "Create Database"
cd.Filter = "VB Databases (*.mdb)|*.mdb"
cd.FilterIndex = 1
cd.Flags = cdlOFNHideReadOnly Or _
           cdlOFNOverwritePrompt Or _
           cdlOFNPathMustExist
cd.CancelError = True
cd.ShowSave
filename = cd.filename
On Error Resume Next
Kill filename

procexit:
GetDBName = filename
Exit Function


procerror:
filename = ""
Resume procexit
End Function

Public Sub CreateDB(dbname As String)
Dim db As Database
Set db = DBEngine(0).CreateDatabase(dbname, dbLangGeneral)
End Sub

Private Sub Command2_Click()
Form2.Show
End Sub

Private Sub Command3_Click()
Form3.Show
End Sub

Private Sub Command4_Click()
Form4.Show
End Sub
0

Task: Changing the System colors from visual basic.

Declarations:

Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
Public Const COLOR_ACTIVEBORDER = 10
Public Const COLOR_ACTIVECAPTION = 2
Public Const COLOR_APPWORKSPACE = 12
Public Const COLOR_BACKGROUND = 1
Public Const COLOR_BTNFACE = 15
Public Const COLOR_BTNSHADOW = 16
Public Const COLOR_BTNTEXT = 18
Public Const COLOR_CAPTIONTEXT = 9
Public Const COLOR_INACTIVEBORDER = 11
Public Const COLOR_INACTIVECAPTION = 3
Public Const COLOR_MENU = 4
Public Const COLOR_MENUTEXT = 7
Public Const COLOR_SCROLLBAR = 0
Public Const COLOR_WINDOW = 5
Public Const COLOR_WINDOWFRAME = 6
Public Const COLOR_WINDOWTEXT = 8

Code:

Public Sub elements()
Combo1.AddItem "COLOR_ACTIVEBORDER"
Combo1.AddItem "COLOR_ACTIVECAPTION"
Combo1.AddItem "COLOR_APPWORKSPACE"
Combo1.AddItem "COLOR_BACKGROUND"
Combo1.AddItem "COLOR_BTNFACE"
Combo1.AddItem "COLOR_BTNTEXT"
Combo1.AddItem "COLOR_CAPTIONTEXT"
Combo1.AddItem "COLOR_INACTIVEBORDER"
Combo1.AddItem "COLOR_INACTIVECAPTION"
Combo1.AddItem "COLOR_MENU"
Combo1.AddItem "COLOR_MENUTEXT"
Combo1.AddItem "COLOR_SCROLLBAR"
Combo1.AddItem "COLOR_WINDOW"
Combo1.AddItem "COLOR_WINDOWFRAME"
Combo1.AddItem "COLOR_WINDOWTEXT"
End Sub

Private Sub Command1_Click()
Dim RT As Long
CD.ShowColor
Call CHANGE_COLORS
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Form_Load()
Call elements
End Sub

Public Sub CHANGE_COLORS()
Select Case Combo1.Text
Case "COLOR_ACTIVEBORDER"
     RT = SetSysColors(1, 10, CD.Color)
Case "COLOR_ACTIVE_CAPTION"
     RT = SetSysColors(1, 2, CD.Color)
Case "COLOR_APPWORKSPACE"
     RT = SetSysColors(1, 12, CD.Color)
Case "COLOR_BACKGROUND"
     RT = SetSysColors(1, 1, CD.Color)
Case "COLOR_BTNFACE"
     RT = SetSysColors(1, 15, CD.Color)
Case "COLOR_BTNTEXT"
     RT = SetSysColors(1, 16, CD.Color)
Case "COLOR_CAPTIONTEXT"
     RT = SetSysColors(1, 9, CD.Color)
Case "COLOR_INACTIVEBORDER"
     RT = SetSysColors(1, 11, CD.Color)
Case "COLOR_INACTIVECAPTION"
     RT = SetSysColors(1, 3, CD.Color)
Case "COLOR_MENU"
     RT = SetSysColors(1, 4, CD.Color)
Case "COLOR_MENUTEXT"
     RT = SetSysColors(1, 7, CD.Color)
Case "COLOR_SCROLLBAR"
     RT = SetSysColors(1, 0, CD.Color)
Case "COLOR_WINDOW"
     RT = SetSysColors(1, 5, CD.Color)
Case "COLOR_WINDOWFRAME"
     RT = SetSysColors(1, 6, CD.Color)
Case "COLOR_WINDOWTEXT"
     RT = SetSysColors(1, 8, CD.Color)
End Select
End Sub
0

Task: This is a code for saving into a file what is in listbox

Sub Savelist(list as listbox, name as string)
 for i = 0 to list.listcount -1
       data$ = list.list(i)
        open name for output as #1
          print #1, data$
            close 1
 next i

End Sub
0

Task: Create directory more than one level deep, such as C:\Windows\MyApp\Files. Returns True if succeeded or False if failed creating directory.

Public Function CreateDir(strDir As String) As Boolean
On Error Resume Next
    Dim bytMax As Byte
    Dim bytNdx As Byte
    Dim strDirLevel As String
    If Right(strDir, 1) <> "\" Then
            strDir = strDir & "\"
    End If
    bytMax = Len(strDir)
    For bytNdx = 4 To bytMax
        If (Mid(strDir, bytNdx, 1) = "\") Then
            strDirLevel = Left(strDir, bytNdx - 1)
            If Dir(strDirLevel, vbDirectory) = "" Then
                MkDir strDirLevel
            End If
        End If
    Next
    If Dir(strDir, vbDirectory) <> "" Then
        CreateDir = True ' Succeeded creating directory
    Else
        CreateDir = False ' Failed creating directory
    End If
End Function
0

Task: to make form transparent

Declarations:

Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_TRANSPARENT = &H20&
Public Const SWP_FRAMECHANGED = &H20
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_SHOWME = SWP_FRAMECHANGED Or _
SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_NOTOPMOST = -2

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

Declare Function 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) As Long

Code:

SetWindowLong Me.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0&, 0&, 0&, 0&, SWP_SHOWME

سوال برنامه نویسی دارید؟

ندونستن عیب نیست، نپرسیدن چرا!

خوش آمدید

برای طرح سوال، ایجاد بحث و فعالیت در سایت نیاز است ابتدا وارد حساب کاربری خود شوید. در صورتی که هنوز عضو سایت نیستید میتوانید در عرض تنها چند ثانیه ثبت نام کنید.