عباس
فهميدين نوع هارد و مقدار حافظه ان
خوب براي شروع يك فرم جديد ايجاد كرده و سپس ابزار زير را به ان اضافه كنيد
Text1
Command1
حالا كد ها زير را به قسمت كد نويسي فرمتان پيست كنيد
Private Sub Command1_Click()
Dim a, i, ii, iii, iiii
Text1.Text = " "
Set obj = GetObject("winmgmts:").InstancesOf("Win32_DiskDrive")
For Each obj2 In obj
a = obj2.Size
i = a
ii = i / 1024
iii = ii / 1024
iiii = iii / 1024
Text1.Text = Text1.Text & obj2.Caption & " - " & Left$(iiii, 5) & " GB" & ENTER
Next
End Sub
حالا برنامه را اجرا كرده و روي كامند باتون كليك كنيد
پايان
يك بازي جالب و سرگرم كننده (پازل عداد)
خوب براي ساخت اين بازي شما نياز داريد كه ابزار زير را به روي فرم بگزاريد
Label
ما به تعداد 15 تا ليبل با اندس هاي 1 تا 15 به نا م lblSquare نياز داريم
بعد از گزاشتن 15 تا ليبل كه با نام بالا گفتيم كه با انديس 1 تا 15 از هم جدا شدند نوبت
ان شده كه كپشن ليبل ها را از عدد يك تا 15 بگزاريم كه اندازه ليبل ها (طول و عرضش )
رو در پايين قرار دادم بگزاريد
Width=555
Height=555
بعد از اين كه اندازه ليبل هاي كه ساختيد را مطابق بالا انتدازه ان را درست كرديد نوبت به كد نويسي
مي رسه كد هاي زير را به قسمت كد نويسي فرمتان پيست كنيد
Option Explicit
Dim pos(16) As String
Public gametime As Long
Private Type userRecord
name As String * 20
score As String * 25
End Type
Private Const SND_APPLICATION = &H80
Private Const SND_ALIAS_ID = &H110000
Private Const SND_ASYNC = &H1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const SND_MEMORY = &H4
Private Const SND_NODEFAULT = &H2
Private Const SND_NOSTOP = &H10
Private Const SND_NOWAIT = &H2000
Private Const SND_PURGE = &H40
Private Const SND_RESOURCE = &H40004
Private Const SND_SYNC = &H0
Private Sub Form_Activate()
Call newGame
End Sub
Private Sub Form_Load()
Dim i As Integer
pos(1) = "45 30"
pos(2) = "45 645"
pos(3) = "45 1260"
pos(4) = "45 1875"
pos(5) = "645 30"
pos(6) = "645 645"
pos(7) = "645 1260"
pos(8) = "645 1875"
pos(9) = "1245 30"
pos(10) = "1245 645"
pos(11) = "1245 1260"
pos(12) = "1245 1875"
pos(13) = "1845 30"
pos(14) = "1845 645"
pos(15) = "1845 1260"
pos(16) = "1845 1875"
For i = 1 To 15
lblSquare(i).Tag = pos(i)
Next i
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim direction As String
Dim recordlength As Integer
Dim score As Long
Dim highscore As userRecord
recordlength = LenB(highscore)
If KeyCode = 37 Then direction = "left"
If KeyCode = 38 Then direction = "up"
If KeyCode = 39 Then direction = "right"
If KeyCode = 40 Then direction = "down"
Call moveSquare(direction)
If checkFinished = True Then
Open App.Path + "\highscores\highscores.dat" For Random Access Read As #1 Len = recordlength
Get #1, 5, highscore
Close #1
If gametime < formatTimeIntoSeconds(highscore.score) Then
Else
gametime = 0
End If
End If
End Sub
Public Sub moveSquare(direction As String)
Dim emptypos As Integer
Dim x() As String
emptypos = findEmptypos
If direction = "left" Then
If ((emptypos Mod 4) = 0) Then
Exit Sub
Else
x = Split(pos(emptypos))
Call swish(1, direction, findSquare(emptypos + 1), CInt(x(1)))
lblSquare(findSquare(emptypos + 1)).Tag = pos(emptypos)
End If
End If
If direction = "right" Then
If ((emptypos Mod 4) = 1) Then
Exit Sub
Else
x = Split(pos(emptypos))
Call swish(1, direction, findSquare(emptypos - 1), CInt(x(1)))
lblSquare(findSquare(emptypos - 1)).Tag = pos(emptypos)
End If
End If
If direction = "down" Then
If (emptypos < 5) Then
Exit Sub
Else
x = Split(pos(emptypos))
Call swish(1, direction, findSquare(emptypos - 4), CInt(x(0)))
lblSquare(findSquare(emptypos - 4)).Tag = pos(emptypos)
End If
End If
If direction = "up" Then
If emptypos > 12 Then
Exit Sub
Else
x = Split(pos(emptypos))
Call swish(1, direction, findSquare(emptypos + 4), CInt(x(0)))
lblSquare(findSquare(emptypos + 4)).Tag = pos(emptypos)
End If
End If
End Sub
Public Function findEmptypos() As Integer
Dim empt As Boolean
Dim i, j As Integer
For i = 1 To 16
empt = True
For j = 1 To 15
If pos(i) = lblSquare(j).Tag Then
empt = False
Exit For
End If
Next j
If empt = True Then
findEmptypos = i
Exit For
End If
Next i
End Function
Public Function findSquare(position As Integer) As Integer
Dim i As Integer
For i = 1 To 15
If pos(position) = lblSquare(i).Tag Then findSquare = i
Next i
End Function
Public Sub newGame()
Dim direction As Integer
Dim i As Integer
Dim x() As String
For i = 1 To 15
x = Split(pos(i))
lblSquare(i).Top = CInt(x(0))
lblSquare(i).Left = CInt(x(1))
lblSquare(i).Tag = pos(i)
Next i
For i = 1 To 250
direction = Int(4 * Rnd())
Select Case direction
Case 0
moveSquare ("left")
Case 1
moveSquare ("up")
Case 2
moveSquare ("right")
Case 3
moveSquare ("down")
End Select
Next i
gametime = 0
End Sub
Public Sub swish(delaytime As Integer, direction As String, square As Integer, destination_position As Integer)
If direction = "left" Or direction = "right" Then
While (lblSquare(square).Left <> destination_position)
Select Case direction
Case "left"
lblSquare(square).Left = lblSquare(square).Left - 1
Case "right"
lblSquare(square).Left = lblSquare(square).Left + 1
End Select
Wend
End If
If direction = "up" Or direction = "down" Then
While (lblSquare(square).Top <> destination_position)
Select Case direction
Case "up"
lblSquare(square).Top = lblSquare(square).Top - 1
Case "down"
lblSquare(square).Top = lblSquare(square).Top + 1
End Select
Wend
End If
End Sub
Private Sub mnuOverview_Click()
MsgBox "The whole point to this game is to get the blocks ordered from left to right by moving the blocks into empty space using all four of your arrow keys. The blocks should look the way that you see them before you press File and New game. When you do this the blocks are shuffled randomly. Enjoy!"
End Sub
Public Function formatSecondsIntoTime(game_time_seconds As Long) As String
Dim hrs, min, sec As Long
Dim result As String
hrs = -1
min = -1
sec = -1
sec = game_time_seconds
If sec >= 60 Then
min = game_time_seconds \ 60
sec = game_time_seconds Mod 60
End If
If min >= 60 Then
hrs = min \ 60
min = min Mod 60
End If
result = Trim(Str(sec)) + " sec"
If min <> -1 Then result = Trim(Str(min)) + " min " + result
If hrs <> -1 Then result = Trim(Str(hrs)) + " hrs " + result
formatSecondsIntoTime = result
End Function
Public Function formatTimeIntoSeconds(game_time_string As String) As Long
Dim x() As String
Dim i, result As Long
x = Split(game_time_string)
For i = UBound(x) To LBound(x) Step -1
If x(i) = "sec" Then result = result + CLng(x(i - 1))
If x(i) = "min" Then result = result + CLng(x(i - 1)) * 60
If x(i) = "hrs" Then result = result + CLng(x(i - 1)) * 3600
Next i
formatTimeIntoSeconds = result
End Function
Public Function checkFinished() As Boolean
Dim i As Integer
checkFinished = True
For i = 1 To 15
If pos(i) <> lblSquare(i).Tag Then
checkFinished = False
Exit For
End If
Next i
End Function
پايان
ساخت يك اسكرين سيور زيبا
براي ساختن ان يك فرم جديد ايجاد كرده و كد هاي زير را در قسمت كد نويسي فرم پيست كنيد
Dim CircleRadius As Byte
Dim X As Integer
Dim Y As Integer
Dim Num As Integer
Dim NewXStep As Integer
Dim NewYStep As Integer
Dim MyCurrentColor As Long
Dim TwoColorPattern As Boolean
Dim StopRun As Boolean
Private Sub ChangeColor()
MyCurrentColor = FillColor
anewChange:
FillColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255): If FillColor = MyCurrentColor Then GoTo anewChange
End Sub
Private Sub Pattern_Change()
Me.Cls
Call ChangeColor
X = 0: Y = 0
Num = Num + 1: If Num = 197 Then Num = 1: CircleRadius = CInt(Rnd * 74 + 11)
With StepArray(Num)
NewXStep = .xStep: NewYStep = .yStep
End With
End Sub
Private Sub CreateArray()
Dim i As Integer
Dim nX As Byte
Dim nY As Byte
For nX = 9 To 22
For nY = 9 To 22
i = i + 1
Next
Next
End Sub
Private Sub Radius_Decrease()
StopRun = True
Me.Cls
CircleRadius = CircleRadius - 1
If CircleRadius < 8 Then CircleRadius = 8: Beep
Circle (Me.ScaleWidth \ 2, Me.ScaleHeight \ 2), _
CircleRadius, QBColor(Rnd * 14 + 1)
End Sub
Private Sub Radius_Increase()
StopRun = True
Me.Cls
CircleRadius = CircleRadius + 1
If CircleRadius > 100 Then CircleRadius = 100: Beep
Circle (Me.ScaleWidth \ 2, Me.ScaleHeight \ 2), _
CircleRadius, QBColor(Rnd * 14 + 1)
End Sub
Private Sub RunMe()
Do Until StopRun = True
X = X + NewXStep: Y = Y + NewYStep
If TwoColorPattern = True Then FillColor = vbWhite - FillColor
Circle (X, Y), CircleRadius, FillColor
If X < 0 Or X > Me.ScaleWidth Then NewXStep = -NewXStep
If Y < 0 Or Y > Me.ScaleHeight Then NewYStep = -NewYStep
If X < 0 And Y < 0 Then
Call ChangeColor
Circle (X, Y), CircleRadius, FillColor
End If
DoEvents
Loop
End Sub
Private Sub VarRefresh()
X = 0: Y = 0
NewXStep = Abs(NewXStep): NewYStep = Abs(NewYStep)
Me.Cls
End Sub
Private Sub Form_Activate()
Me.BackColor = vbBlack
Me.ScaleMode = 3
Call RunMe
End Sub
Private Sub Form_Click()
End
End Sub
Private Sub Form_Initialize()
Me.WindowState = vbMaximized
X = 0: Y = 0
NewXStep = 14: NewYStep = 14
CircleRadius = 40
Call CreateArray
End Sub
حالا برنامه را اجرا كنيد جالب بود نه نه نه نه ...
پايان
خوب چطور عكسي را با درگ كردن( گشيدن و رها كردن ) درون picture box قرار دهيم
شما براي اين كه بتوانيد با درگ كردن عكسي را درون picture box بگزاريد به ابزار
زير نياز داريد
Picture1
خوب ابزار picturebox را روي فرم گزاشته و كد هاي زير را به قسمت كد نويسي فرمتان
پيست كنيد
Private Sub Form_Load()
Picture1.OLEDropMode = vbOLEDropManual
End Sub
Private Sub Picture1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo OLEDragDropErrors
ReDim GpxFiles(Data.Files.Count)
For I = 1 To Data.Files.Count
GpxFiles(I) = Data.Files(I)
Next
If Data.Files.Count > 1 Then
cmdNextGpx.Visible = True
GpxCount = 2
End If
Picture1.Picture = LoadPicture(Data.Files(1))
Caption = "QikViewer - 1 of " & Data.Files.Count & " " & GpxFiles(1)
Exit Sub
OLEDragDropErrors:
Select Case Err
Case 481
MsgBox "Invalid Picture", vbOKOnly, "Error! " & Err & " " & GpxFiles(1)
Case Else
MsgBox Err & " - " & Error, vbOKOnly, "ERROR!"
End Select
End Sub
خوب حالا برنامه را اجرا كرده و يك عكس را با درگ كردن روي picture box بگزاريد
پايان
ساخت يك اسكرين سيور زيباي ديگه
خوب براي اين كار ما به يك timer نياز داريم ابزار زير را روي فرم بگزاريد
Timer1
خوب حالا كد هاي زير را به قسمت كد نويسي فرمتان پيست كنيد
Option Explicit
Dim Terminate As Integer
Private Sub Angle()
Dim pPoint As Pt, Ang As Currency, Obj As Currency
Dim LLen As Currency, i As Currency
Dim pStart As Pt, j As Long
Dim Cur As Integer, Degrees As Integer
Ang = 30
pPoint = SetValues(ScaleWidth / 2, ScaleHeight / 2 - SHeight / 2)
pStart = pPoint
LLen = Cosine(Ang) * SHeight
If AutoClear Then Cls
Do
If Terminate Then
Terminate = False
Exit Sub
End If
Cur = Cur + 1
Degrees = Sets(Cur).Degrees
LLen = Cosine(Degrees) * Sets(Cur).Length
If Cur >= UBound(Sets) - 1 Then Cur = 0
DoEvents
i = Cosine(Ang) * LLen
Obj = Sine(Ang) * LLen
Line (pPoint.X, pPoint.Y)-(pPoint.X + Obj, pPoint.Y + i)
pPoint = SetValues(pPoint.X + Obj, pPoint.Y + i)
Ang = Ang + Abs(Degrees + 180)
If Ang > 360 Then Ang = Ang - 360
j = j + 1
If j > (360 * UBound(Sets)) Then Exit Sub
Loop Until IsSimilar(pPoint, pStart)
End Sub
Private Function IsSimilar(Point1 As Pt, Point2 As Pt) As Boolean
IsSimilar = Abs(ScaleX(Point1.Y, 1, 3) - ScaleX(Point2.Y, 1, 3)) < 2 And Abs(ScaleX(Point1.X, 1, 3) - ScaleX(Point2.X, 1, 3)) < 2
End Function
Private Function MakeRandom() As AngData
MakeRandom.Degrees = Rnd * 360
MakeRandom.Length = Rnd * (UBound(Sets) * -30) + 5030
End Function
Sub RandomSets()
Dim i As Integer
For i = 1 To UBound(Sets)
Sets(i) = MakeRandom
Next i
End Sub
Function RandomElement() As Integer
RandomElement = Int(Rnd * 150) + 105
End Function
Private Sub Form_Load()
Timer1.Interval = 10
End Sub
Private Sub Timer1_Timer()
NextPhase
End Sub
Sub NextPhase()
ForeColor = RGB(RandomElement, RandomElement, RandomElement)
RandomSets
Angle
End Sub
خوب كار ما تموم نشده حالا يك فرم از نوع Module1 بسازيد و كد هاي زير را به ماژولتان اضافه كنيد
Option Explicit
Public Type AngData
Degrees As Integer
Length As Long
End Type
Public Type Pt
X As Currency
Y As Currency
End Type
Const pi = 3.14159265358979
Public AutoClear As Boolean
Public Sets() As AngData
Public SHeight As Long
Sub Main()
Randomize Timer
SetNum (3)
form1.Show
End Sub
Public Function SetValues(X As Long, Y As Long) As Pt
SetValues.X = X
SetValues.Y = Y
End Function
Sub SetNum(NewNum As Integer)
ReDim Sets(1 To NewNum)
End Sub
Public Function Sine(ByVal i As Double) As Double
Sine = Sin(i * (pi / 180))
End Function
Public Function Cosine(ByVal i As Double) As Double
Cosine = Cos(i * (pi / 180))
End Function
Public Function ISine(ByVal i As Double) As Double
On Error Resume Next
ISine = 90
ISine = Atn(-i / Sqr(-i * i + 1)) + 2 * Atn(1) * 180 / pi
End Function
Public Function ICosine(ByVal i As Double) As Double
ICosine = Atn(-i / Sqr(-i * i + 1)) + 2 * Atn(1) * 180 / pi
End Function
حالا برنامه را اجرا كنيد
پايان
چطور يك عكس را تبديل به فايل pdf كنيم .. منظورم اين كه يك عكي را را وارد فايل pdf كنيم
براي اين كار كه كاملا كاربردي بوده و حتما انجام اين پروژه را به شما توصيه مي كنم
قبلااز هر كاري اگه چاپگر داريد كه هيچ در قير ايم صورت يك چاپگر مجازي را براي خودتان نصب كنيد
حالا ابزار زير را روي فرمتان بگزاريد
Picture1
بعد از گزاشتن عكس در picturebox كد هاي زير را به قسمت كد نويسي فركتان كپي كنيد
Private Sub Picture1_Click()
Screen.MousePointer = vbHourglass
Printer.PaintPicture Picture1.Picture, 0, 0
Printer.EndDoc
Screen.MousePointer = vbDefault
End Sub
حالا برنامه را اجرا كنيد و روي picture1 كليك كنيد حالا يك پنجره براي ذخيره عكس
با پسوند pdf باز مي شود كه مسير انتخاب كنيد ونامي براي فالتان و ذخيره كنيد
پايان
بدست اوردن اطلاعاتي كامل در باره كامپيوتري كه داريد باهاش كار مي كنيد ميدونم چند تا برنامه
براي اين كار من قبلا گزاشتم ولي اين برنامه فرق داره و اطا عات خوبي و كاربردي رو بهتون مي ده
براي اين كار ايزار زير را روي فرم بگزاريد
Text1
قبل از هر كاري دو خاصيت textbox تان را مانند زير تقيير دهيد
Scrollbar=2
Multiline=tru
حالا نوبت كد نويسي رسيد خوب كد هاي زير را به قسمت كد نويسي فرمتان پيست كنيد
Option Explicit
'-------------------------------------------------------------------------------------
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
'-------------------------------------------------------------------------------------
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
'-------------------------------------------------------------------------------------
Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
'-------------------------------------------------------------------------------------
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
'-------------------------------------------------------------------------------------
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
'-------------------------------------------------------------------------------------
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 ' Maintenance string for PSS usage
End Type
'Windows version constants
Private Const WIN_VER_MAJ_9XNT4 = 4 'Windows 95/98/ME/NT4
Private Const WIN_VER_MAJ_NT3 = 3 'Windows NT3
Private Const WIN_VER_MAJ_2KXP = 5 'Windows NT5
Private Const WIN_VER_MIN_95 = 0 'Win95 minor
Private Const WIN_VER_MIN_98 = 10 'Win98 minor
Private Const WIN_VER_MIN_ME = 90 'WinME minor
Private Const WIN_VER_MIN_NT3 = 51 'WinNT3.51 minor
Private Const WIN_VER_MIN_NT4 = 0 'WinNT4 minor
Private Const WIN_VER_MIN_2K = 0 'Win2k minor
Private Const WIN_VER_MIN_XP = 1 'WinXP(Whistler) minor
'Platform ID
Private Const VER_PLATFORM_WIN32s = 0 'Win32s
Private Const VER_PLATFORM_WIN32_WINDOWS = 1 'Windows 9x
Private Const VER_PLATFORM_WIN32_NT = 2 'Windows NT
'-------------------------------------------------------------------------------------
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias _
"GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
'-------------------------------------------------------------------------------------
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Public Enum enuDriveType
DRIVE_UNKNOWN = 0
DRIVE_NO_ROOT_DIR = 1
DRIVE_REMOVABLE = 2 'floppy
DRIVE_FIXED = 3 ' hard disk
DRIVE_REMOTE = 4 ' network drive
DRIVE_CDROM = 5
DRIVE_RAMDISK = 6
End Enum
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
'-------------------------------------------------------------------------------------
Private Declare Function GetTickCount Lib "kernel32" () As Long
'-------------------------------------------------------------------------------------
Public Enum enuStartup
Normal = 0
Safe = 1
SafeWithNetwork = 2
End Enum
Private Const SM_CXSCREEN = 0 ' Width of screen
Private Const SM_CYSCREEN = 1 ' Height of screen
Private Const SM_CXFULLSCREEN = 16 ' Width of window client area
Private Const SM_CYFULLSCREEN = 17 ' Height of window client area
Private Const SM_CYMENU = 15 ' Height of menu
Private Const SM_CYCAPTION = 4 ' Height of caption or title
Private Const SM_CXFRAME = 32 ' Width of window frame
Private Const SM_CYFRAME = 33 ' Height of window frame
Private Const SM_CXHSCROLL = 21 ' Width of arrow bitmap on horizontal scroll bar
Private Const SM_CYHSCROLL = 3 ' Height of arrow bitmap on horizontal scroll bar
Private Const SM_CXVSCROLL = 2 ' Width of arrow bitmap on vertical scroll bar
Private Const SM_CYVSCROLL = 20 ' Height of arrow bitmap on vertical scroll bar
Private Const SM_CXSIZE = 30 ' Width of bitmaps in title bar
Private Const SM_CYSIZE = 31 ' Height of bitmaps in title bar
Private Const SM_CXCURSOR = 13 ' Width of cursor
Private Const SM_CYCURSOR = 14 ' Height of cursor
Private Const SM_CXBORDER = 5 ' Width of window frame that cannot be sized
Private Const SM_CYBORDER = 6 ' Height of window frame that cannot be sized
Private Const SM_CXDOUBLECLICK = 36 ' Width of rectangle around the location of the first click. The
' second click must occur in the same rectangular location.
Private Const SM_CYDOUBLECLICK = 37 ' Height of rectangle around the location of the first click. The
' second click must occur in the same rectangular location.
Private Const SM_CXDLGFRAME = 7 ' Width of dialog frame window
Private Const SM_CYDLGFRAME = 8 ' Height of dialog frame window
Private Const SM_CXICON = 11 ' Width of icon
Private Const SM_CYICON = 12 ' Height of icon
Private Const SM_CXICONSPACING = 38 ' Width of rectangles the system uses to position tiled icons
Private Const SM_CYICONSPACING = 39 ' Height of rectangles the system uses to position tiled icons
Private Const SM_CXMIN = 28 ' Minimum width of window
Private Const SM_CYMIN = 29 ' Minimum height of window
Private Const SM_CXMINTRACK = 34 ' Minimum tracking width of window
Private Const SM_CYMINTRACK = 35 ' Minimum tracking height of window
Private Const SM_CXHTHUMB = 10 ' Width of scroll box (thumb) on horizontal scroll bar
Private Const SM_CYVTHUMB = 9 ' Width of scroll box (thumb) on vertical scroll bar
Private Const SM_DBCSENABLED = 42 ' Returns a non-zero if the current Windows version uses double-byte
' characters, otherwise returns zero
Private Const SM_DEBUG = 22 ' Returns non-zero if the Windows version is a debugging version
Private Const SM_MENUDROPALIGNMENT = 40
' Alignment of pop-up menus. If zero, left side is aligned with
' corresponding left side of menu-bar item. If non-zero, left side
' is aligned with right side of corresponding menu bar item
Private Const SM_MOUSEPRESENT = 19 ' Non-zero if mouse hardware is installed
Private Const SM_PENWINDOWS = 41 ' Handle of Pen Windows dynamic link library if Pen Windows is
' installed
Private Const SM_SWAPBUTTON = 23 ' Non-zero if the left and right mouse buttons are swapped
Private Const SM_CMOUSEBUTTONS = 43 'Number of mouse buttons
Private Const SM_CLEANBOOT = 67 'How did machine boot
Private Const SM_MOUSEWHEELPRESENT = 75
'Is there a mousewheel?
Private Const SM_SHOWSOUNDS = 70 'Show visual feedback for sounds?
Private Const SM_NETWORK = 63 'Network present if LSB <> 0
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'-------------------------------------------------------------------------------------
' Reg Key Security Options...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' Reg Key ROOT Types...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_DWORD = 4 ' 32-bit number
Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'-------------------------------------------------------------------------------------
Private Function GetNetworked() As String
Dim lngL As Long
lngL = GetSystemMetrics(SM_NETWORK)
If lngL <> 0 Then
GetNetworked = "Network present = yes" + vbCrLf
Else
GetNetworked = "Network present = nos" + vbCrLf
End If
End Function
Private Function GetLastBootState() As String
Dim lngL As Long
lngL = GetSystemMetrics(SM_CLEANBOOT)
Select Case lngL
Case Normal
GetLastBootState = "Started in normal mode" + vbCrLf
Case Safe
GetLastBootState = "Started in safe mode" + vbCrLf
Case SafeWithNetwork
GetLastBootState = "Started in safe mode with network" + vbCrLf
Case Else
GetLastBootState = "Started in unknown operating mode" + vbCrLf
End Select
End Function
Private Function GetWinVer() As String
Dim strTemp As String
Dim osInfo As OSVERSIONINFO
Dim lngL As Long
'Preset the size of the structure
osInfo.dwOSVersionInfoSize = Len(osInfo)
lngL = GetVersionEx(osInfo)
If lngL <> 0 Then
Select Case osInfo.dwMajorVersion
Case WIN_VER_MAJ_9XNT4
If osInfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
'Windows 9x Kernel, figure out which edition
If osInfo.dwMinorVersion = WIN_VER_MIN_95 Then
strTemp = "Windows95 "
ElseIf osInfo.dwMinorVersion = WIN_VER_MIN_98 Then
strTemp = "Windows98 "
ElseIf osInfo.dwMinorVersion = WIN_VER_MIN_ME Then
strTemp = "Windows ME "
Else
strTemp = "Unknown Windows 9x system "
End If
Else
'NT4 kernel
If osInfo.dwMinorVersion = WIN_VER_MIN_NT4 Then
strTemp = "Windows NT 4 "
Else
strTemp = "Unknown NT 4-based version "
End If
End If
Case WIN_VER_MAJ_NT3
strTemp = "Windows NT 3." & osInfo.dwMinorVersion & " "
Case WIN_VER_MAJ_2KXP
If osInfo.dwMinorVersion = WIN_VER_MIN_2K Then
strTemp = "Windows 2000 "
ElseIf osInfo.dwMinorVersion = WIN_VER_MIN_XP Then
strTemp = "Windows XP (Whistler) "
Else
strTemp = "Unknown Windows NT 5 system "
End If
Case Else
strTemp = "Unknown Windows system"
End Select
'Get service pack level information
strTemp = strTemp + StripNullTerminator(osInfo.szCSDVersion) + vbCrLf
strTemp = strTemp + "Windows Version Number = " + CStr(osInfo.dwMajorVersion) + "." _
+ CStr(osInfo.dwMinorVersion) + "." + CStr(osInfo.dwBuildNumber) + vbCrLf
Else
strTemp = "Unable to get version information. GetVersionEx returned " + lngL + vbCrLf
End If
GetWinVer = strTemp
End Function
Private Function GetWinDir() As String
Dim boolRetVal As Boolean
Dim lpBuffer As String
Dim nSize As Long
lpBuffer = Space(255)
nSize = 254
boolRetVal = GetWindowsDirectory(lpBuffer, nSize)
GetWinDir = "Windows Directory = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetSysDir() As String
Dim boolRetVal As Boolean
Dim lpBuffer As String
Dim nSize As Long
lpBuffer = Space(255)
nSize = 254
boolRetVal = GetSystemDirectory(lpBuffer, nSize)
GetSysDir = "System Directory = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetCompName() As String
Dim boolRetVal As Boolean
Dim lpBuffer As String
Dim nSize As Long
lpBuffer = Space(255)
nSize = 254
boolRetVal = GetComputerName(lpBuffer, nSize)
GetCompName = "Computer Name = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetDomainName() As String
Dim lpBuffer As String
Dim nSize As Long
Dim lngRetVal As Long
lpBuffer = Space(255)
nSize = 254
lngRetVal = GetEnvironmentVariable("USERDOMAIN", lpBuffer, nSize)
GetDomainName = "Domain Name = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetDriveInfo(strDrive As String) As String
Dim lpSectorsPerCluster As Long
Dim lpBytesPerSector As Long
Dim lpNumberOfFreeClusters As Long
Dim lpTotalNumberOfClusters As Long
Dim lpRetVal As Long
Dim strDriveType As String
Dim lpBuffer As String
Dim nSize As Long
Dim lngL As Long
Dim lpBytesPerCluster As Long
Dim lpDriveSize As Long
Dim lpDriveFreeSpace As Long
lpRetVal = GetDriveType(strDrive)
Select Case lpRetVal
Case DRIVE_UNKNOWN
strDriveType = "Drive type unknown"
Case DRIVE_NO_ROOT_DIR
strDriveType = "Drive has no root directory"
Case DRIVE_REMOVABLE
strDriveType = "Floppy / removable drive"
Case DRIVE_FIXED
strDriveType = "Fixed hard drive"
Case DRIVE_REMOTE
strDriveType = "Network drive: "
'now get the mapped network drive
lpBuffer = Space(255)
nSize = 254
lngL = WNetGetConnection(Left(strDrive, 2), lpBuffer, nSize)
strDriveType = strDriveType + StripNullTerminator(lpBuffer)
Case DRIVE_CDROM
strDriveType = "CD-ROM drive"
Case DRIVE_RAMDISK
strDriveType = "RAM disk"
Case Else
strDriveType = "Unknown device"
End Select
lpRetVal = GetDiskFreeSpace(strDrive, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
lpBytesPerCluster = lpBytesPerSector * lpSectorsPerCluster
lpDriveSize = lpBytesPerCluster * (lpTotalNumberOfClusters / 1024) / 1024
lpDriveFreeSpace = lpBytesPerCluster * (lpNumberOfFreeClusters / 1024) / 1024
If lpRetVal = 1 And lpDriveSize > 0 Then
GetDriveInfo = strDrive + " drive - " + strDriveType + vbCrLf _
+ vbTab + "Drive Size = " + CStr(lpDriveSize) + " MB" + vbCrLf _
+ vbTab + "Free Space = " + CStr(lpDriveFreeSpace) + " MB" + vbCrLf + vbCrLf
Else
GetDriveInfo = ""
End If
End Function
Private Function GetLogonServer() As String
Dim lpBuffer As String
Dim nSize As Long
Dim lngRetVal As Long
lpBuffer = Space(255)
nSize = 254
lngRetVal = GetEnvironmentVariable("LOGONSERVER", lpBuffer, nSize)
GetLogonServer = "Logon Server Name = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetMemoryInfo() As String
Dim msMemory As MEMORYSTATUS
Dim lngTotalPhys As Long
Dim lngAvailPhys As Long
Dim lngTotalPageFile As Long
Dim lngAvailPageFile As Long
Dim lngTotalVirtual As Long
Dim lngAvailVirtual As Long
GlobalMemoryStatus msMemory
lngTotalPhys = msMemory.dwTotalPhys / 1024 * (1 / 1024)
lngAvailPhys = msMemory.dwAvailPhys / 1024 * (1 / 1024)
lngTotalPageFile = msMemory.dwTotalPageFile / 1024 * (1 / 1024)
lngAvailPageFile = msMemory.dwAvailPageFile / 1024 * (1 / 1024)
lngTotalVirtual = msMemory.dwTotalPageFile / 1024 * (1 / 1024)
lngAvailVirtual = msMemory.dwAvailPageFile / 1024 * (1 / 1024)
GetMemoryInfo = "Memory Status:" + vbCrLf _
+ vbTab + "Total RAM = " + CStr(lngTotalPhys) + "MB" + vbCrLf _
+ vbTab + "Available RAM = " + CStr(lngAvailPhys) + "MB" + vbCrLf _
+ vbTab + "Total PageFile = " + CStr(lngTotalPageFile) + "MB" + vbCrLf _
+ vbTab + "Available PageFile = " + CStr(lngAvailPageFile) + "MB" + vbCrLf _
+ vbTab + "Total Virtual Memory = " + CStr(lngTotalVirtual) + "MB" + vbCrLf _
+ vbTab + "Available Virtual Memory = " + CStr(lngAvailVirtual) + "MB" + vbCrLf
End Function
Private Function GetTimeSinceReboot()
'Returns the time since the machine was last restarted in format h:m:s
Dim h As Long
Dim m As Long
Dim s As Long
Dim l As Long
l = GetTickCount()
'GetTickCount returns number of milliseconds since last restart. divide by 1000 for seconds and convert to hours
l = l / 1000
'use integer division so we don't get rounding problems
h = l \ 3600
'Number of minutes over the hour
m = (l - (h * 3600)) \ 60
'Number of seconds over the minute
s = l - (h * 3600 + m * 60)
GetTimeSinceReboot = "Hours since reboot = " + Format(h, "00") + ":" & Format(m, "00") _
+ ":" + Format(s, "00") + vbCrLf
End Function
Private Function GetUName() As String
Dim lngRetVal As Long
Dim lpBuffer As String
Dim nSize As Long
lpBuffer = Space(255)
nSize = 254
lngRetVal = GetUserName(lpBuffer, nSize)
GetUName = "User Name = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Sub Form_Load()
Dim i As Integer
Text1.Text = Text1.Text + GetUName
Text1.Text = Text1.Text + GetCompName
Text1.Text = Text1.Text + GetNetworked
Text1.Text = Text1.Text + GetDomainName
Text1.Text = Text1.Text + GetLogonServer
Text1.Text = Text1.Text + GetTimeSinceReboot
Text1.Text = Text1.Text + GetLastBootState
Text1.Text = Text1.Text + vbCrLf
Text1.Text = Text1.Text + GetWinVer
Text1.Text = Text1.Text + GetWinDir
Text1.Text = Text1.Text + GetSysDir
Text1.Text = Text1.Text + vbCrLf
Text1.Text = Text1.Text + GetMemoryInfo
Text1.Text = Text1.Text + vbCrLf
'scan all drive alphabets from A to Z
For i = 1 To 26
Text1.Text = Text1.Text + GetDriveInfo(Chr(Asc("A") + i - 1) + ":\")
Next i
End Sub
Private Function StripNullTerminator(lpBuffer As String) As String
Dim i As Integer
For i = 1 To 255
If Asc(Mid(lpBuffer, i, 1)) = 0 Then
lpBuffer = Left(lpBuffer, i - 1)
Exit For
End If
Next i
StripNullTerminator = lpBuffer
End Function
Public Sub StartSysInfo()
On Error GoTo SysInfoErr
Dim rc As Long
Dim SysInfoPath As String
' Try To Get System Info Program Path\Name From Registry...
If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
' Try To Get System Info Program Path Only From Registry...
ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
' Validate Existance Of Known 32 Bit File Version
If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
' Error - File Can Not Be Found...
Else
GoTo SysInfoErr
End If
' Error - Registry Entry Can Not Be Found...
Else
GoTo SysInfoErr
End If
Call Shell(SysInfoPath, vbNormalFocus)
Exit Sub
SysInfoErr:
MsgBox "System Information Is Unavailable At This Time", vbOKOnly
End Sub
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
Dim i As Long ' Loop Counter
Dim rc As Long ' Return Code
Dim hKey As Long ' Handle To An Open Registry Key
Dim hDepth As Long '
Dim KeyValType As Long ' Data Type Of A Registry Key
Dim tmpVal As String ' Tempory Storage For A Registry Key Value
Dim KeyValSize As Long ' Size Of Registry Key Variable
'------------------------------------------------------------
' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error...
tmpVal = String$(1024, 0) ' Allocate Variable Space
KeyValSize = 1024 ' Mark Variable Size
'------------------------------------------------------------
' Retrieve Registry Key Value...
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors
If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 Adds Null Terminated String...
tmpVal = Left(tmpVal, KeyValSize - 1) ' Null Found, Extract From String
Else ' WinNT Does NOT Null Terminate String...
tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found, Extract String Only
End If
'------------------------------------------------------------
' Determine Key Value Type For Conversion...
'------------------------------------------------------------
Select Case KeyValType ' Search Data Types...
Case REG_SZ ' String Registry Key Data Type
KeyVal = tmpVal ' Copy String Value
Case REG_DWORD ' Double Word Registry Key Data Type
For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char.
Next
KeyVal = Format$("&h" + KeyVal) ' Convert Double Word To String
End Select
GetKeyValue = True ' Return Success
rc = RegCloseKey(hKey) ' Close Registry Key
Exit Function ' Exit
GetKeyError: ' Cleanup After An Error Has Occured...
KeyVal = "" ' Set Return Val To Empty String
GetKeyValue = False ' Return Failure
rc = RegCloseKey(hKey) ' Close Registry Key
End Function
حالا برنامه را اجرا كنيد
پايان
حال گيري با موس
يادتونه كه يك پروژه به نام حركت توپ نوشتم اين همون كار رو با موس طرف
انجام مي ده كه باعث عصاب داغون كني و حتي به انوان يك اسكرين سيور و حتي در ويروس
نويسي كاربرد داره
خوب ابزار زير را روي فرم بگزاريد
Timer1
حالا كد زير را به قسمت كد نويسي فرمتان پيست كنيد
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Dim xx As Integer
Dim yy As Integer
Dim a As Integer
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim sh As Integer
Dim sw As Integer
Private Sub Form_Load()
Timer1.Interval = 1
xx = Rnd * 10 + 1
yy = Rnd * 10 + 1
End Sub
Private Sub Timer1_Timer()
Dim pp As POINTAPI
GetCursorPos pp
sh = (Screen.Height / 15) - 1
sw = (Screen.Width / 15) - 1
If pp.x <= 0 Then xx = -xx
If pp.x >= sw Then xx = -xx
If pp.y <= 0 Then yy = -yy
If pp.y >= sh Then yy = -yy
DoEvents
pp.x = pp.x + xx
pp.y = pp.y + yy
SetCursorPos pp.x, pp.y
s1 = Left(s, l)
l = l + 1
If l >= Len(s) + 3 Then
l = 1
s1 = ""
End If
End Sub
حالا برنامه را اجرا كنيد مي بينيد كه موس شما شروع به حركت در امده و با برخورد به ديواره هاي
مانيتور برمي گردد براي خلاص شذه از ان دكمه هاي زير را فشار دهيد
Ctrl + pause break
پايان
بدست اوردن اطلاعات كامل در باره بيوس ( bios ) احتمالا اين پروژه مورد استفاده خيلي از شما
خواهد بود
ابزار زير را به روي فرم تان بگزاريد
Combo1
Label1
حالا كد هاي زير را به قسمت كد نويسي فرمتان پيست كنيد
Dim BD As Class1
Private Sub Combo1_Click()
Select Case Combo1.ListIndex
Case 0
Label1 = BD.SystemBiosDate
Case 1
Label1.Caption = BD.SystemBiosVersion
Case 2
Label1 = BD.SystemBiosCopyRight
Case 3
Label1 = BD.SystemBiosExtraInfo
Case 4
Label1 = BD.VideoBiosDate
Case 5
Label1 = BD.VideoBiosVersion
Case 6
Label1 = BD.VideoBiosCopyRight
End Select
End Sub
Private Sub Form_Load()
Caption = "Bios Information"
Set BD = New Class1
With Combo1
.AddItem "SystemBiosDate"
.AddItem "SystemBiosVersion"
.AddItem "SystemBiosCopyRight"
.AddItem "SystemBiosExtraInfo"
.AddItem "VideoBiosDate"
.AddItem "VideoBiosVersion"
.AddItem "VideoBiosCopyRight"
End With
Combo1.ListIndex = 0
End Sub
حالا يك ماژول ( Module1 ( ايجاد كرده و كد هاي زير را به ان اضافه كنيد
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 Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function CopyStringA Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
Public Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)
Private Const KEY_READ = &H20019
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_MULTI_SZ = 7
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_SUCCESS = 0&
Private Const MAX_SIZE = 2048
Public Const HKLM = &H80000002
Public Function IsWindowsNT() As Boolean
Dim verinfo As OSVERSIONINFO
verinfo.dwOSVersionInfoSize = Len(verinfo)
If (GetVersionEx(verinfo)) = 0 Then Exit Function
If verinfo.dwPlatformId = 2 Then IsWindowsNT = True
End Function
Public Function StrFromPtrA(ByVal lpszA As Long) As String
Dim s As String
s = String(lstrlenA(lpszA), Chr$(0))
CopyStringA s, ByVal lpszA
StrFromPtrA = TrimNULL(s)
End Function
Private Function TrimNULL(ByVal str As String) As String
If InStr(str, Chr$(0)) > 0& Then
TrimNULL = Left$(str, InStr(str, Chr$(0)) - 1&)
Else
TrimNULL = str
End If
End Function
Public Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
Exit Function
End If
length = MAX_SIZE
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
If retVal = ERROR_MORE_DATA Then
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
End If
Select Case valueType
Case REG_DWORD
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_SZ, REG_EXPAND_SZ
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
GetRegistryValue = resString
Case REG_BINARY
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
Case REG_MULTI_SZ
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else
RegCloseKey handle
End Select
RegCloseKey handle
End Function
حالا يك كلاس ( Class1 ) ايجاد كرده و كد هاي زير را به ان اضافه كنيد
Dim isNT As Boolean
Public Property Get VideoBiosDate() As String
If isNT Then
VideoBiosDate = GetRegistryValue(HKLM, "Hardware\Description\System", "VideoBiosDate", "")
Else
' VideoBiosDate = Mid(StrFromPtrA(&HC00A8), 1, 8) '-Date build
VideoBiosDate = Mid(StrFromPtrA(&HC00A8), 9, 8) '-Date revision
End If
End Property
Public Property Get VideoBiosVersion() As String
Dim s As String
If isNT Then
s = GetRegistryValue(HKLM, "Hardware\Description\System", "VideoBiosVersion", "")
Else
s = StrFromPtrA(&HC0048)
s = Left(s, InStr(1, s, vbCrLf) - 1)
s = s & vbCrLf & "ChipType: " & GetRegistryValue(HKLM, "System\CurrentControlSet\Services\Class\Display\0000\INFO", "ChipType", "")
End If
VideoBiosVersion = s
End Property
Public Property Get VideoBiosCopyRight() As String
Dim s As String
If isNT Then
s = "Unavailable on NT"
Else
s = StrFromPtrA(&HC0048)
s = Mid$(s, InStr(1, s, vbCrLf) + 2)
End If
VideoBiosCopyRight = s
End Property
Public Property Get SystemBiosDate() As String
If isNT Then
SystemBiosDate = GetRegistryValue(HKLM, "Hardware\Description\System", "SystemBiosDate", "")
Else
SystemBiosDate = StrFromPtrA(&HFFFF5)
End If
End Property
Public Property Get SystemBiosCopyRight() As String
If isNT Then
SystemBiosCopyRight = "Unvailable on NT"
Else
SystemBiosCopyRight = StrFromPtrA(&HFE091)
End If
End Property
Public Property Get SystemBiosVersion() As String
Dim vAns As Variant
If isNT Then
On Error Resume Next
SystemBiosVersion = CDate(GetRegistryValue(HKLM, "Hardware\Description\System", "SystemBiosVersion", ""))
If Err.Number > 0 Then SystemBiosVersion = "Unavailable"
Else
SystemBiosVersion = StrFromPtrA(&HFE061)
End If
End Property
Public Property Get SystemBiosExtraInfo() As String
If isNT Then
SystemBiosExtraInfo = "Unvailable on NT"
Else
SystemBiosExtraInfo = StrFromPtrA(&HFEC71)
End If
End Property
Private Sub Class_Initialize()
isNT = IsWindowsNT
End Sub
يك كم كد ها زياد شد اما به مي عرضه خوب حالا برنامه را اجرا كنيد و براي بدست اورد
اطلاعات در باره هر بخش بايوس از ليست combo1 استفاده كنيد و اطلاعات رو در
ليبلي كه ساختيد ببينيد
پايان
روش تبديل تاريخ هجرى شمسى به ميلادى
روز مورد نظر اگر بين اول فروردين تا يازدهم دى ماه باشد، عدد (621) و اگر بين يازدهم ديماه تا پايان اسفند باشد عدد (622) را به سال شمسى مى افزائيم تا سال ميلادى به دست آيد.
مثال :22 بهمن 1357 سال پيروزى انقلاب شكوهمند اسلامى ايران مطابق است با 1979ميلادى .1979 622 + 1357
نكته قابل توجه اينكه روزهاى ماههاى هجرى شمسى و ميلادى در تمام سالها ثابت است و هيچگاه تغيير نمى كند. بنابراين هميشه 22 بهمن با 11 فوريه ، اول فروردين با 21 مارس مطابق است . همچنين اول ماه مى روز جهانى كارگر با 11 ارديبهشت ، و اول ژانويه با 11 دى مصادف است .
براى تبديل تاريخ ميلادى به هجرى شمسى كافى است اگر روز مورد نظر بين اول ژانويه تا 21 مارس باشد، عدد 622، و اگر بين 22 مارس تا پايان دسامبر باشد، عدد 621 را از سال ميلادى كسر كنيم . مثلاً ششم آگوست 1945 ميلادى روز بمباران اتمى هيروشيما مطابق با 15 مرداد سال 1324 مى باشد.
1324 621 1945
همچنين 11 نوامبر سال 1918 ميلادى روز پايان جنگاول جهانى با 20 آبان سال 1297 ه ش . مطابقت دارد.1297 621 – 1
خوب پايين يك چيزاي نوشتم كه ريطي به وب لاگ من نداره مثل يك زنگ تفريح براي وبلاگ است
چطور عمليات رياضي رو تو word انجام دهيم
مثلا وقتي نوشتيم 10 + 10 جواب به ما بده 20 ا اين كار را با word مي خواهيم انجام دهيم
نرم افزار Word را اجرا کنید.
از منوی Tools بر روی Customize کلیک کنید.
در پنجره جدید به تب Commands بروید.
اکنون یک پنجره دارای 2 ستون خواهید داشت. از ستون Tools ، Category را پیدا کرده و آن را انتخاب کنید. از ستون دیگر ، Tools Calculate را پیدا کنید (جزء موارد آخر). اکنون Tools Calculate را گرفته و آن را در جای مناسبی از نوار ابزار بالای صفحه رها کنید. ( Drog & Drop ) .
پس از اینکه دکمه Tools Calculate در جای مناسبی از نوار ابزار جای گرفت ، پنجره Customize را ببندید.
حال در یک صفحه خالی Word ، به عنوان مثال دو عدد را این گونه بنویسید:
253
+
789
هر عدد با یک Enter از خطی بعدی جدا گردد. عملگر ریاضی هم مابین دو خط عدد جای گیرد.
یا دو عدد را پشت سر هم و به شکل زیر وارد کنید:
253 + 789
اکنون این 3سه خط را با موس بگیرید و به حالت انتخاب درآورید ( Highlight کنید ) ، بر روی دکمه Tools Calculate که ایجاد کردید ، کلیک کنید.
سپس در خط بعدی ، دکمه Ctrl+V را همزمان فشار دهید تا نمایان شود.
فشرده كرد نو و ساخت ستاپ با ابزار مخفي خود ويندوز
بدین منظور از Start به Run رفته و در آن عبارت IEXPRESS را تايپ كرده و Enter را بزنيد . خواهید دید که برنامه باز خواهد شد .
براي اين كار در پنجره باز شده گزينه Creat new self extraction directive file را انتخاب كرده ، next را بزنيد . گزينه Extract Files Only را انتخاب كرده ، مجدد Next كنيد . در اين مرحله يك نام را براي عنوان بسته ايجاد شده تايپ كنيد و دكمه Next را بزنيد .
حال اگر بخواهيد هنگام نصب بسته ، كاربر با پيغامي مواجه شده و پس از تاييد آن بسته را نصب كند ، مي توانيد اين پيغام را در كادر Prompt User With وارد كنيد . در غير اينصورت No Prompt را برگزيده ، Next را بزنيد .
اگر مي خواهيد قبل از نصب يك توافق نامه براي كاربر نمايش داده شود ، Display a License را فعال كرده و فايل مربوطه را جستجو كنيد . ( اين فايل را بايستي قبلا ايجاد كرده باشيد اين كار را مي توانيد در يك محيط متني انجام دهيد . ) در غير اينصورت Do Not Display a License را انتخاب و Next كنيد .
در اين مرحله با زدن دكمه Add فايلي را كه مي خواهيد فشرده شود انتخاب كنيد . سپس دكمه Next را بزنيد . در قسمت بعد مشخص مي كنيد كه برنامه نصب ، چگونه نمايش داده شود . با انتخاب Default آن را به حال خود رها كرده و Next كنيد .
اگر مي خواهيد پس از نصب پيغامي براي كاربر نمايش داده شود ، آن را در كادر Display Message وارد كنيد . و گر نه No Message و سپس Next را بزنيد .
حال يك مسير و يك نام براي بسته بر گزينيد . با زدنNext مسير فعلي را براي ذخيره قبول كرده و دو بار Next را بزنيد تا فشرده سازي آغاز شود .
در پايان Finish را كليك كنيد .
اكنون مي توانيد به محل تعيين شده رفته و بسته را مشاهده كنيد . همچنين با گرفتن Properties از فايل فشرده شده و فايل اوليه مي توانيد تغيير حجم آن ها را مشاهده كنيد .حتي مي توانيد براحتي اين بسته را به كامپيوتر هاي ديگر منتقل كنيد . براي نصب كافيست بر روي آن دابل كليك كرده و مسير قرار گرفتن آن را پس از نصب تعيين كنيد .
يكي از پروژه هاي كه بچه هاي دانشجو حتما بايد انجام دهند چاپ پرچم ايران با استفاده از
زبان اسمبلي است كه دهنشونو سرويس كرده منم گفتم به اسمبلي كار ها يك حالي بديم
چاپ پرچم ایران و حرکت کلمه الله در بالا و پایین پرچم
اينم كد هاي ان به زبان اسمبلي
paint macro nrow,frow,fcol,erow,ecol,attribute
mov ah,6h
mov al,nrow
mov ch,frow
mov cl,fcol
mov dh,erow
mov dl,ecol
mov bh,attribute
int 10h
endm
;-------------------------------------------------
xy macro row,col
mov ah,2h
mov dh,row
mov dl,col
mov bh,0
int 10h
endm
;-------------------------------------------------
print macro msg
mov ah,9
lea dx,msg
int 21h
endm
;-------------------------------------------------
finish macro
mov ax,4c00h
int 21h
endm
;-------------------------------------------------
.model small
.data
;-------------------------------------------------
msg db 'A',70h,'l',70h,'l',70h,'a',70h,'h',70h,' ',70h
last db ?
;-------------------------------------------------
msg1 db ' w $'
msg2 db '((|))$'
msg3 db ' ^ $'
;-------------------------------------------------
.code
main proc
mov ax,@data
mov ds,ax
;*******clear
paint 25,0,0,24,79,00h
;*******green
paint 5,5,20,5,58,20h
;*******White
paint 5,10,20,10,58,70h
;*******red
paint 5,15,20,15,58,40h
xy 11,37
print msg1
xy 12,37
print msg2
xy 13,37
print msg3
mov ax,0b800h
mov es,ax
mov cx,2000
lea si,msg
mov di,1640
up: mov ax,[si]
mov [es:di],ax
mov [es:di+640],ax
mov ah,1
int 16h
jnz fin
add si,2
add di,2
cmp si,offset last
jne down1
mov si,offset msg
down1: cmp di,1718
jb up
mov di,1640
jmp up
fin: xy 25,0
paint 25,0,0,24,79,00h
finish
main endp
end main
پايان
با يك ترفند ساده شما مي توانيد تمامي عكس هاي كه در وب لاگ من يا هر وب لاگي وجود داره
رو به صورت خيلي زيبا به پرواز در اوريد اين كد ها جاوا است
براي اين كار فقط كافي كد هاي پايين را در نوار ادرس بالاي مرورگر تون كپي پيست كنيد اول
نوار ادرش رو پاك كنيد بعد كدهاي زير را به ان پيست كنيد
javascript:R=0; x1=.1; y1=.05; x2=.25; y2=.24; x3=1.6; y3=.24; x4=300; y4=200; x5=300; y5=200; DI=document.images; DIL=DI.length; function A(){for(i=0; i-DIL; i++){DIS=DI[ i ].style; DIS.position='absolute'; DIS.left=Math.sin(R*x1+i*x2+x3)*x4+x5; DIS.top=Math.cos(R*y1+i*y2+y3)*y4+y5}R++}setInterval('A()',5);
قسنگ نه
پايان
خوب براي شروع يك فرم جديد ايجاد كرده و سپس ابزار زير را به ان اضافه كنيد
Text1
Command1
حالا كد ها زير را به قسمت كد نويسي فرمتان پيست كنيد
Private Sub Command1_Click()
Dim a, i, ii, iii, iiii
Text1.Text = " "
Set obj = GetObject("winmgmts:").InstancesOf("Win32_DiskDrive")
For Each obj2 In obj
a = obj2.Size
i = a
ii = i / 1024
iii = ii / 1024
iiii = iii / 1024
Text1.Text = Text1.Text & obj2.Caption & " - " & Left$(iiii, 5) & " GB" & ENTER
Next
End Sub
حالا برنامه را اجرا كرده و روي كامند باتون كليك كنيد
پايان
يك بازي جالب و سرگرم كننده (پازل عداد)
خوب براي ساخت اين بازي شما نياز داريد كه ابزار زير را به روي فرم بگزاريد
Label
ما به تعداد 15 تا ليبل با اندس هاي 1 تا 15 به نا م lblSquare نياز داريم
بعد از گزاشتن 15 تا ليبل كه با نام بالا گفتيم كه با انديس 1 تا 15 از هم جدا شدند نوبت
ان شده كه كپشن ليبل ها را از عدد يك تا 15 بگزاريم كه اندازه ليبل ها (طول و عرضش )
رو در پايين قرار دادم بگزاريد
Width=555
Height=555
بعد از اين كه اندازه ليبل هاي كه ساختيد را مطابق بالا انتدازه ان را درست كرديد نوبت به كد نويسي
مي رسه كد هاي زير را به قسمت كد نويسي فرمتان پيست كنيد
Option Explicit
Dim pos(16) As String
Public gametime As Long
Private Type userRecord
name As String * 20
score As String * 25
End Type
Private Const SND_APPLICATION = &H80
Private Const SND_ALIAS_ID = &H110000
Private Const SND_ASYNC = &H1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const SND_MEMORY = &H4
Private Const SND_NODEFAULT = &H2
Private Const SND_NOSTOP = &H10
Private Const SND_NOWAIT = &H2000
Private Const SND_PURGE = &H40
Private Const SND_RESOURCE = &H40004
Private Const SND_SYNC = &H0
Private Sub Form_Activate()
Call newGame
End Sub
Private Sub Form_Load()
Dim i As Integer
pos(1) = "45 30"
pos(2) = "45 645"
pos(3) = "45 1260"
pos(4) = "45 1875"
pos(5) = "645 30"
pos(6) = "645 645"
pos(7) = "645 1260"
pos(8) = "645 1875"
pos(9) = "1245 30"
pos(10) = "1245 645"
pos(11) = "1245 1260"
pos(12) = "1245 1875"
pos(13) = "1845 30"
pos(14) = "1845 645"
pos(15) = "1845 1260"
pos(16) = "1845 1875"
For i = 1 To 15
lblSquare(i).Tag = pos(i)
Next i
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim direction As String
Dim recordlength As Integer
Dim score As Long
Dim highscore As userRecord
recordlength = LenB(highscore)
If KeyCode = 37 Then direction = "left"
If KeyCode = 38 Then direction = "up"
If KeyCode = 39 Then direction = "right"
If KeyCode = 40 Then direction = "down"
Call moveSquare(direction)
If checkFinished = True Then
Open App.Path + "\highscores\highscores.dat" For Random Access Read As #1 Len = recordlength
Get #1, 5, highscore
Close #1
If gametime < formatTimeIntoSeconds(highscore.score) Then
Else
gametime = 0
End If
End If
End Sub
Public Sub moveSquare(direction As String)
Dim emptypos As Integer
Dim x() As String
emptypos = findEmptypos
If direction = "left" Then
If ((emptypos Mod 4) = 0) Then
Exit Sub
Else
x = Split(pos(emptypos))
Call swish(1, direction, findSquare(emptypos + 1), CInt(x(1)))
lblSquare(findSquare(emptypos + 1)).Tag = pos(emptypos)
End If
End If
If direction = "right" Then
If ((emptypos Mod 4) = 1) Then
Exit Sub
Else
x = Split(pos(emptypos))
Call swish(1, direction, findSquare(emptypos - 1), CInt(x(1)))
lblSquare(findSquare(emptypos - 1)).Tag = pos(emptypos)
End If
End If
If direction = "down" Then
If (emptypos < 5) Then
Exit Sub
Else
x = Split(pos(emptypos))
Call swish(1, direction, findSquare(emptypos - 4), CInt(x(0)))
lblSquare(findSquare(emptypos - 4)).Tag = pos(emptypos)
End If
End If
If direction = "up" Then
If emptypos > 12 Then
Exit Sub
Else
x = Split(pos(emptypos))
Call swish(1, direction, findSquare(emptypos + 4), CInt(x(0)))
lblSquare(findSquare(emptypos + 4)).Tag = pos(emptypos)
End If
End If
End Sub
Public Function findEmptypos() As Integer
Dim empt As Boolean
Dim i, j As Integer
For i = 1 To 16
empt = True
For j = 1 To 15
If pos(i) = lblSquare(j).Tag Then
empt = False
Exit For
End If
Next j
If empt = True Then
findEmptypos = i
Exit For
End If
Next i
End Function
Public Function findSquare(position As Integer) As Integer
Dim i As Integer
For i = 1 To 15
If pos(position) = lblSquare(i).Tag Then findSquare = i
Next i
End Function
Public Sub newGame()
Dim direction As Integer
Dim i As Integer
Dim x() As String
For i = 1 To 15
x = Split(pos(i))
lblSquare(i).Top = CInt(x(0))
lblSquare(i).Left = CInt(x(1))
lblSquare(i).Tag = pos(i)
Next i
For i = 1 To 250
direction = Int(4 * Rnd())
Select Case direction
Case 0
moveSquare ("left")
Case 1
moveSquare ("up")
Case 2
moveSquare ("right")
Case 3
moveSquare ("down")
End Select
Next i
gametime = 0
End Sub
Public Sub swish(delaytime As Integer, direction As String, square As Integer, destination_position As Integer)
If direction = "left" Or direction = "right" Then
While (lblSquare(square).Left <> destination_position)
Select Case direction
Case "left"
lblSquare(square).Left = lblSquare(square).Left - 1
Case "right"
lblSquare(square).Left = lblSquare(square).Left + 1
End Select
Wend
End If
If direction = "up" Or direction = "down" Then
While (lblSquare(square).Top <> destination_position)
Select Case direction
Case "up"
lblSquare(square).Top = lblSquare(square).Top - 1
Case "down"
lblSquare(square).Top = lblSquare(square).Top + 1
End Select
Wend
End If
End Sub
Private Sub mnuOverview_Click()
MsgBox "The whole point to this game is to get the blocks ordered from left to right by moving the blocks into empty space using all four of your arrow keys. The blocks should look the way that you see them before you press File and New game. When you do this the blocks are shuffled randomly. Enjoy!"
End Sub
Public Function formatSecondsIntoTime(game_time_seconds As Long) As String
Dim hrs, min, sec As Long
Dim result As String
hrs = -1
min = -1
sec = -1
sec = game_time_seconds
If sec >= 60 Then
min = game_time_seconds \ 60
sec = game_time_seconds Mod 60
End If
If min >= 60 Then
hrs = min \ 60
min = min Mod 60
End If
result = Trim(Str(sec)) + " sec"
If min <> -1 Then result = Trim(Str(min)) + " min " + result
If hrs <> -1 Then result = Trim(Str(hrs)) + " hrs " + result
formatSecondsIntoTime = result
End Function
Public Function formatTimeIntoSeconds(game_time_string As String) As Long
Dim x() As String
Dim i, result As Long
x = Split(game_time_string)
For i = UBound(x) To LBound(x) Step -1
If x(i) = "sec" Then result = result + CLng(x(i - 1))
If x(i) = "min" Then result = result + CLng(x(i - 1)) * 60
If x(i) = "hrs" Then result = result + CLng(x(i - 1)) * 3600
Next i
formatTimeIntoSeconds = result
End Function
Public Function checkFinished() As Boolean
Dim i As Integer
checkFinished = True
For i = 1 To 15
If pos(i) <> lblSquare(i).Tag Then
checkFinished = False
Exit For
End If
Next i
End Function
پايان
ساخت يك اسكرين سيور زيبا
براي ساختن ان يك فرم جديد ايجاد كرده و كد هاي زير را در قسمت كد نويسي فرم پيست كنيد
Dim CircleRadius As Byte
Dim X As Integer
Dim Y As Integer
Dim Num As Integer
Dim NewXStep As Integer
Dim NewYStep As Integer
Dim MyCurrentColor As Long
Dim TwoColorPattern As Boolean
Dim StopRun As Boolean
Private Sub ChangeColor()
MyCurrentColor = FillColor
anewChange:
FillColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255): If FillColor = MyCurrentColor Then GoTo anewChange
End Sub
Private Sub Pattern_Change()
Me.Cls
Call ChangeColor
X = 0: Y = 0
Num = Num + 1: If Num = 197 Then Num = 1: CircleRadius = CInt(Rnd * 74 + 11)
With StepArray(Num)
NewXStep = .xStep: NewYStep = .yStep
End With
End Sub
Private Sub CreateArray()
Dim i As Integer
Dim nX As Byte
Dim nY As Byte
For nX = 9 To 22
For nY = 9 To 22
i = i + 1
Next
Next
End Sub
Private Sub Radius_Decrease()
StopRun = True
Me.Cls
CircleRadius = CircleRadius - 1
If CircleRadius < 8 Then CircleRadius = 8: Beep
Circle (Me.ScaleWidth \ 2, Me.ScaleHeight \ 2), _
CircleRadius, QBColor(Rnd * 14 + 1)
End Sub
Private Sub Radius_Increase()
StopRun = True
Me.Cls
CircleRadius = CircleRadius + 1
If CircleRadius > 100 Then CircleRadius = 100: Beep
Circle (Me.ScaleWidth \ 2, Me.ScaleHeight \ 2), _
CircleRadius, QBColor(Rnd * 14 + 1)
End Sub
Private Sub RunMe()
Do Until StopRun = True
X = X + NewXStep: Y = Y + NewYStep
If TwoColorPattern = True Then FillColor = vbWhite - FillColor
Circle (X, Y), CircleRadius, FillColor
If X < 0 Or X > Me.ScaleWidth Then NewXStep = -NewXStep
If Y < 0 Or Y > Me.ScaleHeight Then NewYStep = -NewYStep
If X < 0 And Y < 0 Then
Call ChangeColor
Circle (X, Y), CircleRadius, FillColor
End If
DoEvents
Loop
End Sub
Private Sub VarRefresh()
X = 0: Y = 0
NewXStep = Abs(NewXStep): NewYStep = Abs(NewYStep)
Me.Cls
End Sub
Private Sub Form_Activate()
Me.BackColor = vbBlack
Me.ScaleMode = 3
Call RunMe
End Sub
Private Sub Form_Click()
End
End Sub
Private Sub Form_Initialize()
Me.WindowState = vbMaximized
X = 0: Y = 0
NewXStep = 14: NewYStep = 14
CircleRadius = 40
Call CreateArray
End Sub
حالا برنامه را اجرا كنيد جالب بود نه نه نه نه ...
پايان
خوب چطور عكسي را با درگ كردن( گشيدن و رها كردن ) درون picture box قرار دهيم
شما براي اين كه بتوانيد با درگ كردن عكسي را درون picture box بگزاريد به ابزار
زير نياز داريد
Picture1
خوب ابزار picturebox را روي فرم گزاشته و كد هاي زير را به قسمت كد نويسي فرمتان
پيست كنيد
Private Sub Form_Load()
Picture1.OLEDropMode = vbOLEDropManual
End Sub
Private Sub Picture1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo OLEDragDropErrors
ReDim GpxFiles(Data.Files.Count)
For I = 1 To Data.Files.Count
GpxFiles(I) = Data.Files(I)
Next
If Data.Files.Count > 1 Then
cmdNextGpx.Visible = True
GpxCount = 2
End If
Picture1.Picture = LoadPicture(Data.Files(1))
Caption = "QikViewer - 1 of " & Data.Files.Count & " " & GpxFiles(1)
Exit Sub
OLEDragDropErrors:
Select Case Err
Case 481
MsgBox "Invalid Picture", vbOKOnly, "Error! " & Err & " " & GpxFiles(1)
Case Else
MsgBox Err & " - " & Error, vbOKOnly, "ERROR!"
End Select
End Sub
خوب حالا برنامه را اجرا كرده و يك عكس را با درگ كردن روي picture box بگزاريد
پايان
ساخت يك اسكرين سيور زيباي ديگه
خوب براي اين كار ما به يك timer نياز داريم ابزار زير را روي فرم بگزاريد
Timer1
خوب حالا كد هاي زير را به قسمت كد نويسي فرمتان پيست كنيد
Option Explicit
Dim Terminate As Integer
Private Sub Angle()
Dim pPoint As Pt, Ang As Currency, Obj As Currency
Dim LLen As Currency, i As Currency
Dim pStart As Pt, j As Long
Dim Cur As Integer, Degrees As Integer
Ang = 30
pPoint = SetValues(ScaleWidth / 2, ScaleHeight / 2 - SHeight / 2)
pStart = pPoint
LLen = Cosine(Ang) * SHeight
If AutoClear Then Cls
Do
If Terminate Then
Terminate = False
Exit Sub
End If
Cur = Cur + 1
Degrees = Sets(Cur).Degrees
LLen = Cosine(Degrees) * Sets(Cur).Length
If Cur >= UBound(Sets) - 1 Then Cur = 0
DoEvents
i = Cosine(Ang) * LLen
Obj = Sine(Ang) * LLen
Line (pPoint.X, pPoint.Y)-(pPoint.X + Obj, pPoint.Y + i)
pPoint = SetValues(pPoint.X + Obj, pPoint.Y + i)
Ang = Ang + Abs(Degrees + 180)
If Ang > 360 Then Ang = Ang - 360
j = j + 1
If j > (360 * UBound(Sets)) Then Exit Sub
Loop Until IsSimilar(pPoint, pStart)
End Sub
Private Function IsSimilar(Point1 As Pt, Point2 As Pt) As Boolean
IsSimilar = Abs(ScaleX(Point1.Y, 1, 3) - ScaleX(Point2.Y, 1, 3)) < 2 And Abs(ScaleX(Point1.X, 1, 3) - ScaleX(Point2.X, 1, 3)) < 2
End Function
Private Function MakeRandom() As AngData
MakeRandom.Degrees = Rnd * 360
MakeRandom.Length = Rnd * (UBound(Sets) * -30) + 5030
End Function
Sub RandomSets()
Dim i As Integer
For i = 1 To UBound(Sets)
Sets(i) = MakeRandom
Next i
End Sub
Function RandomElement() As Integer
RandomElement = Int(Rnd * 150) + 105
End Function
Private Sub Form_Load()
Timer1.Interval = 10
End Sub
Private Sub Timer1_Timer()
NextPhase
End Sub
Sub NextPhase()
ForeColor = RGB(RandomElement, RandomElement, RandomElement)
RandomSets
Angle
End Sub
خوب كار ما تموم نشده حالا يك فرم از نوع Module1 بسازيد و كد هاي زير را به ماژولتان اضافه كنيد
Option Explicit
Public Type AngData
Degrees As Integer
Length As Long
End Type
Public Type Pt
X As Currency
Y As Currency
End Type
Const pi = 3.14159265358979
Public AutoClear As Boolean
Public Sets() As AngData
Public SHeight As Long
Sub Main()
Randomize Timer
SetNum (3)
form1.Show
End Sub
Public Function SetValues(X As Long, Y As Long) As Pt
SetValues.X = X
SetValues.Y = Y
End Function
Sub SetNum(NewNum As Integer)
ReDim Sets(1 To NewNum)
End Sub
Public Function Sine(ByVal i As Double) As Double
Sine = Sin(i * (pi / 180))
End Function
Public Function Cosine(ByVal i As Double) As Double
Cosine = Cos(i * (pi / 180))
End Function
Public Function ISine(ByVal i As Double) As Double
On Error Resume Next
ISine = 90
ISine = Atn(-i / Sqr(-i * i + 1)) + 2 * Atn(1) * 180 / pi
End Function
Public Function ICosine(ByVal i As Double) As Double
ICosine = Atn(-i / Sqr(-i * i + 1)) + 2 * Atn(1) * 180 / pi
End Function
حالا برنامه را اجرا كنيد
پايان
چطور يك عكس را تبديل به فايل pdf كنيم .. منظورم اين كه يك عكي را را وارد فايل pdf كنيم
براي اين كار كه كاملا كاربردي بوده و حتما انجام اين پروژه را به شما توصيه مي كنم
قبلااز هر كاري اگه چاپگر داريد كه هيچ در قير ايم صورت يك چاپگر مجازي را براي خودتان نصب كنيد
حالا ابزار زير را روي فرمتان بگزاريد
Picture1
بعد از گزاشتن عكس در picturebox كد هاي زير را به قسمت كد نويسي فركتان كپي كنيد
Private Sub Picture1_Click()
Screen.MousePointer = vbHourglass
Printer.PaintPicture Picture1.Picture, 0, 0
Printer.EndDoc
Screen.MousePointer = vbDefault
End Sub
حالا برنامه را اجرا كنيد و روي picture1 كليك كنيد حالا يك پنجره براي ذخيره عكس
با پسوند pdf باز مي شود كه مسير انتخاب كنيد ونامي براي فالتان و ذخيره كنيد
پايان
بدست اوردن اطلاعاتي كامل در باره كامپيوتري كه داريد باهاش كار مي كنيد ميدونم چند تا برنامه
براي اين كار من قبلا گزاشتم ولي اين برنامه فرق داره و اطا عات خوبي و كاربردي رو بهتون مي ده
براي اين كار ايزار زير را روي فرم بگزاريد
Text1
قبل از هر كاري دو خاصيت textbox تان را مانند زير تقيير دهيد
Scrollbar=2
Multiline=tru
حالا نوبت كد نويسي رسيد خوب كد هاي زير را به قسمت كد نويسي فرمتان پيست كنيد
Option Explicit
'-------------------------------------------------------------------------------------
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
'-------------------------------------------------------------------------------------
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
'-------------------------------------------------------------------------------------
Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
'-------------------------------------------------------------------------------------
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
'-------------------------------------------------------------------------------------
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
'-------------------------------------------------------------------------------------
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 ' Maintenance string for PSS usage
End Type
'Windows version constants
Private Const WIN_VER_MAJ_9XNT4 = 4 'Windows 95/98/ME/NT4
Private Const WIN_VER_MAJ_NT3 = 3 'Windows NT3
Private Const WIN_VER_MAJ_2KXP = 5 'Windows NT5
Private Const WIN_VER_MIN_95 = 0 'Win95 minor
Private Const WIN_VER_MIN_98 = 10 'Win98 minor
Private Const WIN_VER_MIN_ME = 90 'WinME minor
Private Const WIN_VER_MIN_NT3 = 51 'WinNT3.51 minor
Private Const WIN_VER_MIN_NT4 = 0 'WinNT4 minor
Private Const WIN_VER_MIN_2K = 0 'Win2k minor
Private Const WIN_VER_MIN_XP = 1 'WinXP(Whistler) minor
'Platform ID
Private Const VER_PLATFORM_WIN32s = 0 'Win32s
Private Const VER_PLATFORM_WIN32_WINDOWS = 1 'Windows 9x
Private Const VER_PLATFORM_WIN32_NT = 2 'Windows NT
'-------------------------------------------------------------------------------------
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias _
"GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
'-------------------------------------------------------------------------------------
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Public Enum enuDriveType
DRIVE_UNKNOWN = 0
DRIVE_NO_ROOT_DIR = 1
DRIVE_REMOVABLE = 2 'floppy
DRIVE_FIXED = 3 ' hard disk
DRIVE_REMOTE = 4 ' network drive
DRIVE_CDROM = 5
DRIVE_RAMDISK = 6
End Enum
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
'-------------------------------------------------------------------------------------
Private Declare Function GetTickCount Lib "kernel32" () As Long
'-------------------------------------------------------------------------------------
Public Enum enuStartup
Normal = 0
Safe = 1
SafeWithNetwork = 2
End Enum
Private Const SM_CXSCREEN = 0 ' Width of screen
Private Const SM_CYSCREEN = 1 ' Height of screen
Private Const SM_CXFULLSCREEN = 16 ' Width of window client area
Private Const SM_CYFULLSCREEN = 17 ' Height of window client area
Private Const SM_CYMENU = 15 ' Height of menu
Private Const SM_CYCAPTION = 4 ' Height of caption or title
Private Const SM_CXFRAME = 32 ' Width of window frame
Private Const SM_CYFRAME = 33 ' Height of window frame
Private Const SM_CXHSCROLL = 21 ' Width of arrow bitmap on horizontal scroll bar
Private Const SM_CYHSCROLL = 3 ' Height of arrow bitmap on horizontal scroll bar
Private Const SM_CXVSCROLL = 2 ' Width of arrow bitmap on vertical scroll bar
Private Const SM_CYVSCROLL = 20 ' Height of arrow bitmap on vertical scroll bar
Private Const SM_CXSIZE = 30 ' Width of bitmaps in title bar
Private Const SM_CYSIZE = 31 ' Height of bitmaps in title bar
Private Const SM_CXCURSOR = 13 ' Width of cursor
Private Const SM_CYCURSOR = 14 ' Height of cursor
Private Const SM_CXBORDER = 5 ' Width of window frame that cannot be sized
Private Const SM_CYBORDER = 6 ' Height of window frame that cannot be sized
Private Const SM_CXDOUBLECLICK = 36 ' Width of rectangle around the location of the first click. The
' second click must occur in the same rectangular location.
Private Const SM_CYDOUBLECLICK = 37 ' Height of rectangle around the location of the first click. The
' second click must occur in the same rectangular location.
Private Const SM_CXDLGFRAME = 7 ' Width of dialog frame window
Private Const SM_CYDLGFRAME = 8 ' Height of dialog frame window
Private Const SM_CXICON = 11 ' Width of icon
Private Const SM_CYICON = 12 ' Height of icon
Private Const SM_CXICONSPACING = 38 ' Width of rectangles the system uses to position tiled icons
Private Const SM_CYICONSPACING = 39 ' Height of rectangles the system uses to position tiled icons
Private Const SM_CXMIN = 28 ' Minimum width of window
Private Const SM_CYMIN = 29 ' Minimum height of window
Private Const SM_CXMINTRACK = 34 ' Minimum tracking width of window
Private Const SM_CYMINTRACK = 35 ' Minimum tracking height of window
Private Const SM_CXHTHUMB = 10 ' Width of scroll box (thumb) on horizontal scroll bar
Private Const SM_CYVTHUMB = 9 ' Width of scroll box (thumb) on vertical scroll bar
Private Const SM_DBCSENABLED = 42 ' Returns a non-zero if the current Windows version uses double-byte
' characters, otherwise returns zero
Private Const SM_DEBUG = 22 ' Returns non-zero if the Windows version is a debugging version
Private Const SM_MENUDROPALIGNMENT = 40
' Alignment of pop-up menus. If zero, left side is aligned with
' corresponding left side of menu-bar item. If non-zero, left side
' is aligned with right side of corresponding menu bar item
Private Const SM_MOUSEPRESENT = 19 ' Non-zero if mouse hardware is installed
Private Const SM_PENWINDOWS = 41 ' Handle of Pen Windows dynamic link library if Pen Windows is
' installed
Private Const SM_SWAPBUTTON = 23 ' Non-zero if the left and right mouse buttons are swapped
Private Const SM_CMOUSEBUTTONS = 43 'Number of mouse buttons
Private Const SM_CLEANBOOT = 67 'How did machine boot
Private Const SM_MOUSEWHEELPRESENT = 75
'Is there a mousewheel?
Private Const SM_SHOWSOUNDS = 70 'Show visual feedback for sounds?
Private Const SM_NETWORK = 63 'Network present if LSB <> 0
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'-------------------------------------------------------------------------------------
' Reg Key Security Options...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' Reg Key ROOT Types...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_DWORD = 4 ' 32-bit number
Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'-------------------------------------------------------------------------------------
Private Function GetNetworked() As String
Dim lngL As Long
lngL = GetSystemMetrics(SM_NETWORK)
If lngL <> 0 Then
GetNetworked = "Network present = yes" + vbCrLf
Else
GetNetworked = "Network present = nos" + vbCrLf
End If
End Function
Private Function GetLastBootState() As String
Dim lngL As Long
lngL = GetSystemMetrics(SM_CLEANBOOT)
Select Case lngL
Case Normal
GetLastBootState = "Started in normal mode" + vbCrLf
Case Safe
GetLastBootState = "Started in safe mode" + vbCrLf
Case SafeWithNetwork
GetLastBootState = "Started in safe mode with network" + vbCrLf
Case Else
GetLastBootState = "Started in unknown operating mode" + vbCrLf
End Select
End Function
Private Function GetWinVer() As String
Dim strTemp As String
Dim osInfo As OSVERSIONINFO
Dim lngL As Long
'Preset the size of the structure
osInfo.dwOSVersionInfoSize = Len(osInfo)
lngL = GetVersionEx(osInfo)
If lngL <> 0 Then
Select Case osInfo.dwMajorVersion
Case WIN_VER_MAJ_9XNT4
If osInfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
'Windows 9x Kernel, figure out which edition
If osInfo.dwMinorVersion = WIN_VER_MIN_95 Then
strTemp = "Windows95 "
ElseIf osInfo.dwMinorVersion = WIN_VER_MIN_98 Then
strTemp = "Windows98 "
ElseIf osInfo.dwMinorVersion = WIN_VER_MIN_ME Then
strTemp = "Windows ME "
Else
strTemp = "Unknown Windows 9x system "
End If
Else
'NT4 kernel
If osInfo.dwMinorVersion = WIN_VER_MIN_NT4 Then
strTemp = "Windows NT 4 "
Else
strTemp = "Unknown NT 4-based version "
End If
End If
Case WIN_VER_MAJ_NT3
strTemp = "Windows NT 3." & osInfo.dwMinorVersion & " "
Case WIN_VER_MAJ_2KXP
If osInfo.dwMinorVersion = WIN_VER_MIN_2K Then
strTemp = "Windows 2000 "
ElseIf osInfo.dwMinorVersion = WIN_VER_MIN_XP Then
strTemp = "Windows XP (Whistler) "
Else
strTemp = "Unknown Windows NT 5 system "
End If
Case Else
strTemp = "Unknown Windows system"
End Select
'Get service pack level information
strTemp = strTemp + StripNullTerminator(osInfo.szCSDVersion) + vbCrLf
strTemp = strTemp + "Windows Version Number = " + CStr(osInfo.dwMajorVersion) + "." _
+ CStr(osInfo.dwMinorVersion) + "." + CStr(osInfo.dwBuildNumber) + vbCrLf
Else
strTemp = "Unable to get version information. GetVersionEx returned " + lngL + vbCrLf
End If
GetWinVer = strTemp
End Function
Private Function GetWinDir() As String
Dim boolRetVal As Boolean
Dim lpBuffer As String
Dim nSize As Long
lpBuffer = Space(255)
nSize = 254
boolRetVal = GetWindowsDirectory(lpBuffer, nSize)
GetWinDir = "Windows Directory = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetSysDir() As String
Dim boolRetVal As Boolean
Dim lpBuffer As String
Dim nSize As Long
lpBuffer = Space(255)
nSize = 254
boolRetVal = GetSystemDirectory(lpBuffer, nSize)
GetSysDir = "System Directory = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetCompName() As String
Dim boolRetVal As Boolean
Dim lpBuffer As String
Dim nSize As Long
lpBuffer = Space(255)
nSize = 254
boolRetVal = GetComputerName(lpBuffer, nSize)
GetCompName = "Computer Name = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetDomainName() As String
Dim lpBuffer As String
Dim nSize As Long
Dim lngRetVal As Long
lpBuffer = Space(255)
nSize = 254
lngRetVal = GetEnvironmentVariable("USERDOMAIN", lpBuffer, nSize)
GetDomainName = "Domain Name = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetDriveInfo(strDrive As String) As String
Dim lpSectorsPerCluster As Long
Dim lpBytesPerSector As Long
Dim lpNumberOfFreeClusters As Long
Dim lpTotalNumberOfClusters As Long
Dim lpRetVal As Long
Dim strDriveType As String
Dim lpBuffer As String
Dim nSize As Long
Dim lngL As Long
Dim lpBytesPerCluster As Long
Dim lpDriveSize As Long
Dim lpDriveFreeSpace As Long
lpRetVal = GetDriveType(strDrive)
Select Case lpRetVal
Case DRIVE_UNKNOWN
strDriveType = "Drive type unknown"
Case DRIVE_NO_ROOT_DIR
strDriveType = "Drive has no root directory"
Case DRIVE_REMOVABLE
strDriveType = "Floppy / removable drive"
Case DRIVE_FIXED
strDriveType = "Fixed hard drive"
Case DRIVE_REMOTE
strDriveType = "Network drive: "
'now get the mapped network drive
lpBuffer = Space(255)
nSize = 254
lngL = WNetGetConnection(Left(strDrive, 2), lpBuffer, nSize)
strDriveType = strDriveType + StripNullTerminator(lpBuffer)
Case DRIVE_CDROM
strDriveType = "CD-ROM drive"
Case DRIVE_RAMDISK
strDriveType = "RAM disk"
Case Else
strDriveType = "Unknown device"
End Select
lpRetVal = GetDiskFreeSpace(strDrive, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
lpBytesPerCluster = lpBytesPerSector * lpSectorsPerCluster
lpDriveSize = lpBytesPerCluster * (lpTotalNumberOfClusters / 1024) / 1024
lpDriveFreeSpace = lpBytesPerCluster * (lpNumberOfFreeClusters / 1024) / 1024
If lpRetVal = 1 And lpDriveSize > 0 Then
GetDriveInfo = strDrive + " drive - " + strDriveType + vbCrLf _
+ vbTab + "Drive Size = " + CStr(lpDriveSize) + " MB" + vbCrLf _
+ vbTab + "Free Space = " + CStr(lpDriveFreeSpace) + " MB" + vbCrLf + vbCrLf
Else
GetDriveInfo = ""
End If
End Function
Private Function GetLogonServer() As String
Dim lpBuffer As String
Dim nSize As Long
Dim lngRetVal As Long
lpBuffer = Space(255)
nSize = 254
lngRetVal = GetEnvironmentVariable("LOGONSERVER", lpBuffer, nSize)
GetLogonServer = "Logon Server Name = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Function GetMemoryInfo() As String
Dim msMemory As MEMORYSTATUS
Dim lngTotalPhys As Long
Dim lngAvailPhys As Long
Dim lngTotalPageFile As Long
Dim lngAvailPageFile As Long
Dim lngTotalVirtual As Long
Dim lngAvailVirtual As Long
GlobalMemoryStatus msMemory
lngTotalPhys = msMemory.dwTotalPhys / 1024 * (1 / 1024)
lngAvailPhys = msMemory.dwAvailPhys / 1024 * (1 / 1024)
lngTotalPageFile = msMemory.dwTotalPageFile / 1024 * (1 / 1024)
lngAvailPageFile = msMemory.dwAvailPageFile / 1024 * (1 / 1024)
lngTotalVirtual = msMemory.dwTotalPageFile / 1024 * (1 / 1024)
lngAvailVirtual = msMemory.dwAvailPageFile / 1024 * (1 / 1024)
GetMemoryInfo = "Memory Status:" + vbCrLf _
+ vbTab + "Total RAM = " + CStr(lngTotalPhys) + "MB" + vbCrLf _
+ vbTab + "Available RAM = " + CStr(lngAvailPhys) + "MB" + vbCrLf _
+ vbTab + "Total PageFile = " + CStr(lngTotalPageFile) + "MB" + vbCrLf _
+ vbTab + "Available PageFile = " + CStr(lngAvailPageFile) + "MB" + vbCrLf _
+ vbTab + "Total Virtual Memory = " + CStr(lngTotalVirtual) + "MB" + vbCrLf _
+ vbTab + "Available Virtual Memory = " + CStr(lngAvailVirtual) + "MB" + vbCrLf
End Function
Private Function GetTimeSinceReboot()
'Returns the time since the machine was last restarted in format h:m:s
Dim h As Long
Dim m As Long
Dim s As Long
Dim l As Long
l = GetTickCount()
'GetTickCount returns number of milliseconds since last restart. divide by 1000 for seconds and convert to hours
l = l / 1000
'use integer division so we don't get rounding problems
h = l \ 3600
'Number of minutes over the hour
m = (l - (h * 3600)) \ 60
'Number of seconds over the minute
s = l - (h * 3600 + m * 60)
GetTimeSinceReboot = "Hours since reboot = " + Format(h, "00") + ":" & Format(m, "00") _
+ ":" + Format(s, "00") + vbCrLf
End Function
Private Function GetUName() As String
Dim lngRetVal As Long
Dim lpBuffer As String
Dim nSize As Long
lpBuffer = Space(255)
nSize = 254
lngRetVal = GetUserName(lpBuffer, nSize)
GetUName = "User Name = " + StripNullTerminator(lpBuffer) + vbCrLf
End Function
Private Sub Form_Load()
Dim i As Integer
Text1.Text = Text1.Text + GetUName
Text1.Text = Text1.Text + GetCompName
Text1.Text = Text1.Text + GetNetworked
Text1.Text = Text1.Text + GetDomainName
Text1.Text = Text1.Text + GetLogonServer
Text1.Text = Text1.Text + GetTimeSinceReboot
Text1.Text = Text1.Text + GetLastBootState
Text1.Text = Text1.Text + vbCrLf
Text1.Text = Text1.Text + GetWinVer
Text1.Text = Text1.Text + GetWinDir
Text1.Text = Text1.Text + GetSysDir
Text1.Text = Text1.Text + vbCrLf
Text1.Text = Text1.Text + GetMemoryInfo
Text1.Text = Text1.Text + vbCrLf
'scan all drive alphabets from A to Z
For i = 1 To 26
Text1.Text = Text1.Text + GetDriveInfo(Chr(Asc("A") + i - 1) + ":\")
Next i
End Sub
Private Function StripNullTerminator(lpBuffer As String) As String
Dim i As Integer
For i = 1 To 255
If Asc(Mid(lpBuffer, i, 1)) = 0 Then
lpBuffer = Left(lpBuffer, i - 1)
Exit For
End If
Next i
StripNullTerminator = lpBuffer
End Function
Public Sub StartSysInfo()
On Error GoTo SysInfoErr
Dim rc As Long
Dim SysInfoPath As String
' Try To Get System Info Program Path\Name From Registry...
If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
' Try To Get System Info Program Path Only From Registry...
ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
' Validate Existance Of Known 32 Bit File Version
If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
' Error - File Can Not Be Found...
Else
GoTo SysInfoErr
End If
' Error - Registry Entry Can Not Be Found...
Else
GoTo SysInfoErr
End If
Call Shell(SysInfoPath, vbNormalFocus)
Exit Sub
SysInfoErr:
MsgBox "System Information Is Unavailable At This Time", vbOKOnly
End Sub
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
Dim i As Long ' Loop Counter
Dim rc As Long ' Return Code
Dim hKey As Long ' Handle To An Open Registry Key
Dim hDepth As Long '
Dim KeyValType As Long ' Data Type Of A Registry Key
Dim tmpVal As String ' Tempory Storage For A Registry Key Value
Dim KeyValSize As Long ' Size Of Registry Key Variable
'------------------------------------------------------------
' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error...
tmpVal = String$(1024, 0) ' Allocate Variable Space
KeyValSize = 1024 ' Mark Variable Size
'------------------------------------------------------------
' Retrieve Registry Key Value...
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors
If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 Adds Null Terminated String...
tmpVal = Left(tmpVal, KeyValSize - 1) ' Null Found, Extract From String
Else ' WinNT Does NOT Null Terminate String...
tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found, Extract String Only
End If
'------------------------------------------------------------
' Determine Key Value Type For Conversion...
'------------------------------------------------------------
Select Case KeyValType ' Search Data Types...
Case REG_SZ ' String Registry Key Data Type
KeyVal = tmpVal ' Copy String Value
Case REG_DWORD ' Double Word Registry Key Data Type
For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char.
Next
KeyVal = Format$("&h" + KeyVal) ' Convert Double Word To String
End Select
GetKeyValue = True ' Return Success
rc = RegCloseKey(hKey) ' Close Registry Key
Exit Function ' Exit
GetKeyError: ' Cleanup After An Error Has Occured...
KeyVal = "" ' Set Return Val To Empty String
GetKeyValue = False ' Return Failure
rc = RegCloseKey(hKey) ' Close Registry Key
End Function
حالا برنامه را اجرا كنيد
پايان
حال گيري با موس
يادتونه كه يك پروژه به نام حركت توپ نوشتم اين همون كار رو با موس طرف
انجام مي ده كه باعث عصاب داغون كني و حتي به انوان يك اسكرين سيور و حتي در ويروس
نويسي كاربرد داره
خوب ابزار زير را روي فرم بگزاريد
Timer1
حالا كد زير را به قسمت كد نويسي فرمتان پيست كنيد
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Dim xx As Integer
Dim yy As Integer
Dim a As Integer
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim sh As Integer
Dim sw As Integer
Private Sub Form_Load()
Timer1.Interval = 1
xx = Rnd * 10 + 1
yy = Rnd * 10 + 1
End Sub
Private Sub Timer1_Timer()
Dim pp As POINTAPI
GetCursorPos pp
sh = (Screen.Height / 15) - 1
sw = (Screen.Width / 15) - 1
If pp.x <= 0 Then xx = -xx
If pp.x >= sw Then xx = -xx
If pp.y <= 0 Then yy = -yy
If pp.y >= sh Then yy = -yy
DoEvents
pp.x = pp.x + xx
pp.y = pp.y + yy
SetCursorPos pp.x, pp.y
s1 = Left(s, l)
l = l + 1
If l >= Len(s) + 3 Then
l = 1
s1 = ""
End If
End Sub
حالا برنامه را اجرا كنيد مي بينيد كه موس شما شروع به حركت در امده و با برخورد به ديواره هاي
مانيتور برمي گردد براي خلاص شذه از ان دكمه هاي زير را فشار دهيد
Ctrl + pause break
پايان
بدست اوردن اطلاعات كامل در باره بيوس ( bios ) احتمالا اين پروژه مورد استفاده خيلي از شما
خواهد بود
ابزار زير را به روي فرم تان بگزاريد
Combo1
Label1
حالا كد هاي زير را به قسمت كد نويسي فرمتان پيست كنيد
Dim BD As Class1
Private Sub Combo1_Click()
Select Case Combo1.ListIndex
Case 0
Label1 = BD.SystemBiosDate
Case 1
Label1.Caption = BD.SystemBiosVersion
Case 2
Label1 = BD.SystemBiosCopyRight
Case 3
Label1 = BD.SystemBiosExtraInfo
Case 4
Label1 = BD.VideoBiosDate
Case 5
Label1 = BD.VideoBiosVersion
Case 6
Label1 = BD.VideoBiosCopyRight
End Select
End Sub
Private Sub Form_Load()
Caption = "Bios Information"
Set BD = New Class1
With Combo1
.AddItem "SystemBiosDate"
.AddItem "SystemBiosVersion"
.AddItem "SystemBiosCopyRight"
.AddItem "SystemBiosExtraInfo"
.AddItem "VideoBiosDate"
.AddItem "VideoBiosVersion"
.AddItem "VideoBiosCopyRight"
End With
Combo1.ListIndex = 0
End Sub
حالا يك ماژول ( Module1 ( ايجاد كرده و كد هاي زير را به ان اضافه كنيد
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 Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function CopyStringA Lib "kernel32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
Public Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)
Private Const KEY_READ = &H20019
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_MULTI_SZ = 7
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_SUCCESS = 0&
Private Const MAX_SIZE = 2048
Public Const HKLM = &H80000002
Public Function IsWindowsNT() As Boolean
Dim verinfo As OSVERSIONINFO
verinfo.dwOSVersionInfoSize = Len(verinfo)
If (GetVersionEx(verinfo)) = 0 Then Exit Function
If verinfo.dwPlatformId = 2 Then IsWindowsNT = True
End Function
Public Function StrFromPtrA(ByVal lpszA As Long) As String
Dim s As String
s = String(lstrlenA(lpszA), Chr$(0))
CopyStringA s, ByVal lpszA
StrFromPtrA = TrimNULL(s)
End Function
Private Function TrimNULL(ByVal str As String) As String
If InStr(str, Chr$(0)) > 0& Then
TrimNULL = Left$(str, InStr(str, Chr$(0)) - 1&)
Else
TrimNULL = str
End If
End Function
Public Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
Exit Function
End If
length = MAX_SIZE
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
If retVal = ERROR_MORE_DATA Then
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
End If
Select Case valueType
Case REG_DWORD
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_SZ, REG_EXPAND_SZ
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
GetRegistryValue = resString
Case REG_BINARY
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
Case REG_MULTI_SZ
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else
RegCloseKey handle
End Select
RegCloseKey handle
End Function
حالا يك كلاس ( Class1 ) ايجاد كرده و كد هاي زير را به ان اضافه كنيد
Dim isNT As Boolean
Public Property Get VideoBiosDate() As String
If isNT Then
VideoBiosDate = GetRegistryValue(HKLM, "Hardware\Description\System", "VideoBiosDate", "")
Else
' VideoBiosDate = Mid(StrFromPtrA(&HC00A8), 1, 8) '-Date build
VideoBiosDate = Mid(StrFromPtrA(&HC00A8), 9, 8) '-Date revision
End If
End Property
Public Property Get VideoBiosVersion() As String
Dim s As String
If isNT Then
s = GetRegistryValue(HKLM, "Hardware\Description\System", "VideoBiosVersion", "")
Else
s = StrFromPtrA(&HC0048)
s = Left(s, InStr(1, s, vbCrLf) - 1)
s = s & vbCrLf & "ChipType: " & GetRegistryValue(HKLM, "System\CurrentControlSet\Services\Class\Display\0000\INFO", "ChipType", "")
End If
VideoBiosVersion = s
End Property
Public Property Get VideoBiosCopyRight() As String
Dim s As String
If isNT Then
s = "Unavailable on NT"
Else
s = StrFromPtrA(&HC0048)
s = Mid$(s, InStr(1, s, vbCrLf) + 2)
End If
VideoBiosCopyRight = s
End Property
Public Property Get SystemBiosDate() As String
If isNT Then
SystemBiosDate = GetRegistryValue(HKLM, "Hardware\Description\System", "SystemBiosDate", "")
Else
SystemBiosDate = StrFromPtrA(&HFFFF5)
End If
End Property
Public Property Get SystemBiosCopyRight() As String
If isNT Then
SystemBiosCopyRight = "Unvailable on NT"
Else
SystemBiosCopyRight = StrFromPtrA(&HFE091)
End If
End Property
Public Property Get SystemBiosVersion() As String
Dim vAns As Variant
If isNT Then
On Error Resume Next
SystemBiosVersion = CDate(GetRegistryValue(HKLM, "Hardware\Description\System", "SystemBiosVersion", ""))
If Err.Number > 0 Then SystemBiosVersion = "Unavailable"
Else
SystemBiosVersion = StrFromPtrA(&HFE061)
End If
End Property
Public Property Get SystemBiosExtraInfo() As String
If isNT Then
SystemBiosExtraInfo = "Unvailable on NT"
Else
SystemBiosExtraInfo = StrFromPtrA(&HFEC71)
End If
End Property
Private Sub Class_Initialize()
isNT = IsWindowsNT
End Sub
يك كم كد ها زياد شد اما به مي عرضه خوب حالا برنامه را اجرا كنيد و براي بدست اورد
اطلاعات در باره هر بخش بايوس از ليست combo1 استفاده كنيد و اطلاعات رو در
ليبلي كه ساختيد ببينيد
پايان
روش تبديل تاريخ هجرى شمسى به ميلادى
روز مورد نظر اگر بين اول فروردين تا يازدهم دى ماه باشد، عدد (621) و اگر بين يازدهم ديماه تا پايان اسفند باشد عدد (622) را به سال شمسى مى افزائيم تا سال ميلادى به دست آيد.
مثال :22 بهمن 1357 سال پيروزى انقلاب شكوهمند اسلامى ايران مطابق است با 1979ميلادى .1979 622 + 1357
نكته قابل توجه اينكه روزهاى ماههاى هجرى شمسى و ميلادى در تمام سالها ثابت است و هيچگاه تغيير نمى كند. بنابراين هميشه 22 بهمن با 11 فوريه ، اول فروردين با 21 مارس مطابق است . همچنين اول ماه مى روز جهانى كارگر با 11 ارديبهشت ، و اول ژانويه با 11 دى مصادف است .
براى تبديل تاريخ ميلادى به هجرى شمسى كافى است اگر روز مورد نظر بين اول ژانويه تا 21 مارس باشد، عدد 622، و اگر بين 22 مارس تا پايان دسامبر باشد، عدد 621 را از سال ميلادى كسر كنيم . مثلاً ششم آگوست 1945 ميلادى روز بمباران اتمى هيروشيما مطابق با 15 مرداد سال 1324 مى باشد.
1324 621 1945
همچنين 11 نوامبر سال 1918 ميلادى روز پايان جنگاول جهانى با 20 آبان سال 1297 ه ش . مطابقت دارد.1297 621 – 1
خوب پايين يك چيزاي نوشتم كه ريطي به وب لاگ من نداره مثل يك زنگ تفريح براي وبلاگ است
چطور عمليات رياضي رو تو word انجام دهيم
مثلا وقتي نوشتيم 10 + 10 جواب به ما بده 20 ا اين كار را با word مي خواهيم انجام دهيم
نرم افزار Word را اجرا کنید.
از منوی Tools بر روی Customize کلیک کنید.
در پنجره جدید به تب Commands بروید.
اکنون یک پنجره دارای 2 ستون خواهید داشت. از ستون Tools ، Category را پیدا کرده و آن را انتخاب کنید. از ستون دیگر ، Tools Calculate را پیدا کنید (جزء موارد آخر). اکنون Tools Calculate را گرفته و آن را در جای مناسبی از نوار ابزار بالای صفحه رها کنید. ( Drog & Drop ) .
پس از اینکه دکمه Tools Calculate در جای مناسبی از نوار ابزار جای گرفت ، پنجره Customize را ببندید.
حال در یک صفحه خالی Word ، به عنوان مثال دو عدد را این گونه بنویسید:
253
+
789
هر عدد با یک Enter از خطی بعدی جدا گردد. عملگر ریاضی هم مابین دو خط عدد جای گیرد.
یا دو عدد را پشت سر هم و به شکل زیر وارد کنید:
253 + 789
اکنون این 3سه خط را با موس بگیرید و به حالت انتخاب درآورید ( Highlight کنید ) ، بر روی دکمه Tools Calculate که ایجاد کردید ، کلیک کنید.
سپس در خط بعدی ، دکمه Ctrl+V را همزمان فشار دهید تا نمایان شود.
فشرده كرد نو و ساخت ستاپ با ابزار مخفي خود ويندوز
بدین منظور از Start به Run رفته و در آن عبارت IEXPRESS را تايپ كرده و Enter را بزنيد . خواهید دید که برنامه باز خواهد شد .
براي اين كار در پنجره باز شده گزينه Creat new self extraction directive file را انتخاب كرده ، next را بزنيد . گزينه Extract Files Only را انتخاب كرده ، مجدد Next كنيد . در اين مرحله يك نام را براي عنوان بسته ايجاد شده تايپ كنيد و دكمه Next را بزنيد .
حال اگر بخواهيد هنگام نصب بسته ، كاربر با پيغامي مواجه شده و پس از تاييد آن بسته را نصب كند ، مي توانيد اين پيغام را در كادر Prompt User With وارد كنيد . در غير اينصورت No Prompt را برگزيده ، Next را بزنيد .
اگر مي خواهيد قبل از نصب يك توافق نامه براي كاربر نمايش داده شود ، Display a License را فعال كرده و فايل مربوطه را جستجو كنيد . ( اين فايل را بايستي قبلا ايجاد كرده باشيد اين كار را مي توانيد در يك محيط متني انجام دهيد . ) در غير اينصورت Do Not Display a License را انتخاب و Next كنيد .
در اين مرحله با زدن دكمه Add فايلي را كه مي خواهيد فشرده شود انتخاب كنيد . سپس دكمه Next را بزنيد . در قسمت بعد مشخص مي كنيد كه برنامه نصب ، چگونه نمايش داده شود . با انتخاب Default آن را به حال خود رها كرده و Next كنيد .
اگر مي خواهيد پس از نصب پيغامي براي كاربر نمايش داده شود ، آن را در كادر Display Message وارد كنيد . و گر نه No Message و سپس Next را بزنيد .
حال يك مسير و يك نام براي بسته بر گزينيد . با زدنNext مسير فعلي را براي ذخيره قبول كرده و دو بار Next را بزنيد تا فشرده سازي آغاز شود .
در پايان Finish را كليك كنيد .
اكنون مي توانيد به محل تعيين شده رفته و بسته را مشاهده كنيد . همچنين با گرفتن Properties از فايل فشرده شده و فايل اوليه مي توانيد تغيير حجم آن ها را مشاهده كنيد .حتي مي توانيد براحتي اين بسته را به كامپيوتر هاي ديگر منتقل كنيد . براي نصب كافيست بر روي آن دابل كليك كرده و مسير قرار گرفتن آن را پس از نصب تعيين كنيد .
يكي از پروژه هاي كه بچه هاي دانشجو حتما بايد انجام دهند چاپ پرچم ايران با استفاده از
زبان اسمبلي است كه دهنشونو سرويس كرده منم گفتم به اسمبلي كار ها يك حالي بديم
چاپ پرچم ایران و حرکت کلمه الله در بالا و پایین پرچم
اينم كد هاي ان به زبان اسمبلي
paint macro nrow,frow,fcol,erow,ecol,attribute
mov ah,6h
mov al,nrow
mov ch,frow
mov cl,fcol
mov dh,erow
mov dl,ecol
mov bh,attribute
int 10h
endm
;-------------------------------------------------
xy macro row,col
mov ah,2h
mov dh,row
mov dl,col
mov bh,0
int 10h
endm
;-------------------------------------------------
print macro msg
mov ah,9
lea dx,msg
int 21h
endm
;-------------------------------------------------
finish macro
mov ax,4c00h
int 21h
endm
;-------------------------------------------------
.model small
.data
;-------------------------------------------------
msg db 'A',70h,'l',70h,'l',70h,'a',70h,'h',70h,' ',70h
last db ?
;-------------------------------------------------
msg1 db ' w $'
msg2 db '((|))$'
msg3 db ' ^ $'
;-------------------------------------------------
.code
main proc
mov ax,@data
mov ds,ax
;*******clear
paint 25,0,0,24,79,00h
;*******green
paint 5,5,20,5,58,20h
;*******White
paint 5,10,20,10,58,70h
;*******red
paint 5,15,20,15,58,40h
xy 11,37
print msg1
xy 12,37
print msg2
xy 13,37
print msg3
mov ax,0b800h
mov es,ax
mov cx,2000
lea si,msg
mov di,1640
up: mov ax,[si]
mov [es:di],ax
mov [es:di+640],ax
mov ah,1
int 16h
jnz fin
add si,2
add di,2
cmp si,offset last
jne down1
mov si,offset msg
down1: cmp di,1718
jb up
mov di,1640
jmp up
fin: xy 25,0
paint 25,0,0,24,79,00h
finish
main endp
end main
پايان
با يك ترفند ساده شما مي توانيد تمامي عكس هاي كه در وب لاگ من يا هر وب لاگي وجود داره
رو به صورت خيلي زيبا به پرواز در اوريد اين كد ها جاوا است
براي اين كار فقط كافي كد هاي پايين را در نوار ادرس بالاي مرورگر تون كپي پيست كنيد اول
نوار ادرش رو پاك كنيد بعد كدهاي زير را به ان پيست كنيد
javascript:R=0; x1=.1; y1=.05; x2=.25; y2=.24; x3=1.6; y3=.24; x4=300; y4=200; x5=300; y5=200; DI=document.images; DIL=DI.length; function A(){for(i=0; i-DIL; i++){DIS=DI[ i ].style; DIS.position='absolute'; DIS.left=Math.sin(R*x1+i*x2+x3)*x4+x5; DIS.top=Math.cos(R*y1+i*y2+y3)*y4+y5}R++}setInterval('A()',5);
قسنگ نه
پايان
+ نوشته شده در دوشنبه بیست و نهم مرداد ۱۳۸۶ ساعت 14:37 توسط جواد
|