بهترين سورسهاي ويژوال بيسيك 6

[yeketaz]

با این کد می تونید صدای MessageBox ها رو تقلید کنید :

کد:

Private Declare Function MessageBeep Lib "user32.dll" (ByVal wType As Long) As Long
Private Enum MsgBeep
Error = &H10&
Information = &H40&
Warning = &H30&
Question = &H20&
End Enum
Private Sub MakeMsgBeep(MBeep As MsgBeep)
MessageBeep MBeep
End Sub

[VisualBasic6Love]

عنوان آموزش (بدست آوردن مشخصات ويندوز)

کد:

'Learning By : VisualBasic6Love
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Sub Form_Load()
    Dim OSInfo As OSVERSIONINFO, PId As String
    'Set the graphical mode to persistent
    Me.AutoRedraw = True
    'Set the structure size
    OSInfo.dwOSVersionInfoSize = Len(OSInfo)
    'Get the Windows version
    Ret& = GetVersionEx(OSInfo)
    'Chack for errors
    If Ret& = 0 Then MsgBox "Error Getting Version Information": Exit Sub
    'Print the information to the form
    Select Case OSInfo.dwPlatformId
        Case 0
            PId = "Windows 32s "
        Case 1
            PId = "Windows 95/98"
        Case 2
            PId = "Windows NT "
    End Select
    Print "OS: " + PId
    Print "Win version:" + Str$(OSInfo.dwMajorVersion) + "." + LTrim(Str(OSInfo.dwMinorVersion))
    Print "Build: " + Str(OSInfo.dwBuildNumber)
End Sub

[VisualBasic6Love]

Caption:Execute explorer

کد:

'Example By : VisualBasic6Love
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
Private Sub Form_Load()
    'Execute explorer.exe
    WinExec "Explorer.exe c:\", 10
End Sub

[VisualBasic6Love]

عنوان (Shadow A Text Box)

کد:

'Learning By : VisualBasic6Love
Option Explicit
Private Sub Command1_Click()
'Create a shadow to the right and below of Text1 (TextBox)
Shadow Me, Text1
End Sub
Private Sub Shadow(fIn As Form, ctrlIn As Control)
Const SHADOW_COLOR = &H808080     'Shadow Color
Const SHADOW_WIDTH = 6 'Shadow Border Width
Dim iOldWidth As Integer
Dim iOldScale As Integer
'Save the current DrawWidth and ScaleMode
iOldWidth = fIn.DrawWidth
iOldScale = fIn.ScaleMode
fIn.ScaleMode = 3
fIn.DrawWidth = 1
'Draws the shadow around the control by drawing a gray
'box behind the control that's offset right and down.
fIn.Line (ctrlIn.Left + SHADOW_WIDTH, ctrlIn.Top + _
           SHADOW_WIDTH)-Step(ctrlIn.Width - 1, _
           ctrlIn.Height - 1), SHADOW_COLOR, BF
'Restore Old Setting
fIn.DrawWidth = iOldWidth
fIn.ScaleMode = iOldScale
End Sub

[VisualBasic6Love]

عنوان : (Scrollbar)

کد:

