[Amin_Mansouri]

سورس های بعدی قابل فهم هستند نیازی به توضیح فارسی نیست.

Wave Player

کد:

Option Explicit


Private Sub Command1_Click()


    Dim FileNumber As Integer
    Dim I As Single
    Dim Min As Single
    Dim Max As Single
    Dim Temp As Integer
    Dim XZoomrate As Single
    Dim YZoomrate As Single
    Dim LastX As Single
    Dim LastY As Single
    On Error Goto ErrorHandler
    ' Enable Cancel error



    With Picture1
        CommonDialog1.CancelError = True
        CommonDialog1........ = "Wave files (*.wav)|*.wav"
        CommonDialog1.ShowOpen
        ' Change the caption of the form

        Me.Caption = CommonDialog1.filename
        I = 44 ' Set I To 44, since the wave sample is begin at Byte 44.
        ' Open file to get the length of the wav

        '    

        'e file.

        FileNumber = FreeFile
        Open CommonDialog1.filename For Random As #FileNumber


        Do
            Get #FileNumber, I, Temp
            I = I + 1
            ' Get the smallest and largest number. T

            '    

            'hey will be use for the adjustment

            ' of the vertical size.

            If Temp < Min Then Min = Temp
            If Temp > Max Then Max = Temp
        Loop Until EOF(FileNumber)


        Close #FileNumber
        ' Adjust values and reset values

        XZoomrate = (.Width / I)
        YZoomrate = (Max - Min) / (.Height / 2)
        .CurrentX = 100
        .CurrentY = .Height / 2
        LastX = 100
        LastY = .Height / 2
        .AutoRedraw = True
        I = 44
        ' Reopen file using a different FileNumb

        '    

        'er

        FileNumber = FileNumber + 1
        .Cls
        Open CommonDialog1.filename For Random As #FileNumber


        Do
            Get #FileNumber, I, Temp
            ' Set CurrentX and CurrentY

            .CurrentX = .CurrentX + XZoomrate
            .CurrentY = (Temp / YZoomrate) + .Height / 2
            ' Plot graph

            Picture1.Line (LastX, LastY)-(.CurrentX, .CurrentY), vbBlack
            ' Reset values

            LastX = .CurrentX
            LastY = .CurrentY
            I = I + 1
            
            If .CurrentX > .Width Then Exit Do
        Loop Until EOF(FileNumber)


        Close #FileNumber
    End With


    
    ErrorHandler:
    ' Do nothing

End Sub




Private Sub Form_Resize()


    On Error Resume Next
    ' Resize control



    With Picture1
        .BackColor = vbWhite
        .ForeColor = vbBlack
        .Move 50, 500, Width - 200, Height - 800
    End With


End Sub

Tray Icon

کد:

Public 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
      
'constants required by Shell_NotifyIcon API call:
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click


Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public nid As NOTIFYICONDATA
      
Sub Initialise(mee As Form)  'Place in form load
    With nid
        .cbSize = Len(nid)
        .hwnd = mee.hwnd
        .uId = vbNull
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uCallBackMessage = WM_MOUSEMOVE
        .hIcon = mee.Icon
        '.szTip = " Click Right Mouse Button " & vbNullChar
    End With
    Shell_NotifyIcon NIM_ADD, nid
    mee.Hide
    App.TaskVisible = False

End Sub

Sub PopMenu(mee As Form, x As Single)  'Place in form mouse move
    Dim Msg As Long
    Msg = x / Screen.TwipsPerPixelX

    Select Case Msg
        Case WM_LBUTTONDBLCLK:
          
        Case WM_LBUTTONDOWN:
                
        Case WM_LBUTTONUP:
            mee.PopupMenu mee.mnuPopMenu
        Case WM_RBUTTONDBLCLK:
            
        Case WM_RBUTTONDOWN:
            
        Case WM_RBUTTONUP:
            mee.PopupMenu mee.mnuPopMenu
        
        End Select
End Sub

Sub CloseApp() 'Place in form unload
    Shell_NotifyIcon NIM_DELETE, nid
End Sub

Sub Down(mee As Form)  'Place in form resize
    If mee.WindowState = vbMinimized Then mee.Hide
End Sub

Systary

کد:

'Add the following line to the top of your main form...

