سلام
این برنامه رو ببینید
کارش اینه که پیکسل های سیاه تصویر رو سیاه تر می کنه
اما مشکلش اینه که خط بعد نمیره
سلام
این برنامه رو ببینید
کارش اینه که پیکسل های سیاه تصویر رو سیاه تر می کنه
اما مشکلش اینه که خط بعد نمیره
خط بعد نمی ره یعنی چه .یه خورده واضح تر توضیح بدید .اما مشکلش اینه که خط بعد نمیره
یک سری پیکسل داریم که در ردیف ها و ستون ها قرار گرفتن
اینبرنامه فقط ردیف اول پیکسل ها رو ویرایش می کنه و سراغ ردیف بعدی نمیره
عزیز جان اون تکیه کدی که داره این عملیات پیمایش رو انجام میده قرار بده اینجا .این مطلب رو تو پست قبلیت هم گفتی نیاز به تکرار نبوداینبرنامه فقط ردیف اول پیکسل ها رو ویرایش می کنه و سراغ ردیف بعدی نمیره
فایل رو که ضمیمه کردم دیگه
سرعت اینترنتم انقدر بالا نیست که دم به دقیقه برای هر چیزی فایا دانلود کنم برای پیشبرد کار خودتون گفتمفایل رو که ضمیمه کردم دیگه
226 کیلو بایت بیشتر نیست که
این هم کد:
Private Sub Command1_Click()
Do
Dim R As Byte, G As Byte, B As Byte
Dim Color As Long
'entekhabe pixel
Color = Picture1.Point(txt_x.Text, txt_y.Text)
'-------------------------
'bedast avardane meghdare RGB pixel be komak Module1
R = ExtractR(Color)
G = ExtractG(Color)
B = ExtractB(Color)
txt_R = R
txt_B = B
txt_G = G
'-------------------------
'siah tar kardan e pixel haie siah
If ExtractR(Color) < 200 Then
If ExtractG(Color) < 200 Then
If ExtractB(Color) < 200 Then
Picture2.PSet (txt_x.Text, txt_y.Text), RGB(0, 0, 0)
End If
End If
End If
'-------------------------
'taeene pixele ba'di
If txt_x.Text < Picture1.ScaleWidth Then
txt_x.Text = txt_x.Text + 1
End If
If txt_x.Text = Picture1.ScaleWidth Then
txt_y.Text = txt_y.Text + 1
txt_x.Text = 1
End If
Loop Until txt_y.Text = txt_total_y.Text
End Sub
Private Sub Form_Load()
txt_total_x.Text = Picture1.ScaleWidth
txt_total_y.Text = Picture1.ScaleHeight
End Sub
Private Sub Timer1_Timer()
Dim R As Byte, G As Byte, B As Byte
Dim Color As Long
Color = Picture1.Point(txt_x.Text, txt_y.Text)
R = ExtractR(Color)
G = ExtractG(Color)
B = ExtractB(Color)
txt_R = R
txt_B = B
txt_G = G
If ExtractR(Color) < 200 Then
If ExtractG(Color) < 200 Then
If ExtractB(Color) < 200 Then
Picture1.PSet (txt_x.Text, txt_y.Text), RGB(0, 0, 0)
End If
End If
End If
If txt_x.Text < Picture1.ScaleWidth Then
txt_x.Text = txt_x.Text + 1
End If
If txt_x.Text = Picture1.ScaleWidth Then
txt_y.Text = txt_x.Text + 1
txt_x.Text = 1
End If
End Sub
من بعید میدونم شما آخرش هم جواب بدی
برنامه شما كار ميكنه اما با كمي تغييرات:
1- اضافه كردن دستور DoEvents به داخل دستور Do
Do
DoEvents
2- قرار دادن ScaleMode برابر vbPixels (براي سرعت بيشتر)
Picture1.ScaleMode = vbPixels
Picture2.ScaleMode = vbPixels
3- تغيير خاصيت AutoRedraw پيك2 به True
اشكالات
1- سرعت پايين (راه حلي ندارم)
2- برنامه بسته نميشه = متغييري را به عنوان شرط خروج از حلقه Do Loop Until قرار دهيد
برای سرعت پایین برنامه، سعی کنید بجای اینکه مقادیر رو به TextBox ها پاس بدید، از متغیر استفاده کنید. تخصیص مقدار به TextBox ها در اینگونه مواقع بسیاز زمانبر هست.
توابعی که در ماژول نوشته اید را بی جهت فراخوانی نکنید، شما یک بار خروجی این توابع را در سه متغیر R، G و B قرار داده اید، اما باز در هر سه شرط مجدداً آنها را فراخوانی کرده اید که کار بیهوده ای هست و می تونید از همان مقادیر قبلی استفاده کنید.
هر سه تا شرط که پشت سر هم قرار دارند، و تو در تو هستند را به یک IF تبدیل کنید و بین شرط ها از And استفاده کنید.
DoEvents را با یک شرط اجرا کنید، مثلاً هر بار که یک سطر رنگ میشه، یک بار DoEvents اجرا بشه. اگر DoEvents به ازای هر پیکسلی که رسم میشه اجرا بشه، در کاهش سرعت برنامه بسیار اثر گذار هست.
چرا همه این کارها هم داره توی تایمر انجام میشه و هم در داخل حلقه ای که در Command نوشته شده؟!!!
الگوریتم هایی که تاریخچه خود را فراموش می کنند، محکوم به تکرار آن هستند.
تایمر رو اول برای تست استفاده کرده بودم و الان غیر فعاله
متاسفانه این قسمت رو متوجه نشدمDoEvents را با یک شرط اجرا کنید، مثلاً هر بار که یک سطر رنگ میشه، یک بار DoEvents اجرا بشه. اگر DoEvents به ازای هر پیکسلی که رسم میشه اجرا بشه، در کاهش سرعت برنامه بسیار اثر گذار هست.
اگه یه مثال بزنید خیلی ممنون میشم
منظور دوستمون اينجاست:
هر بار كه به انتها ميرسه از نظر طولي اين شرط True ميشه
If txt_x.Text >= Picture1.ScaleWidth Then
txt_y.Text = txt_y.Text + 1
txt_x.Text = 1
DoEvents
End If
تاثيرشم خوب بود
خیلی ممنون
سرعتش خیلی عالی شد
اما وقتی برمامه رو مینیممایز می کنم تصویر پاک میشه مثلا وقتی میام تو فایر فاکس بعد می بینم که پیکچر 2 سفید شده
چی کار کنم
3- تغيير خاصيت AutoRedraw پيك2 به True
خیلی ممنون از راهنمایی
با این راهنمایی هایی که کردین تونستم زمان انجام عملیات رو از حدود 36 ثانیه به کمتر از 4 ثانیه برسونم
این هم کدش شاید براتون جالب باشه:
Private Sub Command1_Click()
Do
Dim R As Byte, G As Byte, B As Byte
Dim Color As Long
'entekhabe pixel
Color = Picture1.Point(xval, yval)
'-------------------------
'bedast avardane meghdare RGB pixel be komak Module1
R = ExtractR(Color)
G = ExtractG(Color)
B = ExtractB(Color)
'-------------------------
'siah tar kardan e pixel haie siah
If R < 200 And B < 200 And G < 200 Then
Picture2.PSet (xval, yval), RGB(0, 0, 0)
End If
'-------------------------
'taeene pixele ba'di
If xval < Picture1.ScaleWidth Then
xval = xval + 1
End If
If xval >= Picture1.ScaleWidth Then
yval = yval + 1
xval = 1
DoEvents
If yval = Picture1.ScaleHeight Then
MsgBox ("Finished")
End If
End If
Loop Until yval = Picture1.ScaleHeight
End Sub
Private Sub Form_Load()
Dim xval As Long
Dim yval As Long
Dim txval As Long
Dim tyval As Long
xval = 1
yval = 1
txval = Picture1.ScaleWidth
tyval = Picture1.ScaleHeight
End Sub
شما چند تا اشتباه در كد نويسي داريد
به نظر شما متغير yval در متد Command1_Click با Form_Load يكي هست
نه يكي نيست
متغير داخل Form_Load از نوع Long
متغير داخل Command1_Click از نوع Variant
شما بايد متغير رو در قسمت General تعريف كنيد
(بالاي صفحه كدنويسي)
از متغير txval و tyval استفاده نكرديد
این درسته؟:
Dim xval As Long
Dim yval As Long
Dim txval As Long
Dim tyval As Long
Private Sub Command1_Click()
Do
Dim R As Byte, G As Byte, B As Byte
Dim Color As Long
'entekhabe pixel
Color = Picture1.Point(xval, yval)
'-------------------------
'bedast avardane meghdare RGB pixel be komak Module1
R = ExtractR(Color)
G = ExtractG(Color)
B = ExtractB(Color)
'-------------------------
'siah tar kardan e pixel haie siah
If R < 200 And B < 200 And G < 200 Then
Picture2.PSet (xval, yval), RGB(0, 0, 0)
End If
'-------------------------
'taeene pixele ba'di
If xval < txval Then
xval = xval + 1
End If
If xval >= txval Then
yval = yval + 1
xval = 1
DoEvents
If yval = tyval Then
MsgBox ("Finished")
End If
End If
Loop Until yval = tyval
End Sub
Private Sub Form_Load()
xval = 1
yval = 1
txval = Picture1.ScaleWidth
tyval = Picture1.ScaleHeight
End Sub
بله درسته
مساله ديگر كه يادم رفته بود
متغيرها داخل لوپ تعريف شدند
do
Dim R As Byte, G As Byte, B As Byte
Dim Color As Long
اشالا این دفعه درسته دیگه نه ؟
Dim xval As Longآخه نمیدونم چرا قبلا وقتی میوردم بیرون ارور می داد :|
Dim yval As Long
Dim txval As Long
Dim tyval As Long
Dim R As Byte, G As Byte, B As Byte
Dim Color As Long
Private Sub Command1_Click()
Do
'entekhabe pixel
Color = Picture1.Point(xval, yval)
'-------------------------
'bedast avardane meghdare RGB pixel be komak Module1
R = ExtractR(Color)
G = ExtractG(Color)
B = ExtractB(Color)
'-------------------------
'siah tar kardan e pixel haie siah
If R < 200 And B < 200 And G < 200 Then
Picture2.PSet (xval, yval), RGB(0, 0, 0)
End If
'-------------------------
'taeene pixele ba'di
If xval < txval Then
xval = xval + 1
End If
If xval >= txval Then
yval = yval + 1
xval = 1
DoEvents
If yval = tyval Then
MsgBox ("Finished")
End If
End If
Loop Until yval = tyval
End Sub
Private Sub Form_Load()
xval = 1
yval = 1
txval = Picture1.ScaleWidth
tyval = Picture1.ScaleHeight
End Sub
حالا زمان به 3 ثانیه رسید یعنی یک دوازدهم
خیلی ممنون
راستی اگه بشه یه کاری کرد که موس قفل بشه (روی صفحه کلیک نکنه) خیلی خوبه چون اگه کلیک کنم هنگ می کنه
(آپدیت: هنگ نمی کنه)
دوست عزیز برای اینکار تو زمینه OMR نیازی ندارید که به این صورت brightness تصویر رو کاهش بدید این فاز بعنوان فاز threshold که شما بایستی از روش های استانداری که وجود داره استفاده کنید. این کدی که شما نوشتید نشون میده که تجربتون تو برنامه نویسی خیلی کمه و شما به تمرین زیادی نیاز دارید . شما مقدار مربوط به کنترل ها رو مستقیم در پروسه اصلیتون دریافت می کنید. تو پروسه اصلی کارتون دارید از کنترل image استفاده می کنید . شما بایستی این کار رو تو حافظه انجام بدید و سپس نتیجه کار رو به dc مربوطه کپی کنید. برای اینکار بایستی از روش scanline یا pointer استفاده کنید.در ضمن برای این دست کار توابع setpixel , getpixel به شدت کند هستند و مخصوصاً شما هم که هر بار در پروسه اصلیتون ExtractR و ... رو هم استفاده می کنید و قتی که با pointer کار می کنید نیاز به extract رنگ ها به این صورت ندارید چون برای هر رنگ شما 3 برابر دارید function فراخوانی می کنید این function به صورت inline هم پیاده سازی شده باشه باز هم افت زمان زیادی خواهید داشت د .برای همچین عکسی که شما قرار دارید زمان 3 ثانیه زمان خیلی زیادی که تو این زمان میشه یه صفحه a4 پر نوشته رو OCR کردمن بعید میدونم شما آخرش هم جواب بدی
شما به بزرگی خودت ببخشش!
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول