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

بازدید177.7kپست ها136آخرین فعالیت10 سال پیش
0
1

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

آخرین ویرایش: 13-10-2014 ???? 22:26، توسط رضا رمضانپور
0
Task: Find free disk space on a computer

Declarations:

Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long

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

Code:

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
0
Task: Determine when your visual basic application gains or loses focus.

Declarations:

Option Explicit

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

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal 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:

'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(gHW, GWL_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
0
Task: Make a form stay on top of all other forms.

Declarations:

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)

Code:

'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, -1, 0, 0, 0, 0, 3)
0
Task: Check for the existence of a file.

Code:

Public Function FileExists(strPath As String) As Integer

    FileExists = Not (Dir(strPath) = "")

End Function
0
Task: Find and replace one string with another.

Code:

Function FindReplace(SourceString, SearchString, ReplaceString)
        tmpString1 = SourceString
        Do Until vFixed
            tmpString2 = tmpString1
            tmpString1 = ReplaceFirstInstance(tmpString1, SearchString,ReplaceString)
            If tmpString1 = tmpString2 Then vFixed = True
        Loop
        FindReplace = tmpString1
    End Function

    Function ReplaceFirstInstance(SourceString, SearchString, ReplaceString)
        FoundLoc = InStr(1, SourceString, SearchString)
        If FoundLoc <> 0 Then
                ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
                ReplaceString & Right(SourceString, _
                Len(SourceString) - (FoundLoc - 1) - Len(SearchString))
        Else
            ReplaceFirstInstance = SourceString
        End If
    End Function
0
Task: Creating a flashing form title bar.

Declarations:

Private Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long

Code:

Dim lngReturnValue As Long
    lngReturnValue = FlashWindow(Form1.hWnd, True)
0
Task: Determine if a computer is connected to the Internet

Declarations:

Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus 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:

'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).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
                         IsConnected = True
                         Else
                         IsConnected = False
                         End If

End Function
0
Task: Change the Windows wallpaper.

Declarations:

Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Public Const SPI_SETDESKWALLPAPER = 20

Code:

Dim lngSuccess As Long
Dim strBitmapImage As String

strBitmapImage = "c:\windows\straw.bmp"
lngSuccess = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, strBitmapImage, 0)
0
Task: Get Windows directory using an API call.

Declarations:

Public Const MAX_PATH = 260
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Code:

Dim strBuffer As String
Dim lngReturn As Long
Dim strWindowsDirectory As String

strBuffer = Space$(MAX_PATH)
lngReturn = GetWindowsDirectory(strBuffer, MAX_PATH)
strWindowsDirectory = Left$(strBuffer, Len(strBuffer) - 1)
0
Task: Determine whether or not the screen saver is enabled.

Declarations:

Public Const SPI_GETSCREENSAVEACTIVE = 16
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Code:

Dim blnReturn As Boolean
Dim blnActive As Boolean

' Determine whether screen saver is enabled.
Call SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, vbNull, blnReturn, 0)
blnActive = blnReturn
0
Task: Change the Windows display resolution.

Declarations:

Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1

Type typDevMODE
    dmDeviceName       As String * CCDEVICENAME
    dmSpecVersion      As Integer
    dmDriverVersion    As Integer
    dmSize             As Integer
    dmDriverExtra      As Integer
    dmFields           As Long
    dmOrientation      As Integer
    dmPaperSize        As Integer
    dmPaperLength      As Integer
    dmPaperWidth       As Integer
    dmScale            As Integer
    dmCopies           As Integer
    dmDefaultSource    As Integer
    dmPrintQuality     As Integer
    dmColor            As Integer
    dmDuplex           As Integer
    dmYResolution      As Integer
    dmTTOption         As Integer
    dmCollate          As Integer
    dmFormName         As String * CCFORMNAME
    dmUnusedPadding    As Integer
    dmBitsPerPel       As Integer
    dmPelsWidth        As Long
    dmPelsHeight       As Long
    dmDisplayFlags     As Long
    dmDisplayFrequency As Long
End Type

Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lptypDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lptypDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

Code:

Dim typDevM As typDevMODE
Dim lngResult As Long
Dim intAns    As Integer

' Retrieve info about the current graphics mode
' on the current display device.
lngResult = EnumDisplaySettings(0, 0, typDevM)

' Set the new resolution. Don't change the color
' depth so a restart is not necessary.
With typDevM
    .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
    .dmPelsWidth = 640  'ScreenWidth (640,800,1024, etc)
    .dmPelsHeight = 480 'ScreenHeight (480,600,768, etc)
End With

