تحويل الصورة الى نص في vbzoom

Option Explicit
'تم أستخدام هذا النوع للمتغير Variant
' وذلك لأن المتغير الحزمي محدود بالحجم
Private strMain As Variant

' تحويل الصورة الى نص
Private Sub cmdConvert_Click()
On Error GoTo errtrap
Dim X, X1 As Integer 'X الأحداثي, X عداد
Dim Y, Y1 As Integer 'Y الأحداثي, y العداد
Dim jColor As Long 'المتغير الذي يمثل اللون
Dim lngColors() As Long 'مصفوفة الألوان
Dim intX As Long 'دارة العداد
Dim Repeat As Boolean 'مؤشر

'التأكد من وجود صورة
If Len(txtSource) = 0 Then
MsgBox "You must select a picture"
Exit Sub
End If

'تحذير عندما تكون الصورة كبيرة
MsgBox "Large pictures may not display properly. Please open in an RTF viewer and adjust page size and margins to view properly."

'يعطي لون للفراغ
ReDim lngColors(0)

'أعداد أحداثيات النظام
Y = picMain.ScaleWidth - 1
X = picMain.ScaleHeight - 1

'أعداد أو وضع القيمة العظمى لشريط التقدم
pbrMain.Max = X
lblProgress.Caption = "Converting to text..."

'الدارة خلال الأسطر
For X1 = 1 To X Step 1
'الدارة خلال الأعمدة
For Y1 = 1 To Y Step 1
'أطلاق المعالج
DoEvents

'وضع لون نقطة الشاشة الحالية
jColor = picMain.Point(Y1, X1)

'أذا كانت مصفوفة اللون جديدة، فضع اللون الأول
If UBound(lngColors()) = 0 Then
lngColors(0) = jColor
'أضف فراغ للون التالي، ودائما تكون القيمة 0 يعني اللون الأسود
'منطقياً يسبب في وضع القيمة الى 1
ReDim Preserve lngColors(1)
'أبدأ بالرمز 33 وأذا كان أقل وبضمنها الرموز الفردية مثال رمز تغذية السطر
strMain = strMain & Chr(33)
Else
'يعتبر اللون التالي غير مكرر للون السابق
Repeat = False
'يتم وضع دارة خلال مصفوفة الألوان للتأكد من
For intX = 0 To UBound(lngColors())
DoEvents
'أذا وجدت التطابق
If lngColors(intX) = jColor Then
'أضفه الى الحزمة
strMain = strMain & Chr(33 + intX)
'أثبات بطلان أعتبارات عدم التكرار
Repeat = True
End If
Next
'أذا لم تثبت البطلان ، سيتم أستخدام اللون الجديد
If Repeat = False Then
'أجعل مكان أو حيز له
ReDim Preserve lngColors(UBound(lngColors()) + 1)
'ضع قيمته
lngColors(UBound(lngColors())) = jColor
'أضفه الى الحزمة
strMain = strMain & Chr(33 + UBound(lngColors()))
End If
End If
Next
'أعطي الحزمة سطراً جديداً
strMain = strMain & vbCrLf
'قم بزيادة تقدم شريط التقدم ، ولكن ليس أكثر من القيمة العظمى
If pbrMain.Value <> pbrMain.Max Then
pbrMain.Value = pbrMain.Value + 1
End If
Next

'أضف عنوان الى الحزمة
strMain = strMain & vbNewLine & txtTitle & vbCrLf & vbCrLf
'أضف عنوان مخطط الألوان
strMain = strMain & "COLOR CHART:" & vbCrLf & vbCrLf

