Option Explicit
Option Compare Text '<-----!!!----

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private WithEvents mMousewheel As clsMouseWheel
 
Private bMouseIn As Boolean
Public hWnd As Long

Dim ThisList As Variant
Dim lngCnt As Long
Dim StartW
Dim StartH
Dim arrZata() As String
Dim ListRng As Excel.Range
Dim objExcel As Excel.Workbook
Private Sub CheckBox1_Click()
Dim SCaption As String
Select Case CheckBox1.Value
    Case True
        SCaption = "Поиск по первой букве"
    Case False
        SCaption = "Поиск по букве"
    End Select
    Label2.Caption = SCaption
    TextBox1.Text = ""
End Sub

Private Sub CloseButton_Click()
    Unload Me
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
Dim intJ As Integer

Worksheets("Лист1").Cells(6, 5).Value = Me.ListBox1.Column(pvargColumn:=1)
Worksheets("Лист1").Cells(7, 8).ClearContents
   Unload UserForm1
 'Cells(7, 1).Activate
End Sub

Private Sub TextBox1_Change()
Dim InsMode As Boolean
Dim Txt As String, Criteria As String
Dim ListItem As Variant
Dim arrLata() As String
Dim arrSata() As String
Dim intT As Integer, intX As Integer, intU As Integer
    
    If InsMode Then Exit Sub
    Txt = TextBox1.Text
    
    ListBox1.Clear
    If Txt <> "" Then
    'Criteria = "*" & TextBox1.Text & "*"
    
    If CheckBox1.Value = False Then
            Criteria = "*" & TextBox1.Text & "*"
        Else
            Criteria = Txt & "*"
     End If
    
    
       'Criteria = Txt
       'Criteria = Txt & "*"
       intT = 0
       intX = 0
      
        For Each ListItem In ThisList
         intT = intT + 1
         
            'If ListItem Like Criteria Then ListBox1.AddItem ListItem
            If ListItem Like Criteria Then
           
              intX = intX + 1
             ReDim Preserve arrLata(1 To 2, 1 To intX) As String
              arrLata(1, intX) = intT
              arrLata(2, intX) = ListItem
              
            End If
              If intT < lngCnt Then GoTo 10
              
             ReDim Preserve arrSata(1 To intX + 1, 1 To 2) As String
              For intU = 1 To intX
              arrSata(intU, 1) = arrLata(1, intU)
              arrSata(intU, 2) = arrLata(2, intU)
              Next intU
              ListBox1.List = arrSata
10      Next
    Else
         ListBox1.List = arrZata
    End If
    If Txt = "" Then
       Label1.Caption = ListBox1.ListCount & "  из  " & lngCnt
    Exit Sub
    End If
    Label1.Caption = ListBox1.ListCount - 1 & "  из  " & lngCnt
End Sub

Private Sub UserForm_Terminate()

