HD rec3
HD Rec3
前回のHD Rec2で試した方法では、DVD-RAMの場合の問題点を解消出来なかった。使用するOSやドライブにもよるが、動作中に開いたディスクトレーをプログラムで閉じた時、DVD-RAMを空のメディアと認識してしまうため、そこから先へ進めないのだ。
そこで、一部のツールを変更することにした。トレーのオープンを引き起こす原因となっているDVD_disk_Id.exeをやめ、代わりにcprmgetkey.exeを使用する。そのため、必要ファイルは以下の5つになる。
aacs_aes.dll
cprmgetkey.exe※
hddvd_vr_aacskeys.exe
hddvd_vr_decrypt.exe
ProcessingDeviceKeysSimple.txt
（lernel32.dll）※
※cprmgetkey.exeは複数のバージョンがあり、安全に入手することが難しい。新しいバージョンほど対応ドライブが多いので、使用期限付きのVer.0.41とlernel32.dllを入手し、使用期限を解除することをお勧めしておく。具体的な方法についてはこちらを参照して欲しい。改造を施したcprmgetkey.exeを使用するには、lernel32.dllが必要となる・・・らしいのだが、私が使用しているのはVer.0.38なので、未確認だ。
では、例によって、
この下の行から----------
Dim objFS
Dim objText
Dim myText
Dim StrID
Dim objWShell
Dim DVDDrive
Dim ToolPath
Dim StrPath
Dim Fname
Dim objFile
Dim Folder
Dim FSO
Dim objFolder
Dim objDrive
Dim wmp
'フォルダの指定
DVDDrive = "d"'（←DVDドライブを指定。:\は付けないこと）
ToolPath ="C:\HDRec"'（←ツールフォルダを指定。末尾の\は付けないこと。）
'DVDドライブの準備確認（作業開始時）
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objDrive = objFS.GetDrive(DVDDrive&":\")
x = 0
For i = 1 to 2
If objDrive.IsReady Then
Exit For
Else
'ディスクトレーのオープン/クローズ
Set wmp = CreateObject("WMPlayer.OCX")
wmp.cdromcollection.getByDriveSpecifier(DVDDrive).eject()
wmp.cdromcollection.getByDriveSpecifier(DVDDrive).eject()
WScript.Sleep 60000'1分待機
x = x+1
End If
Next
If x = 2 then
MsgBox objDrive.DriveLetter&"ドライブの準備が出来ていません。終了します。"
WScript.Quit(0)
End if
'ファイルコピー
Set objFS = CreateObject("Scripting.FileSystemObject")
objFS.CopyFile DVDDrive&":\DVD_HDVR\HDVR_SOB\*.SRO", ToolPath
'ファイル属性変更
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(ToolPath)
For Each objFile In objFolder.Files
objFile.Attributes = 32
Next
'IDの取得
Set objWShell = CreateObject("WScript.Shell")
Call objWShell.Run ("cmd.exe /c "&ToolPath&"\cprmgetkey.exe "&DVDDrive&": >> "&ToolPath&"\id.txt", vbNormalFocus, True)
Set objWShell = Nothing
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objText = objFS.OpenTextFile(ToolPath&"\id.txt")
For i = 1 To 4
objText.SkipLine
Next
myText = objText.ReadLine
StrID = Right(myText,25)
StrID = Replace(StrID," ","")
objText.Close
WScript.Sleep 1000
'キーの取得
Set objWShell = CreateObject("WScript.Shell")
Call objWShell.Run ("cmd.exe /c "&ToolPath&"\hddvd_vr_aacskeys.exe "&DVDDrive&": v "&StrID, vbNormalFocus, true)
Set objWShell = Nothing
'暗号化解除
Set objWShell = CreateObject("WScript.Shell")
Call objWShell.Run ("cmd.exe /c "&ToolPath&"\hddvd_vr_decrypt", vbNormalFocus, true)
Set objWShell = Nothing
'作業ファイル消去
StrPath = ToolPath&"\id.txt"
Set objFS = CreateObject("Scripting.FileSystemObject")
objFS.DeleteFile StrPath
StrPath = ToolPath&"\key.ini"
Set objFS = CreateObject("Scripting.FileSystemObject")
objFS.DeleteFile StrPath
StrPath = ToolPath&"\HR_*.SRO"
Set objFS = CreateObject("Scripting.FileSystemObject")
objFS.DeleteFile StrPath
StrPath = ToolPath&"\MKB_TBL"
Set objFS = CreateObject("Scripting.FileSystemObject")
objFS.DeleteFile StrPath
'ファイル拡張子変更
Set FSO = CreateObject("Scripting.FileSystemObject")
ShowSubfolders FSO.GetFolder(ToolPath)
Sub ShowSubFolders(Folder)'ShowSubFolders(Folder)
For Each File in Folder.Files
Fname = File.name
If LCase(FSO.GetExtensionName(Fname))="sro" Then
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFile = objFS.GetFile(Fname)
Set objFS = CreateObject("Scripting.FileSystemObject")
objFS = objFS.GetBaseName(Fname)
objFile.Name = objFS&".m2ts"
End If
Next
End Sub
msgbox "完了しました。"
この上の行まで----------
をテキストエディタにコピー、ドライブ名やツールフォルダのパスを変更の上、HDRec3.vbsのようなファイル名で保存。メディアをセットして実行する。
私の所では問題ないが、どうだろうか。情報があれば、お寄せいただけると有り難い。