' Change the display settings to the specified graphics mode.
lngResult = ChangeDisplaySettings(typDevM, CDS_TEST)
Select Case lngResult
    Case DISP_CHANGE_RESTART
        intAns = MsgBox("You must restart your computer to apply these changes." & _
            vbCrLf & vbCrLf & "Do you want to restart now?", _
            vbYesNo + vbSystemModal, "Screen Resolution")
        If intAns = vbYes Then Call ExitWindowsEx(EWX_REBOOT, 0)
    Case DISP_CHANGE_SUCCESSFUL
        Call ChangeDisplaySettings(typDevM, CDS_UPDATEREGISTRY)
        MsgBox "Screen resolution changed", vbInformation, "Resolution Changed"
    Case Else
        MsgBox "Mode not supported", vbSystemModal, "Error"
End Select
0
Task: Launch Windows Add New Hardware wizard

Code:

'Launch Windows Add New Hardware wizard
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", 5)
0
Task: Launch Windows Add/Remove Programs Dialog

Code:

'Launch Windows Add/Remove Programs Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1", 5)
0
Task: Launch Windows Date/Time Properties Dialog

Code:

'Launch Windows Date/Time Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", 5)
Task: Launch Windows Display Properties Dialog

Code:

'Launch Windows Display Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 5)
Task: Launch Windows Internet Properties Dialog

Code:

'Launch Windows Internet Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", 5)
Task: Launch Windows Game Controllers Dialog

Code:

'Launch Windows Game Controllers Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL joy.cpl", 5)
Task: Launch Windows Keyboard Properties Dialog

Code:

'Launch Windows Keyboard Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", 5)
Task: Launch Windows Modem Properties Dialog

Code:

'Launch Windows Modem Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", 5)
Task: Launch Windows Mouse Properties Dialog

Code:

'Launch Windows Mouse Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5)
Task: Launch Windows Network Dialog

Code:

'Launch Windows Network Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl", 5)
Task: Launch Windows Multimedia Properties Dialog

Code:

'Launch Windows Multimedia Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0", 5)
Task: Launch Windows Password Properties Dialog

Code:

'Launch Windows Password Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL password.cpl", 5)
Task: Launch Windows Regional Settings Dialog

Code:

'Launch Windows Regional Settings Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0", 5)
Task: Launch Windows Sounds Properties Dialog

Code:

'Launch Windows Sounds Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1", 5)
Task: Launch Windows System Properties Dialog

Code:

'Launch Windows System Properties Dialog
Dim dblReturn As Double
dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0", 5)
0
Task: Move a file to the Recycling bin

Declarations:

Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As Long
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40

Code:

Dim typOperation As SHFILEOPSTRUCT

    With typOperation
        .wFunc = FO_DELETE
        .pFrom = "filename.txt"   'File to move to bin
        .fFlags = FOF_ALLOWUNDO
    End With
    SHFileOperation typOperation
0
Task: Retrieve the Windows user name

Declarations:

' Access the GetUserNameA function in advapi32.dll and
' call the function GetUserName.
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Code:

' Main routine to Dimension variables, retrieve user name
     ' and display answer.
           Sub Get_User_Name()

                ' Dimension variables
                Dim lpBuff As String * 25
                Dim ret As Long, UserName As String

                ' Get the user name minus any trailing spaces found in the name.
                ret = GetUserName(lpBuff, 25)
                UserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)

                ' Display the User Name
                MsgBox UserName
           End Sub

راه دوم

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Sub Form_Load()
Dim Buffer As String
Buffer = String(255, 0)
GetUserName Buffer, 255
Buffer = Left(Buffer, InStr(Buffer, Chr(0)) - 1)
Label1 = Buffer
End Sub
آخرین ویرایش: 03-02-2013 ???? 16:52، توسط Daniel
0
Task: Retrieve the computer name

Declarations:

Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Code:

Dim strBuffer As String
  Dim lngBufSize As Long
  Dim lngStatus As Long
  
  lngBufSize = 255
  strBuffer = String$(lngBufSize, " ")
  lngStatus = GetComputerName(strBuffer, lngBufSize)
  If lngStatus <> 0 Then
     MsgBox ("Computer name is: " & Left(strBuffer, lngBufSize))
  End If
0
Task: Get drive volume information

Declarations:

Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Private Const FS_CASE_IS_PRESERVED = 2
Private Const FS_CASE_SENSITIVE = 1
Private Const FS_UNICODE_STORED_ON_DISK = 4
Private Const FS_PERSISTENT_ACLS = 8
Private Const FS_FILE_COMPRESSION = 16
Private Const FS_VOL_IS_COMPRESSED = 32768

Code:

