ÿþFunction 72;5G5=85$>B>7"01;8FK:A5;2_>B;04:0()
Dim >;=CBL$09;0
>;=CBL$09;0 = "D:\"5AB72;5G5=85$>B>.xls"

Beep
>;=CBL$09;0 = InputBox("72;5G5=85 :0@B8=>: 87 D09;0" & vbCrLf & _
     "CBL D09;0:", "'  "", >;=CBL$09;0)

Call 72;5G5=85$>B>7"01;8FK:A5;2(>;=CBL$09;0)
End Function


Sub 72;5G5=85$>B>7"01;8FK:A5;2(>;=CBL$09;0)
Dim @8;:A5; As Object, 08<7>, >;7> As Long, ><7> As Long
Dim 7>B5@E0 As Currency, KA>B07> As Currency, &5=B@$>B>B5@E0 As Currency
Dim 08<$09;0 As String,  0AH8@5=85 As String, ><5@ As Long
Dim >;=CBL$09;0" As String, CBL7>>@5<0?:5 As String,  07<5@>2$>B> As Long
Dim CBL7>;O!>E@0=5=8O As String

Dim ><5@!B@>:8 As Long
Dim !B@>:0B5@E0 As Currency, !B@>:0!;54B5@E0 As Currency
Dim 0?:0;O>8A:0$>B> As String
Dim 0:A 07<5@$>B> As Long, CBL$>B>!_0:A 07<5@>< As String
Dim ><5@$>B>!B@>:5 As Long
Dim 0?:0$09;0 As String, 0?:0>2$>B> As String
Dim >;7>72;5G5=> As Long

Const <O@5<$09;0 = "$09;HTM"

If Dir(>;=CBL$09;0) = "" Or >;=CBL$09;0 = "" Then
     MsgBox "$09;" & vbCrLf & >;=CBL$09;0 & vbCrLf & _
          " =0945= !"
     Exit Sub
End If


'-----------------B:@>5< B01;8FC EXEL
Set @8;:A5; = CreateObject("Excel.Application")
@8;:A5;.Application.Workbooks.Open >;=CBL$09;0

'--------------------- 4;O 2A5E D>B> 2 :A5; >?@545;8<
'--------------------- 8<5=0$>B> 2 :A5; 8 =0 :0:>< @0AAB>O=88 >B 25@E0 F5=B@ D>B>
>;7> = @8;:A5;.ActiveSheet.Shapes.Count
>;7>72;5G5=> = 0
If >;7> > 1 Then
     '---------------- ?@545;8< 8<O D09;0 8 ?0?:C, 2 :>B>@>9 =0E>48BLAO D09;
     ><5@ = 0
     Do
          If InStr(><5@ + 1, >;=CBL$09;0, "\") > 0 Then
               ><5@ = InStr(><5@ + 1, >;=CBL$09;0, "\")
          Else
               Exit Do
          End If
     Loop
     If ><5@ = 0 Then Exit Sub
     0?:0$09;0 = Left(>;=CBL$09;0, ><5@)
     08<$09;0 = Mid(>;=CBL$09;0, ><5@ + 1)
     08<$09;0 = Left(08<$09;0, Len(08<$09;0) - 4)
     >;=CBL$09;0" = 0?:0$09;0 & <O@5<$09;0 & ".htm"
     0?:0;O>8A:0$>B> = 0?:0$09;0 & <O@5<$09;0 & ".files\"

     '-------- !>74048< ?0?:C 4;O D>B>
     0?:0>2$>B> = 0?:0$09;0 & 08<$09;0 & "_D>B>\"
     08<$09;0 = Dir(0?:0>2$>B>, vbDirectory)
     If 08<$09;0 = "" Then
          MkDir 0?:0>2$>B>
     Else
          '--------- G8AB8< ?0?:C
          08<$09;0 = Dir(0?:0>2$>B> & "*")
          Do While 08<$09;0 <> ""
               Kill 0?:0>2$>B> & 08<$09;0
               08<$09;0 = Dir(0?:0>2$>B> & "*")
          Loop
     End If
     

    For ><7> = 1 To >;7>
          08<7> = @8;:A5;.ActiveSheet.Shapes.Item(><7>).Name
          7>B5@E0 = @8;:A5;.ActiveSheet.Shapes(08<7>).Top
          KA>B07> = @8;:A5;.ActiveSheet.Shapes(08<7>).Height
          &5=B@$>B>B5@E0 = 7>B5@E0 + KA>B07> / 2
          
          '---------------- ?@545;8< =><5@ AB@>:8 2 :>B>@>9 =0E>48BAO 87>
          ><5@!B@>:8 = 0
          Do
               ><5@!B@>:8 = ><5@!B@>:8 + 1
               !B@>:0B5@E0 = @8;:A5;.ActiveSheet.Rows(><5@!B@>:8).Top
               !B@>:0!;54B5@E0 = @8;:A5;.ActiveSheet.Rows(><5@!B@>:8 + 1).Top
               If &5=B@$>B>B5@E0 >= !B@>:0B5@E0 And &5=B@$>B>B5@E0 < !B@>:0!;54B5@E0 Then Exit Do
          Loop
          
          '--------------- !:>?8@C5< D>B> 8 2AB028< 2 =>2CN :=83C, 345 B>;L:> >4=> D>B>
          @8;:A5;.ActiveSheet.Shapes(08<7>).Copy
          @8;:A5;.Workbooks.Add
          @8;:A5;.ActiveSheet.Paste
          @8;:A5;.ActiveWorkbook.SaveAs FileName:=>;=CBL$09;0", FileFormat:=44, ReadOnlyRecommended:=False, CreateBackup:=False
          @8;:A5;.ActiveWindow.Close
          
          '-------------- 0945< =081>;LH55 D>B> 2 ?0?:5 0?:0;O>8A:0$>B>
          CBL$>B>!_0:A 07<5@>< = ""
          08<$09;0 = Dir(0?:0;O>8A:0$>B> & "*")
          0:A 07<5@$>B> = 0
          
          Do While 08<$09;0 <> ""
               If Right(08<$09;0, 3) <> "xml" Then
                    CBL7>>@5<0?:5 = 0?:0;O>8A:0$>B> & 08<$09;0
                     07<5@>2$>B> = FileLen(CBL7>>@5<0?:5)
                    If 0:A 07<5@$>B> <  07<5@>2$>B> Then
                         CBL$>B>!_0:A 07<5@>< = CBL7>>@5<0?:5
                         0:A 07<5@$>B> =  07<5@>2$>B>
                    End If
               End If
               08<$09;0 = Dir
          Loop
          
          If CBL$>B>!_0:A 07<5@>< <> "" Then
               '-------------- 5@5=5A5< D>B>
                0AH8@5=85 = Right(CBL$>B>!_0:A 07<5@><, 3)
               ><5@$>B>!B@>:5 = 0
               Do
                    ><5@$>B>!B@>:5 = ><5@$>B>!B@>:5 + 1
                    CBL7>;O!>E@0=5=8O = 0?:0>2$>B> & "!B@>:0" & Trim(Format(><5@!B@>:8, "000")) & "_D>B>" & ><5@$>B>!B@>:5 & "." &  0AH8@5=85
                    If Dir(CBL7>;O!>E@0=5=8O) = "" Then Exit Do
               Loop
               FileCopy CBL$>B>!_0:A 07<5@><, CBL7>;O!>E@0=5=8O
               >;7>72;5G5=> = >;7>72;5G5=> + 1
          End If
          '------------- #40;8< 2@5<5==K9 D09; "
          Kill >;=CBL$09;0"
          '------------- #40;8< 2A5 2@5<5==K5 D09;K 2> 2@5< ?0?:5
          08<$09;0 = Dir(0?:0;O>8A:0$>B> & "*")
          Do While 08<$09;0 <> ""
               Kill 0?:0;O>8A:0$>B> & 08<$09;0
               08<$09;0 = Dir(0?:0;O>8A:0$>B> & "*")
          Loop
          '------------- #40;8< 2@5<5==CN ?0?:C
          RmDir 0?:0;O>8A:0$>B>
    Next
    MsgBox "72;5G5=> D>B> - " & >;7>72;5G5=>
Else
     MsgBox "$>B> 2 D09;5 ""
End If

@8;:A5;.Application.ActiveWorkbook.Close (False)
'-------------> >:>=G0=88 @01>BK 2K7K205BAO <5B>4 Quit 4;O 2KE>40 87 ?@8;>65=8O
@8;:A5;.Quit
Set @8;:A5; = Nothing


End Sub