آرشیو سورس های کاربردی و بدردبخور

FormPropManager

با این نمونه می تونید اکثر خصوصیات فرم که فقط در زمان طراحی قابل تغییرن رو در زمان اجرا تغییر بدید.

http://mbt925.parsaspace.com/VBCodeS...ropManager.jpg

دانلود

خیلی زیبا باز و بسته میشه
https://barnamenevis.org/attach...6&d=1213180134

SelfKiller

روشی برای پاک کردن فایل اجرایی توسط خودش :
این روش بهترین و ساده ترین روشه که هیچ اثری از فایل باقی نمیگذاره.

نقل قول:

---

روشی برای پاک کردن فایل اجرایی توسط خودش

---

فایل Bat ساخته میشه ولی Exe پاک نمیشه

اینم یه برنامه کوچولو که دقیقا نمیدونم کارش چیه ولی میدونم که نقشه زمین رو به صورت 3 بعدی طراحی میکنه و خیلی جالبه.
اگه شما دونستین چیه به ما بگید.
ضمیمه 19024

در اینجا مجموعه ای از سورسها رو در رابطه با رجیستری گذاشتم

جستجو در رجیستری(فوق العادست)
ضمیمه 19029

ویرایشگر رجیستری(اینم فوق العادست)
ضمیمه 19028

سورسهایی برای کار با رجیستری(بیشتر به درد آماتورا میخوره)
ضمیمه 19026
ضمیمه 19027

با تشکر...

No Edge

تغییر فرم لبه های شیء با استفاده از تابع API اه DrawEdge.

http://mbt925.googlepages.com/NoEdgeScrShot.jpg

دانلود

Get File Icon

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

http://mbt925.googlepages.com/ShowFileIconScrShot.jpg

دانلود

NewStyle Form Anim

افکت های زیبایی برای باز و بسته شدن فرم

دانلود

Check Mail

این نمونه قراره ایمیل های جدید رو چک کنه.

http://mbt925.googlepages.com/CheckMailScrShot.jpg

دانلود

Custom MsgBox


https://barnamenevis.org/attach...7&d=1214149230

(MessageBoxTimeout API (Msgbox TimeOut

 

 

Rem __siavash__

Rem WwW.Barnamenevis.org

 

Option Explicit

 

'# To indicate the buttons displayed in the message box, specify one of the following values.

Private Const MB_ABORTRETRYIGNORE = &H2&

Private Const MB_OKCANCEL = &H1&

Private Const MB_RETRYCANCEL = &H5&

Private Const MB_OK = &H0&

Private Const MB_YESNO = &H4&

Private Const MB_YESNOCANCEL = &H3&

 

'# To display an icon in the message box, specify one of the following values.

Private Const MB_ICONASTERISK = &H40&

Private Const MB_ICONEXCLAMATION = &H30&

Private Const MB_ICONHAND = &H10&

Private Const MB_ICONINFORMATION = MB_ICONASTERISK

Private Const MB_ICONMASK = &HF0&

Private Const MB_ICONQUESTION = &H20&

Private Const MB_ICONSTOP = MB_ICONHAND

 

'# To indicate the default button, specify one of the following values.

Private Const MB_DEFBUTTON1 = &H0&

Private Const MB_DEFBUTTON2 = &H100&

Private Const MB_DEFBUTTON3 = &H200&

 

'# To indicate the modality of the dialog box, specify one of the following values.

Private Const MB_APPLMODAL = &H0&

Private Const MB_SYSTEMMODAL = &H1000&

Private Const MB_TASKMODAL = &H2000&

 

'# To specify other options, use one or more of the following values.

Private Const MB_DEFAULT_DESKTOP_ONLY = &H20000

Private Const MB_SETFOREGROUND = &H10000

 

Private Const SUBLANG_ENGLISH_US = &H1                   '  English (USA)

 

'Delclare APIs

Private Declare Function MessageBoxTimeout Lib "user32.dll" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageId As Long, ByVal lngMilliseconds As Long) As Long

Private Declare Function MessageBoxEx Lib "user32" Alias "MessageBoxExA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageId As Long) As Long

Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

 

Private Sub Command1_Click()

 MessageBoxTimeout Me.hwnd, "This MsgBox is MessageBoxTimeout API with 5000 Ms timeOut!!!", "Information", MB_YESNO Or MB_DEFBUTTON1 Or MB_ICONASTERISK, SUBLANG_ENGLISH_US, 5000

End Sub

Register TypeLib Source

از اسم نمونه ، کارکردش مشخصه.
از سری سورس های VBAccelerator

http://mbt925.googlepages.com/RegTypeLibScrShot.jpg

دانلود

Multiple Monitor Support

از این مدل نمونه ها خیلی کم نوشته میشه.

http://mbt925.googlepages.com/MultiMonitorScrShot.jpg

دانلود

Scroll Picture - BitBlt

حرکت دادن تصویر با تابع API ، BitBlt

دانلود

Path Extractor

این نمونه یک مسیر دریافت می کنه و تمام فایل ها و فولدرهای اون مسیر رو استخراج می کنه (نامشون رو) و در یک ساختار درختی نمایش میده.

این برنامه از روش BFS برای پیمایش سطوح مسیر استفاده می کنه.

http://mbt925.googlepages.com/PathExtractorScrShot.jpg

دانلود

باز كردن مسیر ها و پوشه های خاص ویندوز
(نویسنده: جناب Darg از ایران ویج)

 

My Computer

Explorer /E,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}