Dim strRootPathName As String
Dim strVolumeNameBuffer As String * 256
Dim lngVolumeNameSize As Long
Dim lngVolumeSerialNumber As Long
Dim lngMaximumComponentLength As Long
Dim lngFileSystemFlags As Long
Dim strFileSystemNameBuffer As String * 256
Dim lngFileSystemNameSize As Long
Dim strMessage As String

    strRootPathName = "C:\" 'drive letter
    
    If GetVolumeInformation(strRootPathName, strVolumeNameBuffer, Len(strVolumeNameBuffer), lngVolumeSerialNumber, lngMaximumComponentLength, lngFileSystemFlags, strFileSystemNameBuffer, Len(strFileSystemNameBuffer)) = 0 Then
        strMessage = "An error occurred!"
    Else
        strMessage = strRootPathName
        strVolumeNameBuffer = Left$(strVolumeNameBuffer, InStr(strVolumeNameBuffer, Chr$(0)) - 1)
        strMessage = strMessage & vbCrLf & "Volume Name: " & strVolumeNameBuffer
        strMessage = strMessage & vbCrLf & "Serial number: " & Format$(lngVolumeSerialNumber)
        strMessage = strMessage & vbCrLf & "Max component length: " & Format$(lngMaximumComponentLength)
        strMessage = strMessage & vbCrLf & "System Flags: "
        If lngFileSystemFlags And FS_CASE_IS_PRESERVED Then strMessage = strMessage & vbCrLf & "    FS_CASE_IS_PRESERVED"
        If lngFileSystemFlags And FS_CASE_SENSITIVE Then strMessage = strMessage & vbCrLf & "    FS_CASE_SENSITIVE"
        If lngFileSystemFlags And FS_UNICODE_STORED_ON_DISK Then strMessage = strMessage & vbCrLf & "    FS_UNICODE_STORED_ON_DISK"
        If lngFileSystemFlags And FS_PERSISTENT_ACLS Then strMessage = strMessage & vbCrLf & "    FS_PERSISTENT_ACLS"
        If lngFileSystemFlags And FS_FILE_COMPRESSION Then strMessage = strMessage & vbCrLf & "    FS_FILE_COMPRESSION"
        If lngFileSystemFlags And FS_VOL_IS_COMPRESSED Then strMessage = strMessage & vbCrLf & "    FS_VOL_IS_COMPRESSED"
        strFileSystemNameBuffer = Left$(strFileSystemNameBuffer, InStr(strFileSystemNameBuffer, Chr$(0)) - 1)
        strMessage = strMessage & vbCrLf & "File System: " & strFileSystemNameBuffer
    End If

    MsgBox (strMessage)
0
Task: Launch default mail program to send an email message

Declarations:

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 Const SW_SHOW = 5

Code:

ShellExecute hwnd, "open", "mailto:vbcode@vbcode.com", vbNullString, vbNullString, SW_SHOW
0
Task: Open the windows start menu

Declarations:

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2
Private Const MENU_KEYCODE = 91

Code:

' Press start button
    keybd_event MENU_KEYCODE, 0, 0, 0

    ' Release start button
    keybd_event MENU_KEYCODE, 0, KEYEVENTF_KEYUP, 0
0
Task: Hide windows taskbar

Declarations:

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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

Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_SHOWWINDOW = &H40

Code:

Dim rtn As Long

'hide the taskbar
rtn = FindWindow("Shell_traywnd", "") 'get the Window
Call SetWindowPos(rtn, 0, 0, 0, 0, 0, SWP_HIDEWINDOW) 'hide the Tasbar
'show th taskbar
rtn = FindWindow("Shell_traywnd", "") 'get the Window
Call SetWindowPos(rtn, 0, 0, 0, 0, 0, SWP_SHOWWINDOW) 'show the Taskbar
0
Task: Retrieve Current printer name

Declarations:

Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwReserved As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName$, ByVal lpdwReserved As Long, lpdwType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Const HKEY_CURRENT_CONFIG As Long = &H80000005

Code:

Dim GetCurrPrinter As String
Dim PName As String
GetCurrPrinter = RegGetString$(HKEY_CURRENT_CONFIG, "System\CurrentControlSet\Control\Print\Printers", "Default")
PName = GetCurrPrinter

Function RegGetString$(hInKey As Long, ByVal subkey$, ByVal valname$)

    Dim RetVal$, hSubKey As Long, dwType As Long, SZ As Long
    Dim R As Long
    RetVal$ = ""
    Const KEY_ALL_ACCESS As Long = &HF0063
    Const ERROR_SUCCESS As Long = 0
    Const REG_SZ As Long = 1
    R = RegOpenKeyEx(hInKey, subkey$, 0, KEY_ALL_ACCESS, hSubKey)
    If R <> ERROR_SUCCESS Then GoTo Quit_Now
    SZ = 256: v$ = String$(SZ, 0)
    R = RegQueryValueEx(hSubKey, valname$, 0, dwType, ByVal v$, SZ)
    If R = ERROR_SUCCESS And dwType = REG_SZ Then
        RetVal$ = Left$(v$, SZ - 1)
    Else
        RetVal$ = "--Not String--"
    End If
    If hInKey = 0 Then
        R = RegCloseKey(hSubKey)
    End If
Quit_Now:
        RegGetString$ = RetVal$
End Function
0
Task: Move a form that has not title bar, or one that does by clicking anywhere on form

Declarations:

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "User32" ()
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2

Code:

'place this code in the MouseMove event of the form
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Dim lngReturnValue As Long
   If Button = 1 Then
      Call ReleaseCapture
      lngReturnValue = SendMessage(Form1.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
  End If
End Sub
0
Task: Create a shortcut in Windows on the desktop and on the start menu

Declarations:

'NOTE: In Visual Basic 5.0, change Stkit432.dll in the following
'statement to Vb5stkit.dll.  Stkit432.dll is for Visual Basic 4.0

Private Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long

Code:

Dim lReturn As Long
    
    'Add to Desktop
    lReturn = fCreateShellLink("..\..\Desktop", _
    "Shortcut to Calculator", "c:\windows\calc.exe", "")
    
    'Add to Program Menu Group
    lReturn = fCreateShellLink("", "Shortcut to Calculator", _
    "c:\windows\calc.exe", "")
    
    'Add to Startup Group
    'Note that on Windows NT, the shortcut will not actually appear
    'in the Startup group until your next reboot.
    lReturn = fCreateShellLink("\Startup", "Shortcut to Calculator", _
    "c:\windows\calc.exe", "")
0
Task: Add an icon to the system tray, and recognize when the icon is clicked or hoovered over

Declarations:

'Declare a user-defined variable to pass to the Shell_NotifyIcon
'function.
Private Type NOTIFYICONDATA
   cbSize As Long
   hWnd As Long
   uId As Long
   uFlags As Long
   uCallBackMessage As Long
   hIcon As Long
   szTip As String * 64
End Type

'Declare the constants for the API function. These constants can be
'found in the header file Shellapi.h.

'The following constants are the messages sent to the
'Shell_NotifyIcon function to add, modify, or delete an icon from the
'taskbar status area.
Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2

'The following constant is the message sent when a mouse event occurs
'within the rectangular boundaries of the icon in the taskbar status
'area.
Private Const WM_MOUSEMOVE = &H200

'The following constants are the flags that indicate the valid
'members of the NOTIFYICONDATA data type.
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

'The following constants are used to determine the mouse input on the
'the icon in the taskbar status area.

'Left-click constants.
Private Const WM_LBUTTONDBLCLK = &H203   'Double-click
Private Const WM_LBUTTONDOWN = &H201     'Button down
Private Const WM_LBUTTONUP = &H202       'Button up

'Right-click constants.
Private Const WM_RBUTTONDBLCLK = &H206   'Double-click
Private Const WM_RBUTTONDOWN = &H204     'Button down
Private Const WM_RBUTTONUP = &H205       'Button up

'Declare the API function call.
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

'Dimension a variable as the user-defined data type.
Dim nid As NOTIFYICONDATA

Code:

' create a form named Form1
' add a commond dialog control named CommonDialog1
' add two command buttons named Command1 and Command2

Private Sub Command1_Click()
   'Click this button to add an icon to the taskbar status area.

   'Set the individual values of the NOTIFYICONDATA data type.
   nid.cbSize = Len(nid)
   nid.hWnd = Form1.hWnd
   nid.uId = vbNull
   nid.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
   nid.uCallBackMessage = WM_MOUSEMOVE
   nid.hIcon = Form1.Icon
   nid.szTip = "Taskbar Status Area Sample Program" & vbNullChar

   'Call the Shell_NotifyIcon function to add the icon to the taskbar
   'status area.
   Shell_NotifyIcon NIM_ADD, nid
End Sub

Private Sub Command2_Click()
   'Click this button to delete the added icon from the taskbar
   'status area by calling the Shell_NotifyIcon function.
   Shell_NotifyIcon NIM_DELETE, nid
End Sub

Private Sub Form_Load()
   'Set the captions of the command button when the form loads.
   Command1.Caption = "Add an Icon"
   Command2.Caption = "Delete Icon"
End Sub

Private Sub Form_Terminate()
   'Delete the added icon from the taskbar status area when the
   'program ends.
   Shell_NotifyIcon NIM_DELETE, nid
End Sub

Private Sub Form_MouseMove _
   (Button As Integer, _
    Shift As Integer, _
    X As Single, _
    Y As Single)
    'Event occurs when the mouse pointer is within the rectangular
    'boundaries of the icon in the taskbar status area.
    Dim msg As Long
    Dim sFilter As String
    msg = X / Screen.TwipsPerPixelX
    Select Case msg
       Case WM_LBUTTONDOWN
       Case WM_LBUTTONUP
       Case WM_LBUTTONDBLCLK
       CommonDialog1.DialogTitle = "Select an Icon"
       sFilter = "Icon Files (*.ico)|*.ico"
       sFilter = sFilter & "|All Files (*.*)|*.*"
       CommonDialog1.Filter = sFilter
       CommonDialog1.ShowOpen
       If CommonDialog1.FileName <> "" Then
          Form1.Icon = LoadPicture(CommonDialog1.FileName)
          nid.hIcon = Form1.Icon
          Shell_NotifyIcon NIM_MODIFY, nid
       End If
       Case WM_RBUTTONDOWN
          Dim ToolTipString As String
          ToolTipString = InputBox("Enter the new ToolTip:", "Change ToolTip")
          If ToolTipString <> "" Then
             nid.szTip = ToolTipString & vbNullChar
             Shell_NotifyIcon NIM_MODIFY, nid
          End If
       Case WM_RBUTTONUP
       Case WM_RBUTTONDBLCLK
    End Select
End Sub
0
Task: Make a 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
0
'//[load pic from URL!]
'//SoftAfzar.Net
Private Type TGUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Declare Function OleLoadPicturePath Lib "oleaut32.dll" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As TGUID, ByRef ppvRet As IPicture) As Long
Public Function LoadPicture(ByVal strFileName As String) As Picture
Dim IID  As TGUID
    With IID
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
On Error GoTo ERR_LINE
    OleLoadPicturePath StrPtr(strFileName), 0&, 0&, 0&, IID, LoadPicture
    Exit Function
