VERSION 5.00
Begin VB.Form OpenForm 
   Caption         =   "Вывод яркостей точек изображения в таблицу Excel"
   ClientHeight    =   5670
   ClientLeft      =   -1350
   ClientTop       =   270
   ClientWidth     =   9270
   Icon            =   "CT-OpenForm.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   378
   ScaleMode       =   3  'Пиксель
   ScaleWidth      =   618
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox Picture5 
      Appearance      =   0  'Плоска
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'Нет
      ForeColor       =   &H80000008&
      Height          =   495
      Left            =   6960
      ScaleHeight     =   33
      ScaleMode       =   3  'Пиксель
      ScaleWidth      =   57
      TabIndex        =   18
      Top             =   1080
      Visible         =   0   'False
      Width           =   855
   End
   Begin VB.Timer Timer0 
      Enabled         =   0   'False
      Interval        =   30
      Left            =   4920
      Top             =   1680
   End
   Begin VB.PictureBox Picture2 
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'Нет
      Height          =   390
      Left            =   7080
      ScaleHeight     =   26
      ScaleMode       =   3  'Пиксель
      ScaleWidth      =   130
      TabIndex        =   15
      Top             =   120
      Width           =   1950
      Begin VB.PictureBox Picture4 
         BorderStyle     =   0  'Нет
         Height          =   390
         Left            =   0
         Picture         =   "CT-OpenForm.frx":75CF
         ScaleHeight     =   390
         ScaleWidth      =   1950
         TabIndex        =   17
         Top             =   0
         Width           =   1950
      End
      Begin VB.PictureBox Picture3 
         AutoRedraw      =   -1  'True
         BorderStyle     =   0  'Нет
         Enabled         =   0   'False
         Height          =   5070
         Left            =   0
         Picture         =   "CT-OpenForm.frx":7D39
         ScaleHeight     =   338
         ScaleMode       =   3  'Пиксель
         ScaleWidth      =   130
         TabIndex        =   16
         Top             =   0
         Width           =   1950
      End
   End
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Плоска
      ForeColor       =   &H80000008&
      Height          =   1215
      Left            =   120
      MousePointer    =   2  'Пересечение
      ScaleHeight     =   79
      ScaleMode       =   3  'Пиксель
      ScaleWidth      =   319
      TabIndex        =   11
      ToolTipText     =   "Палитра 256-ти цветного изображения"
      Top             =   4380
      Visible         =   0   'False
      Width           =   4815
   End
   Begin VB.CheckBox Check1 
      Caption         =   "Показывать файл"
      Height          =   195
      Left            =   6120
      TabIndex        =   7
      Top             =   3720
      Value           =   1  'Отмечено
      Width           =   2535
   End
   Begin VB.TextBox Text7 
      Appearance      =   0  'Плоска
      Height          =   1545
      Left            =   5040
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Вертикаль
      TabIndex        =   6
      ToolTipText     =   "Информация о файле"
      Top             =   4050
      Width           =   4095
   End
   Begin VB.TextBox Text5 
      Appearance      =   0  'Плоска
      Height          =   285
      Left            =   120
      TabIndex        =   5
      Top             =   30
      Width           =   4815
   End
   Begin VB.TextBox Text4 
      Height          =   285
      Left            =   840
      TabIndex        =   4
      Top             =   375
      Width           =   4095
   End
   Begin VB.ComboBox ComboPattern 
      Height          =   315
      ItemData        =   "CT-OpenForm.frx":2830B
      Left            =   120
      List            =   "CT-OpenForm.frx":28318
      TabIndex        =   3
      Text            =   "*.BMP"
      Top             =   4020
      Width           =   2475
   End
   Begin VB.DriveListBox Drive1 
      Height          =   360
      Left            =   2640
      TabIndex        =   2
      Top             =   4020
      Width           =   2295
   End
   Begin VB.DirListBox Dir1 
      Height          =   3015
      Left            =   2640
      TabIndex        =   1
      Top             =   720
      Width           =   2295
   End
   Begin VB.FileListBox File1 
      Height          =   3015
      Left            =   120
      Pattern         =   "*.bmp"
      TabIndex        =   0
      Top             =   720
      Width           =   2475
   End
   Begin VB.Line Line16 
      BorderColor     =   &H80000014&
      X1              =   608
      X2              =   616
      Y1              =   240
      Y2              =   232
   End
   Begin VB.Line Line15 
      BorderColor     =   &H80000010&
      BorderWidth     =   2
      X1              =   608
      X2              =   616
      Y1              =   248
      Y2              =   240
   End
   Begin VB.Line Line14 
      BorderColor     =   &H80000014&
      X1              =   608
      X2              =   616
      Y1              =   256
      Y2              =   248
   End
   Begin VB.Line Line13 
      BorderColor     =   &H80000010&
      BorderWidth     =   2
      X1              =   608
      X2              =   616
      Y1              =   264
      Y2              =   256
   End
   Begin VB.Label Label6 
      Alignment       =   2  'Центровка
      BackStyle       =   0  'Прозрачно
      Caption         =   "Файл:"
      Height          =   285
      Left            =   120
      TabIndex        =   19
      Top             =   435
      Width           =   735
   End
   Begin VB.Image Image15 
      Height          =   390
      Left            =   5160
      Picture         =   "CT-OpenForm.frx":28368
      Top             =   2880
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Image Image14 
      Height          =   390
      Left            =   5160
      Picture         =   "CT-OpenForm.frx":28AD2
      Top             =   2760
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Image Image13 
      Enabled         =   0   'False
      Height          =   390
      Left            =   5040
      Top             =   540
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Label Label5 
      Alignment       =   2  'Центровка
      BackStyle       =   0  'Прозрачно
      Height          =   255
      Left            =   7080
      TabIndex        =   14
      Top             =   600
      Visible         =   0   'False
      Width           =   1935
   End
   Begin VB.OLE OLE1 
      Class           =   "Excel.Sheet.8"
      DisplayType     =   1  'Иконка
      Height          =   855
      Left            =   6240
      OleObjectBlob   =   "CT-OpenForm.frx":2923C
      TabIndex        =   13
      Top             =   1680
      Visible         =   0   'False
      Width           =   1695
   End
   Begin VB.Label Label4 
      Alignment       =   2  'Центровка
      Appearance      =   0  'Плоска
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Фиксировано один
      ForeColor       =   &H000000FF&
      Height          =   600
      Left            =   1080
      TabIndex        =   12
      Top             =   4680
      Visible         =   0   'False
      Width           =   2775
   End
   Begin VB.Line Line2 
      X1              =   600
      X2              =   336
      Y1              =   224
      Y2              =   64
   End
   Begin VB.Line Line1 
      X1              =   336
      X2              =   600
      Y1              =   224
      Y2              =   64
   End
   Begin VB.Label Label3 
      Appearance      =   0  'Плоска
      BackColor       =   &H80000005&
      BackStyle       =   0  'Прозрачно
      Caption         =   "Тип файла:"
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   120
      TabIndex        =   10
      Top             =   3780
      Width           =   1335
   End
   Begin VB.Label Label2 
      Appearance      =   0  'Плоска
      BackColor       =   &H80000005&
      BackStyle       =   0  'Прозрачно
      Caption         =   "Устройства:"
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   2640
      TabIndex        =   9
      Top             =   3780
      Width           =   1575
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Центровка
      Appearance      =   0  'Плоска
      BackStyle       =   0  'Прозрачно
      ForeColor       =   &H00004000&
      Height          =   255
      Left            =   4920
      TabIndex        =   8
      ToolTipText     =   "Размер, масштаб и число цветов в файле"
      Top             =   3435
      Width           =   4215
   End
   Begin VB.Image Image11 
      Appearance      =   0  'Плоска
      BorderStyle     =   1  'Фиксировано один
      Height          =   2415
      Left            =   5040
      Top             =   960
      Width           =   3975
   End
   Begin VB.Image Image10 
      Height          =   390
      Left            =   3960
      Picture         =   "CT-OpenForm.frx":2B654
      Top             =   3840
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Image Image8 
      Appearance      =   0  'Плоска
      Height          =   390
      Left            =   4560
      Picture         =   "CT-OpenForm.frx":2BDBE
      Top             =   3120
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Image Image7 
      Appearance      =   0  'Плоска
      Height          =   390
      Left            =   3840
      Picture         =   "CT-OpenForm.frx":2C528
      Top             =   3480
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Image Image6 
      Appearance      =   0  'Плоска
      Height          =   390
      Left            =   3840
      Picture         =   "CT-OpenForm.frx":2C996
      Top             =   3600
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Image Image5 
      Appearance      =   0  'Плоска
      Height          =   390
      Left            =   3840
      Picture         =   "CT-OpenForm.frx":2CE1A
      Top             =   3240
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Image Image4 
      Appearance      =   0  'Плоска
      Height          =   390
      Left            =   3840
      Picture         =   "CT-OpenForm.frx":2D584
      Top             =   3000
      Visible         =   0   'False
      Width           =   1950
   End
   Begin VB.Image Image3 
      Appearance      =   0  'Плоска
      Height          =   390
      Left            =   6000
      Top             =   540
      Width           =   1950
   End
   Begin VB.Image Image1 
      Appearance      =   0  'Плоска
      Height          =   390
      Left            =   5040
      ToolTipText     =   "Открыть файл"
      Top             =   120
      Width           =   1950
   End
End
Attribute VB_Name = "OpenForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim FileNum As Integer
Dim LishnyShag As Integer
Dim TimeHelp As Integer
Dim Spravka As String
Dim Chislo_Sostavlyauschih_V_Palitre As Byte
Dim Vremya_Do_IZMER As Date
Dim Vremya_Na_Stroku As Long
Dim Ostalos As Long
Dim PervStl As Long
Dim PervStr As Long
Dim PoslStl As Long
Dim PoslStr As Long
Dim StopLoop As Boolean

Dim БайтыДоСтрокиКПред As Long
Dim БайтыДоСтрокиЗПред As Long
Dim БайтыДоСтрокиСПред As Long
Dim БайтыДоСтрокиКПредНиж As Long
Dim БайтыДоСтрокиЗПредНиж As Long
Dim БайтыДоСтрокиСПредНиж As Long

Dim bfOffbitsMinus As Long
Dim ШагПредпросмотра As Single
Dim ВысотаИзобрПредпросм As Long
Dim ШиринаИзобрПредпросм As Long
Dim КоординатаВысоты As Long 'для расчёта в циклах

Dim j10 As Long 'для расчёта в циклах
Dim j32 As Long 'для расчёта в циклах

Const ШиринаЛевогоКрая = 5
Dim ШиринаDir1File1 As Long

