عجایب برنامه نویسی

[pcdownload.bloghaa.com]

با عرض سلام خدمت اعضا و بازدید کنندگان سایت برنامه نویس.
در دنیای برنامه نویسی 4 نوع مساله وجود دارد.1.مساعل بدیهی 2.مساعل سخت 3.مساعل به ظاهر غیر ممکن 4. مساعل منطقا غیر ممکن

1.مثل ساخت یک ساعت که به یک تایمر و یک لیبل نیاز دارد:

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

Private Sub Timer1_Timer()
Label1.Caption = Time
End Sub


2.مثل ضبط و پخش کردن صدا با وی بی :
این کار قبل از انجام سخت است.
Declare Function mciSendString Lib "winmm.dll" _
Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long
Declare Function mciGetErrorString Lib "winmm.dll" _
Alias "mciGetErrorStringA" _
(ByVal dwError As Long, _
ByVal lpstrBuffer As String, _
ByVal uLength As Long) As Long

Sub CloseSound()

Dim Result&
Dim errormsg%
Dim ReturnString As String * 1024
Dim ErrorString As String * 1024

Result& = mciSendString("close mysound", ReturnString, 1024, 0)

End Su
ub RecordSound()
'records sound aliased as mysound to memory for six seconds
Dim Result&
Dim errormsg%
Dim ReturnString As String * 1024
Dim ErrorString As String * 1024

CloseSound

Result& = mciSendString("open new type waveaudio alias mysound", ReturnString, 1024, 0)
If Not Result& = 0 Then
errormsg% = mciGetErrorString(Result&, ErrorString, 1024)
MsgBox ErrorString, 0, "Error"
Exit Sub
End If

Result& = mciSendString("set mysound time format ms bitspersample 8 samplespersec 11025", ReturnString, 1024, 0)
If Not Result& = 0 Then
errormsg% = mciGetErrorString(Result&, ErrorString, 1024)
MsgBox ErrorString, 0, "Error"
Exit Sub
End If

'Record for 60000 milliseconds
Result& = mciSendString("record mysound to 60000", ReturnString, 1024, 0)
If Not Result& = 0 Then
errormsg% = mciGetErrorString(Result&, ErrorString, 1024)
MsgBox ErrorString, 0, "Error"
Exit Sub
End If
End Sub

Sub PlayRecSound()
'plays the recoreded sound aliased by mysound
Dim Result&
Dim errormsg%
Dim ReturnString As String * 1024
Dim ErrorString As String * 1024

Result& = mciSendString("stop mysound", ReturnString, 1024, 0)
If Not Result& = 0 Then
errormsg% = mciGetErrorString(Result&, ErrorString, 1024)
MsgBox ErrorString, 0, "Error"
End If

Result& = mciSendString("play mysound from 1 wait", ReturnString, 1024, 0)
If Not Result& = 0 Then
errormsg% = mciGetErrorString(Result&, ErrorString, 1024)
MsgBox ErrorString, 0, "Error"
End If

End Su

Private Sub Command1_Click()
RecordSound
End Sub

Private Sub Command2_Click()
Call PlayRecSound
End Sub

Private Sub Form_Unload(Cancel As Integer)
CloseSound
End Sub


3.دیدن چهره یک فایل :
این کار به نظر غیر ممکن میرسد.

یک دکمه و یک تکست باکس در فرم قرار داده وکد زیر را بنویسید.
Dim temp As String
Dim a, b1, b2, b3 As String
Private Sub Command1_Click()
On Error Resume Next
Me.Cls
Open Text1 For Binary As #1
temp = Space(LOF(1))
Get #1, , temp
Close
For i = 1 To Int(Len(temp) / 3)
p = p + 1
DoEvents
If p > Val(500) Then
g p - Val(500), l + 1
p = 0
l = l + 1
Else
g p, l
End If
Next i

End Sub
Private Sub g(i, j)
a = Mid(temp, 1, 3)
b1 = Left(a, 1)
b2 = Mid(a, 2, 1)
b3 = Right(a, 1)
Me.PSet (i, j), RGB(Asc(b1), Asc(b2), Asc(b3))
temp = Mid(temp, 3)
End Sub

Private Sub Form_Load()
k = 1
Me.autoredraw=true
End Sub



در تکست باکس آدرس فایل را نوشته وبا زدن دکمه چهره فایل را روی فرم ببینید.


4.ساخت برنامه ای که یک فایل را آنقدر فشرده کند که حجم آن صفر شود-و دوباره
قابل باز یابی باشد.

این کار مطلقا غیر عملی است چون در هیچ نمی توان اطلاعات ذخیره کرد.

یک تکست باکس و یک دکمه در فرم قرار دهید:
Private Sub Command1_Click()
Dim s as string
Open text1.text for binary as #1
S=space(lof(1))
Get #1,,s
Close #1
Mkdir “c:\test1.soc”
Open “c:\test1.soc\”+strreverse(s) for binary as #1
Close #1
End Sub
در تکست باکس آدرس یک فایل متنی کم حجم حدود 200 بایت را وارد کنید.
و دکمه روی فرم را فشار دهید. یک پوشه به عنوان خروجی با حجم صفر در درایو c:
با نام test1.soc ساخته خواهد شد.

و برای بازیابی فایل از کد زیر استفاده کنید.

یک تکست باکس و یک دکمه و یک فایل لیست در فرم قرار دهید:
Private Sub Command1_Click()
Dim s as string
File1.path=text1
File1.refresh
Open file1.list(0) for binary as #1
S=space(lof(1))
Get #1,,s
Close #1
Open “c:\test1.soc\test1.txt” for binary as #1
Put #1,,strreverse(s)
Close #1
End Sub

آدرس پوشه خروجی برنامه قبل را در تکست باکس وارد کرده و دکمه روی فرم را فشار دهید
یک فایل با نام test1.txt در درایو c: ساخته می شود این همان فایلی است که فشرده شده بود.

[milad-fa]

با سلام
به ترتیب شماره هاشون نظر خودم رو میگم::چشمک:
1-خوب بود.
2-قبلاً این کار رو خودم انجام داده بودم!
3-تست کردم ولی هیچ کار خاصی انجام نمیده.
4-این دستورات رو نمیشناسه :
Mkdir “c:\test1.soc”
Open “c:\test1.soc\”+strreverse(s) for binary as #1
آیا باید رفرنسی Add کنم یا با Shell مشکل حل میشه؟!
مرسی.

[AmirAmiri]

اول اینکه ترفند چهارم شما کاملا زیرکانه بود اما به این نکته باید توجه داشته باشید که نام فایل نمیتونه بیش از 255 کاراکتر بشه پس اگه فایلی که در حدود 260 بایت بهش بدیم، عملا این ترفند کار ساز نیست.
در ثانی ، شما فایلی تولید کردید که درون محتوای خودش هیچ حجمی از اطلاعات قرار نداره اما خوده فایل ، جدا از محتواش ، دارای حجم و اندازه هست که درون فایل سیستم ذخیره میشه و مسلما فضایی از دیسک رو به خودش اختصاص میده.

اما جالب بود.
موفق و پیروز باشید.

[SlowCode]

آقا میلاد شما گیومه ها رو دوباره بنویس درست میشه.

[golbafan]

سلام
منظورت از چهره فایل چیه؟

[pcdownload.bloghaa.com]

این کد تصویری از هر فایل ارایه می دهد که فقط مختص همان فایل می باشد
و از همه عجیب تر نظمی است در چهره برخی فایل ها دیده می شود که یک
نمونه آن را ضمیمه کردم.

[night_secret]

ممنون برنامه ی جالبی بود!!!:چشمک: