دنیای سورس کد ویژوال بیسیک

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Activate()

    DoEvents
        'block the mouse and keyboard input
        BlockInput True
        'wait 10 seconds before unblocking it
        Sleep 10000
        'unblock the mouse and keyboard input
        BlockInput False
    End Sub

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long


Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long


Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long


Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long


Private Sub Form_Load()

    Dim Libary As Long
    Dim PrcAdress As Long
    On Error Goto NoApi
    'Load the Libary
    Libary = LoadLibrary("user32")
    'Find the procedure we want
    Procadress = GetProcAddress(Libary, "MessageBoxA")
    'Call the Api
    CallWindowProc Procadress, Me.hWnd, "My Message", "Api without Declare", &H0&
    'Unload the libary
    FreeLibrary Libary
    NoApi:
End Sub

Public Function rgbtohex(r As Byte, g As Byte, b As Byte)
'input format = 255,255,255
'get the r value
If r < 16 Then
hex1 = 0 & Hex(r)
Else

End If
...

 Sub Command1_Click ()
f$ = "C:\WINDOWS"
dirFolder = Dir(f$, vbDirectory)


If dirFolder <> "" Then
strmsg = MsgBox("This folder already exists.", vbCritical):goto optout
End IF
End Sub

Set wshshell = CreateObject("WScript.Shell")
wshshell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Start Page", "http://www.Micro-TC.Blogfa.com"

Private Function FileExists(FullFileName As String) As Boolean

    On Error Goto MakeF
        'If file does Not exist, there will be an Error
        Open FullFileName For Input As #1
        Close #1
        'no error, file exists
        FileExists = True
    Exit Function
    MakeF:
        'error, file does Not exist
        FileExists = False
    Exit Function
End Function

Sub Command1_Click ()
msgbox FileExists
End Sub

.

Public Sub DelAll(ByVal DirtoDelete As Variant)

    Dim FSO, FS
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FS = FSO.DeleteFolder(DirtoDelete, True)
End Sub

'so like

Private Sub Command1_Click()

    Call delall("c:\New Folder")
    'that would delete the c:\New Folder
End Sub

Private Sub Form_Load()

    ' the "A" in getsetting and savesetting
    '     can be changed to another letter
    retvalue = GetSetting("A", "0", "RunCount") ' this returns the value of the registry edit.
    Worm$ = Val(retvalue) + 1 ' adds one To the value of the regisrty edit.
    SaveSetting "A", "0", "RunCount", Worm$ ' saves the new value


    If Worm$ < 25 Then 'put one number higher then it says.
        ' this is the popup to warn the user how
        '     many runs have been executed and how man
        '     y are left.
        MsgBox "you have used this program " & Worm$ & " Times. Only " & (25 - Worm$) & " left."
    End If

    ' this is the statement to check whether
    '     to execute the form load or end program


    If Worm$ > 24 Then 'put one number lower then it says.
        MsgBox "you have used this program 25 Times, purchase is now required", 16, "Sorry"
        ' this would send the user to a website
        '     in their default browser.
        Win32Keyword "http://skygazer.net"
        Unload Me
        End
    End If

End Sub



Private Sub Command1_Click()

    End
End Sub

    For a = 0 To List1.ListCount - 1 'Start Loop
        List1.Selected(a) = True 'Select part of list
        Text1.Text = Text1.Text & List1.Text & " " 'Add selected part of list To text
    Next 'End Loop

Public Sub PrintBinary(Num As Long)
    Dim j&, i&
    j = 128
    For i = 8 To 1 Step -1
        If (Num And j) = 0 Then
            Debug.Print "0";
        Else
            Debug.Print "1";
        End If
        j = j / 2
    Next
End Sub

Private A As Integer: Private B As Integer
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
    A = X: B = Y
    End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Form1.Line (A, B)-(X, Y)
        A = X: B = Y
    End If
End Sub

Sub ReadLineByLine()

    ' Variable Declarations
    Dim folderName As String
    Dim fileName As String
    folderName = "C:\Dump\"
    fileName = "test.txt"
    Open folderName & fileName For Input As #1


    Do While Not EOF(1)
        Line Input #1, inputdata
        MsgBox inputdata  ' or txtFile.Text = TxtFile.Text + vbcrlf + Input Data
    Loop

    Close #1
End Sub

Option Explicit


Private Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Private Declare Function RemoveMenu Lib "user32" Alias "RemoveMenu" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
    Private Const MF_BYPOSITION = &H400&

Public Sub RemoveCloseMenu(frm As Form)

    Dim hSysMenu As Long
    ' Get the system menu for the form
    hSysMenu = GetSystemMenu(frm.hwnd, 0)
    ' Remove the close item
    Call RemoveMenu(hSysMenu, 6, MF_BYPOSITION)
    ' and the seperator
    Call RemoveMenu(hSysMenu, 5, MF_BYPOSITION)
End Sub

Public Sub SunkenPanel3D(obj As Object)

    ' Gives the effect of sinking the entire
    '    
    ' form or picture box, much like a 3d pi
    '     cture
    ' box with border style set to 1 - Fixed
    '     Single
    ' Hold the original scale mode
    Dim nScaleMode As Integer
 ...   

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    Const SND_SYNC = &H0
    Const SND_ASYNC = &H1
    Const SND_NODEFAULT = &H2
    Const SND_LOOP = &H8
    Const SND_NOSTOP = &H10

    '----------PLAY WAVE SOUND--------

Private Sub PlayWaveSound_Click()

    soundfile$ = "c:/TheCustomSoundIWant.wav"
    wFlags% = SND_ASYNC Or SND_NODEFAULT
    HaHa = sndPlaySound(soundfile$, wFlags%)
End Sub

'-------STOP WAVE SOUND-------

Private Sub StopTheSound_Click()
    StopTheSoundNOW = sndPlaySound(soundfile$, wFlags%)
End Sub
'Replace "c:/TheCustomSoundIWant.wav" wi
'     th your sound

    On Error Resume Next

Dim EX, ARGU, path, X
If fldrs = True Then
EX = "explorer.exe"

        ARGU = " /e,/root, "

        path = rootpath$

        X = Shell(EX & ARGU & path, 1)

    ElseIf fldrs = False Then

        EX = "explorer.exe"

        ARGU = " n/e,/,root, "

        path = rootpath$

        X = Shell(EX & ARGU & path, 1)

End IF

End Sub