• 0
professional VB99

مكتبة الاكواد

سؤال

السلام عليكم

وشرايكم انسوي

مكتبه الاكواد كل واحد ينزل كود او اكثر

ليس بملف مرفق بل يكتب هنا لكي يسهل

وكل واحد يكتب ماذا يعمل هذا الكود

وماذا يحتاج لتعم الفائدة ولكي يشتهر المنتدى

ولكي يكون المنتدى المرجع الاول للفجوال بيسك

ويكون أفضل منتدى بالعالم إن شاء الله

وشكر ا وهذا اول كود

يحتاج الى زرين فقط للأخفاء وللأظهار

هذا الكود لخفاء واظهار أيقونات سطح المكتب والخلفيه لسطح المكتب

Coming soon

قريباً

'ضع هذا الكود في الفورم

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Sub Command1_Click()

Dim hwnd As Long

hwnd = FindWindowEx(0&, 0&, "Progman", vbNullString)

ShowWindow hwnd, 0

End Sub

Private Sub Command2_Click()

Dim hwnd As Long

hwnd = FindWindowEx(0&, 0&, "Progman", vbNullString)

ShowWindow hwnd, 5

End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

85 إجابة على هذا السؤال .

  • 0

السلام عليكم

هذا الكود الثاني

لحصر الفارة داخل الفورم وفك الحصر

يحتاج الى زرين فقط

Coming Soon

' ضع هذا الكود في الفورم

Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)
Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)
Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)
Private Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
Private Type POINT
X As Long
Y As Long
End Type


Private Sub Command1_Click() 'هذا الايعاز يجعل الماوس لا يخرج عن نطاق الفورم
Dim Client As RECT
Dim Up As POINT
ClientToScreen Me.hwnd, Up
GetClientRect Me.hwnd, Client
OffsetRect Client, Up.X, Up.Y
Up.X = Client.Left
Up.Y = Client.Top
ClipCursor Client
End Sub


Private Sub Command2_Click() 'هذا الايعاز يحرر حركة الماوس
ClipCursor ByVal 0&
End Sub

' في هذا المثال سوف تنحصر حركة الماوس داخل الفورم
' كما يمكنك حصرها داخل أي أداة أخرى
' me.hwnd   باستبدال الكلمة
'أو غيرها  text1.hwnd   , label1.hwnd باسم

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

هذا الكود الثالث

ولا يحتاج الى أي شي

وهو رسم خطين متقاطعين على حسب حركة الفارة

ويمكنك تغير لون الخطين

' ضع هذا الكود في الفورم

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Cls
Line (X, 0)-(X, Me.ScaleHeight), vbRed
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

هذا الكود لصهر الشاشة حلو

لا يحتاج الى أي شي

Coming Soon

قريباً

' ضع هذا الكود في الفورم

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
Dim lngDC As Long
Dim intWidth As Integer, intHeight As Integer
Dim intX As Integer, intY As Integer

lngDC = GetDC(0)

intWidth = Screen.Width / Screen.TwipsPerPixelX
intHeight = Screen.Height / Screen.TwipsPerPixelY

form1.Width = intWidth * 15
form1.Height = intHeight * 15

Call BitBlt(hDC, 0, 0, intWidth, intHeight, lngDC, 0, 0, vbSrcCopy)
form1.Visible = vbTrue

Do
intX = (intWidth - 128) * Rnd
intY = (intHeight - 128) * Rnd

Call BitBlt(lngDC, intX, intY + 1, 128, 128, lngDC, intX, intY, vbSrcCopy)

DoEvents
Loop
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set form1 = Nothing
End
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

هذا الكود لطباعة النص فقط

ويحتاج الى زر فقط

' ضع هذا الكود في الفورم

Private Sub Command1_Click()

Printer.Print text1.text

End Sub




			
		
0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

هذا الكود لا يحتاج الى شي

هذا الكود لتشغيل البرنامج لعدد معين

' ضع هذا الكود في الفورم

Private Sub Form_Load()
retvalue = GetSetting("A", "0", "Runcount")
GD$ = Val(retvalue) + 1
SaveSetting "A", "0", "RunCount", GD$
If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل
MsgBox ("انتهت مدة تشغيل البرنامج ،،، قم بشراء النسخة الكاملة من المنتج")
Unload Me
End If
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

تلوين النموذج قبل اغلاقة

'ضع هذا الكود في الفورم

Private Sub Form_Unload(Cancel As Integer)
WindowState = 2     'تكبير حجم النموذج ليصبح بحجم الشاشة
DrawWidth = 4       'اتغيير حجم نقطة الرسم
For i = 1 To 18000  'التحضير للتنفيذ
Down = Down + 1     ' سرعة الرسم
Across = Across + 1
PSet (Rnd * Across, Rnd * Down), QBColor(Rnd * 15) 'رسم النقط
Next i            '  اعد تنقيذ الرسم
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

هذا الكود لتجميل الفورم

' ضع هذا الكود في الفورم