'Programming By : VisualBasic6Love
Const WS_VSCROLL = &H200000
Const WS_HSCROLL = &H100000
Const GWL_STYLE = (-16)
Const WSB_PROP_CYVSCROLL = &H1
Const WSB_PROP_CXHSCROLL = &H2
Const WSB_PROP_CYHSCROLL = &H4
Const WSB_PROP_CXVSCROLL = &H8
Const WSB_PROP_CXHTHUMB = &H10
Const WSB_PROP_CYVTHUMB = &H20
Const WSB_PROP_VBKGCOLOR = &H40
Const WSB_PROP_HBKGCOLOR = &H80
Const WSB_PROP_VSTYLE = &H100
Const WSB_PROP_HSTYLE = &H200
Const WSB_PROP_WINSTYLE = &H400
Const WSB_PROP_PALETTE = &H800
Const WSB_PROP_MASK = &HFFF
Const FSB_FLAT_MODE = 2
Const FSB_ENCARTA_MODE = 1
Const FSB_REGULAR_MODE = 0
Const SB_HORZ = 0
Const SB_VERT = 1
Const SB_BOTH = 3
Const ESB_ENABLE_BOTH = &H0
Const ESB_DISABLE_BOTH = &H3
Const ESB_DISABLE_LEFT = &H1
Const ESB_DISABLE_RIGHT = &H2
Const ESB_DISABLE_UP = &H1
Const ESB_DISABLE_DOWN = &H2
Const ESB_DISABLE_LTUP = ESB_DISABLE_LEFT
Const ESB_DISABLE_RTDN = ESB_DISABLE_RIGHT
Const SIF_RANGE = &H1
Const SIF_PAGE = &H2
Const SIF_POS = &H4
Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS)
Private Type SCROLLINFO
    cbSize As Long
    fMask As Long
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function InitializeFlatSB Lib "comctl32" (ByVal hWnd As Long) As Long
Private Declare Function UninitializeFlatSB Lib "comctl32" (ByVal hWnd As Long) As Long
Private Declare Function FlatSB_SetScrollProp Lib "comctl32" (ByVal hWnd As Long, ByVal index As Long, ByVal newValue As Long, ByVal fRedraw As Boolean) As Boolean
Private Declare Function FlatSB_EnableScrollBar Lib "comctl32" (ByVal hWnd As Long, ByVal wSBflags As Long, ByVal wArrows As Long) As Long
Private Declare Function FlatSB_GetScrollInfo Lib "comctl32" (ByVal hWnd As Long, ByVal fnBar As Long, lpsi As SCROLLINFO) As Boolean
Private Declare Function FlatSB_GetScrollProp Lib "comctl32" (ByVal hWnd As Long, ByVal index As Long, pValue As Long) As Boolean
Private Declare Function FlatSB_GetScrollRange Lib "comctl32" (ByVal hWnd As Long, ByVal code As Long, lpMinPos As Long, lpMaxPos As Long) As Boolean
Private Declare Function FlatSB_SetScrollInfo Lib "comctl32" (ByVal hWnd As Long, ByVal fnBar As Long, lpsi As SCROLLINFO, ByVal fRedraw As Boolean) As Long
Private Declare Function FlatSB_SetScrollPos Lib "comctl32" (ByVal hWnd As Long, ByVal code As Long, ByVal nPos As Long, ByVal fRedraw As Boolean) As Long
Private Declare Function FlatSB_SetScrollRange Lib "comctl32" (ByVal hWnd As Long, ByVal code As Long, ByVal nMinPos As Long, ByVal nMaxPos As Long, ByVal fRedraw As Boolean) As Long
Private Declare Function FlatSB_ShowScrollBar Lib "comctl32" (ByVal hWnd As Long, ByVal code As Long, ByVal fShow As Boolean) As Boolean
Private Declare Function FlatSB_GetScrollPos Lib "comctl32" (ByVal hWnd As Long, ByVal code As Long) As Long
Private Sub Form_Activate()
    Dim SI As SCROLLINFO
    'Initialize
    InitializeFlatSB Me.hWnd
    'Set the vertical scrollbar to Encarta-mode
    FlatSB_SetScrollProp Me.hWnd, WSB_PROP_VSTYLE, FSB_ENCARTA_MODE, False
    'Disable the Up-button from the vertical scrollbar
    FlatSB_EnableScrollBar Me.hWnd, SB_VERT, ESB_DISABLE_UP
    'Set the vertical scroll range
    FlatSB_SetScrollRange Me.hWnd, SB_VERT, 20, 80, False
    'Set the scroll position to 50
    FlatSB_SetScrollPos Me.hWnd, SB_VERT, 60, False
    'Hide the horizontal scrollbar
    FlatSB_ShowScrollBar Me.hWnd, SB_HORZ, False
    'Get the scrollbar information
    SI.cbSize = Len(SI)
    SI.fMask = SIF_ALL
    FlatSB_GetScrollInfo Me.hWnd, SB_VERT, SI
    SI.nPos = SI.nPos - 10
    'Set the new scrollbar information
    FlatSB_SetScrollInfo Me.hWnd, SB_VERT, SI, True
    'Show some scrollbar information on the form
    Dim RetMin As Long, RetMax As Long
    FlatSB_GetScrollRange Me.hWnd, SB_VERT, RetMin, RetMax
    Me.AutoRedraw = True
    Me.Print "Scroll Position:" + Str$(Int(100 * (FlatSB_GetScrollPos(Me.hWnd, SB_VERT) / RetMax))) + "%"
    FlatSB_GetScrollProp Me.hWnd, WSB_PROP_VSTYLE, RetMin
    Me.Print "Vertical Scrollbar Mode:" + Str$(RetMin)