'لكل لون من الألوان الموجودة في الرسم
For intX = 0 To UBound(lngColors())
'أخلق مؤشر ألوان ودليل رموز جديد
Load lbl(intX + 1)
Load lblCaption(intX + 1)
lbl(intX + 1).Caption = ""
'لون المؤشر
lbl(intX + 1).BackColor = lngColors(intX)
lbl(intX + 1).Visible = True
'ضع أو أعد دليل الرموز
lblCaption(intX + 1).Caption = " = " & Chr(33 + intX)
'رتب عناصر دليل الرموز
Select Case intX
Case Is <= 14
lblCaption(intX + 1).Move 350, 400 + (300 * intX), 500, 290
lbl(intX + 1).Move 20, 400 + (300 * intX), 290, 290
Case Is <= 27
lblCaption(intX + 1).Move 1200, 400 + (300 * (intX - 15)), 500, 290
lbl(intX + 1).Move 900, 400 + (300 * (intX - 15)), 290, 290
Case Else
lblCaption(intX + 1).Move 900, 400 + (300 * 14), 500, 290
lblCaption(intX + 1).Caption = "More..."
lbl(intX + 1).Move 900, 400 + (300 * 14), 290, 290
lbl(intX + 1).BackColor = Me.BackColor
End Select
lblCaption(intX + 1).Visible = True
'أضف عناصر دليل الرموز الى الحزمة
strMain = strMain & Chr(33 + intX) & " = " & lngColors(intX) & vbCrLf
Next
'يضع الليبل في المقدمة في حالة وجود أكثر من 27 لون مختلف
lblCaption(intX).ZOrder

' RichTextBox وضع خاصية النص ل
'String الى حزمي
txtMain.Text = strMain

' RichTextBox الكود عبارة عن دارة خلال ال
' وتغير ألوان الرموز
'للتخلص من أو صرف النظر عن التلوين ، أظهر التعليق الموضح في هذه الفقرة
lblProgress.Caption = "Painting Colors..."
pbrMain.Value = pbrMain.Min
pbrMain.Max = InStr(txtMain.Text, txtTitle)

For intX = 0 To InStr(txtMain.Text, txtTitle)
DoEvents
txtMain.SelStart = intX
txtMain.SelLength = 1
If txtMain.SelText <> "" Then
If (Asc(txtMain.SelText) - 33 <= UBound(lngColors())) And (Asc(txtMain.SelText) - 33 >= 0) Then
txtMain.SelColor = lngColors(Asc(txtMain.SelText) - 33)
End If
End If

DoEvents
If pbrMain.Value <> pbrMain.Max Then
pbrMain.Value = pbrMain.Value + 1
End If
Next
'نهاية الفقرة

lblProgress = "Complete!"
SavePictureText txtDestination
MsgBox "Your file has been saved to: " & txtDestination.Text
cmdOpenRTF.Enabled = True

Exit Sub
errtrap:
Select Case Err.Number
' في حالة وجود أي خطأ في الأجراءات
Case 5
If UBound(lngColors()) = 223 Then
MsgBox "Your image has too many colors to convert, you must limit the palate to 223 colors"
End If
Case Else
MsgBox Err.Number & ": " & Err.Description
End Select
End Sub
' لغرض تحميل الصورة
Private Sub cmdFind_Click()
txtSource = Main.OpenFile
picMain.Picture = LoadPicture(txtSource)
If Len(txtSource) = 0 Then
txtDestination = ""
Else
txtDestination = Left(txtSource, Len(txtSource) - 3) + "rtf"
End If

End Sub
' خزن الصورة المحورة الى نص
Sub SavePictureText(Filename As String)
Open Filename For Output As #1
Print #1, txtMain.TextRTF;
Close #1
End Sub

' فتح الملف المخزون في الورد
Private Sub cmdOpenRTF_Click()
Call ShellExecute(0&, vbNullString, txtDestination, vbNullString, vbNullString, vbNormalFocus)
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Public 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 Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Public Function OpenFile() As String
Dim ofn As OPENFILENAME
ofn.lStructSize = Len(ofn)
ofn.hWndOwner = frmMain.hwnd
ofn.hInstance = App.hInstance
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = App.Path & "\Icons"
ofn.lpstrTitle = "Open Picture"
ofn.flags = 0

A = GetOpenFileName(ofn)
If (A) Then
OpenFile = Trim$(ofn.lpstrFile)
End If

End Function