ما أروعك;)
أكواد للمبتدئين
مغلقاستطلاعرائج
يعطيك ألف عافية(f)
كلامك صحيح يا NOP ويجب أن يؤخذ بعين الاعتبار، فإذا توصلت إلى جديد أرجو أن تخبرني، وإليك جزيل الشكر.
تحياتي إليك أخي en_gold.
اقتباساقتباسكاتب الرسالة الأصلية : عبد الله فتحي(f)الكود الأربعون(f)
لعمل فورم شفاف
بعد اذن اخى عبدالله
فهذا كود ايضا لكيفية عمل فورم شفاف
Option Explicit 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 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 Public Sub TransparentForm(frm As Form) frm.ScaleMode = vbPixels Const RGN_DIFF = 4 Const RGN_OR = 2 Dim outer_rgn As Long Dim inner_rgn As Long Dim wid As Single Dim hgt As Single Dim border_width As Single Dim title_height As Single Dim ctl_left As Single Dim ctl_top As Single Dim ctl_right As Single Dim ctl_bottom As Single Dim control_rgn As Long Dim combined_rgn As Long Dim ctl As Control If frm.WindowState = vbMinimized Then Exit Sub ' Create the main form region. wid = frm.ScaleX(frm.Width, vbTwips, vbPixels) hgt = frm.ScaleY(frm.Height, vbTwips, vbPixels) outer_rgn = CreateRectRgn(0, 0, wid, hgt) border_width = (wid - frm.ScaleWidth) / 2 title_height = hgt - border_width - frm.ScaleHeight inner_rgn = CreateRectRgn(border_width, title_height, wid - border_width, _ hgt - border_width) ' Subtract the inner region from the outer. combined_rgn = CreateRectRgn(0, 0, 0, 0) CombineRgn combined_rgn, outer_rgn, inner_rgn, RGN_DIFF ' Create the control regions. For Each ctl In frm.Controls If ctl.Container Is frm Then ctl_left = frm.ScaleX(ctl.Left, frm.ScaleMode, vbPixels) _ + border_width ctl_top = frm.ScaleX(ctl.Top, frm.ScaleMode, vbPixels) + title_height ctl_right = frm.ScaleX(ctl.Width, frm.ScaleMode, vbPixels) + ctl_left ctl_bottom = frm.ScaleX(ctl.Height, frm.ScaleMode, vbPixels) + ctl_top control_rgn = CreateRectRgn(ctl_left, ctl_top, ctl_right, ctl_bottom) CombineRgn combined_rgn, combined_rgn, control_rgn, RGN_OR End If Next ctl 'Restrict the window to the region. SetWindowRgn frm.hWnd, combined_rgn, True End Sub Private Sub Form_Resize() TransparentForm Me End Sub
وَقُل رَّبِّ زِدْنِي عِلْماً
اخي عبد الله مرة اخرى مساعدتك الكريمة لو سمحت او اي احد يعرف كيف
Private Sub Form_Load()
On Error GoTo Error:
Open "c:/vote" For Input As #1
Close
txtfrom.Text = "http://"
txtsaveas.Text = "Whatever.zip"
Exit Sub
Error:
MsgBox ("هل تظن بأن جهدي يستحق بعض الثناء ؟, صوت لموقعي اذن رجاء.")
MsgBox ("لا تنسى أن تصوت.")
Call Shell("Start.exe " & "http://www.diamondwebawards.com/cgi-bin/clwork.cgi?id=12303", 0)
MsgBox ("هل قمت بالتصويت ؟ شكرا لك")
Open "c:/vote.txt" For Output As #1
Print #1, "voted, thanx"
Close #1
txtfrom.Text = "http://"
txtsaveas.Text = "Whatever.zip"
End Subالغاية ان يتاكد البرنامج من وجود ملف ضمن ال c: فان لم يجده يفتح صفحة الانترنيت ثم يقوم بانشاءه كي لا يظهر التنبيه مرة اخرى لكن المشكلة انه حتى ولو تم انشاءه فالصفحة تفتح مع التشغيل مرة اخرى :(
Do as I say, not as I do
We are Anonymous. We are Legion. We don't forgive. We don't forget
مشكور اخوي عرفة حصلت على الكود منذ قليل لكن تواجهني مشكلة الان وهي كيفية اعادة الفورم للحالة العادية بدون شفافية وهذا ما استخدمته
في module:
Option Explicit
Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public 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 Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Const RGN_XOR = 3
Public Const RGN_DIFF = 4
Public Const RGN_COPY = 5
Public Const RGN_AND = 1
Public Const RGN_OR = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
Public Const HWND_TOPMOST = -1
Public 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)
Public Function MakeRegion(ByRef objForm As Form) As Long
Const OpacityWidth As Integer = 2 'YOU CAN PLAY WHITH THIS ONE
Const StepSize As Integer = 4 'YOU CAN PLAY WHITH THIS ONE
Dim X As Long, Y As Long, StartLineX As Long
Dim FullRegion As Long, LineRegion As Long
Dim InFirstRegion As Boolean
Dim InLine As Boolean ' Flags whether we are in a non-tranparent pixel sequence
Dim hDC As Long
Dim PicWidth As Long
Dim PicHeight As Long
Dim ctlItem As Control 'controls
hDC = objForm.hDC
PicWidth = objForm.ScaleWidth
PicHeight = objForm.ScaleHeight
InFirstRegion = True: InLine = False
X = Y = StartLineX = 0
'set the x lines
For Y = 0 To PicHeight / Screen.TwipsPerPixelY - OpacityWidth Step StepSize
LineRegion = CreateRectRgn(0, Y, PicWidth, Y + OpacityWidth)
If InFirstRegion Then
FullRegion = LineRegion
InFirstRegion = False
Else
CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
' Always clean up your mess
DeleteObject LineRegion
End If
Next
'set the y lines
For X = 0 To PicWidth / Screen.TwipsPerPixelX - OpacityWidth Step StepSize
LineRegion = CreateRectRgn(X, 1, X + OpacityWidth, PicHeight)
CombineRgn FullRegion, FullRegion, LineRegion, RGN_XOR
' Always clean up your mess
DeleteObject LineRegion
Next
'set the command region
On Error Resume Next
For Each ctlItem In objForm.Controls
LineRegion = CreateRectRgn(ctlItem.Left / Screen.TwipsPerPixelX, _
ctlItem.Top / Screen.TwipsPerPixelY, _
(ctlItem.Left + ctlItem.Width) / Screen.TwipsPerPixelX, _
(ctlItem.Top + ctlItem.Height) / Screen.TwipsPerPixelY)
CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR
' Always clean up your mess
DeleteObject LineRegion
Next ctlItem
MakeRegion = FullRegion
End Functionوفي حدث النقر
Dim WindowRegion As Long
WindowRegion = MakeRegion(Me)
SetWindowRgn Me.hWnd, WindowRegion, Trueفكيف يمكن التخلص مرة اخرى من الشفافية ؟
ودمتم (f)
Do as I say, not as I do
We are Anonymous. We are Legion. We don't forgive. We don't forget
أخي العزيز عرفة، بالنسبة للكود الذي وضعته، فهو كود رائع، ولكنه لا يقوم فقط بجعل الفورم شفافة وإنما يقوم بتفريغها أيضاً، بحيث لو نقرت في داخلها بالماوس، فإن الفورم ستختفي ويحصل التركيز على ما بداخلها.
أخي العزيز NOP بالنسبة للكود الذي وضعته لجعل الفورم شفافة فهو يقوم على نفس فكرة الأخ عرفة، حيث يقوم بتفريغ نقاط في الفورم، بحيث أيضاً لو نقرت في أجزاء منها سيخرج التركيز عن الفورم.
أما بالنسبة للكود رقم 40، فإنه يقوم فقط بزيادة شفافية الفورم، من غير تفريغها، ويمكنك التحكم في هذه الشفافية كماتريد.
أخيراً: بالنسبة للكود الآخر الذي وضعته للتأكد من وجود ملف في الـ c: فأنا لم أفهم ما هو المقصود بالضبط، وما الذي تريده؟
أرجو أن توضح أكثر فأنا لم أفهم الكود؟؟؟؟:confused:
(gift) عرفة (gift) NOP (gift)
(f)الكود السادس والأربعون(f)
كرات صغيرة تتبع الماوس
Private Type POINTAPI x As Long y As Long End Type Private Declare Function GetActiveWindow Lib "user32" () As Long Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function Ellipse 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 TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Sub Form_Load() Timer1.Interval = 100 Timer1.Enabled = True Timer2.Interval = 100 Timer2.Enabled = True Form1.Hide End Sub Sub Timer1_Timer() Dim Position As POINTAPI GetCursorPos Position Ellipse GetWindowDC(0), Position.x - 7, Position.y - 7, Position.x + 5, Position.y + 5 End Sub
(f)الكود السابع والأربعون(f)
لمعرفة الإصدارة الحالية من الويندوز
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
(f)الكود الثامن والأربعون(f)
تأثير على الـ Label
Option Explicit Private Declare Function timeGetTime Lib "winmm.dll" () As Long Private Declare Function SetTextCharacterExtra Lib "gdi32" _ (ByVal hdc As Long, ByVal nCharExtra As Long) As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function OffsetRect Lib "user32" (lpRect _ As RECT, ByVal x As Long, ByVal y As Long) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc _ As Long, ByVal crColor As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As _ Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal _ crColor As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal _ hObject As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal _ nIndex As Long) As Long Private Const COLOR_BTNFACE = 15 Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _ (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal _ lpString As String, ByVal nCount As Long) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" _ (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _ lpRect As RECT, ByVal wFormat As Long) As Long Private Const DT_BOTTOM = &H8 Private Const DT_CALCRECT = &H400 Private Const DT_CENTER = &H1 Private Const DT_CHARSTREAM = 4 ' Character-stream, PLP Private Const DT_DISPFILE = 6 ' Display-file Private Const DT_EXPANDTABS = &H40 Private Const DT_EXTERNALLEADING = &H200 Private Const DT_INTERNAL = &H1000 Private Const DT_LEFT = &H0 Private Const DT_METAFILE = 5 ' Metafile, VDM Private Const DT_NOCLIP = &H100 Private Const DT_NOPREFIX = &H800 Private Const DT_PLOTTER = 0 ' Vector plotter Private Const DT_RASCAMERA = 3 ' Raster camera Private Const DT_RASDISPLAY = 1 ' Raster display Private Const DT_RASPRINTER = 2 ' Raster printer Private Const DT_RIGHT = &H2 Private Const DT_SINGLELINE = &H20 Private Const DT_TABSTOP = &H80 Private Const DT_TOP = &H0 Private Const DT_VCENTER = &H4 Private Const DT_WORDBREAK = &H10 Private Declare Function OleTranslateColor Lib "olepro32.dll" _ (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long Private Const CLR_INVALID = -1 Public Sub TextEffect(obj As Object, ByVal sText As String, _ ByVal lX As Long, ByVal lY As Long, Optional ByVal bLoop _ As Boolean = False, Optional ByVal lStartSpacing As Long = 128, _ Optional ByVal lEndSpacing As Long = -1, Optional ByVal oColor _ As OLE_COLOR = vbWindowText) Dim lhDC As Long Dim i As Long Dim x As Long Dim lLen As Long Dim hBrush As Long Static tR As RECT Dim iDir As Long Dim bNotFirstTime As Boolean Dim lTime As Long Dim lIter As Long Dim bSlowDown As Boolean Dim lCOlor As Long Dim bDoIt As Boolean lhDC = obj.hdc iDir = -1 i = lStartSpacing tR.Left = lX: tR.Top = lY: tR.Right = lX: tR.Bottom = lY OleTranslateColor oColor, 0, lCOlor hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE)) lLen = Len(sText) SetTextColor lhDC, lCOlor bDoIt = True Do While bDoIt lTime = timeGetTime If (i < -3) And Not (bLoop) And Not (bSlowDown) Then bSlowDown = True iDir = 1 lIter = (i + 4) End If If (i > 128) Then iDir = -1 If Not (bLoop) And iDir = 1 Then If (i = lEndSpacing) Then ' Stop bDoIt = False Else lIter = lIter - 1 If (lIter <= 0) Then i = i + iDir lIter = (i + 4) End If End If Else i = i + iDir End If FillRect lhDC, tR, hBrush x = 32 - (i * lLen) SetTextCharacterExtra lhDC, i DrawText lhDC, sText, lLen, tR, DT_CALCRECT tR.Right = tR.Right + 4 If (tR.Right > obj.ScaleWidth Screen.TwipsPerPixelX) Then _ tR.Right = obj.ScaleWidth Screen.TwipsPerPixelX DrawText lhDC, sText, lLen, tR, DT_LEFT obj.Refresh Do DoEvents If obj.Visible = False Then Exit Sub Loop While (timeGetTime - lTime) < 20 Loop DeleteObject hBrush End Sub Private Sub Command1_Click() Me.ScaleMode = vbTwips Me.AutoRedraw = True Call TextEffect(Me, "H e l l o!", 10, 10, False, 75) End Sub
(f)الكود التاسع والأربعون(f)
التقاط صورة للشاشة
Const RC_PALETTE As Long = &H100 Const SIZEPALETTE As Long = 104 Const RASTERCAPS As Long = 38 Private Type PALETTEENTRY peRed As Byte peGreen As Byte peBlue As Byte peFlags As Byte End Type Private Type LOGPALETTE palVersion As Integer palNumEntries As Integer palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc 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 Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID 'Fill GUID info With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With 'Fill picture info With Pic .Size = Len(Pic) ' Length of structure .Type = vbPicTypeBitmap ' Type of Picture (bitmap) .hBmp = hBmp ' Handle to bitmap .hPal = hPal ' Handle to palette (may be null) End With 'Create the picture R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic) 'Return the new picture Set CreateBitmapPicture = IPic End Function Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE 'Create a compatible device context hDCMemory = CreateCompatibleDC(hDCSrc) 'Create a compatible bitmap hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc) 'Select the compatible bitmap into our compatible device context hBmpPrev = SelectObject(hDCMemory, hBmp) 'Raster capabilities? RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster 'Does our picture use a palette? HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette 'What's the size of that palette? PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of If HasPaletteScrn And (PaletteSizeScrn = 256) Then 'Set the palette version LogPal.palVersion = &H300 'Number of palette entries LogPal.palNumEntries = 256 'Retrieve the system palette entries R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0)) 'Create the palette hPal = CreatePalette(LogPal) 'Select the palette hPalPrev = SelectPalette(hDCMemory, hPal, 0) 'Realize the palette R = RealizePalette(hDCMemory) End If 'Copy the source image to our compatible device context R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy) 'Restore the old bitmap hBmp = SelectObject(hDCMemory, hBmpPrev) If HasPaletteScrn And (PaletteSizeScrn = 256) Then 'Select the palette hPal = SelectPalette(hDCMemory, hPalPrev, 0) End If 'Delete our memory DC R = DeleteDC(hDCMemory) Set hDCToPicture = CreateBitmapPicture(hBmp, hPal) End Function Private Sub Form_Load() 'Create a picture object from the screen Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY) End Sub
(f)الكود الخمسون(f)
لإمهال النظام 60 ثانية قبل إغلاقه
' Shutdown Flags
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const SE_PRIVILEGE_ENABLED = &H2
Const TokenPrivileges = 3
Const TOKEN_ASSIGN_PRIMARY = &H1
Const TOKEN_DUPLICATE = &H2
Const TOKEN_IMPERSONATE = &H4
Const TOKEN_QUERY = &H8
Const TOKEN_QUERY_SOURCE = &H10
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_ADJUST_GROUPS = &H40
Const TOKEN_ADJUST_DEFAULT = &H80
Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Const ANYSIZE_ARRAY = 1
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Type Luid
lowpart As Long
highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
'pLuid As Luid
pLuid As LARGE_INTEGER
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Private Declare Function InitiateSystemShutdown Lib "advapi32.dll" Alias "InitiateSystemShutdownA" (ByVal lpMachineName As String, ByVal lpMessage As String, ByVal dwTimeout As Long, ByVal bForceAppsClosed As Long, ByVal bRebootAfterShutdown As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LARGE_INTEGER) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Public Function InitiateShutdownMachine(ByVal Machine As String, Optional Force As Variant, Optional Restart As Variant, Optional AllowLocalShutdown As Variant, Optional Delay As Variant, Optional Message As Variant) As Boolean
Dim hProc As Long
Dim OldTokenStuff As TOKEN_PRIVILEGES
Dim OldTokenStuffLen As Long
Dim NewTokenStuff As TOKEN_PRIVILEGES
Dim NewTokenStuffLen As Long
Dim pSize As Long
If IsMissing(Force) Then Force = False
If IsMissing(Restart) Then Restart = True
If IsMissing(AllowLocalShutdown) Then AllowLocalShutdown = False
If IsMissing(Delay) Then Delay = 0
If IsMissing(Message) Then Message = ""
'Make sure the Machine-name doesn't start with ''
If InStr(Machine, "") = 1 Then
Machine = Right(Machine, Len(Machine) - 2)
End If
'check if it's the local machine that's going to be shutdown
If (LCase(GetMyMachineName) = LCase(Machine)) Then
'may we shut this computer down?
If AllowLocalShutdown = False Then Exit Function
'open access token
If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hProc) = 0 Then
MsgBox "OpenProcessToken Error: " & GetLastError()
Exit Function
End If
'retrieve the locally unique identifier to represent the Shutdown-privilege name
If LookupPrivilegeValue(vbNullString, SE_SHUTDOWN_NAME, OldTokenStuff.Privileges(0).pLuid) = 0 Then
MsgBox "LookupPrivilegeValue Error: " & GetLastError()
Exit Function
End If
NewTokenStuff = OldTokenStuff
NewTokenStuff.PrivilegeCount = 1
NewTokenStuff.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
NewTokenStuffLen = Len(NewTokenStuff)
pSize = Len(NewTokenStuff)
'Enable shutdown-privilege
If AdjustTokenPrivileges(hProc, False, NewTokenStuff, NewTokenStuffLen, OldTokenStuff, OldTokenStuffLen) = 0 Then
MsgBox "AdjustTokenPrivileges Error: " & GetLastError()
Exit Function
End If
'initiate the system shutdown
If InitiateSystemShutdown("" & Machine, Message, Delay, Force, Restart) = 0 Then
Exit Function
End If
NewTokenStuff.Privileges(0).Attributes = 0
'Disable shutdown-privilege
If AdjustTokenPrivileges(hProc, False, NewTokenStuff, Len(NewTokenStuff), OldTokenStuff, Len(OldTokenStuff)) = 0 Then
Exit Function
End If
Else
'initiate the system shutdown
If InitiateSystemShutdown("" & Machine, Message, Delay, Force, Restart) = 0 Then
Exit Function
End If
End If
InitiateShutdownMachine = True
End Function
Function GetMyMachineName() As String
Dim sLen As Long
'create a buffer
GetMyMachineName = Space(100)
sLen = 100
'retrieve the computer name
If GetComputerName(GetMyMachineName, sLen) Then
GetMyMachineName = Left(GetMyMachineName, sLen)
End If
End Function
Private Sub Form_Load()
InitiateShutdownMachine GetMyMachineName, True, True, True, 60, "You initiated a system shutdown..."
End Sub1- مشكور على الاكواد الجديدة
2- سؤال: هل هناك طريقة لارجاع الفورم كما كانت يعني كما وضحت انت كملئ النقاط مرة اخرى ؟
3- بالنسبة للتحقق من الملف اريد فتح رسالة تسال المستخدم ان يصوت لي في موقعي وتفتح صفحى انترنيت عندها تسجل قيمة او ملف ولا تظهر هذه الرسالة للتصويت مرة اخرى لان الملف موجود ارجو ان اكون قد اوضحت الفكرة
شكرا لك (f)
Do as I say, not as I do
We are Anonymous. We are Legion. We don't forgive. We don't forget
بارك الله فيك أخ عبدالله فتحي على الجهود المبذولة
أخي العزيز (f) NOP (f) بعد التحية:
بالنسبة للكود العكسي لكود جعل الفورم شفافة:
فبداية بإمكانك إرجاعها إلى ما كانت عليه من خلال التغيير في الأرقام بالنسبة للسطرين
الموجودين في الموديول:
Const OpacityWidth As Integer = 2
Const StepSize As Integer = 4
---------------------------
بارك الله فيك أخي مختار(f)
---------------------------
أخي NOP (f)(f)(f) الكود صحيح ولا مشكلة فيه، فقط قم بتغيير السطر:
Open "c:/vote" For Input As #1
إلى:
Open "c:/vote.txt" For Input As #1
:D:D:D
بارك الله فيك اخوي بالفعل اخطائي اغلببها عدم التركيز في الكود :'( لكن ان شاء الله نتحسن يعطيك العافية
Do as I say, not as I do
We are Anonymous. We are Legion. We don't forgive. We don't forget
اخوي سؤال بالنسبة للشفافية وهي ان الكود الذي وضعته يعمل فقط مع اكس بي وليس مع 9X كما تعلم اما الكود اللي وضعته ووضعه الاخ عرفة فهو مع 9x فكيف يمكنني استغلاله لاعادة الشفافية الى الاصلية بالنسبة للفورم لانه بصراحة حاولت اكثر من طريقة وما قدرت :(
Do as I say, not as I do
We are Anonymous. We are Legion. We don't forgive. We don't forget
قم بالتغيير في الأرقام بالنسبة للسطرين الموجودين في الموديول:
Const OpacityWidth As Integer = 2
Const StepSize As Integer = 4
قراتها اخوي ما بصدق ايمت اقرا اجاباتك يا رجال :D بس ما عرفت غيرهم لاي قيمة والمشكلة اني بستخدم الكود السبق كما قلتت في موديول لاظهار الفورم شفاف عند النقر على زر طيب اريد اعادته لحالته يج ان اغير ال 4 و ال 2 وبفرض عرفت القيم تبقى مشكلة وهي يجب وضع الكود بكامله معدل في موديول جديد وتسميته باسم غير ثم وضع كود النقر على الزر في زر اخر هل هذا صحيحي ؟ اذا نعم اذا فانا اتلقى خطا :'(
Do as I say, not as I do
We are Anonymous. We are Legion. We don't forgive. We don't forget
(f)الكود الحادي والخمسون(f)
تحديد دقة عرض الشاشة
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")(f)الكود الثاني والخمسون(f)
للتجسس على لوحة المفاتيح
ضع هذا الكود في الموديول
Public Const DT_CENTER = &H1 Public Const DT_WORDBREAK = &H10 Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Any) As Long Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Global Cnt As Long, sSave As String, sOld As String, Ret As String Dim Tel As Long Function GetPressedKey() As String For Cnt = 32 To 128 'Get the keystate of a specified key If GetAsyncKeyState(Cnt) <> 0 Then GetPressedKey = Chr$(Cnt) Exit For End If Next Cnt End Function Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) Ret = GetPressedKey If Ret <> sOld Then sOld = Ret sSave = sSave + sOld End If End Sub
ضع هذا الكود في الفورم
Private Sub Form_Load() Me.Caption = "Key Spy" 'Create an API-timer SetTimer Me.hwnd, 0, 1, AddressOf TimerProc End Sub Private Sub Form_Paint() Dim R As RECT Const mStr = "Start this project, go to another application, type something, switch back to this application and unload the form. If you unload the form, a messagebox with all the typed keys will be shown." 'Clear the form Me.Cls 'API uses pixels Me.ScaleMode = vbPixels 'Set the rectangle's values SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight 'Draw the text on the form DrawTextEx Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER, ByVal 0& End Sub Private Sub Form_Resize() Form_Paint End Sub Private Sub Form_Unload(Cancel As Integer) 'Kill our API-timer KillTimer Me.hwnd, 0 'Show all the typed keys MsgBox sSave End Sub
(f)الكود الثالث والخمسون(f)
مؤثر جميل على الفورم
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
هذا الموضوع مغلق.