'Элемент управления OLE
'Режимы работы
Const OLE_CREATE_EMBED = 0  'Пример OLE1.Action = OLE_COPY
Const OLE_CREATE_LINK = 1
Const OLE_COPY = 4
Const OLE_PASTE = 5
Const OLE_UPDATE = 6
Const OLE_ACTIVATE = 7
Const OLE_CLOSE = 9
Const OLE_DELETE = 10
Const OLE_SAVE_TO_FILE = 11
Const OLE_READ_FROM_FILE = 12
Const OLE_INSERT_OBJ_DIALOG = 14
Const OLE_PASTE_SPECIAL_DLG = 15
Const OLE_FETCH_VERBS = 17
Const OLE_SAVE_TO_OLE1FILE = 18
 'Типы OLE
Const OLE_LINKED = 0
Const OLE_EMBEDDED = 1
Const OLE_NONE = 3
Dim TablicaExcel As Object

Private Sub ComboPattern_Change()
Select Case ComboPattern.ListIndex
 Case 0
 File1.Pattern = "*.bmp"
 Case 1
 File1.Pattern = "*.tga"
 Case 2
 File1.Pattern = "*.*"
End Select
File1.Refresh
End Sub

Private Sub ComboPattern_Click()
Select Case ComboPattern.ListIndex
 Case 0
 File1.Pattern = "*.bmp"
 Case 1
 File1.Pattern = "*.tga"
 Case 2
 File1.Pattern = "*.*"
End Select
File1.Refresh
End Sub

Private Sub Dir1_Change()
On Error GoTo AnotherDir
 File1.Path = Dir1.Path
 Text5.Text = File1.Path
 Exit Sub

AnotherDir:
 MsgBox "Ошибка " & Err.Number & " " & Err.Description, vbOKOnly, "Ошибка"
 Dir1.Path = "C:\"
Resume
End Sub
Private Sub Drive1_Change()
On Error GoTo AnotherDrive
 Dir1.Path = Drive1.Drive
 Exit Sub

AnotherDrive:
 MsgBox "Ошибка " & Err.Number & " " & Err.Description, vbOKOnly, "Ошибка"
 On Error GoTo AnotherDrive2
 Drive1.Drive = "C:"
Resume

AnotherDrive2:
 MsgBox "Ошибка " & Err.Number & " " & Err.Description & vbCrLf & "Диск C: недоступен.", vbOKOnly, "Ошибка"
 On Error GoTo AnotherDrive3
 Drive1.Drive = "A:"
Resume

AnotherDrive3:
 MsgBox "Ошибка " & Err.Number & " " & Err.Description & vbCrLf & "Диск А: недоступен.", vbOKOnly, "Ошибка"
 Drive1.Drive = "D:"
Resume
End Sub

Private Sub File1_Click()
Image1.Picture = Image7.Picture 'Кнопка Открыть нажимается
k = File1.ListIndex             'Перед обновлением запоминается позиция
SelectedFile2 = File1.List(k) 'и название файла.

'если задействовать следующие строки,
'то выделение будет сбрасываться на самый файл в списке:
'File1.Refresh                   'Обновляется перед загрузкой
'Dir1.Refresh                    'Обновляется
If File1.List(k) <> SelectedFile2 Then 'Проверяется, не исчез ли файл
  For i = 0 To k
   If File1.List(i) = SelectedFile2 Then
     File1.ListIndex = i
     Image1_Click
    Else
     File1.ListIndex = k
     Image1.Picture = Image6.Picture
     Image11.Picture = LoadPicture() 'убирается картинка
     Image11.Height = 161  'стандартные габариты
     Image11.Left = Text7.Left
     Image11.Top = 64
     Image11.Width = 265
     'перечёркивание предпросмотра:
     Line1.Visible = True
     Line2.Visible = True
   End If
  Next i
 Else
  'File1.ListIndex = k 'зачем это было нужно?
  Image1_Click
End If
End Sub

Private Sub Form_Load()
 OpenForm.Width = 9300 'чтобы форма у меня не переезжала, а то случается
 
 Dir1.Path = Drive1.Drive
 File1.Path = Dir1.Path
 Text5.Text = File1.Path
 Zagruzka = 0
 Otmena = True
Image1.Picture = Image6.Picture 'для кнопки ОТКРЫТЬ

Picture3.Left = 0   'для кнопки ОБРАБОТКА
Picture3.Top = 0
Picture4.Move 0, 0, 1, 26
Picture3.Enabled = False
Timer0.Enabled = False 'Timer0 для видеоролика на кнопке ОБРАБОТКА

Image3.Picture = Image4.Picture 'для кнопки СПРАВКА
Image13.Picture = Image14.Picture 'для кнопки ПРЕРВАТЬ

ДоляКрасного = 0.299 'доля красного в яркости по в телевизионном расчёте
ДоляЗелёного = 0.587
ДоляСинего = 0.114




End Sub

Private Sub Form_Resize()
 Line13.X1 = Me.Width / Screen.TwipsPerPixelX - 9
 Line13.X2 = Line13.X1 - 4
 Line13.Y1 = Me.Height / Screen.TwipsPerPixelY - 32
 Line13.Y2 = Line13.Y1 + 4
 Line14.X1 = Me.Width / Screen.TwipsPerPixelX - 9
 Line14.X2 = Line14.X1 - 6
 Line14.Y1 = Me.Height / Screen.TwipsPerPixelY - 33
 Line14.Y2 = Line14.Y1 + 6
 
 Line15.X1 = Me.Width / Screen.TwipsPerPixelX - 9
 Line15.X2 = Line15.X1 - 9
 Line15.Y1 = Me.Height / Screen.TwipsPerPixelY - 36
 Line15.Y2 = Line15.Y1 + 9
 Line16.X1 = Me.Width / Screen.TwipsPerPixelX - 9
 Line16.X2 = Line16.X1 - 10
 Line16.Y1 = Me.Height / Screen.TwipsPerPixelY - 37
 Line16.Y2 = Line16.Y1 + 10
 

 'ШиринаЛевогоКрая = 5 - константа
 File1.Left = ШиринаЛевогоКрая
 ComboPattern.Left = File1.Left
 Text5.Left = File1.Left
 Label6.Left = File1.Left
 ШиринаDir1File1 = Me.Width / Screen.TwipsPerPixelX - Text7.Width - 7 - File1.Left - 14
 If ШиринаЛевогоКрая + ШиринаDir1File1 + 7 >= Picture1.Left + Picture1.Width Then
  '165 + 2 + 153 = 320 - это  100%
  '165 от 318 - это  165/(320/100) =  51,5625 % и 47,8125% и 0,625%
  File1.Width = ШиринаDir1File1 * 0.515625
  ComboPattern.Width = File1.Width
  Dir1.Width = ШиринаDir1File1 * 0.478125
  Drive1.Width = Dir1.Width
  Dir1.Left = File1.Left + File1.Width + 3
  Drive1.Left = Dir1.Left
  Label2.Left = Dir1.Left
  If (ШиринаDir1File1 + ШиринаЛевогоКрая) - 56 > 3 Then Text4.Width = (ШиринаDir1File1 + ШиринаЛевогоКрая) - 56
  Text5.Width = ШиринаDir1File1
  Label1.Left = ШиринаЛевогоКрая + ШиринаDir1File1 + 1
  Text7.Left = ШиринаЛевогоКрая + ШиринаDir1File1 + 7
  Image11.Left = Text7.Left + (265 - Image11.Width) / 2
  Picture5.Left = Text7.Left + (265 - Picture5.Width) / 2
  Image13.Left = Text7.Left
  Image1.Left = Text7.Left
  Line1.X1 = Text7.Left
  Line2.X2 = Text7.Left
  Check1.Left = Text7.Left + (Text7.Width - Check1.Width) \ 2
  Image3.Left = Text7.Left + (Text7.Width - Image3.Width) \ 2
  Picture2.Left = Image1.Left + Image1.Width + 7
  Label5.Left = Picture2.Left
  Line1.X2 = Image11.Left + Image11.Width - 1
  Line2.X1 = Line1.X2
 End If

 'Dir1.Width + File1.Width
 
End Sub

Private Sub Image1_Click()
SelectedFile = ""
bfType = ""
If k >= 0 Then
  SelectedFile = File1.Path
  If Right$(SelectedFile, 1) <> "\" Then
    SelectedFile = SelectedFile & "\"
  End If
  SelectedFile = SelectedFile & File1.List(k) 'File1.List(File1.ListIndex)
End If
If File1.List(k) = "" Then
  Image1.Picture = Image6.Picture
  Exit Sub
End If
Text4.Text = File1.List(k) 'File1.List(File1.ListIndex)

'SelectedFile

If (Right(SelectedFile, 4) = ".tga" Or Right(SelectedFile, 4) = ".TGA") Then
 bfType = "TG"
 GoTo ПропускПроверкиBMP
End If

FileNum = FreeFile
Open SelectedFile For Binary As FileNum
 РазмерФайла = LOF(FileNum)
 If РазмерФайла = 0 Then
  Text7.Text = "Файл занимает 0 байт."
  'перечёркивание предпросмотра:
  Line1.Visible = True
  Line2.Visible = True
  Picture3.Enabled = False 'запретить обработку
  Picture3.Top = 0
  Timer0.Enabled = False
  Picture1.Visible = False
  Image11.Height = 161  'стандартные габариты
  Image11.Left = Text7.Left
  Image11.Top = 64
  Image11.Width = 265
  Image11.Picture = LoadPicture()
  Image11.Visible = True
  Image11.BorderStyle = 1
  Exit Sub
 End If
 Get FileNum, 1, bfType
 'сюда можно добавить обработку других форматов
Close FileNum
If (bfType <> "BM" And bfType <> "BA") And (Right(SelectedFile, 4) = ".bmp" Or Right(SelectedFile, 4) = ".BMP") Then
  MsgBox "Файл " & Text4.Text & vbCrLf & " или имеет неизвестный формат или" & vbCrLf & "не является изображением, а содержит что-то другое.", vbExclamation, "Неизвестный формат файла"
End If

ПропускПроверкиBMP:
'сюда можно добавить обработку других форматов

Select Case bfType
  Case "BM", "BA"
   Text7.Text = "" 'очистка текстового окна с информацией про bmp файл
   Call BM_Load
   Zagruzka = 1
  Case "TG"
   Text7.Text = "" 'очистка текстового окна с информацией про tga файл
   Call TGA_Load
   Zagruzka = 1
  'сюда можно добавить обработку других форматов
End Select

Image1.Picture = Image6.Picture
End Sub

Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Image1.Picture = Image7.Picture
End Sub