Explanation: The object My Computer is a namespace which has the CLSID: {20D04FE0-3AEA-1069-A2D8-08002B30309D}
 

 

 

 

Control Panel

Explorer /N,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}

Explanation: The Control Panel object whose CLSID is: {21EC2020-3AEA-1069-A2DD-08002B30309D} is a sub-object of My Computer.
 

 

 

 

 

Printers and telecopiers

Explorer /N,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{2227A280-3AEA-1069-A2DE-08002B30309D}
 

 

 

 

Fonts

Explorer /N,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{D20EA4E1-3957-11d2-A40B-0C5020524152}
 

 

 

 

 

Scanners and Cameras

Explorer /N,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{E211B736-43FD-11D1-9EFB-0000F8757FCD}
 

 

 

 

 

Network Neighborhood

Explorer /N,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{7007ACC7-3202-11D1-AAD2-00805FC1270E}
 

 

 

 

 

Administration Tools

Explorer /N,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{D20EA4E1-3957-11d2-A40B-0C5020524153}
 

 

 

 

 

Tasks Scheduler

Explorer /N,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{D6277990-4C6A-11CF-8D87-00AA0060F5BF}
 

 

 

 

 

Web Folders

Explorer /N,::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\::{BDEADF00-C265-11D0-BCED-00A0C90AB50F}
 

 

 

 

 

Recycle Bin

Explorer /N,::{645FF040-5081-101B-9F08-00AA002F954E}
 

 

 

 

Network Favorites

Explorer /N,::{208D2C60-3AEA-1069-A2D7-08002B30309D}
 

 

 

 

Default Navigator

Explorer /N,::{871C5380-42A0-1069-A2EA-08002B30309D}
 

 

 

 

Computer search results folder

Explorer /N,::{1F4DE370-D627-11D1-BA4F-00A0C91EEDBA}
 

 

 

 

 

Network Search Results computer

Explorer /N,::{E17D4FC0-5564-11D1-83F2-00A0C90DC849}
 

 

 

 

 

My Documents

Explorer /N,::{450D8FBA-AD25-11D0-98A8-0800361B1103}

مرتبط با همین بحث میتونید به این تاپیک برید
آشنایی با RunDll32.exe

Auto Complete Path

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

http://mbt925.googlepages.com/AutoCompScrShot.jpg

دانلود

Create Object By API

ساخت کنترل با API و در زمان اجرا

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long

دانلود

کنترل وضعیت مانیتور

Option Explicit



Private Declare Function SendScreenMessage Lib "user32" _

   Alias "SendMessageA" _

  (ByVal hwnd As Long, _

   ByVal wMsg As Long, _

   ByVal wParam As Long, _

   lParam As Any) As Long



Private Const MONITOR_ON = -1&