'Dim lngCnt As Long
'Dim ListRng As Excel.Range
Dim oSheet As Excel.Worksheet
Dim owb1 As Excel.Workbook
Dim intW As Integer
          

          Set objExcel = GetObject("D:\Книга1.xls")
          Set owb1 = GetObject("D:\Книга2.xls")

           Set oSheet = objExcel.Worksheets("Лист1")

      Set ListRng = Range(oSheet.Range("A2"), oSheet.Range("A2").End(xlDown))

          lngCnt = ListRng.Rows.Count
          If lngCnt = 65535 Then Let lngCnt = 1
         
          intW = 2
         Do While oSheet.Cells(intW, 1) <> owb1.Worksheets("Лист1").Cells(6, 5)
         intW = intW + 1
          If intW - 1 > lngCnt Then Exit Sub
         Loop
          owb1.Worksheets("Лист1").Cells(7, 8) = oSheet.Cells(intW, 18) & _
                                                                oSheet.Cells(intW, 19) & _
                                                                oSheet.Cells(intW, 20) & _
                                                                oSheet.Cells(intW, 21) & _
                                                                oSheet.Cells(intW, 22) & _
                                                                oSheet.Cells(intW, 23) & _
                                                                oSheet.Cells(intW, 24) & _
                                                                oSheet.Cells(intW, 25) & _
                                                                oSheet.Cells(intW, 26) & _
                                                                oSheet.Cells(intW, 27) & _
                                                                oSheet.Cells(intW, 28) & _
                                                                oSheet.Cells(intW, 29)


          
          owb1.Worksheets("Лист2").Cells(10, 22) = oSheet.Cells(intW, 1)
          
          If owb1.Worksheets("Лист1").Cells(7, 8) = "" Then _             owb1.Worksheets("Лист2").Cells(10, 22) = ""

          
             
             
          
          owb1.Worksheets("Лист2").Cells(13, 26) = oSheet.Cells(intW, 18)
          owb1.Worksheets("Лист2").Cells(13, 27) = oSheet.Cells(intW, 19)
          owb1.Worksheets("Лист2").Cells(13, 28) = oSheet.Cells(intW, 20)
          owb1.Worksheets("Лист2").Cells(13, 29) = oSheet.Cells(intW, 21)
          owb1.Worksheets("Лист2").Cells(13, 30) = oSheet.Cells(intW, 22)
          owb1.Worksheets("Лист2").Cells(13, 31) = oSheet.Cells(intW, 23)
          owb1.Worksheets("Лист2").Cells(13, 32) = oSheet.Cells(intW, 24)
          owb1.Worksheets("Лист2").Cells(13, 33) = oSheet.Cells(intW, 25)
          owb1.Worksheets("Лист2").Cells(13, 34) = oSheet.Cells(intW, 26)
          owb1.Worksheets("Лист2").Cells(13, 35) = oSheet.Cells(intW, 27)
          owb1.Worksheets("Лист2").Cells(13, 36) = oSheet.Cells(intW, 28)
          owb1.Worksheets("Лист2").Cells(13, 37) = oSheet.Cells(intW, 29)
          
          owb1.Worksheets("Лист2").Cells(15, 20) = oSheet.Cells(intW, 17)
         
          owb1.Worksheets("Лист2").Cells(17, 28) = oSheet.Cells(intW, 40)
          owb1.Worksheets("Лист2").Cells(17, 29) = oSheet.Cells(intW, 41)
          owb1.Worksheets("Лист2").Cells(17, 30) = oSheet.Cells(intW, 42)
          owb1.Worksheets("Лист2").Cells(17, 31) = oSheet.Cells(intW, 43)
          owb1.Worksheets("Лист2").Cells(17, 32) = oSheet.Cells(intW, 44)
          owb1.Worksheets("Лист2").Cells(17, 33) = oSheet.Cells(intW, 45)
          owb1.Worksheets("Лист2").Cells(17, 34) = oSheet.Cells(intW, 46)
          owb1.Worksheets("Лист2").Cells(17, 35) = oSheet.Cells(intW, 47)
          owb1.Worksheets("Лист2").Cells(17, 36) = oSheet.Cells(intW, 48)
          owb1.Worksheets("Лист2").Cells(17, 37) = oSheet.Cells(intW, 49)
         
          owb1.Worksheets("Лист2").Cells(19, 28) = oSheet.Cells(intW, 30)
          owb1.Worksheets("Лист2").Cells(19, 29) = oSheet.Cells(intW, 31)
          owb1.Worksheets("Лист2").Cells(19, 30) = oSheet.Cells(intW, 32)
          owb1.Worksheets("Лист2").Cells(19, 31) = oSheet.Cells(intW, 33)
          owb1.Worksheets("Лист2").Cells(19, 32) = oSheet.Cells(intW, 34)
          owb1.Worksheets("Лист2").Cells(19, 33) = oSheet.Cells(intW, 35)
          owb1.Worksheets("Лист2").Cells(19, 34) = oSheet.Cells(intW, 36)
          owb1.Worksheets("Лист2").Cells(19, 35) = oSheet.Cells(intW, 37)
          owb1.Worksheets("Лист2").Cells(19, 36) = oSheet.Cells(intW, 38)
          owb1.Worksheets("Лист2").Cells(19, 37) = oSheet.Cells(intW, 39)
         
          owb1.Worksheets("Лист2").Cells(21, 23) = oSheet.Cells(intW, 9)
          owb1.Worksheets("Лист2").Cells(21, 24) = oSheet.Cells(intW, 10)
          owb1.Worksheets("Лист2").Cells(21, 25) = oSheet.Cells(intW, 11)
          owb1.Worksheets("Лист2").Cells(21, 26) = oSheet.Cells(intW, 12)
          owb1.Worksheets("Лист2").Cells(21, 27) = oSheet.Cells(intW, 13)
          owb1.Worksheets("Лист2").Cells(21, 28) = oSheet.Cells(intW, 14)
          owb1.Worksheets("Лист2").Cells(21, 29) = oSheet.Cells(intW, 15)
          owb1.Worksheets("Лист2").Cells(21, 30) = oSheet.Cells(intW, 16)
         
          owb1.Worksheets("Лист2").Cells(21, 33) = oSheet.Cells(intW, 3) & _
                                                   oSheet.Cells(intW, 4) & _
                                                   oSheet.Cells(intW, 5) & _
                                                   oSheet.Cells(intW, 6) & _
                                                   oSheet.Cells(intW, 7) & _
                                                   oSheet.Cells(intW, 8)
          
          owb1.Worksheets("Лист2").Cells(23, 17) = oSheet.Cells(intW, 50)
       