Sub BM_Load()
bfSize = 0
bfOffbits = 0
biSize = 0
biWidth = 0
biHeight = 0
LishnyShag = 0
biPlanes = 0
biBitCount = 0
FormatBMP = 0
biCompression = 0
biSizeImage = 0
biXPelsPerMeter = 0
biYPelsPerMeter = 0
biClrUsed = 0
biClrImportant = 0
Vyravnivanie_Na4 = 0
Chislo_Sostavlyauschih_V_Palitre = 0

FileNum = FreeFile
Open SelectedFile For Binary As FileNum
 'bfType уже был загружен в Image1_Click()
  Get FileNum, 3, bfSize      'размер файла
  Get FileNum, 11, bfOffbits  'начало битового образа (в байтах от заголовка)
  Get FileNum, 15, biSize     'байт в заголовке

  i = 19    'определение ширины и высоты (для bmp формата OS/2 и bmp формата Windows)
   CalcWord (i + 2)
   biHeight = LongDword
   If biHeight > 0 Then     'если biHeight > 0, то это растр OS/2
        Text7.Text = "BMP формат - растр OS/2"
        CalcWord (i)
        biWidth = LongDword
        LishnyShag = 0 'нет сдвига остальных данных
      Else
        Text7.Text = "BMP формат - растр Windows"
        Get FileNum, i, biWidth
        Get FileNum, i + 4, biHeight
        LishnyShag = 4 'сдвиг остальных данных на 4 байта
   End If
   If РазмерФайла > bfSize Then
    Text7.Text = Text7.Text & vbCrLf & "Размер файла " & РазмерФайла & " байт, а в файле указан " & bfSize
   Else
    Text7.Text = Text7.Text & vbCrLf & "Размер файла " & bfSize & " байт"
   End If
   'Text7.Text = Text7.Text & vbCrLf & "Начало битового образа с" & (bfOffbits + 1) & " байта от заголовка"
   'Text7.Text = Text7.Text & vbCrLf & "В заголовке " & biSize & " байт"
   Text7.Text = Text7.Text & vbCrLf & "Ширина " & biWidth
   Text7.Text = Text7.Text & vbCrLf & "Высота " & biHeight
   Label1.Caption = biWidth & " x " & biHeight
   ReDim BM_MassivК(1 To biWidth, 1 To biHeight) As Byte
   ReDim BM_MassivЗ(1 To biWidth, 1 To biHeight) As Byte
   ReDim BM_MassivС(1 To biWidth, 1 To biHeight) As Byte
   'Stop
  i = 23 + LishnyShag
   Call CalcWord(i)
   biPlanes = LongDword     'число плоскостей
   'Text7.Text = Text7.Text & vbCrLf & "Число плоскостей " & biPlanes
  i = 25 + LishnyShag
   Call CalcWord(i)
   biBitCount = LongDword     'число бит на пиксель
   Text7.Text = Text7.Text & vbCrLf & biBitCount & " бит на каждый пиксель "
 If biSize + 15 > 27 + LishnyShag Then  'если это растр Windows, то
   FormatBMP = 1
   
   Get FileNum, 27 + LishnyShag, biCompression  'Тип сжатия
   If biCompression = 0 Then
     Text7.Text = Text7.Text & vbCrLf & "Сжатия нет"
    Else
     Text7.Text = Text7.Text & vbCrLf & biCompression & " тип сжатия"
   End If
   
   Get FileNum, 31 + LishnyShag, biSizeImage  'Размер картинки в байтах(иногда не указывается , т.е. =0)
   'Text7.Text = Text7.Text & vbCrLf & biSizeImage & " размер картинки в байтах"
   
   Get FileNum, 35 + LishnyShag, biXPelsPerMeter  'горизонтальное разрешение устройства (пиксель/метр)
   Text7.Text = Text7.Text & vbCrLf & "Горизонтальное разрешение устройства " & biXPelsPerMeter & " пиксель/метр"
   Get FileNum, 39 + LishnyShag, biYPelsPerMeter  'Вертикальное разрешение устройства (пиксель/метр)
   Text7.Text = Text7.Text & vbCrLf & "Вертикальное разрешение устройства " & biYPelsPerMeter & " пиксель/метр"
   
   Get FileNum, 43 + LishnyShag, biClrUsed  'сколько цветов палитры используется (если =0, то все)
   If biClrUsed = 0 Or (biClrUsed = 2 ^ biBitCount) Then
      Text7.Text = Text7.Text & vbCrLf & "Используется все цвета палитры"
     Else
      Text7.Text = Text7.Text & vbCrLf & "Используется " & biClrUsed & " цветов из " & (2 ^ biBitCount) & " цветной палитры"
   End If
   
   Get FileNum, 47 + LishnyShag, biClrImportant  'число "важных" цветов
   Text7.Text = Text7.Text & vbCrLf & "Число важных цветов " & biClrImportant
 End If
 
 If biCompression = 0 Then  'Кратна ли 4 длина строки в байтах
   If РазмерФайла > bfSize Then
    Vyravnivanie_Na4 = (РазмерФайла - bfOffbits - biHeight * biWidth * (biBitCount / 8)) / biHeight
    If Vyravnivanie_Na4 > 3 Then Vyravnivanie_Na4 = (bfSize - bfOffbits - biHeight * biWidth * (biBitCount / 8)) / biHeight
   ElseIf bfSize = РазмерФайла Then
    Vyravnivanie_Na4 = (bfSize - bfOffbits - biHeight * biWidth * (biBitCount / 8)) / biHeight
   Else 'bfSize > РазмерФайла 'что очень  странно
    Vyravnivanie_Na4 = biWidth Mod 4
   End If
   'ОстатокПослеВычВыравнивания = (bfSize - bfOffbits - biHeight * biWidth * (biBitCount / 8)) Mod biHeight
  Else
   Vyravnivanie_Na4 = ((4 - biWidth Mod 4) Mod 4)
 End If
 If Vyravnivanie_Na4 <> ((4 - biWidth Mod 4) Mod 4) Then Text7.Text = Text7.Text & vbCrLf & "Нет выравнивания строк по 4 байтной границе"
 
   On Error GoTo ErrorLoadImage 'GoTo ПослеОшибкиЗагрузки
    Image11.Picture = LoadPicture(SelectedFile) 'загрузка изображения
    Screen.ActiveForm.PaletteMode = 2           'Установим палитру для 256 цветного экрана
    Screen.ActiveForm.Palette = Image11.Picture
ПослеОшибкиЗагрузки:

If Check1.Value = 1 And FormatBMP <> 2 Then
 If biWidth > 265 Or biHeight > 161 Then
  Image11.Stretch = True
  If biHeight / biWidth > 161 / 265 Then
   Image11.Top = 64
   Image11.Width = biWidth / biHeight * 161
   Image11.Left = Text7.Left + (265 - Image11.Width) / 2
   Image11.Height = 161
  Else
   Image11.Left = Text7.Left
   Image11.Height = biHeight / biWidth * 265
   Image11.Top = 64 + (161 - Image11.Height) / 2
   Image11.Width = 265
  End If
 Else
  Image11.Stretch = False
  Image11.Height = biHeight
  Image11.Width = biWidth
  Image11.Top = 64 + (161 - biHeight) / 2
  Image11.Left = Text7.Left + (265 - biWidth) / 2
 End If
 Image11.BorderStyle = 0
   If biHeight > Image11.Height Then
    Label1.Caption = Label1.Caption & "   Уменьшено в " & Format(biHeight / Image11.Height, "0.00") & " раза"
    Else
    Label1.Caption = Label1.Caption & "   Масштаб 1:1"
   End If
  Line1.Visible = False
  Line2.Visible = False
Else
 Image11.Picture = LoadPicture()
 Image11.Left = Text7.Left
 Image11.Top = 64
 Image11.Width = 265
 Image11.Height = 161
 Image11.BorderStyle = 1
 Line1.Visible = True
 Line2.Visible = True
End If  'Закончен вывод изображения в Image1
Picture5.Visible = False
Image11.Visible = True
'цвет в палитре обычно занимает 4 байта (байт на синюю, байт на зелёную,на красную и на резервную составляющие)
If biBitCount < 24 Then
 If biClrUsed > 0 Then
  Chislo_Sostavlyauschih_V_Palitre = (bfOffbits - biSize - 14) / biClrUsed
 Else 'biClrUsed = 0 (или < 0)
  Chislo_Sostavlyauschih_V_Palitre = (bfOffbits - biSize - 14) / (2 ^ biBitCount) 'Но в некоторых версиях резервной нет. Узнаем сколько байт на каджый цвет
 End If
End If

Picture1.Visible = False 'отключить показ палитры (если это 8 битное изображение, то потом включим)
Label4.Visible = False
If biBitCount = 24 Or biBitCount = 8 Then
  If biCompression = 0 Then 'если изображение не сжато
   If Picture3.Enabled = False Then
    Picture3.Top = 0
    Timer0.Enabled = True
    Picture3.Enabled = True
   End If
  Else 'если есть сжатие изображения, то не обрабатывать, т.к. ещё не поддерживается
   MsgBox "Изображение с типом сжатия " & biCompression & vbCrLf & "            не поддерживается", vbOKOnly, "Не поддерживаемый формат"
   Picture3.Top = 0
   Picture3.Enabled = False
   Timer0.Enabled = False
  End If
 Select Case biBitCount
   Case 8
'    j = 0  ' j считает, сколько цветов с совпадающими составляющими R, G и B

'    For i = 0 To biClrUsed - 1 '255
'      Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 17, Byte1 'яркость красной составляющей
'      Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 16, Byte2 'яркость зелёной
'      Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 15, Byte3 'яркость синей
'      Massiv256(i, 0) = CSng(Byte1): Massiv256(i, 1) = CSng(Byte2): Massiv256(i, 2) = CSng(Byte3)
      'Massiv256(i, 4) = Massiv256(i, 2) 'в Massiv256(i, 4) максимальная яркость
      'If Massiv256(i, 1) > Massiv256(i, 4) Then Massiv256(i, 4) = Massiv256(i, 1)
      'If Massiv256(i, 0) > Massiv256(i, 4) Then Massiv256(i, 4) = Massiv256(i, 0)
      'Massiv256(i, 5) = (Massiv256(i, 0) * ДоляКрасного + Massiv256(i, 1) * ДоляЗелёного + Massiv256(i, 2) * ДоляСинего) 'яркость =R*0,299 + G*0,587 + B*0,114
       'If Massiv256(i, 0) = Massiv256(i, 1) And Massiv256(i, 0) = Massiv256(i, 2) Then
       '  Massiv256(i, 3) = Massiv256(i, 0)
       '  j = j + 1
       ' Else
       '  Massiv256(i, 3) = (Massiv256(i, 2) + Massiv256(i, 1) + Massiv256(i, 0)) / 3 'среднее арифметическое яркости
       'End If