Private Const MONITOR_LOWPOWER = 1&

Private Const MONITOR_OFF = 2&

Private Const SC_MONITORPOWER = &HF170&

Private Const WM_SYSCOMMAND = &H112



Public Function MonitorOff(Form As Form)

    

    Call SendScreenMessage(Form.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_OFF)



End Function



Public Function MonitorOn(Form As Form)

    

    Call SendScreenMessage(Form.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_ON)



End Function



Public Function MonitorPowerDown(Form As Form)

    

    Call SendScreenMessage(Form.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_LOWPOWER)

    

End Function

ایجاد سایه برای فرم

List of applications

این نمونه لیست Application ها رو نشون میده، یه چیزی شبیه به تب Applications در TaskManager.

با رعایت یه سری قوانین ساده و استفاده از تابع API اه EnumWindows

دانلود

Form Animate
یه افکت زیبا برای باز و بسته شدن فرم

دانلود

Window Magnetizing to edge of the screen
نمونه ی جالبیه. وقتی فرم رو نزدیک به گوشه های صفحه ببرید، می چسبه بهشون.
نکات دیگه ای هم درش نهفته است.

دانلود

http://www.planetsourcecode.com/Uplo...2821426883.gif

Fast Rotate Picture

این نمونه با 3 روش مختلف تصویر رو می چرخونه و روی سرعتشون بحث می کنه.

دانلود

http://www.planetsourcecode.com/uplo...1249409047.gif

Skin Like Winamp

یه اسکین جالب که با تصویر ساخته میشه.

دانلود

http://mbt925.googlepages.com/Winamp-VBSkinScrShot.jpg

Some effect

یه مجموعه از چند جلوه ی جالب که همشون زیبان.
این جلوه ها گلچین شده هستن.

چند جلوه برروی صفحه نمایش

جلوه ی زیر آب

جلوه ی دور شونده برای متن

جلوه ی دورشونده و تاشو برای متن

Make exe from pictures

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

دانلود

Super Gradiant

این نمونه چند مدل شیب رنگ رو ایجاد می کنه که همشون زیبان.

دانلود

http://mbt925.googlepages.com/SuperGradiantScrShot.jpg

Transparent Form BackGround

شفاف کردن قسمتی از فرم

دانلود

TileMaker

این نمونه، یه برنامه ی کامله برای ...

دانلود

http://mbt925.googlepages.com/TileMakerScrShot.jpg

اینم یه ماژول که 60 تا تابع توش نوشتم
از قبیل :بدست آوردن پوشه ویندوز،خاموش کردن،ریست کردن،تغییر مکان موس،بستن پنجره،تغییر عنوان پنجره،بدست آوردن عنوان پنجره،تغییر ساعت،گرفتن مشخصات کامل یک فایل و ست کردن خصوصیات فایل،گرفتن مشخصات کامل یک درایو،حذف پوشه و ....

یه چیزی شبیه winamp

سلام. من مي خوام يك مجموعه كدهاي كوچولو ولي واقعا كاربردي رو اينجا بزارم.


اين كد شبيه AutoComplete مي باشد نمونه تصوير رو ببينيد:
يك text و يك List

http://i36.tinypic.com/otjby0.jpg

Private Const LB_FINDSTRING = &H18F

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long



Private Sub Form_Load()

List1.AddItem "Computer"

List1.AddItem "Screen"

List1.AddItem "Modem"

List1.AddItem "Printer"

List1.AddItem "Scanner"

List1.AddItem "Sound Blaster"

List1.AddItem "Keyboard"

List1.AddItem "CD-Rom"

List1.AddItem "Mouse"

End Sub



Private Sub Text1_Change()

List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, ByVal CStr(Text1.Text))

End Sub

بدون شرح:
https://barnamenevis.org/attach...1&d=1278280494
http://i36.tinypic.com/2ch5h95.jpg

Private Const EM_UNDO = &HC7

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long



Private Sub Form_Click()

SendMessage Text1.hwnd, EM_UNDO, 0, ByVal CStr(0)

End Sub



Private Sub Form_Load()

Text1.Text = "قسمتي از متن را تغيير بدهيد سپس روي فرم كليك كنيد و انجام عمل Undo را در متن خواهيد ديد"