ERR_LINE:
    Set LoadPicture = VB.LoadPicture(strFileName)
End Function

Private Sub Command1_Click()
    Set Picture1.Picture = LoadPicture(Text1.Text)
    Image1.Picture = Picture1.Picture
End Sub
0
Task: Change the color of the active forms title bar

Declarations:

Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long

Public Const COLOR_SCROLLBAR = 0 'The Scrollbar color
Public Const COLOR_BACKGROUND = 1 'Colour of the background with no wallpaper
Public Const COLOR_ACTIVECAPTION = 2 'Caption of Active Window
Public Const COLOR_INACTIVECAPTION = 3 'Caption of Inactive window
Public Const COLOR_MENU = 4 'Menu
Public Const COLOR_WINDOW = 5 'Windows background
Public Const COLOR_WINDOWFRAME = 6 'Window frame
Public Const COLOR_MENUTEXT = 7 'Window Text
Public Const COLOR_WINDOWTEXT = 8 '3D dark shadow (Win95)
Public Const COLOR_CAPTIONTEXT = 9 'Text in window caption
Public Const COLOR_ACTIVEBORDER = 10 'Border of active window
Public Const COLOR_INACTIVEBORDER = 11 'Border of inactive window
Public Const COLOR_APPWORKSPACE = 12 'Background of MDI desktop
Public Const COLOR_HIGHLIGHT = 13 'Selected item background
Public Const COLOR_HIGHLIGHTTEXT = 14 'Selected menu item
Public Const COLOR_BTNFACE = 15 'Button
Public Const COLOR_BTNSHADOW = 16 '3D shading of button
Public Const COLOR_GRAYTEXT = 17 'Grey text, of zero if dithering is used.
Public Const COLOR_BTNTEXT = 18 'Button text
Public Const COLOR_INACTIVECAPTIONTEXT = 19 'Text of inactive window
Public Const COLOR_BTNHIGHLIGHT = 20 '3D highlight of button

Code:

'set active forms title bar to red
Dim lngReturn As Long
lngReturn = SetSysColors(1, COLOR_ACTIVECAPTION, RGB(255, 0, 0))
0
Task: Retrieve double-click time of mouse in milliseconds

Declarations:

Declare Function GetDoubleClickTime& Lib "user32" ()

Code:

'retrieve the mouse double-click time in milliseconds
Dim lngReturn As Long
lngReturn = GetDoubleClickTime

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

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

خوش آمدید

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