Function Dist(x1, y1, x2, y2) As Single
Dim A As Single, B As Single
A = (x2 - y1) * (x2 - x1)
B = (y2 - y1) * (y2 - y1)
Dist = Sqr(A + B)
End Function
Sub MoveIt(A, B, t)
A = (1 - t) * A + t * B
End Sub

Private Sub Form_Click()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub

Private Sub Form_Resize()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

هذا الكود لوضع الخطوط في أدة Combo

يحتاج الى اداة Combo

كود حلو

'ضع هذا الكود في الفورم

Private Sub Form_Load()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

هذا الكود حلو وجميل وممتاز

لصنع فجوة بالفورم

لا يحتاج الى شي

' ضع هذا الكود في الفورم

Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean

Const RGN_DIFF = 4

Dim lOriginalForm As Long

Dim ltheHole As Long

Dim lNewForm As Long

Dim lFwidth As Single

Dim lFHeight As Single

Dim lborder_width As Single

Dim ltitle_height As Single

On Error GoTo Trap

lFwidth = ScaleX(Width, vbTwips, vbPixels)

lFHeight = ScaleY(Height, vbTwips, vbPixels)

lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)

lborder_width = (lFHeight - ScaleWidth) / 2

ltitle_height = lFHeight - lborder_width - ScaleHeight

Select Case AreaType

Case "Elliptic"

ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))

Case "RectAngle"

ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))

Case "RoundRect"

ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))

Case "Circle"

ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))

Case Else

MsgBox "Unknown Shape!!"

Exit Function

End Select

lNewForm = CreateRectRgn(0, 0, 0, 0)

CombineRgn lNewForm, lOriginalForm, ltheHole, RGN_DIFF

SetWindowRgn hWnd, lNewForm, True

Me.Refresh

fMakeATranspArea = True

Exit Function

Trap:

MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description

End Function

Private Sub Form_Load()

Dim lParam(1 To 6) As Long

lParam(1) = 100

lParam(2) = 208

lParam(3) = 50

lParam(4) = 50

lParam(5) = 666

lParam(6) = 555

'Call fMakeATranspArea("RoundRect", lParam())

'Call fMakeATranspArea("RectAngle", lParam())

'Call fMakeATranspArea("Circle", lParam())

Call fMakeATranspArea("Elliptic", lParam())

End Sub




			
		
0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

السلام عليكم

هذا الكود لتجميل الفورم

'ضع هذا الكود في الفورم

Private Sub Form_Load()
   Me.AutoRedraw = True
   Me.ScaleMode = vbTwips
   Me.Caption = "Rainbow Generator by " & _
   "K. O. Thaha Hussain"
End Sub
Private Sub Form_Resize()
   Call Rainbow
End Sub
Private Sub Rainbow()
   On Error Resume Next
   Dim Position As Integer, Red As Integer, Green As _
   Integer, Blue As Integer
   Dim ScaleFactor As Double, Length As Integer
   ScaleFactor = Me.ScaleWidth / (255 * 6)
   Length = Int(ScaleFactor * 255)
   Position = 0
   Red = 255
   Blue = 1
   For Green = 1 To Length
       Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
       RGB(Red, Green \ ScaleFactor, Blue)
       Position = Position + 1
   Next Green
   For Red = Length To 1 Step -1
       Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
       RGB(Red \ ScaleFactor, Green, Blue)
       Position = Position + 1
   Next Red
   For Blue = 0 To Length
       Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
       RGB(Red, Green, Blue \ ScaleFactor)
       Position = Position + 1
   Next Blue
   For Green = Length To 1 Step -1
       Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
       RGB(Red, Green \ ScaleFactor, Blue)
       Position = Position + 1
   Next Green
   For Red = 1 To Length
       Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
       RGB(Red \ ScaleFactor, Green, Blue)
       Position = Position + 1
   Next Red
   For Blue = Length To 1 Step -1
       Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
       RGB(Red, Green, Blue \ ScaleFactor)
       Position = Position + 1
   Next Blue
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

فتح الفورم بشكل جميل

' ضع هذا الكود في الفورم

Sub Explode(form1 As Form)
form1.Width = 0
form1.Height = 0
form1.Show
For x = 0 To 5000 Step 1
form1.Width = x
form1.Height = x
With form1
.Left = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / 2
End With
Next

End Sub
Private Sub Form_Load()
Explode Me
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

بس انا الي اشارك بالكود

شاركوا ياشباب يامبرمجين

:)

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

هذا لوضع اجهزه الطابعة في قائمة مندلسه

تحتاج الى Combo

'ضع هذا الكود في الفورم

Private Sub Form_Load()
Dim cPrinter As Printer
For Each cPrinter In Printers
   Combo1.AddItem Printer.DeviceName
Next
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

حركة عند اغلاق الفورم جميله

' ضع هذا الكود في الفورم

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.Left + frmSlide.Width < Screen.Width
DoEvents
frmSlide.Left = frmSlide.Left + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
DoEvents
frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 100)
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

اخى انا اقدر تعبك ومجهودك الرائع والمستمر لكن اتمنى ان توفر عليك عناء الشرح لانه توجد مكتبة ممتازة من الاكواد وهى المكتبة الخاصة بالمنتدى وهذه هى وصلتها