End Sub

با همين يه ذره كد مي تونيد همه فونت هاي سيستم رو تو يك Combo نمايش بديد و بعد هم استفاده كنيد.

http://i34.tinypic.com/30w5dtk.jpg


اين قسمت تو ماژول:

Const CB_FINDSTRING = &H14C

Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const CB_SHOWDROPDOWN = &H14F



Public Function ComboBoxIndex(ByVal lHwnd As Long, ByVal sSearchText As String) As Long

ComboBoxIndex = SendMessageAny(lHwnd, CB_FINDSTRING, -1, ByVal sSearchText)

End Function



Private Sub Combo1_Change()

r = SendMessageLong(Combo1.hwnd, CB_SHOWDROPDOWN, True, 0)

ComboBoxIndex Combo1.hwnd, Combo1.Text

End Sub

اين قسمت هم تو فرم:

Private Sub Command1_Click()

Text1.FontName = Combo1.Text

End Sub



Private Sub Form_Load()

For i = 0 To Screen.FontCount - 1

Combo1.AddItem Screen.Fonts(i)

Next i

Combo1.Text = Screen.Fonts(0)

End Sub

توابع تبديل عدد به رشته !

اما اين با اون چيزي كه فكر مي كنيد فرق مي كنه به عكس نگاه كنيد:
http://i33.tinypic.com/1yn6km.jpg

اين يكي كوچولو نيست چون هرچي بزرگتر باشه بهتره.

براي برنامه هاي حسابداري چيزه خوبيه.
اما فارسي كردنش با خودتون. هركي فارسيش كرد به بقيه هم ندا بده.

Option Explicit



Public Function ConvertNumberToText(ByVal strNumber As String) As String

strNumber = CleanNumber(strNumber)

Select Case Len(strNumber)

Case Is > 9

ConvertNumberToText = "Error: Number Too Large!"

Case 9, 8, 7

ConvertNumberToText = ProcessMillions(strNumber)

Case 6, 5, 4

ConvertNumberToText = ProcessThousands(strNumber)

Case 3

ConvertNumberToText = ProcessHundreds(strNumber)

Case 2

ConvertNumberToText = ProcessTensAndUnits(strNumber)

Case 1

ConvertNumberToText = GetNumberWord(strNumber)

End Select

End Function



Private Function CleanNumber(ByVal strNumber As String) As String

CleanNumber = strNumber

Do Until Left(CleanNumber, 1) <> "0"

CleanNumber = Mid(CleanNumber, 2)

If Len(CleanNumber) = 0 Then

Exit Do

End If

Loop

End Function



Private Function GetNumberWord(ByVal strNumber As String) As String

Select Case strNumber

Case "9"

GetNumberWord = "nine"

Case "8"

GetNumberWord = "eight"

Case "7"

GetNumberWord = "seven"

Case "6"

GetNumberWord = "six"

Case "5"

GetNumberWord = "five"

Case "4"

GetNumberWord = "four"

Case "3"

GetNumberWord = "three"

Case "2"

GetNumberWord = "two"

Case "1"

GetNumberWord = "one"

End Select

End Function



Private Function ProcessTensAndUnits(ByVal strNumber As String) As String

Dim blmIsTeen As Boolean

If Len(strNumber) >= 2 Then

Select Case Mid(strNumber, 1, 1)

Case "9", "7", "6"

ProcessTensAndUnits = GetNumberWord(Left(strNumber, 1)) & "ty"

Case "8"

ProcessTensAndUnits = GetNumberWord(Left(strNumber, 1)) & "y"

Case "5"

ProcessTensAndUnits = "fifty"

Case "4"

ProcessTensAndUnits = "forty"

Case "3"

ProcessTensAndUnits = "thirty"

Case "2"

ProcessTensAndUnits = "twenty"

Case "1"

blmIsTeen = True

End Select

End If

If blmIsTeen = True Then

Select Case Right(strNumber, 1)

Case "9", "7", "6", "4"

ProcessTensAndUnits = ProcessTensAndUnits & GetNumberWord(Right(strNumber, 1)) & "teen"