'    Next i
      'If j = 256 Then
      '  ChyornoBeloe = True
      ' Else
      '  ChyornoBeloe = False
      'End If
   Picture1.AutoRedraw = True
   Picture1.Cls
   If biClrUsed = 0 Or biClrUsed = 256 Then
     For i = 0 To 255
      Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 17, Byte1 'яркость красной составляющей
      Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 16, Byte2 'яркость зелёной
      Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 15, Byte3 'яркость синей
      Massiv256(i, 0) = CSng(Byte1): Massiv256(i, 1) = CSng(Byte2): Massiv256(i, 2) = CSng(Byte3)
     Next i
     For j = 0 To 7
      j32 = j * 32
      j10 = j * 10
      For i = 0 To 31
        Picture1.Line (i * 10, j10)-(i * 10 + 8, j10 + 8), RGB(CByte(Massiv256(i + j32, 0)), CByte(Massiv256(i + j32, 1)), CByte(Massiv256(i + j32, 2))), BF
      Next i
     Next j
   Else
     For i = 0 To biClrUsed - 1
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 17, Byte1 'яркость красной составляющей
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 16, Byte2 'яркость зелёной
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 15, Byte3 'яркость синей
       'MsgBox "Индекс цвета - " & i & " , К = " & Byte1 & " , З = " & Byte2 & " , С = " & Byte3
       Massiv256(i, 0) = CSng(Byte1): Massiv256(i, 1) = CSng(Byte2): Massiv256(i, 2) = CSng(Byte3)
     Next i
     For j = 0 To 7
      j32 = j * 32
      j10 = j * 10
      For i = 0 To 31
       If j32 + i + 1 <= biClrUsed Then
        Picture1.Line (i * 10, j10)-(i * 10 + 8, j10 + 8), RGB(CByte(Massiv256(i + j32, 0)), CByte(Massiv256(i + j32, 1)), CByte(Massiv256(i + j32, 2))), BF
       End If
      Next i
     Next j
    End If
    Picture1.Visible = True
    Label1.Caption = Label1.Caption & "    256 цветов"
   Case 24
    Picture1.Visible = False
    Label1.Caption = Label1.Caption & "    16 млн. цветов"
 End Select
Else
    Picture3.Enabled = False
    Picture3.Left = 0
    Picture3.Top = 0
    Timer0.Enabled = False
    Label1.Caption = Label1.Caption & "    " & (2 ^ biBitCount) & " цветов"
    Label4.Caption = (2 ^ biBitCount) & "-ти цветное изображение" & vbCrLf & "не поддерживается."
    Label4.Visible = True
End If
Close FileNum
Exit Sub

ErrorLoadImage: 'Обработка ошибки загрузки BMP файла формата с рабочим названием № 2
If Err.Number <> 481 Then
  MsgBox "Ошибка №" & Err.Number & " " & Error(Err.Number), vbCritical, "Ошибка"
  Exit Sub
 Else
  If Check1.Value = 0 Then Exit Sub
  
  If biBitCount = 8 Or biBitCount = 24 Then
    'попытка загрузить неавтоматически
    'MsgBox "Предпросмотр этого формата BMP файла не поддерживается" & vbCrLf & "Но его можно загрузить", vbExclamation, "Неподдерживаемая версия формата BMP"
    Image11.Visible = False
    Picture5.Visible = False
    '265 х 161 - размеры окна предпросмотра
    If biWidth > 265 Or biHeight > 161 Then
     If biHeight / biWidth > 161 / 265 Then 'высота больше ширины
     Picture5.Top = Image13.Top + Image13.Height + 7
     Picture5.Width = biWidth * 161 / biHeight
     Picture5.Left = Dir1.Left + Dir1.Width + 7 + (265 - Picture5.Width) / 2
     Picture5.Height = 163 'ещё 2 пикселя на рамку
     ШагПредпросмотра = CSng(biHeight) / CSng(Picture5.Height)
     ВысотаИзобрПредпросм = 161 'из 163 2 пикселя на рамку
     ШиринаИзобрПредпросм = Picture5.Width - 2 'ещё 2 пикселя на рамку
    Else 'ширина больше высоты или относится ровно как 161 / 265
     Picture5.Left = Dir1.Left + Dir1.Width + 7
     Picture5.Height = biHeight * 265 / biWidth
     Picture5.Top = Image13.Top + Image13.Height + 7 + (161 - Picture5.Height) / 2
     Picture5.Width = 267 'ещё 2 пикселя на рамку
     ШагПредпросмотра = CSng(biWidth) / CSng(Picture5.Width)
     ВысотаИзобрПредпросм = Picture5.Height - 2 'ещё 2 пикселя на рамку
     ШиринаИзобрПредпросм = 265 'из 267 2 пикселя на рамку
    End If
   Else 'картинка вписалась в размер
    Picture5.Height = biHeight + 2
    Picture5.Width = biWidth + 2
    ШагПредпросмотра = 1
    ВысотаИзобрПредпросм = biHeight
    ШиринаИзобрПредпросм = biWidth
    Picture5.Top = Image13.Top + Image13.Height + 7 + (161 - biHeight) / 2
    Picture5.Left = Dir1.Left + Dir1.Width + 7 + (265 - biWidth) / 2
   End If

 If biCompression = 0 Then
  Select Case biBitCount
   Case 8
     Screen.MousePointer = 13
     Picture5.Cls
     
     'загрузка палитры
     Picture1.AutoRedraw = True
     Picture1.Cls
     If biClrUsed > 0 Then
      Chislo_Sostavlyauschih_V_Palitre = (bfOffbits - biSize - 14) / biClrUsed
     Else 'biClrUsed = 0 (или < 0)
      Chislo_Sostavlyauschih_V_Palitre = (bfOffbits - biSize - 14) / (2 ^ biBitCount) 'Но в некоторых версиях резервной нет. Узнаем сколько байт на каджый цвет
     End If
     If biClrUsed = 0 Or biClrUsed = 256 Then  'по умолчанию нулевое значение biClrUsed подразумевает 256 цветов
      For i = 0 To 255
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 17, Byte1 'яркость красной составляющей
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 16, Byte2 'яркость зелёной
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 15, Byte3 'яркость синей
       Massiv256(i, 0) = CSng(Byte1): Massiv256(i, 1) = CSng(Byte2): Massiv256(i, 2) = CSng(Byte3)
      Next i
      For j = 0 To 7
       j32 = j * 32
       j10 = j * 10
       For i = 0 To 31
         Picture1.Line (i * 10, j10)-(i * 10 + 8, j10 + 8), RGB(CByte(Massiv256(i + j32, 0)), CByte(Massiv256(i + j32, 1)), CByte(Massiv256(i + j32, 2))), BF
       Next i
      Next j
     Else 'если цветов < 256
      For i = 0 To biClrUsed - 1
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 17, Byte1 'яркость красной составляющей
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 16, Byte2 'яркость зелёной
       Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + biSize + 15, Byte3 'яркость синей
       'MsgBox "Индекс цвета - " & i & " , К = " & Byte1 & " , З = " & Byte2 & " , С = " & Byte3
       Massiv256(i, 0) = CSng(Byte1): Massiv256(i, 1) = CSng(Byte2): Massiv256(i, 2) = CSng(Byte3)
      Next i
      For j = 0 To 7
       j32 = j * 32
       j10 = j * 10
       For i = 0 To 31
        If j32 + i + 1 <= biClrUsed Then
         Picture1.Line (i * 10, j10)-(i * 10 + 8, j10 + 8), RGB(CByte(Massiv256(i + j32, 0)), CByte(Massiv256(i + j32, 1)), CByte(Massiv256(i + j32, 2))), BF
        End If
       Next i
      Next j
     End If
     Picture1.Visible = True 'отобразить палитру
     
     'прорисовка изображения
     'LongDword = biWidth * biBitCount / 8 + Vyravnivanie_Na4
     'т.к. biBitCount = 8
     LongDword = biWidth + Vyravnivanie_Na4
     bfOffbitsMinus = bfOffbits - LongDword
     For l = 1 To ВысотаИзобрПредпросм
          БайтыДоСтроки0 = CLng(CSng(l) * ШагПредпросмотра) * LongDword + bfOffbitsMinus
          КоординатаВысоты = ВысотаИзобрПредпросм - l
          For k = 1 To ШиринаИзобрПредпросм
           Get FileNum, CLng(Int(CSng(k) * ШагПредпросмотра)) + БайтыДоСтроки0, Byte1
           Picture5.PSet (k - 1, КоординатаВысоты), &H2000000 Or RGB(Massiv256(Byte1, 0), Massiv256(Byte1, 1), Massiv256(Byte1, 2))
          Next k
     Next l
     Picture5.Visible = True
     Line1.Visible = False
     Line2.Visible = False
     Screen.MousePointer = 0
     If Picture3.Enabled = False Then 'разрешить обработку
      Picture3.Top = 0
      Timer0.Enabled = True
      Picture3.Enabled = True
     End If
   Case 24
     Picture5.Cls
     Picture1.Visible = False 'неотображать палитру
     LongDword = biWidth * biBitCount / 8 + Vyravnivanie_Na4
     bfOffbitsMinus = bfOffbits - LongDword
     
     If ШагПредпросмотра < 2 Then
      Screen.MousePointer = 13
      For l = 1 To ВысотаИзобрПредпросм
        БайтыДоСтроки0 = CLng(CSng(l) * ШагПредпросмотра) * LongDword + bfOffbitsMinus
        БайтыДоСтроки2 = БайтыДоСтроки0 - 2
        БайтыДоСтроки1 = БайтыДоСтроки0 - 1
        'КоординатаВысоты = CLng(ВысотаИзобрПредпросм - l - 1) '= (biHeight - j) / ШагПредпросмотра
        КоординатаВысоты = ВысотаИзобрПредпросм - l
        For k = 1 To ШиринаИзобрПредпросм
           i = CLng(Int(CSng(k) * ШагПредпросмотра)) * 3
           Get FileNum, i + БайтыДоСтроки2, Синий
           Get FileNum, i + БайтыДоСтроки1, Зелёный
           Get FileNum, i + БайтыДоСтроки0, Красный
           Picture5.PSet (k - 1, КоординатаВысоты), &H2000000 Or RGB(Красный, Зелёный, Синий)
        Next k
      Next l
     Else 'ШагПредпросмотра >=2
      Screen.MousePointer = 13
      'If ВысотаИзобрПредпросм > 1 Then
      ' МножительПриращенияСчётчика = 8 / (ВысотаИзобрПредпросм - 1)
      'Else
      ' МножительПриращенияСчётчика = 8
      'End If
      For l = 1 To ВысотаИзобрПредпросм - 1
        'If CSng(l) * ШагПредпросмотра < biHeight Then
        БайтыДоСтроки0 = CLng(CSng(l) * ШагПредпросмотра) * LongDword + bfOffbitsMinus
        БайтыДоСтроки1 = БайтыДоСтроки0 - 1
        БайтыДоСтроки2 = БайтыДоСтроки0 - 2

        БайтыДоСтрокиКПред = БайтыДоСтроки2 - 1
        БайтыДоСтрокиЗПред = БайтыДоСтроки2 - 2
        БайтыДоСтрокиСПред = БайтыДоСтроки2 - 3
        
        БайтыДоСтроки3 = CLng(CSng(l) * ШагПредпросмотра + 1) * LongDword + bfOffbitsMinus
        БайтыДоСтроки4 = БайтыДоСтроки3 - 1
        БайтыДоСтроки5 = БайтыДоСтроки3 - 2
        
        БайтыДоСтрокиКПредНиж = БайтыДоСтроки5 - 1
        БайтыДоСтрокиЗПредНиж = БайтыДоСтроки5 - 2
        БайтыДоСтрокиСПредНиж = БайтыДоСтроки5 - 3
        
        'КоординатаВысоты = CLng(ВысотаИзобрПредпросм - l - 1) '= (biHeight - j) / ШагПредпросмотра
        КоординатаВысоты = ВысотаИзобрПредпросм - l
        
        'k = 1 - самый первый столбец
        i = CLng(Int(ШагПредпросмотра)) * 3
        Get FileNum, i + БайтыДоСтроки2, Синий
        Get FileNum, i + БайтыДоСтроки1, Зелёный
        Get FileNum, i + БайтыДоСтроки0, Красный
        Get FileNum, i + БайтыДоСтроки5, Byte3 'Синий ниже строчкой
        Get FileNum, i + БайтыДоСтроки4, Byte2 'Зелёный ниже строчкой
        Get FileNum, i + БайтыДоСтроки3, Byte1 'Красный ниже строчкой
        Красный = CByte((CSng(Красный) + CSng(Byte1)) \ 2)
        Зелёный = CByte((CSng(Зелёный) + CSng(Byte2)) \ 2)
        Синий = CByte((CSng(Синий) + CSng(Byte3)) \ 2)
        Picture5.PSet (0, КоординатаВысоты), &H2000000 Or RGB(Красный, Зелёный, Синий)
        
        For k = 2 To ШиринаИзобрПредпросм
           i = CLng(Int(CSng(k) * ШагПредпросмотра)) * 3
           'Усреднение значений из 4 точек
            Get FileNum, i + БайтыДоСтроки0, Красный
            Get FileNum, i + БайтыДоСтроки3, Byte1 'Красный ниже строчкой
            Get FileNum, i + БайтыДоСтрокиКПред, Byte4 'Красный канал в предыдущей точке
            Get FileNum, i + БайтыДоСтрокиКПредНиж, Byte2 'Красный ниже строчкой в предыдущей точке
            Красный = CByte((CInt(Красный) + CInt(Byte1) + CInt(Byte4) + CInt(Byte2)) \ 4)
            Get FileNum, i + БайтыДоСтроки1, Зелёный
            Get FileNum, i + БайтыДоСтроки4, Byte2 'Зелёный ниже строчкой
            Get FileNum, i + БайтыДоСтрокиЗПред, Byte4 'Зелёный канал в предыдущей точке
            Get FileNum, i + БайтыДоСтрокиЗПредНиж, Byte1  'Зелёный ниже строчкой в предыдущей точке
            Зелёный = CByte((CInt(Зелёный) + CInt(Byte2) + CInt(Byte4) + CInt(Byte1)) \ 4)
            Get FileNum, i + БайтыДоСтроки2, Синий
            Get FileNum, i + БайтыДоСтроки5, Byte3 'Синий ниже строчкой
            Get FileNum, i + БайтыДоСтрокиСПред, Byte4 'Синий канал в предыдущей точке
            Get FileNum, i + БайтыДоСтрокиСПредНиж, Byte1 'Синий ниже строчкой в предыдущей точке
            Синий = CByte((CInt(Синий) + CInt(Byte3) + CInt(Byte4) + CInt(Byte1)) \ 4)
            'If k = ШиринаИзобрПредпросм Then Stop
            'If Красный = 255 And Зелёный = 255 And Синий = 255 Then GoTo НеРисовать
           Picture5.PSet (k - 1, КоординатаВысоты), &H2000000 Or RGB(Красный, Зелёный, Синий)
