Visual Basic 6 مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

كود لجعل الفورم في المقدمه form on top

كــــــــــــود الموديل

كود PHP:

Public lwHandles() As Long
Public l As Long
Public Path As String

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Type POINTAPI
        x As Long
        y As Long
End Type

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

Private Declare Function sGetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

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 Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_GETTEXT = &HD

Private Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
Private Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function GetModuleFileNameExA Lib "psapi.dll" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
Private Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
Private Const MAX_PATH = 260

Private Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function ExtractIcon Lib "<font color="#FF0000">*</font><font color="#FF0000">*</font><font color="#FF0000">*</font><font color="#FF0000">*</font>l32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

Private Declare Function Setwindowpos Lib "user32" Alias "SetWindowPos" (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 HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const HWND_NOTOPMOST = -2
Public Const LB_ITEMFROMPOINT = &H1A9

Public Sub GethWnd()
    Dim p As POINTAPI
    GetCursorPos p
    ReDim lwHandles(0) As Long
    lwHandles(0) = WindowFromPoint(p.x, p.y)
    Call HandleSearch
    Call GetWindowFileName
End Sub

Public Sub HandleSearch()
    l = 0
    Do While GetParent(lwHandles(l)) <> 0
    If GetParent(lwHandles(l)) <> 0 Then
        l = l + 1
        ReDim Preserve lwHandles(l) As Long
        lwHandles(l) = GetParent(lwHandles(l - 1))
    End If
    Loop
End Sub

Public Function GetClassname(ByVal hwnd As Long) As String
    Dim retVal As Long
    Dim sClassName As String
    sClassName = SPACE$(260)
    retVal = sGetClassName(hwnd, sClassName, 260)
    GetClassname = Left(sClassName, retVal)
End Function

Public Function GetWinText(hwnd As Long) As String
    Dim WindowText As String
    Dim retVal As Long
    Dim WindowTextLen As Long
    WindowTextLen = SendMessage(hwnd, WM_GETTEXTLENGTH, ByVal CLng(0), ByVal CLng(0)) + 1
    WindowText = SPACE(WindowTextLen)
    retVal = SendMessageByString(hwnd, WM_GETTEXT, WindowTextLen, WindowText)
    GetWinText = Left(WindowText, retVal)
End Function

Public Function GetWindowFileName()
    Dim ProcessID As Long
    Dim hProcess As Long
    Dim lRet As Long
    Dim Modules(1 To 200) As Long
    Dim cbNeeded As Long
    Dim FileName As String
    Dim nSize As Long
    
    GetWindowThreadProcessId lwHandles(0), ProcessID
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, ProcessID)
    lRet = EnumProcessModules(hProcess, Modules(1), 200, cbNeeded)
    FileName = SPACE$(MAX_PATH)
    nSize = 500
    lRet = GetModuleFileNameExA(hProcess, Modules(1), FileName, nSize)
    Path = FileName
End Function

Public Function lExtractIcon(IconHDC As Long)
    return1& = ExtractIcon(lwHandles(0), Path, 0)
    return2& = DrawIcon(IconHDC, 0, 0, return1&)
End Function

Public Function SetWinPos(iPos As Integer, lhwnd As Long) As Boolean
    Dim lwinpos As Long
    iPos = 1

    Select Case iPos
        Case 1
            lwinpos = HWND_TOPMOST
    End Select
    If Setwindowpos(lhwnd, lwinpos, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE) Then
        SetWinPos = True
    End If
End Function

كـــــود هذا في الفورم

كود PHP:

Dim B As Boolean

B = SetWinPos(1, Me.hwnd)

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

كود لعكس الفورم

كود PHP:

Private Sub Form_Load()
Dim Ctrl As Control
On Error Resume Next
For Each Ctrl In Controls
If TypeOf Ctrl Is Line Then
Ctrl.X1 = Ctrl.Container.ScaleWidth - Ctrl.X1
Ctrl.X2 = Ctrl.Container.ScaleWidth - Ctrl.X2
Else
Ctrl.Left = Ctrl.Container.ScaleWidth - Ctrl.Left - Ctrl.Width
End If
If Ctrl.Alignment = 1 Then
Ctrl.Alignment = 0
ElseIf Ctrl.Alignment = 0 Then
Ctrl.Alignment = 1
End If
Ctrl.RightToLeft = True
Next
RightToLeft = True
Err.Clear
End Sub

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

كود جعل الجملة عمودية

كود PHP:

Private Sub Form_Activate()
Dim s As String
For i = 1 To Len(Label1)
s = s & Mid$(Label1, i, 1) & vbCrLf
Next
Label1 = s
End Sub 

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

كود اخفاء مؤشر الفأرة في تطبيق الفيجول بيسك :
قسم التعاريف

كود PHP:

Private Declare Function ShowCursor Lib "user32" _
(ByVal bShow As Long) As Long
اخفاء :
x = ShowCursor(False)
اظهار :
x = ShowCursor(True) 

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

كود تحديد دقت عرض الشاشة

كود PHP:

Dim x, y As Integer
x = Screen.Width / 15
y = Screen.Height / 15
If x = 640 And y = 480 Then MsgBox ("640 * 480")
If x = 800 And y = 600 Then MsgBox ("800 * 600")
If x = 1024 And y = 768 Then MsgBox ("1024 * 768") 

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

تأجيل تنفيذ الكود لفترة معينة

كود PHP:

Public Sub Delay(HowLong As Date)
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents
Wend
End Sub

Private Sub Command1_Click()
Delay 5
MsgBox "Test"
End Sub 

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

منع تشغيل أكثر من نسخة من البرنامج

كود PHP:

Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub 

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

حساب عدد حروف مربع نص

كود PHP:

Private Sub Command1_Click()
MsgBox ("عدد الحروف = " + Str(Len(Text1.Text)))
End Sub 

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

تحريك الفورم عن طريق الماوس

كود PHP:

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub 

ونكتب في موديل Modell

كود PHP:

Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1 

 

رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

منع نسخ أو لصق أي ملف ..في الـ Autorun لحماية برنامجك من النسخ.

كود PHP:

Private Sub Form_Load()
Timer1.Interval = 1
End Sub

Private Sub Timer1_Timer()
R = Clipboard.GetText
If Len(R) = 0 Then
Clipboard.Clear
End If
End Sub