Case "8"

ProcessTensAndUnits = ProcessTensAndUnits & GetNumberWord(Right(strNumber, 1)) & "een"

Case "5"

ProcessTensAndUnits = ProcessTensAndUnits & "fifteen"

Case "3"

ProcessTensAndUnits = ProcessTensAndUnits & "thirteen"

Case "2"

ProcessTensAndUnits = ProcessTensAndUnits & "twelve"

Case "1"

ProcessTensAndUnits = ProcessTensAndUnits & "eleven"

Case "0"

ProcessTensAndUnits = ProcessTensAndUnits & "ten"

End Select

Else

ProcessTensAndUnits = ProcessTensAndUnits & " " & GetNumberWord(Right(strNumber, 1))

End If

End Function



Private Function ProcessHundreds(ByVal strNumber As String) As String

ProcessHundreds = GetNumberWord(Left(strNumber, 1)) & " hundred"

strNumber = CleanNumber(Mid(strNumber, 2))

Select Case Len(strNumber)

Case 2

ProcessHundreds = ProcessHundreds & " and " & ProcessTensAndUnits(strNumber)

Case Is = 1

ProcessHundreds = ProcessHundreds & " and " & GetNumberWord(strNumber)

End Select

End Function



Private Function ProcessThousands(ByVal strNumber As String) As String

Select Case Len(strNumber)

Case 6

ProcessThousands = ProcessHundreds(Left(strNumber, 3)) & " thousand"

strNumber = Mid(strNumber, 4)

Case 5

ProcessThousands = ProcessTensAndUnits(Left(strNumber, 2)) & " thousand"

strNumber = Mid(strNumber, 3)

Case 4

ProcessThousands = GetNumberWord(Left(strNumber, 1)) & " thousand"

strNumber = Mid(strNumber, 2)

End Select

strNumber = CleanNumber(strNumber)

Select Case Len(strNumber)

Case 3

ProcessThousands = ProcessThousands & " " & ProcessHundreds(strNumber)

Case Is >= 1

ProcessThousands = ProcessThousands & " and " & ProcessTensAndUnits(strNumber)

End Select

End Function



Private Function ProcessMillions(ByVal strNumber As String) As String

Select Case Len(strNumber)

Case 9

ProcessMillions = ProcessHundreds(Left(strNumber, 3)) & " million"

strNumber = Mid(strNumber, 4)

Case 8

ProcessMillions = ProcessTensAndUnits(Left(strNumber, 2)) & " million"

strNumber = Mid(strNumber, 3)

Case 7

ProcessMillions = GetNumberWord(Left(strNumber, 1)) & " million"

strNumber = Mid(strNumber, 2)

End Select

strNumber = CleanNumber(strNumber)

Select Case Len(strNumber)

Case Is >= 4

ProcessMillions = ProcessMillions & " " & ProcessThousands(strNumber)

Case 3

ProcessMillions = ProcessMillions & " " & ProcessHundreds(strNumber)

Case Is >= 1

ProcessMillions = ProcessMillions & " and " & ProcessTensAndUnits(strNumber)

End Select

End Function

ادغام دو عكس با همديگر

تا چند وقت پيش سوال خيلي ها از جمله خودم اين بود كه چطور مي تونيم محتويات يك عكس رو تغيير بديم و بعد هم با اعمال تغييرات آن را ذخيره كنيم.

سه تا Picture لازم داريم و يك Command.

Private Declare Function SetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long



Private Sub Command1_Click()

For i = 1 To Picture2.ScaleWidth

   For j = 1 To Picture2.ScaleHeight

      q = GetPixel(Picture1.hdc, i, j)

      r = GetPixel(Picture2.hdc, i, j)

      SetPixel Picture3.hdc, i, j, q Or r

      DoEvents

   Next j

Next i

End Sub

اين قطعه برنامه پيكسل به پيكسل هر دو عكس هاي 1و 2 را مي خواند و با هم جمع (or) مي كند و حاصل را در picture3 قرار مي دهد.
هدف از قرار دادن اين قطعه كد آشنايي با توابع گرافيكي GetPixel و SetPixel هست كه در كتابخانه gdi32.dll وجود دارند.