'НеРисовать:
        Next k
      Next l
      'и последняя строчка:
      БайтыДоСтроки0 = CLng(CSng(ВысотаИзобрПредпросм) * ШагПредпросмотра) * LongDword + bfOffbitsMinus
      БайтыДоСтроки1 = БайтыДоСтроки0 - 1
      БайтыДоСтроки2 = БайтыДоСтроки0 - 2
      For k = 1 To ШиринаИзобрПредпросм
           i = CLng(Int(CSng(k) * ШагПредпросмотра)) * 3
           Get FileNum, i + БайтыДоСтроки2, Синий
           Get FileNum, i + БайтыДоСтроки1, Зелёный
           Get FileNum, i + БайтыДоСтроки0, Красный
           Picture5.PSet (k - 1, 0), &H2000000 Or RGB(Красный, Зелёный, Синий)
      Next k
     End If
     Screen.MousePointer = 0
     Picture5.Visible = True
     Line1.Visible = False
     Line2.Visible = False
     If Picture3.Enabled = False Then 'разрешить обработку
      Picture3.Top = 0
      Timer0.Enabled = True
      Picture3.Enabled = True
     End If
   Case Else
     Label2.Caption = "Изображение с числом бит на пиксель " & biBitCount & " не поддерживается. Только 8 или 24."
     Label2.Visible = True
     Picture5.Visible = False
     Picture3.Enabled = False 'запретить обработку
     Picture3.Top = 0
     Timer0.Enabled = False
  End Select
  Else 'biCompression > 0 , т.е. есть сжатие
   'перечёркивание предпросмотра:
   Line1.Visible = True
   Line2.Visible = True
   MsgBox "Формат BMP файла cо сжатием " & biCompression & " не поддерживается." & vbCrLf & "Возможно только 8 бит или 24 бита на пиксель.", vbExclamation, "Неподдерживаемая версия формата BMP"
   Picture3.Enabled = False 'запретить обработку
   Picture3.Top = 0
   Timer0.Enabled = False
  End If
  
  Else 'biBitCount не 8 и не 24
   Image1.Picture = Image6.Picture
   Image11.Picture = LoadPicture()
   Image11.Height = 161  'стандартные габариты
   Image11.Left = Text7.Left
   Image11.Top = 64
   Image11.Width = 265
   'перечёркивание предпросмотра:
   Line1.Visible = True
   Line2.Visible = True
   Picture3.Enabled = False 'запретить обработку
   Picture3.Top = 0
   Timer0.Enabled = False
   MsgBox "Формат BMP файла c " & biBitCount & " бит на пиксель не поддерживается." & vbCrLf & "Возможно только 8 бит или 24 бита на пиксель.", vbExclamation, "Неподдерживаемая версия формата BMP"
  End If
End If
 Image11.Picture = LoadPicture()
 FormatBMP = 2
 Image11.Left = Text7.Left
 Image11.Top = 64
 Image11.Width = 265
 Image11.Height = 161
 Image11.BorderStyle = 1
 'Line1.Visible = True
 'Line2.Visible = True
 Close FileNum
 Exit Sub
 'GoTo ПослеОшибкиЗагрузки
Resume
End Sub
Sub TGA_Load()
tgaIdentLen = 0 'количество байт, содержащихся в поле Идентификатор. Часто = 0
tgaClrMap = 0 'Тип карты цветов - 0 или 1
tgaType = 0
tgaClrOffset = 0
tgaMapColors = 0
tgaBytesPerClr = 0
tgaОтсчётИзображенияПоX = 0
tgaОтсчётИзображенияПоY = 0
biWidth = 0 'ширина
biHeight = 0 'высота
tgaClrBitPerPixel = 0
tgaImageDesc = 0


'bfSize = 0
'bfOffbits = 0
'biSize = 0
'biPlanes = 0 'кол-во проекций или плоскостей в bmp файле
biBitCount = 0
'biSizeImage = 0
'biXPixelsPerMeter = 0
'biYPixelsPerMeter = 0
'biClrImportant = 0
Chislo_Sostavlyauschih_V_Palitre = 0
Label4.Caption = ""

If Picture3.Enabled = False Then 'доступна загрузка
    Picture3.Top = 0
    Timer0.Enabled = True
    Picture3.Enabled = True