End Sub
Private Sub NormalButton_Click()
    ScrollBar1.Value = 100
End Sub

Private Sub ScrollBar1_Change()
    Me.Zoom = ScrollBar1.Value
    Me.Width = StartW * (ScrollBar1.Value / 100)
    Me.Height = StartH * (ScrollBar1.Value / 100)
    LabelZoom.Caption = ScrollBar1.Value & "%"
End Sub

Private Sub UserForm_Initialize()

Dim intU As Integer, intH As Integer
'Dim ListRng As Excel.Range
'Dim ThisList As Variant


'Dim arrZata() As String
'Dim arrSata() As String
'Dim objExcel As Excel.Workbook
'Dim lngCnt As Long
  
  hWnd = FindWindow("ThunderDFrame", Me.Caption)
  Set MouseWheel = New clsMouseWheel
  Set mMousewheel = MouseWheel
  LocalPrevWndProc = SetWindowLong(Me.hWnd, GWL_WNDPROC, AddressOf WindowProc)


    StartW = Me.Width
    StartH = Me.Height
    
    Set objExcel = GetObject("D:\Книга1.xls")

    Set ListRng = Range(objExcel.Worksheets("Лист1").Range("A2"), objExcel.Worksheets("Лист1").Range("A2").End(xlDown))
           
    
           ThisList = ListRng.Value
           

           lngCnt = ListRng.Rows.Count
           If lngCnt = 65535 Then Let lngCnt = 1
           
          ReDim arrZata(1 To lngCnt, 1 To 2) As String
             
           For intH = 1 To lngCnt
             
             arrZata(intH, 1) = intH
             arrZata(intH, 2) = ThisList(intH, 1)
           Next intH

             
            
         'ReDim arrSata(1 To lngCnt, 1 To 2) As String
              
              'For intU = 1 To lngCnt
              'arrSata(intU, 1) = arrZata(intU, 1)
              'arrSata(intU, 2) = arrZata(intU, 2)
              'Next intU
              
              
           ListBox1.List = arrZata
           'ListBox1.List = arrSata
           Label1.Caption = ListBox1.ListCount & "  &#179;&#231;  " & lngCnt
           Label2.Caption = "Поиск по букве"
End Sub
Private Sub UserForm_Activate()
  ListBox1.ListIndex = 0
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  bMouseIn = False
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  WheelUnHook
End Sub
 
Private Sub UserForm_Deactivate()
  WheelUnHook
End Sub
 
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  bMouseIn = True
End Sub
Private Sub ListBox1_Change()
Dim intR As Integer
For intR = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(intR) Then
        Label3.Caption = ListBox1.List(intR) & "  " & ThisList(intR + 1, 1)
    End If
    Next
End Sub
Private Sub mMousewheel_Rotation(bUp As Boolean)
  If bMouseIn Then
    With Me.ListBox1
      If bUp Then
        If .ListIndex > 0 Then .ListIndex = .ListIndex - 1
        If .TopIndex > 0 Then
          If .TopIndex > 1 Then
            .TopIndex = .TopIndex - 1
          Else
            .TopIndex = 0
          End If
        End If
      Else
        .TopIndex = .TopIndex + 1
        If .ListIndex >= 0 And .ListIndex < .ListCount - 1 Then .ListIndex = .ListIndex + 1
      End If
    End With
  End If
End Sub
 
Private Sub WheelUnHook()
  Dim WorkFlag As Long
  On Error Resume Next
  WorkFlag = SetWindowLong(Me.hWnd, GWL_WNDPROC, LocalPrevWndProc)
  Set MouseWheel = Nothing
End Sub