يك مثلث كه ميشه مربع بعد ميشه پنج ضلعي بعد ميشه شش ضلعي بعد ميشه ...
همه اينها در حال چرخش هستند.
كپي كنيد يك تايمر بزارين رو فرم بعد هم F5

چون همه چيز تحت Scale فرم كار ميكنه پس با تغيير اندازه فرم عكس العمل نشون ميده.

Private Type POINTAPI

   x As Long

   y As Long

End Type

Public picc As Integer

Public Max As Integer

Public phi As Integer

Public lhdc As Long

Public b As Boolean

Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long

Dim lp As POINTAPI

Dim x(10) As Single

Dim y(10) As Single

Dim xo(10) As Single

Dim yo(10) As Single

Dim xx As Single

Dim yy As Single

Dim cc As Single

Dim i%, j%

Dim l As Long

Option Explicit



Private Sub Form_Load()

Timer1.Interval = 100

Timer1.Enabled = True

Max = 3

lhdc = Me.hdc

End Sub



Private Sub Timer1_Timer()

phi = phi + 20

If phi >= 180 Then

   phi = 0

   If Not b Then

      Max = Max + 1

      If Max = 11 Then

         Max = 9

         b = Not b

      End If

   Else

      Max = Max - 1

      If Max = 2 Then

         Max = 4

         b = Not b

      End If

   End If

End If

Cls

xx = (Form1.Width - 10) / 2

yy = (Form1.Height - 600) / 2

If xx <= yy Then cc = xx Else cc = yy

For i% = 1 To Max

   xo(i%) = Cos((phi + (i% - 1) * (360 / Max)) * 3.1415927 / 180) * cc + xx

   yo(i%) = Sin((phi + (i% - 1) * (360 / Max)) * 3.1415927 / 180) * cc + yy

Next i%

For i% = 1 To Max

   xo(i%) = xo(i%) / 15

   yo(i%) = yo(i%) / 15

Next i%

For i% = 1 To Max

   j% = i% + 1

   If j% > Max Then j% = 1

   l = MoveToEx(lhdc, xo(i%), yo(i%), lp)

   l = LineTo(lhdc, xo(j%), yo(j%))

Next i%

While Abs(CInt(yo(1)) - CInt(yo(3))) > 60 Or Abs(CInt(xo(1)) - CInt(xo(3))) > 60

   For i% = 1 To Max

      j% = i% + 1

      If j% = Max + 1 Then j% = 1

      x(j%) = xo(j%) + 0.05 * (xo(i%) - xo(j%))

      y(j%) = yo(j%) + 0.05 * (yo(i%) - yo(j%))

   Next i%

   For i% = 1 To Max

      xo(i%) = x(i%)

      yo(i%) = y(i%)

   Next i%

   For i% = 1 To Max

      j% = i% + 1

      If j% > Max Then j% = 1

      l = MoveToEx(lhdc, xo(i%), yo(i%), lp)

      l = LineTo(lhdc, xo(j%), yo(j%))

   Next i%

Wend

End Sub

استخراج آيكن هر نوع فايل

تا حالا اين همه برنامه براي كش رفتن آيكن ديديد و دانلود كرديد اما كدوم يكيش دوخطي بوده !

https://barnamenevis.org/attach...1&d=1278280295

http://i34.tinypic.com/1zpl5py.jpg

Private Const DI_MASK = &H1

Private Const DI_IMAGE = &H2

Private Const DI_NORMAL = DI_MASK Or DI_IMAGE

Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long

Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long

Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long



Private Sub Form_Click()

mIcon = ExtractAssociatedIcon(App.hInstance, "C:\Autoexec.bat", 2)

DrawIconEx Me.hdc, 0, 0, mIcon, 0, 0, 0, 0, DI_NORMAL

End Sub

براي ذخيره كردنش هم كه ديگه كاري نداره يك picture رو فرم ميزارين و آيكن رو تو اون قرار ميديد و بعد هم با SavePicture ذخيرش مي كنيد.

انتخاب قسمتي از عكس