End If
FileNum = FreeFile
Open SelectedFile For Binary As FileNum
  РазмерФайла = LOF(FileNum)
  If РазмерФайла = 0 Then
   Text7.Text = "Файл занимает 0 байт."
   'перечёркивание предпросмотра:
   Line1.Visible = True
   Line2.Visible = True
   Picture3.Enabled = False 'запретить обработку
   Picture3.Top = 0
   Timer0.Enabled = False
   Picture1.Visible = False
   Image11.Height = 161  'стандартные габариты
   Image11.Left = Text7.Left
   Image11.Top = 64
   Image11.Width = 265
   Image11.Picture = LoadPicture()
   Image11.Visible = True
   Image11.BorderStyle = 1
   Exit Sub
  End If
  Get FileNum, 1, tgaIdentLen
  If tgaIdentLen = 0 Then
   Text7.Text = "Поле идентификатора не используется."
  ElseIf tgaIdentLen = 2 Or tgaIdentLen = 3 Or tgaIdentLen = 4 Then
   Text7.Text = tgIdentLen & " байта содержатся в поле Идентификатора."
  ElseIf tgaIdentLen = 1 Or tgaIdentLen = 21 Or tgaIdentLen = 31 Or tgaIdentLen = 41 Then
   Text7.Text = tgIdentLen & " байт содержится в поле Идентификатора."
  Else
   Text7.Text = tgIdentLen & " байт содержатся в поле Идентификатора."
  End If
  Get FileNum, 2, tgaClrMap
  Select Case tgaClrMap
    Case 0
     Text7.Text = Text7.Text & vbCrLf & "Не содержит карту цветов."
     biBitCount = 24
     'tgaMapColors = 0
    Case 1
     Text7.Text = Text7.Text & vbCrLf & "Файл содержит карту цветов."
     CalcWord (4)
     tgaClrOffset = LongDword
     CalcWord (6)
     tgaMapColors = LongDword
     Text7.Text = Text7.Text & vbCrLf & "карта содержит " & tgaMapColors & " цветов"
     biBitCount = tgaMapColors
     Text7.Text = Text7.Text & vbCrLf & "и начинается по адресу " & tgaClrOffset
     Get FileNum, 8, tgaBytesPerClr
     If tgaBytesPerClr = 24 Or tgaBytesPerClr = 4 Or tgaBytesPerClr = 32 Then
      Text7.Text = Text7.Text & vbCrLf & "На каждый цвет палитры отведено по " & tgaBytesPerClr & " бита."
     Else
      Text7.Text = Text7.Text & vbCrLf & "На каждый цвет палитры отведено по " & tgaBytesPerClr & " бит."
     End If
  End Select
  Get FileNum, 3, tgaType 'тип изображения и наличие его сжатия
  Select Case tgaType
    Case 0
     Text7.Text = Text7.Text & vbCrLf & "Нет изображения."
     'перечёркивание предпросмотра:
     Line1.Visible = True
     Line2.Visible = True
     Picture3.Enabled = False 'запретить обработку
     Picture3.Top = 0
     Timer0.Enabled = False
     Picture1.Visible = False
    Case 1, 9
     Text7.Text = Text7.Text & vbCrLf & "Изображение с палитрой."
     'загрузка палитры
     Picture1.AutoRedraw = True
     Picture1.Cls
     If tgaBytesPerClr > 0 Then
       Chislo_Sostavlyauschih_V_Palitre = tgaBytesPerClr / 8 'обычно 24/8 = 3
     Else 'biClrUsed = 0 (или < 0)
       Chislo_Sostavlyauschih_V_Palitre = 3 'альтернативы кроме 3 пока не рассматривал
     End If
     For i = 0 To tgaMapColors - 1
         Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + 21, Byte1  'яркость красной составляющей
         Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + 20, Byte2  'яркость зелёной
         Get FileNum, i * Chislo_Sostavlyauschih_V_Palitre + 19, Byte3  'яркость синей
         Massiv256(i, 0) = CSng(Byte1): Massiv256(i, 1) = CSng(Byte2): Massiv256(i, 2) = CSng(Byte3)
     Next i
     For j = 0 To 7
         j32 = j * 32
         j10 = j * 10
         For i = 0 To 31
           If i + j32 <= tgaMapColors Then
             Picture1.Line (i * 10, j10)-(i * 10 + 8, j10 + 8), RGB(CByte(Massiv256(255 - (i + j32), 0)), CByte(Massiv256(255 - (i + j32), 1)), CByte(Massiv256(255 - (i + j32), 2))), BF
           End If
         Next i
     Next j
     Picture1.Visible = True 'палитра
    Case 2, 10
     Text7.Text = Text7.Text & vbCrLf & "Полноцветное изображение 16 млн. цветов."
     Picture1.Visible = False 'без палитры
    Case 3, 11
     Text7.Text = Text7.Text & vbCrLf & "Изображение в градациях серого."
     'отрисовка палитры
     Picture1.AutoRedraw = True
     Picture1.Cls
     For j = 0 To 7
         j32 = j * 32
         j10 = j * 10
         For i = 0 To 31
             Picture1.Line (i * 10, j10)-(i * 10 + 8, j10 + 8), RGB(CByte(i + j32), CByte(i + j32), CByte(i + j32)), BF
         Next i
     Next j
     Picture1.Visible = True 'палитра
  End Select
  If tgaType <= 3 Then
   Text7.Text = Text7.Text & vbCrLf & "Без сжатия"
  Else
   Text7.Text = Text7.Text & vbCrLf & "Используется сжатие"
   'перечёркивание предпросмотра:
   Line1.Visible = True
   Line2.Visible = True
   Picture3.Enabled = False 'запретить обработку
   Picture3.Top = 0
   Timer0.Enabled = False
  End If

  
  Call CalcWord(9)
  tgaОтсчётИзображенияПоX = LongDword
  If tgaОтсчётИзображенияПоX = 0 Then
     Text7.Text = Text7.Text & vbCrLf & "Начало изображения слева"
  Else
     Text7.Text = Text7.Text & vbCrLf & "Начало изображения со столбца " & tgaОтсчётИзображенияПоX & " от левого края."
     'перечёркивание предпросмотра:
     Line1.Visible = True
     Line2.Visible = True
     Picture3.Enabled = False 'запретить обработку
     Picture3.Top = 0
     Timer0.Enabled = False
  End If
  Call CalcWord(11)
  tgaОтсчётИзображенияПоY = LongDword
  If tgaОтсчётИзображенияПоY = 0 Then
     Text7.Text = Text7.Text & vbCrLf & "Начало изображения снизу"
  Else
     Text7.Text = Text7.Text & vbCrLf & "Начало изображения со строки " & tgaОтсчётИзображенияПоY & " от низа."
  End If
  Get FileNum, 18, tgaImageDesc 'Описатель изображения
   ОбходСправаНалево = tgaImageDesc \ 16
   If ОбходСправаНалево > 1 Then
    ОбходCверхуВниз = ОбходСправаНалево \ 2
    k = ОбходCверхуВниз \ 2
    ОбходCверхуВниз = ОбходCверхуВниз - k * 2
   Else
    ОбходCверхуВниз = 0
    k = 0
   End If
   If ОбходCверхуВниз = 1 Then
     Text7.Text = Text7.Text & vbCrLf & "Порядок обхода: Cверху вниз и"
   ElseIf ОбходCверхуВниз = 0 Then
     Text7.Text = Text7.Text & vbCrLf & "Порядок обхода: Cнизу вверх и"
   End If
   ОбходСправаНалево = ОбходСправаНалево - ОбходCверхуВниз * 2 - k * 4
   If ОбходСправаНалево = 1 Then
     Text7.Text = Text7.Text & vbCrLf & "справа налево."
     'перечёркивание предпросмотра:
     Line1.Visible = True
     Line2.Visible = True
     Picture3.Enabled = False 'запретить обработку
     Picture3.Top = 0
     Timer0.Enabled = False
   ElseIf ОбходСправаНалево = 0 Then
     Text7.Text = Text7.Text & vbCrLf & "слева направо."
   End If

   'определение ширины и высоты для TGA формата
   CalcWord (15)
   biHeight = LongDword
   CalcWord (13)
   biWidth = LongDword
   Text7.Text = Text7.Text & vbCrLf & "Ширина " & biWidth
   Text7.Text = Text7.Text & vbCrLf & "Высота " & biHeight
   Label1.Caption = biWidth & " x " & biHeight
   
   Select Case tgaType
    Case 2, 10
     ReDim BM_MassivК(1 To biWidth, 1 To biHeight)
     ReDim BM_MassivЗ(1 To biWidth, 1 To biHeight)
     ReDim BM_MassivС(1 To biWidth, 1 To biHeight)
    Case 1, 9, 3, 11
     ReDim BM_MassivК(1 To biWidth, 1 To biHeight)
   End Select
   ПутьКПервомуФайлу = SelectedPath
   НазваниеПервогоФайла = File1.List(File1.ListIndex)
   НазваниеПервогоФайлаБезРасширения = Left(НазваниеПервогоФайла, Len(НазваниеПервогоФайла) - 4)
   Get FileNum, 17, tgaClrBitPerPixel 'Глубина цвета бит на пиксель
   If tgaClrBitPerPixel = 24 Or tgaClrBitPerPixel = 4 Or tgaClrBitPerPixel = 2 Or tgaClrBitPerPixel = 32 Then
    Text7.Text = Text7.Text & vbCrLf & "Глубина цвета " & tgaClrBitPerPixel & " бита на пиксель."
   Else
    Text7.Text = Text7.Text & vbCrLf & "Глубина цвета " & tgaClrBitPerPixel & " бит на пиксель."
   End If
   biBitCount = tgaClrBitPerPixel
   Text7.Text = Text7.Text & vbCrLf & "Число атрибутивных бит на пиксель " & tgaImageDesc - ОбходСправаНалево * 16 - ОбходCверхуВниз * 32 - k * 64

Picture5.Visible = False
If Check1.Value = 0 Then
    Image11.Picture = LoadPicture()
    Exit Sub
End If
'иначе не отображать
Image11.Visible = False
Line1.Visible = False
Line2.Visible = False