مكتبة اكواد الفريق العربى :rolleyes:

تم تعديل بواسطه GHOST2010
0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

تحريك النص بطريقة جميله

تحتاج الى label

' ضع هذا الكود في الفورم

Private Sub Form_Load()
Me.Label1.Top = 0
End Sub

Private Sub Timer1_Timer()
a = Me.Height
b = 200
If Me.Label1.Top < a Then 'Me.Height Then
Me.Label1.Top = Me.Label1.Top + b
Exit Sub
End If
For m = 1 To (Int(a / b) + 1)
Me.Label1.Top = Me.Label1.Top - 200
For x = 1 To 1000000
Next
Next
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

فورم شفاف

' ضع هذا الكود في الفورم

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000

Private Sub Form_Load()
  SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
  SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

طباعة صفحة انترنت طبعا تحتاج الى اداة الانترنت

'تأكد من وجود الملف MSHTML.DLL في مجلد ال system

Public Declare Function OpenProcess Lib "kernel32" _
       (ByVal dwDesiredAccess As Long, _
       ByVal bInheritHandle As Long, _
       ByVal dwProcessId As Long) As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" _
       (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" _
       (ByVal hObject As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias
"GetSystemDirectoryA" _
       (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STATUS_PENDING = &H103&

Public Sub PrintHtmlFile(cHtmlFile As String)
   Dim hProcess As Long
   Dim ProcessId As Long
   Dim ExitCode As Long
   Dim cWinSysDir As String
   cWinSysDir = String(254, " ")
   Call GetSystemDirectory(cWinSysDir, Len(cWinSysDir))
   cWinSysDir = Trim(Left(cWinSysDir, InStr(cWinSysDir, Chr(0)) - 1))
   If Dir(cWinSysDir & "\MSHTML.DLL") <> "" Then
       ProcessId = Shell("rundll32.exe " & cWinSysDir &
       "\MSHTML.DLL,PrintHTML " & Chr(34) & cHtmlFile & Chr(34), vbNormalFocus)
       hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId)
       Do
           Call GetExitCodeProcess(hProcess, ExitCode)
           DoEvents
       Loop While ExitCode = STATUS_PENDING
       Call CloseHandle(hProcess)
   End If
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

كود بسيط لجعل الفورم بالمقدمة

' ضع هذا الكود في الفورم

Private Declare Sub 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)
Private Sub Form_Load()
Timer1.Interval = 1
End Sub
Private Sub Timer1_Timer()
SetWindowPos Form1.hwnd, -1, 0, 0, 0, 0, 3
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

إلغاء تفعيل زر التكبير في أعلى النافذة

' ضع هذا الكود في الفورم

Option Explicit
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 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 Sub Form_Load()
 Const WS_MAXIMIZEBOX = &H10000
 Const GWL_STYLE = (-16)
 Const SWP_FRAMECHANGED = &H20
 Const SWP_NOMOVE = &H2
 Const SWP_NOSIZE = &H1

 Dim nStyle As Long
 nStyle = GetWindowLong(Me.hWnd, GWL_STYLE)
 Call SetWindowLong(Me.hWnd, GWL_STYLE, nStyle And Not WS_MAXIMIZEBOX)
 SetWindowPos Me.hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

إلغاء تفعيل زر الإغلاق في أعلى النافذة

' ضع هذا الكود في الموديول
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Public Const MF_BYPOSITION = &H400&

' ضع هذا الكود في الفورم
Public Sub DisableCloseWindowButton(frm As Form)

  Dim hSysMenu As Long

  'Get the handle to this windows system menu
  hSysMenu = GetSystemMenu(frm.hwnd, 0)

  'Remove the Close menu item This will also disable the close button
  RemoveMenu hSysMenu, 6, MF_BYPOSITION

  'Lastly, we remove the seperator bar
  RemoveMenu hSysMenu, 5, MF_BYPOSITION

End Sub

Private Sub Form_Load()
  DisableCloseWindowButton Me
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

أبطال زر x في اعلى النافذه

' ضع هذا الكود في الفورم

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = True
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

جعل الفورم بالمقدمة بس الكود طويل

' ضع هذا الكود في الفورم

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 Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)
Dim lR As Long
If bSetOnTop Then
  lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
  lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub

Private Sub Form_Load()
  SetOnTop Form1.hwnd, True
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

ترجمة النجوم ********

' ضع هذا الكود في الفورم

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
      x As Long
      y As Long
End Type
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 Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

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

Private Sub Timer1_Timer()
Const EM_SETPASSWORDCHAR = &HCC
Dim coord As POINTAPI

s = GetCursorPos(coord)
x = coord.x
y = coord.y

h = WindowFromPoint(x, y)

Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه
  • 0

حساب عدد الحروف في النص

' ضع هذا الكود في الفورم

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

0

شارك هذا الرد


رابط المشاركة
شارك الرد من خلال المواقع ادناه

  • يستعرض القسم حالياً   0 members

    لا يوجد أعضاء مسجلين يشاهدون هذه الصفحة .