Public MyTrayIcon As New <NAME OF ADDED CLASS MODULE (see below)>

'"MyTrayIcon" is the name of the actual trayicon, this icon would
'be classed as an object. The following functions are the events
'of this object.

'To use the tray icon you must add a "Class Module"
'to your project and place the following code into it



Option Explicit

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
  
Private FormHandle As Long
Private mvarbRunningInTray As Boolean
Private SysIcon As NOTIFYICONDATA
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Private Property Let bRunningInTray(ByVal vData As Boolean)
    mvarbRunningInTray = vData
End Property


Property Get bRunningInTray() As Boolean
    bRunningInTray = mvarbRunningInTray
End Property

Public Sub ShowIcon(ByRef sysTrayForm As Form)
    SysIcon.cbSize = Len(SysIcon)
    SysIcon.hwnd = sysTrayForm.hwnd
    SysIcon.uId = vbNull
    SysIcon.uFlags = 7
    SysIcon.ucallbackMessage = 512
    SysIcon.hIcon = sysTrayForm.Icon
    SysIcon.szTip = sysTrayForm.Caption + Chr(0)
    Shell_NotifyIcon 0, SysIcon
    mvarbRunningInTray = True
End Sub

Public Sub RemoveIcon(sysTrayForm As Form)
    SysIcon.cbSize = Len(SysIcon)
    SysIcon.hwnd = sysTrayForm.hwnd
    SysIcon.uId = vbNull
    SysIcon.uFlags = 7
    SysIcon.ucallbackMessage = vbNull
    SysIcon.hIcon = sysTrayForm.Icon
    SysIcon.szTip = Chr(0)
    Shell_NotifyIcon 2, SysIcon
    If sysTrayForm.Visible = False Then sysTrayForm.Show    'Incase user can't see form
    mvarbRunningInTray = False
End Sub

Public Sub ChangeIcon(sysTrayForm As Form, picNewIcon As PictureBox)

If mvarbRunningInTray = True Then   'If running in the tray
    SysIcon.cbSize = Len(SysIcon)
    SysIcon.hwnd = sysTrayForm.hwnd
    'SysIcon.uId = vbNull
    'SysIcon.uFlags = 7
    'SysIcon.ucallbackMessage = 512
    SysIcon.hIcon = picNewIcon.Picture
    'SysIcon.szTip = sysTrayForm.Caption + Chr(0)
    Shell_NotifyIcon 1, SysIcon
End If

End Sub

Public Sub ChangeToolTip(sysTrayForm As Form, strNewTip As String)

If mvarbRunningInTray = True Then   'If running in the tray
    SysIcon.cbSize = Len(SysIcon)
    SysIcon.hwnd = sysTrayForm.hwnd
    SysIcon.szTip = strNewTip & Chr(0)
    Shell_NotifyIcon 1, SysIcon
End If

End Sub

ShutDown

کد:

Private 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


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


Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
    
    Private Const EWX_SHUTDOWN = 1

    Dim ret As Integer
    Dim pOld As Boolean
    Dim i
  

Private sub Shutdown()

        ret = SystemParametersInfo(97, False, pOld, 0)
    'SetWindowPos(Form1.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)

End Sub

Screen Shot

کد:

Declare Function BitBlt Lib "gdi32" _
    (ByVal hDestDC As Integer, ByVal x As Integer, _
    ByVal y As Integer, ByVal nWidth As Integer, _
    ByVal nHeight As Integer, ByVal _
    hSrcDC As Integer, ByVal xSrc As Integer, _
    ByVal ySrc As Integer, ByVal dwRop As _
    Long) As Integer


Declare Function GetDesktopWindow Lib "user32" () As Long


Declare Function GetDC Lib "user32" _
    (ByVal hwnd As Long) As Long
    Public Const SRCCOPY = &HCC0020
    Public Const SRCAND = &H8800C6
    Public Const SRCINVERT = &H660046


Set the Form properties To the following:
AutoRedraw True
BorderStyle 0 - None
WindowState 2 - Maximized


DeskhWnd& = GetDesktopWindow()

DeskDC& = GetDC(DeskhWnd&)
BitBlt Form1.hDC, 0&, 0&, _
Screen.Width, Screen.Height, DeskDC&, _
0&, 0&, SRCCOPY