フォルダを作ってそこに移動

Option Explicit

Dim FSYS 'FileSystem
Dim SHAP 'ShellApplication
Dim CurFolder '移動元のディレクトリ
Dim TargetFolderName '移動先のディレクトリ名
Dim TargetFolder '移動先のディレクトリ
Dim file '
Dim MoveFileName '移動対象のファイル
Const FOF_CREATEPROGRESSDLG = &H0&

Set FSYS = WScript.CreateObject("Scripting.FileSystemObject")
Set CurFolder = FSYS.GetFolder(".")
Set SHAP = WScript.CreateObject("Shell.Application")
’ファイル名からフォルダを作ってそこに移動(jpgのみ)
For Each file In CurFolder.Files
TargetFolderName = FolderName(file.Name)
If TargetFolderName <> vbNull Then
If FSYS.FolderExists(TargetFolderName) = False Then
FSYS.CreateFolder(TargetFolderName)
End If
Set TargetFolder = SHAP.Namespace(CurFolder.Path & "\" & TargetFolderName)
'ワイルドカードを使ってまとめてMove
MoveFileName = CurFolder.Path & "\" & TargetFolderName & "*.jpg"
TargetFolder.MoveHere MoveFileName, FOF_CREATEPROGRESSDLG
End If

Next
Set TargetFolder = Nothing
Set CurFolder = Nothing
Set SHAP = Nothing
Set FSYS = Nothing

Function FolderName(FileName)
Dim objRegExp ' 正規表現オブジェクト
Dim Matches ' 検索結果Collection

Set ObjRegExp = New RegExp
ObjRegExp.Pattern = "_.*\d{3}\.jpg" 'jpg のみ対象　xxxx_999.jpg のパターン
ObjRegExp.IgnoreCase = True
ObjRegExp.Global = False
Set Matches = objRegExp.Execute(FileName)

If Matches.Count > 0 Then
FolderName = objRegExp.Replace(FileName,"")
Else
FolderName = vbNull
End If

Set ObjRegExp = Nothing
Set Matches = Nothing

End Function

フォルダの中身をZIP

Option Explicit

Dim FLSYS 'FileSystem
Dim SHLAP 'ShellApplication
Dim WSSHL 'WScriptShell
Dim CurFolder
Dim SubFolder
Dim AddFolder
Const ZipFilePath = "c:\zipped\"
Dim ZipFileName
Dim ZipFile

Dim AddCount
Dim ZipCount

Dim LogFile
Dim LogFileName

Set FLSYS = WScript.CreateObject("Scripting.FileSystemObject")
Set CurFolder = FLSYS.GetFolder(".")

LogFileName = CurFolder.Path
LogFileName = LogFileName & "\"
LogFileName = LogFileName & Mid(Date,1,4) & Mid(Date,6,2) & Mid(Date,9,2)
LogFileName = LogFileName & ".log"
Set LogFile = FLSYS.OpenTextFile(LogFileName,8,True)
LogFile.WriteLine Date & " " & Time & " ##### STRAT CopyToZIP ######"

Set SHLAP = WScript.CreateObject("Shell.Application")
Set WSSHL = WScript.CreateObject("WScript.Shell")

'カレントフォルダ下のサブフォルダ毎にZIPファイルを作ります
For Each SubFolder in CurFolder.SubFolders
LogFile.WriteLine Date & " " & Time & " " & FLSYS.GetFileName(SubFolder.Path)
'カレントディレクトリに同名のZIPファイルが存在していたら削除
ZipFileName = ZipFilePath & FLSYS.GetFileName(SubFolder.Path) & ".zip"
If FLSYS.FileExists(ZipFileName) Then
FLSYS.DeleteFile ZipFileName
End If
FLSYS.CreateTextFile(ZipFileName).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
Set ZipFile = SHLAP.NameSpace(ZipFileName)
ZipCount = ZipFile.Items.Count

'1.　フォルダごと圧縮する場合
' ZipFile.CopyHere(SubFolder.Path)

'2.　フォルダの中身だけ圧縮する場合
'追加するフォルダのオブジェクトを作成
Set AddFolder = SHLAP.NameSpace(SubFolder.Path)
AddCount = AddFolder.Items.Count
LogFile.WriteLine Date & " " & Time & " Copy Start " & ZipCount & "/" & AddCount

ZipFile.CopyHere AddFolder.Items , FOF_NOCONFIRMATION + FOF_SIMPLEPROGRESS
' ZipFile.MoveHere AddFolder.Items , FOF_NOCONFIRMATION + FOF_SIMPLEPROGRESS ' Moveでもファイル残る？

'CopyHere が非同期なので終了を判定
'ファイル数が一致するまで
Do
ZipCount = ZipFile.Items.Count
If ZipCount = AddCount Then Exit Do
WScript.Sleep(3000) '3秒待つ
LogFile.WriteLine Date & " " & Time & " Copy ..... " & ZipCount & "/" & AddCount
Loop
LogFile.WriteLine Date & " " & Time & " Copy End " & ZipCount & "/" & AddCount

Set AddFolder = Nothing
Set ZipFile = Nothing
Next

LogFile.WriteLine Date & " " & Time & " ##### END CopyToZIP ######"
MsgBox "おわり"

Set CurFolder = Nothing
Set SHLAP = Nothing
Set FLSYS = Nothing


ZIPファイルのアイテム数をZipCountに取り出して３秒ごとにログに吐き出してみましたが
ほとんどの場合、０でした。
圧縮中はZipファイルがロックされているようなので、そのせいかな。
Zipファイルの作成される側のフォルダを見ていると、テンポラリファイルが作成されていて、これが時々消えます。

テンポラリファイルが消えたタイミングでアイテム数を取り出すと、
その時点でコピーしたファイルの数が取り出せるようです。
ついでにこのタイミングで一時ロックを解除しているようで、
圧縮処理の終了判定をロックの有無でやるとしくじりがちです。

時々処理が止まってしまいます。エラーメッセージを出してくれる事もあるけど
何にも言わずに待ってるだけの場合、
手でファイルをコピーしてあげると処理を続行できました。

copyhere フォルダ.items でやると隠しファイルは無視されるのかな？
それは具合がいいのでそのまま。
movehere でやっても元のファイルはそのまま残りました。
移動先が圧縮ファイルだから？未検証。
まあ、自動的に消えてしまうのも怖いのでcopyhereで。

zipファイルのサイズが大きくなると１ファイル当たりの処理時間が長くなります。ファイルが育っていくにつれて、だんだん遅くなる感じで、ちょっと考えもの。
そもそもJPEGをさらにZip圧縮してもそんなにメリット無いしにゃーという感じです。

お気に入り

(´･ω･`)･ω･`)　ｷｬｰ
/　　つ⊂　　＼ 

 

ExcelにCSVを。SQLで、Recordsetとして

SQLが使えるなら射影も選択も楽ちんじゃないか。

Sub test()
    Dim CON As ADODB.Connection
    Dim RS As ADODB.Recordset

    Dim SQLTEXT = "SELECT 商品名 FROM testdata.csv where 種類='CD' order by 金額"
 
    Set CON = New ADODB.Connection
    CON.Provider = "Microsoft.Jet.OLEDB.4.0"
    CON.Properties("Extended Properties") = "Text;HDR=YES"
    CON.ConnectionString = "G:\test"   ’フォルダを指定
    CON.Open
 
    Set RS = CON.Execute(SQLTEXT)
    RS.Filter = "商品名 = '旅の途中 [Maxi]'"          'フィルタも。
    Sheet1.Range("B2").CopyFromRecordset RS   'ワークシートに流し込み

    Set RS = Nothing
    Set CN = Nothing
End Sub

3DS,アニメーションGif 参考になりません

3DSで撮影した３D写真をアニメーションGIFにしてみました。
雑すぎる。

Sマリオ

スーパーマリオブラザーズはそんなに好きでは無いのだけれど、
これはとても好きです。

ネットのどこかで拾いもの。

I Care Because You Do

今の会社でパートをはじめて半年と少し。 架電業務はやっぱりストレス高いのか、定着しない人も多い。 それでも何人かは残っていく。 職場で人間関係を築けない人は続かない。 休憩時間に寂しそうにしているけれど、こちらも自分のことで手一杯なんだもの。 昼休みに人を避けて、一人で車の中で飯食ってる人に、何をしてあげられるだろうか。 社会という自然環境の中での生存能力。

哭きの竜

ひとつ晒せば自分を晒す、ふたつ晒せばすべてを晒す、みっつ晒せば地獄が見える。
見える見える、落ちるさま

Facebookは人の繋がりや絆を保証しない。

昔の友人知人との繋がりが途切れてしまうと、それを再接続するのはけっこう
怖いもんだったと思う。
その敷居を低くすることを考えのかどうか、そういう風にも機能している。
これは利用者が実名と正しい履歴を晒すことを前提にしているんだ。
wiredとrealworldとの密接な結合、融合と言い換えても良いかもしれない。
地理的距離と時間の隔たりを超えて、wiredがrealworldと呼ばれていた地域を包含する。
domainとしてのrealworld。

1-2-3

もう20年以上も前のこと。
その頃はパソコン（NECのPC-98xx）でやることと言えば、Lotus1-2-3。
あとゲームもだけど。
1-2-3の関数リファレンス本（たぶんナツメ社のやつ）を買ってきて、
全部の関数を一通り試してみたのが、 今の私を支える基盤の一部になっているように思えます。
そこに差分で知識を積み重ねていったのだと。

さて、Excel2007あたりで大幅に関数増えてるみたいで、これがまた便利。
もー、べんりー。って感じ。
でもIFERROR関数があるなら IFBLANK関数があってもいいのに、と思いました。

こういう、コレがありなら、コレもいけるんじゃ無い？とか
こうなって、こうなるんなら、こうしたらこうなるんじゃないか？っていう予測は
大体当たるようにデザインされてるもんだ。