FormPropManager
با این نمونه می تونید اکثر خصوصیات فرم که فقط در زمان طراحی قابل تغییرن رو در زمان اجرا تغییر بدید.
دانلود
انیمیشن زیبا برای فرمهای About
خیلی زیبا باز و بسته میشه
https://barnamenevis.org/attach...6&d=1213180134
SelfKiller
روشی برای پاک کردن فایل اجرایی توسط خودش :
این روش بهترین و ساده ترین روشه که هیچ اثری از فایل باقی نمیگذاره.
فایل Bat ساخته میشه ولی Exe پاک نمیشهروشی برای پاک کردن فایل اجرایی توسط خودش
اینم یه برنامه کوچولو که دقیقا نمیدونم کارش چیه ولی میدونم که نقشه زمین رو به صورت 3 بعدی طراحی میکنه و خیلی جالبه.
اگه شما دونستین چیه به ما بگید.
3DTerrain.rar
آخرین ویرایش به وسیله Mbt925 : پنج شنبه 23 خرداد 1387 در 12:49 عصر
اینم مجموعه ای از سورسهای مفید در رابطه با رجیستری
در اینجا مجموعه ای از سورسها رو در رابطه با رجیستری گذاشتم
جستجو در رجیستری(فوق العادست)
RegistrySearch.zip
ویرایشگر رجیستری(اینم فوق العادست)
RegistryRunEdit.rar
سورسهایی برای کار با رجیستری(بیشتر به درد آماتورا میخوره)
RegCtrl.rar
registryeditor.zip
با تشکر...
Custom MsgBox
(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
باز كردن مسیر ها و پوشه های خاص ویندوز
(نویسنده: جناب 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
آخرین ویرایش به وسیله __siavash__ : سه شنبه 25 تیر 1387 در 14:35 عصر
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
ایجاد سایه برای فرم
Some effect
یه مجموعه از چند جلوه ی جالب که همشون زیبان.
این جلوه ها گلچین شده هستن.
چند جلوه برروی صفحه نمایش
جلوه ی زیر آب
جلوه ی دور شونده برای متن
جلوه ی دورشونده و تاشو برای متن
اینم یه ماژول که 60 تا تابع توش نوشتم
از قبیل :بدست آوردن پوشه ویندوز،خاموش کردن،ریست کردن،تغییر مکان موس،بستن پنجره،تغییر عنوان پنجره،بدست آوردن عنوان پنجره،تغییر ساعت،گرفتن مشخصات کامل یک فایل و ست کردن خصوصیات فایل،گرفتن مشخصات کامل یک درایو،حذف پوشه و ....
یه چیزی شبیه winamp
سلام. من مي خوام يك مجموعه كدهاي كوچولو ولي واقعا كاربردي رو اينجا بزارم.
اين كد شبيه AutoComplete مي باشد نمونه تصوير رو ببينيد:
يك text و يك List
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
الگوریتم هایی که تاریخچه خود را فراموش می کنند، محکوم به تکرار آن هستند.
بدون شرح:
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
آخرین ویرایش به وسیله xxxxx_xxxxx : دوشنبه 14 تیر 1389 در 01:05 صبح
الگوریتم هایی که تاریخچه خود را فراموش می کنند، محکوم به تکرار آن هستند.
با همين يه ذره كد مي تونيد همه فونت هاي سيستم رو تو يك Combo نمايش بديد و بعد هم استفاده كنيد.
اين قسمت تو ماژول:
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
الگوریتم هایی که تاریخچه خود را فراموش می کنند، محکوم به تکرار آن هستند.
توابع تبديل عدد به رشته !
اما اين با اون چيزي كه فكر مي كنيد فرق مي كنه به عكس نگاه كنيد:
اين يكي كوچولو نيست چون هرچي بزرگتر باشه بهتره.
براي برنامه هاي حسابداري چيزه خوبيه.
اما فارسي كردنش با خودتون. هركي فارسيش كرد به بقيه هم ندا بده.
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
آخرین ویرایش به وسیله xxxxx_xxxxx : دوشنبه 14 تیر 1389 در 01:03 صبح
الگوریتم هایی که تاریخچه خود را فراموش می کنند، محکوم به تکرار آن هستند.
استخراج آيكن هر نوع فايل
تا حالا اين همه برنامه براي كش رفتن آيكن ديديد و دانلود كرديد اما كدوم يكيش دوخطي بوده !
براي ذخيره كردنش هم كه ديگه كاري نداره يك picture رو فرم ميزارين و آيكن رو تو اون قرار ميديد و بعد هم با SavePicture ذخيرش مي كنيد.
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
آخرین ویرایش به وسیله xxxxx_xxxxx : دوشنبه 14 تیر 1389 در 01:01 صبح
الگوریتم هایی که تاریخچه خود را فراموش می کنند، محکوم به تکرار آن هستند.
انتخاب قسمتي از عكس
يك كوچولو كد براي يك كار بزرگ.
به عكس نگاه كنيد معلومه كه چه چيزهايي لازم داريم.
قبل از اجراي برنامه Scalemode هر دو Picture رو به Pixel تغيير بديد.
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
آخرین ویرایش به وسیله xxxxx_xxxxx : دوشنبه 14 تیر 1389 در 00:59 صبح
الگوریتم هایی که تاریخچه خود را فراموش می کنند، محکوم به تکرار آن هستند.
انتخاب رنگ جايي كه موس قرار دارد
يك label و يك تايمر رو فرم قرار بديد.
چون با API كار مي كنيم رنگ هاي خارج از محيط فرم رو مي تونيم دريافت كنيم.
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 ها بي عدالتي پيش بياد و رنگهاي روشن تر به رنگ هاي تيره غلبه كنند.
به عكس نگاه كنيد چقدر قشنگ تعادل در تقسيم رنگ وجود داره.
براي ادغام دوعكس مي تونيد از اين كوچولو كد استفاده كنيد:
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
الگوریتم هایی که تاریخچه خود را فراموش می کنند، محکوم به تکرار آن هستند.
پاسخ با نقل قول