'попытка загрузить в изобр-е предварительного просмотра неавтоматически:
If tgaType <= 3 Then 'если без сжатия, то отрисуется предпросмотр
    Picture5.Visible = False
    '265 х 161 - размеры окна предпросмотра
    If biWidth > 265 Or biHeight > 161 Then
     If biHeight / biWidth > 161 / 265 Then 'высота больше ширины
     Picture5.Top = Image3.Top + Image3.Height + 3
     Picture5.Width = biWidth * 161 / biHeight
     Picture5.Left = Dir1.Left + Dir1.Width + 7 + (265 - Picture5.Width) / 2
     Picture5.Height = 163 'ещё 2 пикселя на рамку
     ШагПредпросмотра = CSng(biHeight) / CSng(Picture5.Height)
     ВысотаИзобрПредпросм = 163 'или 161 и 2 пикселя на рамку, если бы она была
     ШиринаИзобрПредпросм = Picture5.Width ' - 2 'ещё 2 пикселя на рамку, если бы она была
    Else 'ширина больше высоты или относится ровно как 161 / 265
     Picture5.Left = Dir1.Left + Dir1.Width + 7
     Picture5.Height = biHeight * 265 / biWidth
     Picture5.Top = Image3.Top + Image3.Height + 3 + (161 - Picture5.Height) / 2
     Picture5.Width = 267 'ещё 2 пикселя на рамку
     ШагПредпросмотра = CSng(biWidth) / CSng(Picture5.Width)
     ВысотаИзобрПредпросм = Picture5.Height '- 2 'ещё 2 пикселя на рамку
     ШиринаИзобрПредпросм = 267 'из 267 2 пикселя на рамку
    End If
   Else 'картинка вписалась в размер
    Picture5.Height = biHeight ' + 2 если будет рамка
    Picture5.Width = biWidth ' + 2
    ШагПредпросмотра = 1
    ВысотаИзобрПредпросм = biHeight
    ШиринаИзобрПредпросм = biWidth
    Picture5.Top = Image3.Top + Image3.Height + 7 + (161 - biHeight) / 2
    Picture5.Left = Dir1.Left + Dir1.Width + 7 + (265 - biWidth) / 2
   End If
  
  Picture5.Cls
  If tgaОтсчётИзображенияПоY = 0 And ОбходCверхуВниз = 0 Then
   'Начало изображения слева снизу
    If tgaType = 2 Or tgaType = 10 Then
     'если 24 бита/пиксель
     If biHeight - CLng(CSng(ВысотаИзобрПредпросм) * ШагПредпросмотра) < 0 Then
      ВысотаИзобрПредпросм = ВысотаИзобрПредпросм - 1
      Picture5.Height = ВысотаИзобрПредпросм
     End If
     LongDword = biWidth * tgaClrBitPerPixel / 8
     For l = ВысотаИзобрПредпросм To 1 Step -1
       БайтыДоСтроки0 = (biHeight - CLng(CSng(l) * ШагПредпросмотра)) * LongDword + 18
       БайтыДоСтроки1 = БайтыДоСтроки0 - 1
       БайтыДоСтроки2 = БайтыДоСтроки0 - 2
       КоординатаВысоты = l - 1
       For k = 1 To ШиринаИзобрПредпросм
          i = CLng(CSng(k) * ШагПредпросмотра) * 3
          Get FileNum, i + БайтыДоСтроки2, Синий  'Синяя сост.
          Get FileNum, i + БайтыДоСтроки1, Зелёный  'Зелёная сост.
          Get FileNum, i + БайтыДоСтроки0, Красный 'Красная сост.
          Picture5.PSet (k - 1, КоординатаВысоты), &H2000000 Or RGB(Красный, Зелёный, Синий)
       Next k
     Next l
     Label4.Visible = False
     
    ElseIf tgaType = 1 Or tgaType = 9 Then
     'если 8 бит/пиксель и есть палитра
     If ШагПредпросмотра = 1 Then
      If biHeight - ВысотаИзобрПредпросм < 0 Then
       ВысотаИзобрПредпросм = ВысотаИзобрПредпросм - 1
       Picture5.Height = ВысотаИзобрПредпросм
      End If
       For l = ВысотаИзобрПредпросм To 1 Step -1
        БайтыДоСтроки0 = (biHeight - l) * biWidth + 787
        '787 - это 19 + 2 + 255*3 + 1 '18 байт заголовок, 19-21 цвет с 0 индексом и ещё 765 до конца палитры
        КоординатаВысоты = l - 1
        For k = 0 To ШиринаИзобрПредпросм - 1
           Get FileNum, k + БайтыДоСтроки0, Красный 'Красная сост.
           Picture5.PSet (k, КоординатаВысоты), &H2000000 Or RGB(Massiv256(Красный, 0), Massiv256(Красный, 1), Massiv256(Красный, 2))
        Next k
       Next l
     Else
      If biHeight - CLng(CSng(ВысотаИзобрПредпросм) * ШагПредпросмотра) < 0 Then
       ВысотаИзобрПредпросм = ВысотаИзобрПредпросм - 1
       Picture5.Height = ВысотаИзобрПредпросм
      End If
      For l = ВысотаИзобрПредпросм To 1 Step -1
       БайтыДоСтроки0 = (biHeight - CLng(CSng(l) * ШагПредпросмотра)) * biWidth + 787
       '787 - это 19 + 2 + 255*3 + 1 '18 байт заголовок, 19-21 цвет с 0 индексом и ещё 765 до конца палитры
       КоординатаВысоты = l - 1
       For k = 0 To ШиринаИзобрПредпросм - 1
          Get FileNum, CLng(CSng(k) * ШагПредпросмотра) + БайтыДоСтроки0, Красный 'Красная сост.
          Picture5.PSet (k, КоординатаВысоты), &H2000000 Or RGB(Massiv256(Красный, 0), Massiv256(Красный, 1), Massiv256(Красный, 2))
       Next k
      Next l
     End If
     Label4.Visible = False
    ElseIf tgaType = 3 Or tgaType = 11 Then
     'если 8 бит/пиксель в градациях серого
     If ШагПредпросмотра = 1 Then
      For l = ВысотаИзобрПредпросм To 1 Step -1
       БайтыДоСтроки0 = (biHeight - l) * biWidth + 18 '18 байт заголовок
       КоординатаВысоты = l - 1
       For k = 0 To ШиринаИзобрПредпросм - 1
          Get FileNum, k + БайтыДоСтроки0, Byte1 'Яркость
          Picture5.PSet (k, КоординатаВысоты), &H2000000 Or RGB(Byte1, Byte1, Byte1)
       Next k
      Next l
     Else
      If biHeight - CLng(CSng(ВысотаИзобрПредпросм) * ШагПредпросмотра) < 0 Then
       ВысотаИзобрПредпросм = ВысотаИзобрПредпросм - 1
       Picture2.Height = ВысотаИзобрПредпросм
      End If
      For l = ВысотаИзобрПредпросм To 1 Step -1
       БайтыДоСтроки0 = (biHeight - CLng(CSng(l) * ШагПредпросмотра)) * biWidth + 18 '18 байт заголовок
       КоординатаВысоты = l - 1
       For k = 0 To ШиринаИзобрПредпросм - 1
          Get FileNum, CLng(CSng(k) * ШагПредпросмотра) + БайтыДоСтроки0, Byte1 'Яркость
          Picture5.PSet (k, КоординатаВысоты), &H2000000 Or RGB(Byte1, Byte1, Byte1)
       Next k
      Next l
     End If
     Label4.Visible = False
    End If
    
    
  ElseIf tgaОтсчётИзображенияПоY = biHeight And ОбходCверхуВниз = 1 Then
    'Начало изображения слева сверху.
    If tgaType = 2 Or tgaType = 10 Then
     'если 24 бита/пиксель
     LongDword = biWidth * 3
     For l = 1 To ВысотаИзобрПредпросм
       КоординатаВысоты = l - 1
       БайтыДоСтроки0 = (CLng(CSng(l) * ШагПредпросмотра) - 1) * LongDword + 18
       БайтыДоСтроки2 = БайтыДоСтроки0 - 2
       БайтыДоСтроки1 = БайтыДоСтроки0 - 1
       For k = 1 To ШиринаИзобрПредпросм
          i = CLng(CSng(k) * ШагПредпросмотра) * 3
          Get FileNum, i + БайтыДоСтроки2, Синий  'Синяя сост.
          Get FileNum, i + БайтыДоСтроки1, Зелёный  'Зелёная сост.
          Get FileNum, i + БайтыДоСтроки0, Красный 'Красная сост.
          Picture5.PSet (k - 1, КоординатаВысоты), &H2000000 Or RGB(Красный, Зелёный, Синий)
       Next k
     Next l
     
    ElseIf tgaType = 1 Or tgaType = 9 Then
     'если 8 бит/пиксель и есть палитра
     If ШагПредпросмотра = 1 Then
      If biHeight - ВысотаИзобрПредпросм < 0 Then
       ВысотаИзобрПредпросм = ВысотаИзобрПредпросм - 1
       Picture5.Height = ВысотаИзобрПредпросм
      End If
      For l = 1 To ВысотаИзобрПредпросм
        БайтыДоСтроки0 = (l - 1) * biWidth + 787
        '787 - это 19 + 2 + 255*3 + 1 '18 байт заголовок, 19-21 цвет с 0 индексом и ещё 765 до конца палитры
        КоординатаВысоты = l - 1
        For k = 0 To ШиринаИзобрПредпросм - 1
           Get FileNum, k + БайтыДоСтроки0, Красный 'Красная сост.
           Picture5.PSet (k, КоординатаВысоты), &H2000000 Or RGB(Massiv256(Красный, 0), Massiv256(Красный, 1), Massiv256(Красный, 2))
        Next k
       Next l
     Else
      If biHeight - CLng(CSng(ВысотаИзобрПредпросм) * ШагПредпросмотра) < 0 Then
       ВысотаИзобрПредпросм = ВысотаИзобрПредпросм - 1
       Picture5.Height = ВысотаИзобрПредпросм
      End If
      For l = 1 To ВысотаИзобрПредпросм
       БайтыДоСтроки0 = (CLng(CSng(l) * ШагПредпросмотра) - 1) * biWidth + 787
       '787 - это 19 + 2 + 255*3 + 1 '18 байт заголовок, 19-21 цвет с 0 индексом и ещё 765 до конца палитры
       КоординатаВысоты = l - 1
       For k = 0 To ШиринаИзобрПредпросм - 1
          Get FileNum, CLng(CSng(k) * ШагПредпросмотра) + БайтыДоСтроки0, Красный 'Красная сост.
          Picture5.PSet (k, КоординатаВысоты), &H2000000 Or RGB(Massiv256(Красный, 0), Massiv256(Красный, 1), Massiv256(Красный, 2))
       Next k
      Next l
     End If
     Label4.Visible = False
    ElseIf tgaType = 3 Or tgaType = 11 Then
     'если 8 бит/пиксель в градациях серого
     If ШагПредпросмотра = 1 Then
      For l = 1 To ВысотаИзобрПредпросм
       БайтыДоСтроки0 = (l - 1) * biWidth + 18  '18 байт заголовок
       КоординатаВысоты = l - 1
       For k = 0 To ШиринаИзобрПредпросм - 1
          Get FileNum, k + БайтыДоСтроки0, Byte1 'Яркость
          Picture5.PSet (k, КоординатаВысоты), &H2000000 Or RGB(Byte1, Byte1, Byte1)
       Next k
      Next l
     Else
      For l = 1 To ВысотаИзобрПредпросм
       БайтыДоСтроки0 = (CLng(CSng(l) * ШагПредпросмотра) - 1) * biWidth + 18 '18 байт заголовок
       КоординатаВысоты = l - 1
       For k = 0 To ШиринаИзобрПредпросм - 1
          Get FileNum, CLng(CSng(k) * ШагПредпросмотра) + БайтыДоСтроки0, Byte1 'Яркость
          Picture5.PSet (k, КоординатаВысоты), &H2000000 Or RGB(Byte1, Byte1, Byte1)
       Next k
      Next l
     End If
     Label4.Visible = False
    End If
  End If
  Picture5.Visible = True
  Label2.Visible = False