يك كوچولو كد براي يك كار بزرگ.
به عكس نگاه كنيد معلومه كه چه چيزهايي لازم داريم.
قبل از اجراي برنامه Scalemode هر دو Picture رو به Pixel تغيير بديد.

http://i38.tinypic.com/24fwff4.jpghttps://barnamenevis.org/attach...1&d=1278280158

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

Const SRCCOPY = &HCC0020

Dim minX As Single

Dim maxX As Single

Dim minY As Single

Dim maxY As Single

Dim isRectExist As Boolean

  

Private Sub Command1_Click()

Picture2.Cls

If maxX < minX Then

   temp = minX

   minX = maxX

   maxX = temp

End If

If maxY < minY Then

   temp = minY

   minY = maxY

   maxY = temp

End If

result& = BitBlt(Picture2.hdc, 0, 0, maxX - minX, maxY - minY, Picture1.hdc, _

minX, minY, SRCCOPY)

End Sub



Sub Form_Load()

isBoxExist = False

minX = -10

maxX = 10

minY = -10

maxY = 10

End Sub



Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 1 Then

   If isRectExist Then

      Picture1.Cls

      isBoxExist = False

   End If

   minX = X

   maxY = Y

   maxX = X

   maxY = Y

End If

End Sub



Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 1 Then

   Picture1.DrawMode = 10

   Picture1.Line (minX, maxY)-(maxX, minY), , B

   maxX = X

   minY = Y

   Picture1.Line (minX, maxY)-(maxX, minY), , B

   Picture1.DrawMode = 13

End If

End Sub



Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

isRectExist = True

End Sub

انتخاب رنگ جايي كه موس قرار دارد

يك label و يك تايمر رو فرم قرار بديد.
چون با API كار مي كنيم رنگ هاي خارج از محيط فرم رو مي تونيم دريافت كنيم.

http://i38.tinypic.com/29mlr3n.jpg

Option Explicit

Private Type POINTAPI

   x As Long

   y As Long

End Type

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long



Private Sub Form_Load()

Timer1.Interval = 100

End Sub

Private Sub Timer1_Timer()

Dim tPOS As POINTAPI

Dim sTmp As String

Dim lColor As Long

Dim lDC As Long

lDC = GetWindowDC(0)

Call GetCursorPos(tPOS)

lColor = GetPixel(lDC, tPOS.x, tPOS.y)

Label1.BackColor = lColor

sTmp = Right$("000000" & Hex(lColor), 6)

Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2)

End Sub

ادغام دو عكس با همديگر

نه دوست من هنوز يادم نرفته چند پست بالاتر با اين عنوان يك كوچولو كد گذاشتم.
اونو فقط براي اين گذاشتم تا كار با GetPixel و SetPixel رو ياد بگيريم چون خيلي جا ها اين توابع لازم هستند.
ولي براي ادغام دو عكس از اون استفاده نكنيد چون ممكنه در جمع رنگ Pixel ها بي عدالتي پيش بياد و رنگهاي روشن تر به رنگ هاي تيره غلبه كنند.
به عكس نگاه كنيد چقدر قشنگ تعادل در تقسيم رنگ وجود داره.

http://i34.tinypic.com/23kad05.jpg

براي ادغام دوعكس مي تونيد از اين كوچولو كد استفاده كنيد:

Const AC_SRC_OVER = &H0

Private Type BLENDFUNCTION

   BlendOp As Byte

   BlendFlags As Byte

   SourceConstantAlpha As Byte

   AlphaFormat As Byte

End Type

Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long

Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)



Private Sub Form_Load()

Dim BF As BLENDFUNCTION, lBF As Long

Picture1.AutoRedraw = True

Picture2.AutoRedraw = True

Picture1.ScaleMode = vbPixels

Picture2.ScaleMode = vbPixels

With BF

   .BlendOp = AC_SRC_OVER

   .BlendFlags = 0

   .SourceConstantAlpha = 128

   .AlphaFormat = 0

End With

RtlMoveMemory lBF, BF, 4

AlphaBlend Picture2.hdc, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, lBF

End Sub

Messenger File Transfer

ارسال و دریافت فایل در مسنجر

http://mbt925.googlepages.com/Messen...ferScrShot.jpg

دانلود