واژال بيسيك
قبل
از جواب دادن به نظرات شما چند نكته را به دو باره بگم
اولا بازم مي گم اگه كسي سايتي در باره اپالود فايل ها كه سرعت و كار كردن باهاش اسون
باشه
به من
بده تا من چند تا برنامه كه قول داده بودم
را براتون بزارم تا شما بتونيد دانلود كنيد
بعدشم بازم مي گم اگه كسي خواست وب لاگ يا سايتشو تو پيوندام بزارم تو نظرات بگه
من سايتشو با هر توضيحي كه گفتيد تو پيوندام
مي زارم
يك بار
ديگه هم مي گم من خيلي وقته كه ويژال كار نكردم پس تو
سوالاتون توضيح به اندازه كافي
بديد تا من
زود تر جوابتو نو بدم
بازم جواب
چند تا نظر :
نظر
اول : با سلام
بابا واقعاً داری حال میدی با این برنامه ها
واقعاً دستت درد نکنه . من که حسابی حال کردم.
راستی من همه قسمت های بایگانی
وبلاگت را خوندم . اگه اشتباه نکنم در آرشیو آذر ماه 85 نوشته
بودی که یه فایل آموزشی با فرمت Pdf داری آمده می کنی .
اگه ممکنه اون فایل را برای استفاده همه ، جایی آپلود کن
به هر حال ذکات علم ، آموزش دادن اونه (یه چیزی تو این
مایه ها)
یا فایل را برای من میل کن !!!
راستی اگه وقت کردی آموزش بانک های اطلاعاتی SQL Server رو هم بده
.
یه سوال هم داشتم :
چه طوری میشه توی بانک های اطلاعاتی اکسس که
با خود وی بی ساخته میشن ، حالت Auto Number ایجاد کرد و با استفاده از Adodc و
DataGrid با اون ارتباط برقرار نمود به
صورتی که وقتی یه رکورد جدید ایجاد میشه خودش یه شماره جلوتر بره ؟
با تشکر فراوان - دوست دار تو - حمید رضا از اصفهان
جواب : سلام حميد
رضا اميد وارم شما هم مثل من خوب باشيد
بابا يك ايول داري يعني اينقدر با
ويژال حال مي كني كه همه بايگاني هاي وب لاگ رو خوندي
بعد در مورد اون فايل اموزشي كه يك مشكلي برام پيش اومد و فايل
رو كه كلي براش وقت
گزاشتم رو از دست دادم كه حا ل گرفته شده و در مورد اموزش بانك اطلاعات
Sql sever در اينده نزديك باشه اموزش اون را هم مي زارم
در مورد سوالت هم تا جاي كه ميدونم يك راهش با كد نويسي كه من قبلا ديدم و
روش بسيار
خوبيه و چرا مي خواهي كارت رو سخت كني برو با اكسس فايلي كه ساختي رو باز كن و
يك فيلد از نوع اتو نامبر بهش اضافه كن ولي
اگه مي خواهي كه با ويژال باشه بهترين راه كه
به نظرم مي رسه با كد نويسي بايد يك
فيلد جديد ايجاد كنيد و نوعشو اتو نامبر انتخاب كنيد كه
در حال حاضر كدشو ندارم من اين موضوعي كه گفتي را دو سال پيش ديده بودم دنبالش
مي گردم اگه چيزي پيدا كردم تو پست
بعدي مي زارم و در
مورد دنباله سوالت هم ارتباط
از اين همه لطفي كه داري راستي نگفتي در چه سطحي داري ويژال كار مي كني
نظر دوم
: سلام دوست عزیز
من ، عباس جان
نوشته و مطلب های خوبی داری
با تبادل لینک چطوری ؟
اگه موافقی اول لینک منو با
نامه "بهترین دانلودها" بذار و بعد بیا تو وبلاگم و از طریق
نظرات بهم خبر بده تا منم با هرنامی که خواستی لینکه تورو بذارم .
موفق باشی
جواب : سلام اشكان
من هم تا تبادل لينك موافقم لينكتو تو وب لاگم مي زارم
___________________________________________________________________
نظر سوم : با سلام و خسته نباشيد
يه سوال داشتم
من يه زمان سنج ديجيتالي طرحي كردام و دو تا
دستور يكي شروع و ديگري متوقف به خوبي كار مي كنه اما نمي
توانم يه دستوري بنويسم كه زمان را دوباره از صفر شروع بشه (نمي
خواهم كه فقط صورت را پاك كنه ) برنامه به دستور شروع كاري ميكنه و با
متوقف مي ايسته و وقتي شروع را دوباره كليك مي كنم از همان ساعت شروع به
كار مي كنه من مي خواستم در دستور سوم اين طور كار كنه كه زمان را به صفر
برسانه و با دستور شروع از صفر كار كنه
جواب : ببين صابر جون داداش سوالي كه
پرسيدي يا خيلي خيلي ابتداي يا اينكه منظورتو بد فهميدم
ولي طبق روال كار جوابتو مي دم كارها و ابزار هاي كه مي گم را بر روي فرم بگزار
ساعت ديجيتالي : ابزارهاي زير را روي فرم بگزار
Text1
Text2
Text3
Command1
Command2
Command3
Timer1
خوب ما نياز به سه تا كامند باتون يا همون دكمه و سه تا تكست باكس و يك تايمر داريم
حالا
كدهاي زير را د قسمت كد نويسي فرمت
كپي كن
Private
Sub Command1_Click()
Timer1.Enabled
= True
End Sub
Private
Sub Command2_Click()
Timer1.Enabled
= False
End Sub
Private
Sub Command3_Click()
Text3.Text
= 1
Text2.Text
= 1
Text1.Text
= 1
End Sub
Private
Sub Form_Load()
Text3.Text
= Second(Time)
Text2.Text
= Minute(Time)
Text1.Text
= Hour(Time)
Timer1.Interval
= 1000
Command1.Caption
= "Pleay"
Command2.Caption
= "Stop"
Command3.Caption
= "Clse"
End Sub
Private
Sub Timer1_Timer()
Dim a As
Integer, b As Integer
a =
Text3.Text
If a <
60 Then a = a + 1 Else a = 1
Text3.Text
= a
If
Text3.Text = 60 Then
If
Text2.Text < 60 Then Text2.Text = Text2.Text + 1 Else Text2.Text = 1
If
Text2.Text = 60 Then
If
Text1.Text < 12 Then Text1.Text = Text1.Text + 1 Else Text1.Text = 1
End If
End If
End Sub
خوب كد
نويسي تمام شد برنامه را اجرا كن ببين منظورت همين بود يا نه اگه مشكلي
بود بگو
روش بالا ساده ترين و ابتداي ترين روش بود كه نياز به توضيح فكر نكنم داشته باشه
اجراي دستورات داس در ويژال بيسيك
خوب ما مي خواهيم به عنوان مثال دستور help كه در داس باعث ديدن ليست
همه
دستورات داس مي شود را در ويژال
بيسيك ايجاد كنيم
خوب براي
ديدن دستورات داس در يك تكست باكس يك فرم جديد ايجاد كرده
ابزار زير
را روي فرم بگزاريد
Text1
در قسمت
خصوصيات تكست باكس مانند پايين تقيير دهيد
Text1.MultiLine
= true
Text1.Name = txtOutputs
خوب براي
شروع يك فرم از نوع Class Modules ( كلاس ماژول ) ايجاد كرده و كدهاي
زير در ان
پيست كنيد
Private
Declare Function CreatePipe Lib "kernel32" ( _
phReadPipe As Long, _
phWritePipe As Long, _
lpPipeAttributes As Any, _
ByVal nSize As Long) As Long
Private
Declare Function ReadFile Lib "kernel32" ( _
ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Any) As Long
Private
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private
Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private
Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private
Declare Function CreateProcessA Lib "kernel32" ( _
ByVal lpApplicationName As Long, _
ByVal lpCommandLine As String, _
lpProcessAttributes As SECURITY_ATTRIBUTES, _
lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, _
ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long
Private
Declare Function CloseHandle Lib "kernel32" ( _
ByVal hHandle As Long) As Long
Private
Const NORMAL_PRIORITY_CLASS = &H20&
Private
Const STARTF_USESTDHANDLES = &H100&
Private
Const STARTF_USESHOWWINDOW = &H1
Private
mCommand As String
Private
mOutputs As String
Public
Event ReceiveOutputs(CommandOutputs As String)
Public
Property Let CommandLine(DOSCommand As String)
mCommand = DOSCommand
End
Property
Public
Property Get CommandLine() As String
CommandLine = mCommand
End
Property
Public
Property Get Outputs()
Outputs = mOutputs
End
Property
Public
Function ExecuteCommand(Optional CommandLine As String) As String
Dim proc As PROCESS_INFORMATION
Dim ret As Long
Dim start As STARTUPINFO
Dim sa As SECURITY_ATTRIBUTES
Dim hReadPipe As Long
Dim hWritePipe As Long
Dim lngBytesread As Long
Dim strBuff As String * 256
If Len(CommandLine) > 0 Then
mCommand = CommandLine
End If
If Len(mCommand) = 0 Then
MsgBox "Command Line empty", vbCritical
Exit Function
End If
sa.nLength = Len(sa)
sa.bInheritHandle = 1&
sa.lpSecurityDescriptor = 0&
ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
If ret = 0 Then
MsgBox "CreatePipe failed. Error: " & Err.LastDllError,
vbCritical
Exit Function
End If
start.cb = Len(start)
start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
start.hStdOutput = hWritePipe
start.hStdError = hWritePipe
ret& = CreateProcessA(0&, mCommand, sa, sa, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
If ret <> 1 Then
MsgBox "File or command not found", vbCritical
Exit Function
End If
ret = CloseHandle(hWritePipe)
mOutputs = ""
Do
ret = ReadFile(hReadPipe, strBuff, 256, lngBytesread, 0&)
mOutputs = mOutputs & Left(strBuff, lngBytesread)
RaiseEvent ReceiveOutputs(Left(strBuff,
lngBytesread))
Loop While ret <> 0
ret = CloseHandle(proc.hProcess)
ret = CloseHandle(proc.hThread)
ret = CloseHandle(hReadPipe)
ExecuteCommand = mOutputs
End
Function
حالا نوبت
كد نويسي فرم رسيده حالا كدهاي زير را در قسمت كد نويسي فرمتان
پيست كنيد
Private
WithEvents objDOS As DOSOutputs
Private
Sub Form_Load()
Set objDOS = New DOSOutputs
objDOS.CommandLine = "help"
objDOS.ExecuteCommand
End Sub
Private
Sub objDOS_ReceiveOutputs(CommandOutputs As String)
txtOutputs.Text = txtOutputs.Text & CommandOutputs
End Sub
پايان
_______________________________________________________________
پيدا كر
دن يك كلمه در متن و جايگزين كردن ان كلمه
با كلمه ديگر
براي درك حرف من نرم افزار نو ت پد را اجرا كنيد و از منوي اديت گينه find ويا
Replace جمله اي بنويسيد تا برنمه توي متن
بگردد و جمله شما را پيدا كند و يا با
جمله ديگر جايگزين
كند فكر كنم منظورم رو رسوندم ما مي خواهيم چنين چيزي
بنويسيم
خوب براي
اين كار ابزار زير را روي فرم بگزاريد
Text1
Command1
Command2
حالا كد
هاي زير را در قسمت كد نويسي فرمتان پيست كنيد
Private
Sub command1_Click()
Call
ShowFindDialog(Text1)
End Sub
Private
Sub command2_Click()
Call ShowReplaceDialog(Text1)
End Sub
Private
Sub Form_Load()
command1.Caption
= " Find"
command2.Caption
= "Find and &Replace"
End Sub
حالا ما به يك ماژول نياز داريم يك ماژول ايجاد كنيد
Module1
كدهاي زير را در Module1 پيست كنيد
Option Explicit
Public
Type FINDREPLACE
lStructSize As Long ' size of this struct 0x20
hwndOwner As Long ' handle to owner's window
hInstance As Long ' instance handle of.EXE that
' contains cust. dlg. template
flags As Long ' one or more of the FR_??
lpstrFindWhat As Long ' ptr. to search string
lpstrReplaceWith As Long ' ptr. to replace string
wFindWhatLen As Integer ' size of find buffer
wReplaceWithLen As Integer ' size of replace buffer
lCustData As Long ' data passed to hook fn.
lpfnHook As Long ' ptr. to hook fn. or NULL
lpTemplateName As Long ' custom template name
End Type
Declare
Function FindText Lib "comdlg32.dll" Alias "FindTextA"
(pFindreplace As FINDREPLACE) As Long
Declare
Function ReplaceText Lib "comdlg32.dll" Alias
"ReplaceTextA" (pFindreplace As FINDREPLACE) As Long
Public
Enum FindReplaceConstants
FR_DIALOGTERM = &H40
FR_DOWN = &H1
FR_ENABLEHOOK = &H100
FR_ENABLETEMPLATE = &H200
FR_ENABLETEMPLATEHANDLE = &H2000
FR_FINDNEXT = &H8
FR_HIDEMATCHCASE = &H8000
FR_HIDEUPDOWN = &H4000
FR_HIDEWHOLEWORD = &H10000
FR_MATCHCASE = &H4
FR_NOMATCHCASE = &H800
FR_NOUPDOWN = &H400
FR_NOWHOLEWORD = &H1000
FR_REPLACE = &H10
FR_REPLACEALL = &H20
FR_WHOLEWORD = &H2
End Enum
Public
Enum FindReplaceErrors
FRERR_BUFFERLENGTHZERO = &H4001
FRERR_FINDREPLACECODES = &H4000
End Enum
Declare
Function RegisterWindowMessage Lib "user32" Alias
"RegisterWindowMessageA" (ByVal lpString As String) As Long
Declare
Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Type
POINTAPI
x As Long
y As Long
End Type
Type Msg
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Declare
Function IsDialogMessage Lib "user32" Alias
"IsDialogMessageA" (ByVal hDlg As Long, lpMsg As Msg) As Long
Declare
Function ShellExecute Lib "shell32.dll" Alias
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String,
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As
String, ByVal nShowCmd As Long) As Long
Private
mTxtBox As TextBox
Declare
Function DefDlgProc Lib "user32" Alias "DefDlgProcA" (ByVal
hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
As Long
Declare
Function CallWindowProc Lib "user32" Alias
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long,
ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare
Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Global
mDlgHandle As Long
Global
mDlgWndProc As Long
Global
frThis As FINDREPLACE
Global
sFindWhat As String
Global
sReplaceWhat As String
Global
ByteArray() As Byte
Global
ByteArrayReplace() As Byte
Private
Const FINDREPLACEMESSAGE = "commdlg_FindReplace"
Private
Const GWL_WNDPROC = (-4)
Private
Declare Function SetWindowLongApi Lib "user32" Alias
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal
dwNewLong As Long) As Long
Private
lOldWndProcAddress As Long
Declare
Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow
As Long) As Long
Declare
Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Public
Const WM_INITDIALOG = &H110
Public
Const SW_SHOW = 5
Private
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
_
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private
Declare Function IsBadStringPtrByLong Lib "kernel32" Alias
"IsBadStringPtrA" (ByVal lpsz As Long, ByVal ucchMax As Long) As Long
Private
Sub FindNext(ByVal psIn As String, ByVal bWholeWord As Boolean, ByVal
bMatchCase As String)
Dim
lNextPos
lNextPos
= InStr(mTxtBox.SelStart + 1, mTxtBox.Text, psIn, vbTextCompare)
If
lNextPos > 0 Then
mTxtBox.SelStart = lNextPos
mTxtBox.SelLength = Len(psIn)
Else
Beep
End If
End Sub
Private
Sub Replace(ByVal psOld As String, ByVal psNew As String, ByVal bWholeWord As
Boolean, ByVal bMatchCase As Boolean, ByVal ReplaceAll As Boolean)
Dim
lNextPos
lNextPos
= InStr(mTxtBox.SelStart + 1, mTxtBox.Text, psOld, vbTextCompare)
If
lNextPos > 0 Then
Do
mTxtBox.SelStart = lNextPos - 1
mTxtBox.SelLength = Len(psOld)
mTxtBox.SelText = psNew
If Not ReplaceAll Then
Exit Do
Else
lNextPos = InStr(mTxtBox.SelStart + 1, mTxtBox.Text, psOld, vbTextCompare)
End If
Loop While lNextPos > 0
Else
Beep
End If
End Sub
Private
Function StringFromPointer(lpString As Long, lMaxlength As Long) As String
Dim sRet
As String
Dim lRet
As Long
If
lpString = 0 Then
StringFromPointer = ""
Exit Function
End If
If Not
IsBadStringPtrByLong(lpString, lMaxlength) Then
sRet = String$(lMaxlength, 0)
CopyMemory ByVal sRet, ByVal lpString, ByVal Len(sRet)
If InStr(sRet, Chr$(0)) > 0 Then
sRet = Left$(sRet, InStr(sRet, Chr$(0)) - 1)
End If
End If
StringFromPointer
= sRet
End
Function
Private
Sub ShowDialog(ByVal txtboxIn As TextBox, ByVal bReplace As Boolean)
sFindWhat
= String$(1024, 0)
sReplaceWhat
= String$(1024, 0)
Dim nByte
As Long
If FINDMSGSTRING
= 0 Then
MsgBox "Cannot Find/Replace - Call to register message failed"
Exit Sub
End If
If
lOldWndProcAddress <> 0 Then
lOldWndProcAddress = SetWindowLongApi(mTxtBox.Parent.hwnd, GWL_WNDPROC,
lOldWndProcAddress)
End If
Set mTxtBox
= txtboxIn
lOldWndProcAddress
= SetWindowLongApi(mTxtBox.Parent.hwnd, GWL_WNDPROC, AddressOf VB_WindowProc)
sFindWhat
= mTxtBox.SelText
ReDim
ByteArray(0 To 1024) As Byte
If
bReplace Then
ReDim ByteArrayReplace(0 To 1024) As Byte
End If
For nByte
= 0 To Len(sFindWhat) - 1
ByteArray(nByte) = Asc(Mid$(sFindWhat, nByte + 1, 1))
If bReplace Then
ByteArrayReplace(nByte) = ByteArray(nByte)
End If
Next
nByte
With
frThis
.lStructSize = Len(frThis)
.hwndOwner = mTxtBox.Parent.hwnd
.lpstrFindWhat = VarPtr(ByteArray(0))
.wFindWhatLen = UBound(ByteArray)
If bReplace Then
.lpstrReplaceWith = VarPtr(ByteArrayReplace(0))
.wReplaceWithLen = UBound(ByteArrayReplace)
Else
.lpstrReplaceWith = 0
.wReplaceWithLen = 0
End If
End With
If
bReplace Then
mDlgHandle = ReplaceText(frThis)
Else
mDlgHandle = FindText(frThis)
End If
If
mDlgHandle <> 0 Then
mDlgWndProc = GetWindowLong(mDlgHandle, GWL_WNDPROC)
Else
If CommDlgExtendedError <> 0 Then
Debug.Print CommDlgExtendedError
End If
End If
End Sub
Public
Sub ShowFindDialog(ByVal txtboxIn As TextBox)
Call
ShowDialog(txtboxIn, False)
End Sub
Public
Sub ShowReplaceDialog(ByVal txtboxIn As TextBox)
Call ShowDialog(txtboxIn,
True)
End Sub
Public
Function VB_WindowProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As
Long, ByVal lParam As Long) As Long
Dim
mFindReplace As FINDREPLACE
If wMsg =
FINDMSGSTRING Then
Call CopyMemory(mFindReplace, ByVal lParam, Len(mFindReplace))
With mFindReplace
If .wFindWhatLen > 0 Then
sFindWhat = StringFromPointer(.lpstrFindWhat,
CLng(.wFindWhatLen))
End If
If .wReplaceWithLen > 0 Then
sReplaceWhat =
StringFromPointer(.lpstrReplaceWith, CLng(.wReplaceWithLen))
End If
Select Case True
Case .flags And FR_FINDNEXT
Call FindNext(sFindWhat, (.flags And
FR_WHOLEWORD), (.flags And FR_MATCHCASE))
Case .flags And FR_REPLACE
Call Replace(sFindWhat, sReplaceWhat, (.flags And
FR_WHOLEWORD), (.flags And FR_MATCHCASE), False)
Case .flags And FR_REPLACEALL
Call Replace(sFindWhat, sReplaceWhat, (.flags And
FR_WHOLEWORD), (.flags And FR_MATCHCASE), True)
End Select
End With
Else
VB_WindowProc = CallWindowProc(lOldWndProcAddress, hwnd, wMsg, wParam,
lParam)
End If
End
Function
Public
Property Get FINDMSGSTRING() As Long
Static
msgValue As Long
If
msgValue = 0 Then
msgValue = RegisterWindowMessage(FINDREPLACEMESSAGE)
End If
FINDMSGSTRING
= msgValue
End
Property
پايان
________________________________________________________________
بدست
اوردن سريال نامبر هارد و بسيار اطلاعات بيشتر در باره هارد
براي بدست
اوردن اطلاعات هارد ابزار زير را روي فرم
بگزاريد
Label1
Text1
وخاصيت text1 را مانند پايين تغيير دهيد
Text1. MultiLine = true
خوب حلا
كد هاي زير را در قسمت كد نويسي فرمتان پيست كنيد
Private
Sub Command1_Click()
Dim fso As New FileSystemObject
MsgBox fso.GetDrive("c:").TotalSize +
fso.GetDrive("d:").TotalSize
Set fso = Nothing
End Sub
Private
Sub Form_Load()
Caption = "HDD low level info"
Text1.Font = "Courier New"
Dim drv_info As DRIVE_INFO
Dim sInfo As String
Dim sInfoAttr As String
drv_info = GetDriveInfo(0)
sInfo = sInfo & ": " & vbCrLf
Text1 = ""
With drv_info
If .bDriveType = 0 Then sInfo = sInfo & "[Not present]"
If .bDriveType = 2 Then sInfo = sInfo & "[ATAPI drive - info not
available]"
If .bDriveType = 1 Then
sInfo = sInfo & "[IDE drive]" &
vbCrLf
sInfo = sInfo & "Model: " &
Trim(.Model) & vbCrLf
sInfo = sInfo & "FirmWare: " &
Trim(.FirmWare) & vbCrLf
sInfo = sInfo & "SerialNumber: "
& Trim(.SerialNumber) & vbCrLf
sInfo = sInfo & "Cilinders: " &
.Cilinders & vbCrLf
sInfo = sInfo & "Heads: " &
.Heads & vbCrLf
sInfo = sInfo & "SecPerTrack: "
& .SecPerTrack & vbCrLf
sInfoAttr = Format("Attribute Name",
String(24, "@") & "!") & Format("Value",
String(7, "@") & "!") &
Format("Threshold", String(11, "@") & "!")
& Format("WorstValue", String(12, "@") &
"!") & "Status" & vbCrLf
sInfoAttr = sInfoAttr & String(60,
"-") & vbCrLf
For i = 1 To .NumAttributes - 1
sInfoAttr = sInfoAttr &
Format(.Attributes(i).AttrName, String(25, "@") & "!")
& Format(.Attributes(i).AttrValue, String(3, "@")) & vbTab
& Space(2) & Format(.Attributes(i).ThresholdValue, String(3,
"@")) & vbTab & Format(.Attributes(i).WorstValue, String(8,
"@")) & vbTab & Format("&H" &
Hex(.Attributes(i).StatusFlags), String(4, "@"))
'
sInfoAttr = sInfoAttr & vbNewLine
Next i
Text1 = sInfoAttr
End If
End With
Label1 = sInfo
End Sub
حاالا يك ماژول ايجاد كنيد وكدهاي زير را در ان پيست كنيد
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
Private
Type ATTR_DATA
AttrID As Byte
AttrName As String
AttrValue As Byte
ThresholdValue As Byte
WorstValue As Byte
StatusFlags As STATUS_FLAGS
End Type
Public
Type DRIVE_INFO
bDriveType As Byte
SerialNumber As String
Model As String
FirmWare As String
Cilinders As Long
Heads As Long
SecPerTrack As Long
BytesPerSector As Long
BytesperTrack As Long
NumAttributes As Byte
Attributes() As ATTR_DATA
End Type
Public
Enum IDE_DRIVE_NUMBER
PRIMARY_MASTER
PRIMARY_SLAVE
SECONDARY_MASTER
SECONDARY_SLAVE
End Enum
Private
Declare Function CreateFile Lib "kernel32" Alias
"CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As
Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal
dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal
hTemplateFile As Long) As Long
Private
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)
As Long
Private
Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As
Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As
Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As
Long, ByVal lpOverlapped As Long) As Long
Public
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(Destination As Any, Source As Any, ByVal Length As Long)
Private
Const GENERIC_READ = &H80000000
Private
Const GENERIC_WRITE = &H40000000
Private
Const FILE_SHARE_READ = &H1
Private
Const FILE_SHARE_WRITE = &H2
Private
Const OPEN_EXISTING = 3
Private
Const FILE_ATTRIBUTE_SYSTEM = &H4
Private
Const CREATE_NEW = 1
Private
Const INVALID_HANDLE_VALUE = -1
Dim di As
DRIVE_INFO
Dim
colAttrNames As Collection
Private
Function OpenSmart(drv_num As IDE_DRIVE_NUMBER) As Long
If IsWindowsNT Then
OpenSmart = CreateFile("\\.\PhysicalDrive" & CStr(drv_num),
GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal
0&, OPEN_EXISTING, 0, 0)
Else
OpenSmart = CreateFile("\\.\SMARTVSD", 0, 0, ByVal 0&,
CREATE_NEW, 0, 0)
End If
End
Function
Private
Function CheckSMARTEnable(ByVal hDrive As Long, DriveNum As IDE_DRIVE_NUMBER)
As Boolean
Dim SCIP As SENDCMDINPARAMS
Dim SCOP As SENDCMDOUTPARAMS
Dim lpcbBytesReturned As Long
With SCIP
.cBufferSize = 0
With .irDriveRegs
.bFeaturesReg = SMART_ENABLE_SMART_OPERATIONS
.bSectorCountReg = 1
.bSectorNumberReg = 1
.bCylLowReg = SMART_CYL_LOW
.bCylHighReg = SMART_CYL_HI
.bDriveHeadReg = &HA0
.bCommandReg = IDE_EXECUTE_SMART_FUNCTION
End With
.bDriveNumber = DriveNum
End With
CheckSMARTEnable = DeviceIoControl(hDrive, DFP_SEND_DRIVE_COMMAND, SCIP,
Len(SCIP) - 4, SCOP, Len(SCOP) - 4, lpcbBytesReturned, ByVal 0&)
End
Function
Private
Function IdentifyDrive(ByVal hDrive As Long, ByVal IDCmd As Byte, ByVal
DriveNum As IDE_DRIVE_NUMBER) As Boolean
Dim SCIP As SENDCMDINPARAMS
Dim IDSEC As IDSECTOR
Dim bArrOut(OUTPUT_DATA_SIZE - 1) As Byte
Dim sMsg As String
Dim lpcbBytesReturned As Long
Dim barrfound(100) As Long
Dim i As Long
Dim lng As Long
With SCIP
.cBufferSize = IDENTIFY_BUFFER_SIZE
.bDriveNumber = CByte(DriveNum)
With .irDriveRegs
.bFeaturesReg = 0
.bSectorCountReg = 1
.bSectorNumberReg = 1
.bCylLowReg = 0
.bCylHighReg = 0
.bDriveHeadReg = &HA0
If Not IsWindowsNT Then .bDriveHeadReg =
.bDriveHeadReg Or (DriveNum And 1) * 16
.bCommandReg = CByte(IDCmd)
End With
End With
If DeviceIoControl(hDrive, DFP_RECEIVE_DRIVE_DATA, SCIP, Len(SCIP) - 4,
bArrOut(0), OUTPUT_DATA_SIZE, lpcbBytesReturned, ByVal 0&) Then
IdentifyDrive = True
CopyMemory IDSEC, bArrOut(16), Len(IDSEC)
di.Model = SwapStringBytes(StrConv(IDSEC.sModelNumber, vbUnicode))
di.FirmWare = SwapStringBytes(StrConv(IDSEC.sFirmwareRev, vbUnicode))
di.SerialNumber = SwapStringBytes(StrConv(IDSEC.sSerialNumber, vbUnicode))
di.Cilinders = IDSEC.wNumCyls
di.Heads = IDSEC.wNumHeads
di.SecPerTrack = IDSEC.wSectorsPerTrack
End If
End
Function
Private
Function ReadAttributesCmd(ByVal hDrive As Long, DriveNum As IDE_DRIVE_NUMBER)
As Boolean
Dim cbBytesReturned As Long
Dim SCIP As SENDCMDINPARAMS
Dim drv_attr As DRIVEATTRIBUTE
Dim bArrOut(OUTPUT_DATA_SIZE - 1) As Byte
Dim sMsg As String
Dim i As Long
With SCIP
.cBufferSize = READ_ATTRIBUTE_BUFFER_SIZE
.bDriveNumber = DriveNum
With .irDriveRegs
.bFeaturesReg = SMART_READ_ATTRIBUTE_VALUES
.bSectorCountReg = 1
.bSectorNumberReg = 1
.bCylLowReg = SMART_CYL_LOW
.bCylHighReg = SMART_CYL_HI
.bDriveHeadReg = &HA0
If Not IsWindowsNT Then .bDriveHeadReg = .bDriveHeadReg
Or (DriveNum And 1) * 16
.bCommandReg = IDE_EXECUTE_SMART_FUNCTION
End With
End With
ReadAttributesCmd = DeviceIoControl(hDrive, DFP_RECEIVE_DRIVE_DATA, SCIP,
Len(SCIP) - 4, bArrOut(0), OUTPUT_DATA_SIZE, cbBytesReturned, ByVal 0&)
On Error Resume Next
For i = 0 To NUM_ATTRIBUTE_STRUCTS - 1
If bArrOut(18 + i * 12) > 0 Then
di.Attributes(di.NumAttributes).AttrID = bArrOut(18 + i * 12)
di.Attributes(di.NumAttributes).AttrName = "Unknown value ("
& bArrOut(18 + i * 12) & ")"
di.Attributes(di.NumAttributes).AttrName = colAttrNames(CStr(bArrOut(18 + i
* 12)))
di.NumAttributes = di.NumAttributes + 1
ReDim Preserve di.Attributes(di.NumAttributes)
CopyMemory di.Attributes(di.NumAttributes).StatusFlags, bArrOut(19 + i *
12), 2
di.Attributes(di.NumAttributes).AttrValue = bArrOut(21 + i * 12)
di.Attributes(di.NumAttributes).WorstValue = bArrOut(22 + i * 12)
End If
Next i
End
Function
Private
Function ReadThresholdsCmd(ByVal hDrive As Long, DriveNum As IDE_DRIVE_NUMBER)
As Boolean
Dim cbBytesReturned As Long
Dim SCIP As SENDCMDINPARAMS
Dim IDSEC As IDSECTOR
Dim bArrOut(OUTPUT_DATA_SIZE - 1) As Byte
Dim sMsg As String
Dim thr_attr As ATTRTHRESHOLD
Dim i As Long, j As Long
With SCIP
.cBufferSize = READ_THRESHOLD_BUFFER_SIZE
.bDriveNumber = DriveNum
With .irDriveRegs
.bFeaturesReg = SMART_READ_ATTRIBUTE_THRESHOLDS
.bSectorCountReg = 1
.bSectorNumberReg = 1
.bCylLowReg = SMART_CYL_LOW
.bCylHighReg = SMART_CYL_HI
.bDriveHeadReg = &HA0
If Not IsWindowsNT Then .bDriveHeadReg =
.bDriveHeadReg Or (DriveNum And 1) * 16
.bCommandReg = IDE_EXECUTE_SMART_FUNCTION
End With
End With
ReadThresholdsCmd = DeviceIoControl(hDrive, DFP_RECEIVE_DRIVE_DATA, SCIP,
Len(SCIP) - 4, bArrOut(0), OUTPUT_DATA_SIZE, cbBytesReturned, ByVal 0&)
For i = 0 To NUM_ATTRIBUTE_STRUCTS - 1
CopyMemory thr_attr, bArrOut(18 + i *
Len(thr_attr)), Len(thr_attr)
If thr_attr.bAttrID > 0 Then
For j = 0 To UBound(di.Attributes)
If thr_attr.bAttrID = di.Attributes(j).AttrID Then
di.Attributes(j).ThresholdValue =
thr_attr.bWarrantyThreshold
Exit For
End If
Next j
End If
Next i
End
Function
Private
Function GetSmartVersion(ByVal hDrive As Long, VersionParams As
GETVERSIONOUTPARAMS) As Boolean
Dim cbBytesReturned As Long
GetSmartVersion = DeviceIoControl(hDrive, DFP_GET_VERSION, ByVal 0&, 0,
VersionParams, Len(VersionParams), cbBytesReturned, ByVal 0&)
End
Function
Public
Function GetDriveInfo(DriveNum As IDE_DRIVE_NUMBER) As DRIVE_INFO
Dim hDrive As Long
Dim VerParam As GETVERSIONOUTPARAMS
Dim cb As Long
di.bDriveType = 0
di.NumAttributes = 0
ReDim di.Attributes(0)
hDrive = OpenSmart(DriveNum)
If hDrive = INVALID_HANDLE_VALUE Then Exit Function
If Not GetSmartVersion(hDrive, VerParam) Then Exit Function
If Not IsBitSet(VerParam.bIDEDeviceMap, DriveNum) Then Exit Function
di.bDriveType = 1 + Abs(IsBitSet(VerParam.bIDEDeviceMap, DriveNum + 4))
If Not CheckSMARTEnable(hDrive, DriveNum) Then Exit Function
FillAttrNameCollection
Call IdentifyDrive(hDrive, IDE_ID_FUNCTION, DriveNum)
Call ReadAttributesCmd(hDrive, DriveNum)
Call ReadThresholdsCmd(hDrive, DriveNum)
GetDriveInfo = di
CloseHandle hDrive
Set colAttrNames = Nothing
End
Function
Private
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
Private
Function IsBitSet(iBitString As Byte, ByVal lBitNo As Integer) As Boolean
If lBitNo = 7 Then
IsBitSet = iBitString < 0
Else
IsBitSet = iBitString And (2 ^ lBitNo)
End If
End
Function
Private
Function SwapStringBytes(ByVal sIn As String) As String
Dim sTemp As String
Dim i As Integer
sTemp = Space(Len(sIn))
For i = 1 To Len(sIn) - 1 Step 2
Mid(sTemp, i, 1) = Mid(sIn, i + 1, 1)
Mid(sTemp, i + 1, 1) = Mid(sIn, i, 1)
Next i
SwapStringBytes = sTemp
End
Function
Public
Sub FillAttrNameCollection()
Set colAttrNames = New Collection
With colAttrNames
.Add "ATTR_INVALID", "0"
.Add "READ_ERROR_RATE", "1"
.Add "THROUGHPUT_PERF", "2"
.Add "SPIN_UP_TIME", "3"
.Add "START_STOP_COUNT", "4"
.Add "REALLOC_SECTOR_COUNT", "5"
.Add "READ_CHANNEL_MARGIN", "6"
.Add "SEEK_ERROR_RATE", "7"
.Add "SEEK_TIME_PERF", "8"
.Add "POWER_ON_HRS_COUNT", "9"
.Add "SPIN_RETRY_COUNT", "10"
.Add "CALIBRATION_RETRY_COUNT", "11"
.Add "POWER_CYCLE_COUNT", "12"
.Add "SOFT_READ_ERROR_RATE", "13"
.Add "G_SENSE_ERROR_RATE", "191"
.Add "POWER_OFF_RETRACT_CYCLE", "192"
.Add "LOAD_UNLOAD_CYCLE_COUNT", "193"
.Add "TEMPERATURE", "194"
.Add "REALLOCATION_EVENTS_COUNT", "196"
.Add "CURRENT_PENDING_SECTOR_COUNT", "197"
.Add "UNCORRECTABLE_SECTOR_COUNT", "198"
.Add "ULTRADMA_CRC_ERROR_RATE", "199"
.Add "WRITE_ERROR_RATE", "200"
.Add "DISK_SHIFT", "220"
.Add "G_SENSE_ERROR_RATEII", "221"
.Add "LOADED_HOURS", "222"
.Add "LOAD_UNLOAD_RETRY_COUNT", "223"
.Add "LOAD_FRICTION", "224"
.Add "LOAD_UNLOAD_CYCLE_COUNTII", "225"
.Add "LOAD_IN_TIME", "226"
.Add
"TORQUE_AMPLIFICATION_COUNT", "227"
.Add "POWER_OFF_RETRACT_COUNT", "228"
.Add "GMR_HEAD_AMPLITUDE", "230"
.Add "TEMPERATUREII", "231"
.Add "READ_ERROR_RETRY_RATE", "250"
End With
End Sub
حالا يك
ماژول ديگر هم ايجاد كنيد و كدهاي زير را در ان پيست كنيد
Public
Const MAX_IDE_DRIVES = 4
Public
Const READ_ATTRIBUTE_BUFFER_SIZE = 512
Public
Const IDENTIFY_BUFFER_SIZE = 512
Public
Const READ_THRESHOLD_BUFFER_SIZE = 512
Public
Const OUTPUT_DATA_SIZE = IDENTIFY_BUFFER_SIZE + 16
Public
Const DFP_GET_VERSION = &H74080
Public
Const DFP_SEND_DRIVE_COMMAND = &H7C084
Public
Const DFP_RECEIVE_DRIVE_DATA = &H7C088
Public
Type GETVERSIONOUTPARAMS
bVersion As Byte
bRevision As Byte
bReserved As Byte
bIDEDeviceMap As Byte
fCapabilities As Long
dwReserved(3) As Long
End Type
Public
Const CAP_IDE_ID_FUNCTION = 1
Public
Const CAP_IDE_ATAPI_ID = 2
Public
Const CAP_IDE_EXECUTE_SMART_FUNCTION = 4
Public
Type IDEREGS
bFeaturesReg As Byte
bSectorCountReg As Byte
bSectorNumberReg As Byte
bCylLowReg As Byte
bCylHighReg As Byte
bDriveHeadReg As Byte
bCommandReg As Byte
bReserved As Byte
End Type
Public
Type SENDCMDINPARAMS
cBufferSize As Long
irDriveRegs As IDEREGS
bDriveNumber As Byte
bReserved(2) As Byte
dwReserved(3) As Long
bBuffer() As Byte
End Type
Public
Const IDE_ATAPI_ID = &HA1
Public
Const IDE_ID_FUNCTION = &HEC
Public
Const IDE_EXECUTE_SMART_FUNCTION = &HB0
Public
Const SMART_CYL_LOW = &H4F
Public
Const SMART_CYL_HI = &HC2
Public
Type DRIVERSTATUS
bDriverError As Byte
bIDEStatus As Byte
bReserved(1) As Byte
dwReserved(1) As Long
End Type
Public
Enum DRIVER_ERRORS
SMART_NO_ERROR = 0
SMART_IDE_ERROR = 1
SMART_INVALID_FLAG = 2
SMART_INVALID_COMMAND = 3
SMART_INVALID_BUFFER = 4
SMART_INVALID_DRIVE = 5
SMART_INVALID_IOCTL = 6
SMART_ERROR_NO_MEM = 7
SMART_INVALID_REGISTER = 8
SMART_NOT_SUPPORTED = 9
SMART_NO_IDE_DEVICE = 10
End Enum
Public
Type IDSECTOR
wGenConfig As Integer
wNumCyls As Integer
wReserved As Integer
wNumHeads As Integer
wBytesPerTrack As Integer
wBytesPerSector As Integer
wSectorsPerTrack As Integer
wVendorUnique(2) As Integer
sSerialNumber(19) As Byte
wBufferType As Integer
wBufferSize As Integer
wECCSize As Integer
sFirmwareRev(7) As Byte
sModelNumber(39) As Byte
wMoreVendorUnique As Integer
wDoubleWordIO As Integer
wCapabilities As Integer
wReserved1 As Integer
wPIOTiming As Integer
wDMATiming As Integer
wBS As Integer
wNumCurrentCyls As Integer
wNumCurrentHeads As Integer
wNumCurrentSectorsPerTrack As Integer
ulCurrentSectorCapacity As Long
wMultSectorStuff As Integer
ulTotalAddressableSectors As Long
wSingleWordDMA As Integer
wMultiWordDMA As Integer
bReserved(127) As Byte
End Type
Public
Type SENDCMDOUTPARAMS
cBufferSize As Long
DRIVERSTATUS As DRIVERSTATUS
bBuffer() As Byte
End Type
Public
Const SMART_READ_ATTRIBUTE_VALUES = &HD0
Public
Const SMART_READ_ATTRIBUTE_THRESHOLDS = &HD1
Public
Const SMART_ENABLE_DISABLE_ATTRIBUTE_AUTOSAVE = &HD2
Public
Const SMART_SAVE_ATTRIBUTE_VALUES = &HD3
Public
Const SMART_EXECUTE_OFFLINE_IMMEDIATE = &HD4
Public
Const SMART_ENABLE_SMART_OPERATIONS = &HD8
Public
Const SMART_DISABLE_SMART_OPERATIONS = &HD9
Public
Const SMART_RETURN_SMART_STATUS = &HDA
Public
Const NUM_ATTRIBUTE_STRUCTS = 30
Public
Type DRIVEATTRIBUTE
bAttrID As Byte
wStatusFlags As Integer
bAttrValue As Byte
bWorstValue As Byte
bRawValue(5) As Byte
bReserved As Byte
End Type
Public
Enum STATUS_FLAGS
PRE_FAILURE_WARRANTY = &H1
ON_LINE_COLLECTION = &H2
PERFORMANCE_ATTRIBUTE = &H4
ERROR_RATE_ATTRIBUTE = &H8
EVENT_COUNT_ATTRIBUTE = &H10
SELF_PRESERVING_ATTRIBUTE = &H20
End Enum
Public
Type ATTRTHRESHOLD
bAttrID As Byte
bWarrantyThreshold As Byte
bReserved(9) As Byte
End Type
Public
Enum ATTRIBUTE_ID
ATTR_INVALID = 0
ATTR_READ_ERROR_RATE = 1
ATTR_THROUGHPUT_PERF = 2
ATTR_SPIN_UP_TIME = 3
ATTR_START_STOP_COUNT = 4
ATTR_REALLOC_SECTOR_COUNT = 5
ATTR_READ_CHANNEL_MARGIN = 6
ATTR_SEEK_ERROR_RATE = 7
ATTR_SEEK_TIME_PERF = 8
ATTR_POWER_ON_HRS_COUNT = 9
ATTR_SPIN_RETRY_COUNT = 10
ATTR_CALIBRATION_RETRY_COUNT = 11
ATTR_POWER_CYCLE_COUNT = 12
ATTR_SOFT_READ_ERROR_RATE = 13
ATTR_G_SENSE_ERROR_RATE = 191
ATTR_POWER_OFF_RETRACT_CYCLE = 192
ATTR_LOAD_UNLOAD_CYCLE_COUNT = 193
ATTR_TEMPERATURE = 194
ATTR_REALLOCATION_EVENTS_COUNT = 196
ATTR_CURRENT_PENDING_SECTOR_COUNT = 197
ATTR_UNCORRECTABLE_SECTOR_COUNT = 198
ATTR_ULTRADMA_CRC_ERROR_RATE = 199
ATTR_WRITE_ERROR_RATE = 200
ATTR_DISK_SHIFT = 220
ATTR_G_SENSE_ERROR_RATEII = 221
ATTR_LOADED_HOURS = 222
ATTR_LOAD_UNLOAD_RETRY_COUNT = 223
ATTR_LOAD_FRICTION = 224
ATTR_LOAD_UNLOAD_CYCLE_COUNTII = 225
ATTR_LOAD_IN_TIME = 226
ATTR_TORQUE_AMPLIFICATION_COUNT = 227
ATTR_POWER_OFF_RETRACT_COUNT = 228
ATTR_GMR_HEAD_AMPLITUDE = 230
ATTR_TEMPERATUREII = 231
ATTR_READ_ERROR_RETRY_RATE = 250
End Enum
پايان
____________________________________________________________
فراخواني پنجره كنترل پنل
كدهاي زير
را در قسمت كد نويسي فرمتان پيست كنيد
Public
Function ShowControlPanel() As Boolean
On Error Resume Next
Shell "rundll32 shell32,Control_RunDLL", vbNormalFocus
ShowControlPanel = Err.Number = 0
End
Function
Private
Sub Form_Load()
ShowControlPanel
End Sub
پايان
حركت
دادن و تازه سازي ايكن هاي روي دسكتاپ
ما مي
خواهيم ايكن هاي روي دسكتاپ را جابه جا كنيم
خوب براي
اين كار به ابزار زير نياز داريم
Command1
كنترل كامند باتون يا دكمه را روي فرم بگزاريد
حالا
كدهاي زير را در قسمت كد نويسي فرمتان پيست كنيد
Private
Declare Function SendMessageByLong& Lib "user32" Alias
_
"SendMessageA" (ByVal hwnd&, ByVal
wMsg&, ByVal wParam&, ByVal lParam&)
Private
Declare Function FindWindow& Lib "user32" Alias "FindWindowA"
_
(ByVal lpClassName As String, ByVal
lpWindowName As String)
Private
Declare Function FindWindowEx& Lib "user32" Alias
"FindWindowExA" _
(ByVal hWndParent As Long, ByVal
hWndChildAfter As Long, ByVal lpClassName _
As
String, ByVal lpWindowName As String)
Private
Const LVM_GETTITEMCOUNT& = (&H1000 + 4)
Private
Const LVM_SETITEMPOSITION& = (&H1000 + 15)
Dim
hdesk&, i&, icount&, X&, Y&
Public
Sub MoveIcons()
hdesk =
FindWindow("progman", vbNullString)
hdesk =
FindWindowEx(hdesk, 0, "shelldll_defview", vbNullString)
hdesk =
FindWindowEx(hdesk, 0, "syslistview32", vbNullString)
icount =
SendMessageByLong(hdesk, LVM_GETTITEMCOUNT, 0, 0)
For i = 0
To icount - 1
X = 40 *
i: Y = 40 * i
Call
SendMessageByLong(hdesk, LVM_SETITEMPOSITION, i, CLng(X + Y * &H10000))
Next
End Sub
Private
Sub Command1_Click()
Call
MoveIcons
End Sub
پايان
بدست اوردن زمان استارت كامپيوتر يا بدست اوردن زماني كه كامپيوتر را
روشن كردديد
كد
زير زمان اخرين باري كه كامپيوتر لود شده
و يا استارت خورد را نشان مي دهد
براي اين
كار كدهاي زير را در قسمت كد نويسي فرمتان
پيست كنيد
Private
Declare Function GetTickCount Lib "kernel32.dll" _
() As Long
Public
Function GetSystemStartup() As Date
Dim dTicks As Double
dTicks = GetTickCount / 1000 / 60 / 60 / 24
GetSystemStartup = Now() - dTicks
End
Function
Private
Sub Form_Activate()
Print
GetSystemStartup
End Sub
خوب
برانامه را اجرا كنيد اگر شما رياستارت نداده باشد زمان استارت كامپيو ترتان را نشان
مي دهد در
غير اين صورت زمان اخرين ري استارت كه كامپيوتر تان خورد را
نشان مي دهد
پايان
نمايش نوشته هاي داخل تكست باكس با افكت زيبا
ابزارهاي زير را روي فرم بگزاريد
Text1
Timer1
يك تكست
باكس و يك تايمر روي فرم بگزاريد
حالا كد
هاي زير را در قسمت كد نويسي فرمتان پيست كنيد
Dim a
Private
Sub Form_Load()
Timer1.Interval
= 122
End Sub
Private
Sub Timer1_Timer()
If Val(a)
> Len(Text1) Then a = "-1"
a =
Val(a) + 1
Text1.Text
= Mid(" i am abbas mirmousavi you?", 1, Val(a))
End Sub
پايان
_________________________________________________________________
خوب مي خواهم در پست بعدي اگر خدا بخواهد كد يك بازي با هوش مصنوعي خوب و
روش گزاشتن نوشته در عكس به صورت مخفي و چند تا كد در باره امنيت و كمي هم
از بانك
اطلاعاتي ها بزارم اين پستم زياد پر بار نيست ديگه يواش يواش دارم از وب لاگ
نويسي خدا حافظي مي كنم ولي هنوز تا دو سه پست ديگه هم بايد تامل كنيد
اگه سوالي داشتيد تو نظرات بگيد اگه بدونم حتمي
جوابتو نو مي دم در ضمن من خيلي وقته كه
ديگه كد نويسي نمي كنم و يواش يواش دارم اصطلاحات را فراموش مي كنم پس در سوالات
تا جاي كه
مي تونيد توضيح بديد تا من را
حت تر بتونم بهتون كمك كنم
پايان