Else
  Picture5.Visible = False
  Label2.Caption = "Изображение со сжатием не поддерживается"
  Label2.Visible = True
  Label4.Visible = True
    Select Case biCompression
     Case 1
     Label4.Caption = Label4.Caption & biCompression & " тип сжатия 8 битное RLE" & vbCrLf
     Case 2
     Label4.Caption = Label4.Caption & biCompression & " тип сжатия 4 битное RLE" & vbCrLf
     Case 3
     Label4.Caption = Label4.Caption & biCompression & " тип сжатия - битовые поля (обычно используется, когда больше 8 разрядов на цветовую составляющую)" & vbCrLf
     Case 4
     Label4.Caption = Label4.Caption & biCompression & " тип сжатия JPEG" & vbCrLf
     Case 5
     Label4.Caption = Label4.Caption & biCompression & " тип сжатия PNG" & vbCrLf
     Case Else
     Label4.Caption = Label4.Caption & biCompression & " тип сжатия" & vbCrLf
    End Select
  'предпросмотра не видно
  Picture5.Visible = False
  Image11.Picture = LoadPicture()
  Image11.Visible = True
  Line1.Visible = True
  Line2.Visible = True
End If
 
Close FileNum
End Sub

Sub CalcWord(i)
        Get FileNum, i, Byte1
        Get FileNum, i + 1, Byte2
        LongDword = CLng(Byte1) + CLng(Byte2) * 256
End Sub


Private Sub Image13_Click()
StopLoop = True
End Sub

Private Sub Image13_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Image13.Picture = Image15.Picture
End Sub

Private Sub Image13_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Image13.Picture = Image14.Picture
End Sub

Private Sub Image3_Click()
HelpOpenForm.Show 1, OpenForm
End Sub

Private Sub Image3_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Image3.Picture = Image4.Picture
End Sub


Private Sub Picture3_Click()
Dim PosleTablicy As Long
Otmena = False

ExportForm.Show 1, OpenForm
If Otmena = False Then
  Picture3.Top = -312
  PervStl = PervStolb
  PervStr = PervStroka
  PoslStl = PoslStolb
  PoslStr = PoslStroka
  Image1.Visible = False
  Image3.Visible = False
  PosleTablicy = PoslStroka - PervStroka + 2
  
  On Error GoTo Sboy_ot_zakrytiya_proshlogo_Excel 'при ошибке из-за закрытого после предыдущего раза Excela при работающей программе
  Set TablicaExcel = CreateObject("Excel.Application")
  OLE1.CreateEmbed "", "Excel.Sheet"   'создание связанного объекта "лист Excel"
  Screen.MousePointer = 13             'курсор ожидания
  TablicaExcel.ScreenUpdating = False  'отключение показа изменений ускоряет вывод
  TablicaExcel.Range("A1:" & Posledniy_Stolbec & (PoslStroka - PervStroka + 1)) = Export  'вывод яркостей
  If Check_Zalivka = True Then FonYacheek 'процедура закраски фона ячеек
  If ChyornoBely <> 0 And (Minus = 4 Or Minus = 6) Then   'если числа дробные, то показывать до 2-го знака после запятой
     TablicaExcel.Columns("A:" & Posledniy_Stolbec).EntireColumn.NumberFormat = "0.00"
  End If
  TablicaExcel.Columns("A:" & Posledniy_Stolbec).EntireColumn.AutoFit   'подравняем столбцы в таблице
  Timer0.Enabled = True
  
  'Image2.Picture = Image8.Picture
  
  Select Case bfType
    Case "BM", "BA", "TG"
      TablicaExcel.Cells(PosleTablicy, 1) = "Файл: " & File1.List(File1.ListIndex) & " ;    Точек " & biWidth & "x" & biHeight & "   ; " & 2 ^ biBitCount & " цветов"
      If ChyornoBely = 0 Then
        TablicaExcel.Cells(PosleTablicy + 1, 1) = "Выведена ЯРКОСТЬ (яркость чёрно-белого изображения)"
       Else
        Select Case Minus
         Case 1
          TablicaExcel.Cells(PosleTablicy + 1, 1) = "Выведена ЯРКОСТЬ КРАСНОЙ СОСТАВЛЯЮЩЕЙ"
          TablicaExcel.Cells(PosleTablicy + 1, 1).Font.ColorIndex = 3 'сделать текст красным
         Case 2
          TablicaExcel.Cells(PosleTablicy + 1, 1) = "Выведена ЯРКОСТЬ ЗЕЛЁНОЙ СОСТАВЛЯЮЩЕЙ"
          TablicaExcel.Cells(PosleTablicy + 1, 1).Font.ColorIndex = 10 'сделать текст зелёным
         Case 3
          TablicaExcel.Cells(PosleTablicy + 1, 1) = "Выведена ЯРКОСТЬ СИНЕЙ СОСТАВЛЯЮЩЕЙ"
          TablicaExcel.Cells(PosleTablicy + 1, 1).Font.ColorIndex = 11 'сделать текст синим
         Case 4
          TablicaExcel.Cells(PosleTablicy + 1, 1) = "Выведена ЯРКОСТЬ как среднее арифметическое от красной, зелёной и синей составляющей"
         Case 5
          TablicaExcel.Cells(PosleTablicy + 1, 1) = "Выведена МАКСИМАЛЬНАЯ ЯРКОСТЬ среди красной, зелёной и синей составляющих каждой точки"
         Case 6
          TablicaExcel.Cells(PosleTablicy + 1, 1) = "Выведена ЯРКОСТЬ = " & Format(ДоляКрасного, "0.000") & "•R + " & Format(ДоляЗелёного, "0.000") & "•G + " & Format(ДоляСинего, "0.000") & "•B"
        End Select
      End If
      TablicaExcel.Cells(PosleTablicy + 2, 1) = "От [" & PervStolb & ";" & PervStroka & "] до [" & PoslStolb & ";" & PoslStroka & "] (отсчёт с левого верхнего угла), занятый диапазон в таблице [A1:" & Posledniy_Stolbec & (PosleTablicy - 1) & "]"
     'можно добавить обработку других форматов
  End Select
  
  TablicaExcel.ScreenUpdating = True
  TablicaExcel.Visible = True
  OLE1.Verb = 2              'Действие "открыть самостоятельный лист"
  OLE1.Action = OLE_ACTIVATE 'запуск действия
  Set TablicaExcel = Nothing 'очищаем (уничтожаем?) связанный объект, оставляя самостоятельный лист
  Screen.MousePointer = 0
  Image1.Visible = True
  Image3.Visible = True
  Label5.Visible = False
  'MsgBox "Программе необходимо прервать работу." & vbCrLf & "Перезапустите её снова.", , "Выход из программы"
  'OLE1.Action = OLE_CLOSE
  'End
End If
Picture3.Top = -260
Exit Sub

Sboy_ot_zakrytiya_proshlogo_Excel:
MsgBox "        Перезапустите программу." & vbCrLf & "Программа будет закрыта.", vbCritical, "Ошибка с открытием листа Excel-а"
End
Resume
End Sub

Private Sub Picture3_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture3.Top = -286
End Sub

Private Sub Image3_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Image3.Picture = Image5.Picture
End Sub

Sub FonYacheek()
StopLoop = False
Label5.Visible = True
Image13.Visible = True
Image13.Enabled = True
Vremya_Do_IZMER = Now

For j = 1 To (PoslStr - PervStr + 1)
 DoEvents
 If StopLoop = True Then Exit For
 Picture4.Width = j * 130 \ (PoslStr - PervStr + 1)
 Picture4.Refresh
 For i = 1 To (PoslStl - PervStl + 1)
  On Error Resume Next 'если плохо идёт, то выполнять следующую строку
   If ExportFon(j, i, 1) <> 2 Then TablicaExcel.Cells(j, i).Interior.ColorIndex = ExportFon(j, i, 1)
'или так?    If ExportFon(j, i, 1) <> 2 And ExportFon(j, i, 1) <> Null Then TablicaExcel.Cells(j, i).Interior.ColorIndex = ExportFon(j, i, 1)
  On Error Resume Next 'если плохо идёт, то выполнять следующую строку
   If ExportFon(j, i, 2) > 1 Then TablicaExcel.Cells(j, i).Font.ColorIndex = ExportFon(j, i, 2)
 Next i
 Vremya_Na_Stroku = Second(Now - Vremya_Do_IZMER)
 Vremya_Do_IZMER = Now
 Ostalos = Vremya_Na_Stroku * (PoslStr - PervStr + 1 - j)
 If Ostalos > 0 Then Label5.Caption = "Осталось  " & Ostalos & " с"
Next j

 Picture4.Width = 1
 Picture4.Refresh
 Image13.Enabled = False
 Image13.Visible = False
End Sub

Private Sub Text5_KeyPress(KeyAscii As Integer)
Dim DiskLetter As String * 1
If KeyAscii = 13 Then
 TextInfo = RTrim(Text5.Text)
 If File1.Path <> TextInfo Then
  DiskLetter = Left(TextInfo, 1)
  If Mid(TextInfo, 2, 1) = ":" Then 'если вначале диск
   If Asc(DiskLetter) >= 97 And Asc(DiskLetter) <= 122 Then 'строчная буква
    'MsgBox Drive1.Drive & DiskLetter & " - " & Asc(DiskLetter) & vbCrLf & Chr(Asc(DiskLetter) - 32)
    If Drive1.Drive <> Left(TextInfo, 2) Then
     On Error GoTo НевозможноОткрытьПуть
     Drive1.Drive = Left(TextInfo, 2)
    End If
    On Error GoTo НевозможноОткрытьПуть
    Dir1.Path = TextInfo
   ElseIf Asc(DiskLetter) >= 65 And Asc(DiskLetter) <= 90 Then 'Заглавная буква
    'MsgBox Drive1.Drive & DiskLetter & " - " & Asc(DiskLetter) & vbCrLf & Chr(Asc(DiskLetter) + 32)
    TextInfo2 = Chr(Asc(DiskLetter) + 32) & ":"
    If Drive1.Drive <> TextInfo2 Then
     On Error GoTo НевозможноОткрытьПуть
     Drive1.Drive = Left(TextInfo, 2)
    End If
    On Error GoTo НевозможноОткрытьПуть
    Dir1.Path = TextInfo
   Else 'совсем не латинская буква
    Exit Sub
   End If 'размер буквы диска
  Else 'если вначале нет диска
    If DiskLetter = "\" Then 'DiskLetter - первый символ
     On Error GoTo НевозможноОткрытьПуть
     Dir1.Path = Drive1.Drive & TextInfo
    Else
     On Error GoTo НевозможноОткрытьПуть
     Dir1.Path = Drive1.Drive & "\" & TextInfo
    End If
  End If
 End If
End If
Exit Sub
НевозможноОткрытьПуть:
MsgBox "Файловый путь не доступен или не существует", vbExclamation, "Невозможно открыть путь"
End Sub

Private Sub Timer0_Timer()
 If Picture3.Top > -260 Then
   Picture3.Top = Picture3.Top - 26
   Picture3.Refresh
  Else
   Timer0.Enabled = False
 End If
End Sub