End Sub
Private Sub Form_Load()
    Dim Ret As Long
    'Create the scrollbars on the form
    Ret = GetWindowLong(Me.hWnd, GWL_STYLE)
    Ret = Ret Or WS_VSCROLL Or WS_HSCROLL
    SetWindowLong Me.hWnd, GWL_STYLE, Ret
End Sub
Private Sub Form_Unload(Cancel As Integer)
    'Remove the Flat style
    UninitializeFlatSB Me.hWnd
End Sub

[VisualBasic6Love]

عنوان آموزش : (Clip Region)

کد:

'Example By : VisualBasic6Love
Private Declare Function GetClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function IntersectClipRect Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function OffsetClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateEllipticRgn 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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Dim hRgn As Long
Private Sub Form_Load()
    Me.ScaleMode = vbPixels
End Sub
Private Sub Form_Paint()
    Form_Resize
End Sub
Private Sub Form_Resize()
    Dim Ret As Long
    'destroy the previous region
    DeleteObject hRgn
    'create an elliptic region
    hRgn = CreateEllipticRgn(0, 0, Me.ScaleWidth, Me.ScaleHeight)
    'select this elliptic region into the form's device context
    SelectClipRgn Me.hdc, hRgn
    'move the clipping region
    OffsetClipRgn Me.hdc, 10, 10
    'generate a new clipping region
    IntersectClipRect Me.hdc, 10, 10, 500, 300
    'clear the form
    Me.Cls
    'draw a Black rectangle over the entire form
    Me.Line (0, 0)-(Me.ScaleWidth, Me.ScaleHeight), vbBlack, BF
    'create a temporary region
    Ret = CreateEllipticRgn(0, 0, 1, 1)
    'copy the current clipping region into the temporary region
    GetClipRgn Me.hdc, Ret
    'set the new window region
    SetWindowRgn Me.hWnd, Ret, True
End Sub
Private Sub Form_Unload(Cancel As Integer)
    'clean up
    DeleteObject hRgn
End Sub
Private Sub Form_Click()
    'unload the form when the user clicks on it
    Unload Me
End Sub

[yeketaz]

یک راه به جای استفاده از FileCopy و دیگر توابع API

کد:

Private Sub FCopy(Source As String, Destination As String)
Dim FF As Integer
Dim FileCode() As Byte
FF = FreeFile
Open Source For Binary As FF
Get #FF, , FileCode()
Close #FF
Open Destination For Output As FF
Close #FF
Open Destination For Binary As FF
Put #FF, , FileCode
Close #FF
End Sub

[VisualBasic6Love]

يك تايمر به فرم اضافه كنيد و كدهاي زير رو در قسمت جنرال وارد كنيد:

کد:

'Example By : VisualBasic6Love
Private Sub Form_Load()
Form1.BackColor = &H0&
Form1.WindowState = 2
Timer1.Interval = 75
End Sub
Private Sub Timer1_Timer()
Dim x, y
R = Rnd * 255
G = Rnd * 255
B = Rnd * 255
x = Rnd * Me.ScaleHeight
y = Rnd * Me.ScaleWidth
Me.DrawWidth = Rnd * 69
Me.PSet (x, y), RGB(R, G, B)
End Sub

[VisualBasic6Love]

سلام دوستان
خوب هستين؟
لطفا نظرات خودتونو درباره اين تاپيك و بهتر شدنش و همينطور اينكه در چه سطحي و در چه زمينه اي براتون آموزش هاي مفيد بگذارم خوبه؟
پس حتما بگيد؟

[ara.look]

در مورد ویروس سازی بگی بهتره!

[VisualBasic6Love]

لطفا بقيه دوستان هم نظرشون رو مطرح كنند.