REM ******************************************************
REM メール送信
REM Basp21 と基本的に同じ使用方法
REM ( Basp21 ほど細かい指定はできない )
REM ******************************************************
Function CDOSendMail( _
svname, _
mailto, _
mailfrom, _
subj, _
body, _
files _
)

'	if not IsObject( Cdo ) then
		Call GetObj( "Cdo", "CDO.Message" )
'	end if

	Dim aAuth,aUser,aFile

	if instr( mailfrom, vbTab ) > 0 then
		aAuth = Split( mailfrom, vbTab )
		aUser = Split( aAuth(1), ":" )
		Cdo.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
		Cdo.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/sendusername") = aUser(0)
		Cdo.Configuration.Fields.Item _ 
		 ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = aUser(1)

		mailfrom = aAuth(0)
	end if

	Cdo.From = mailfrom
	Cdo.To = mailto
	Cdo.Subject	= subj
	Cdo.Textbody = body

	Dim sv

	sv = Split(svname,":")

	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = _
		2

	on error resume next
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = _
		sv(0)
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = _
		sv(1)
	on error goto 0

	Dim I

	if files <> "" then
		if instr( files, vbTab ) > 0 then
			aFile = Split( files, vbTab )
			For I = 0 to Ubound( aFile )
				Cdo.AddAttachment( aFile(I) )
			Next
		else
			Cdo.AddAttachment( files )
		end if
	end if

	Cdo.Configuration.Fields.Update

	on error resume next
	Cdo.Send
	if Err.Number <> 0 then
		CDOSendMail = Err.Description
	else
		CDOSendMail = ""
	end if
	on error goto 0

End Function

REM ******************************************************
REM メール送信2
REM ******************************************************
Function CDOSendMail2( _
svname, _
mailto, _
mailfrom, _
subj, _
body, _
files, _
cc, _
bcc, _
htmlbody _
)

'	if not IsObject( Cdo ) then
		Call GetObj( "Cdo", "CDO.Message" )
'	end if

	Dim aAuth,aUser,aFile

	if instr( mailfrom, vbTab ) > 0 then
		aAuth = Split( mailfrom, vbTab )
		aUser = Split( aAuth(1), ":" )
		Cdo.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
		Cdo.Configuration.Fields.Item _
		 ("http://schemas.microsoft.com/cdo/configuration/sendusername") = aUser(0)
		Cdo.Configuration.Fields.Item _ 
		 ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = aUser(1)

		mailfrom = aAuth(0)
	end if

	Cdo.From = mailfrom
	Cdo.To = mailto
	Cdo.Subject	= subj
	Cdo.Textbody = body

	if cc <> "" then
		Cdo.Cc = cc
	end if
	if bcc <> "" then
		Cdo.Bcc = bcc
	end if
	if htmlbody <> "" then
		Cdo.Htmlbody = htmlbody
	end if

	Dim sv

	sv = Split(svname,":")

	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = _
		2

	on error resume next
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = _
		sv(0)
	Cdo.Configuration.Fields.Item _
	 ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = _
		sv(1)
	on error goto 0

	Dim I

	if files <> "" then
		if instr( files, vbTab ) > 0 then
			aFile = Split( files, vbTab )
			For I = 0 to Ubound( aFile )
				Cdo.AddAttachment( aFile(I) )
			Next
		else
			Cdo.AddAttachment( files )
		end if
	end if

	Cdo.Configuration.Fields.Update

	on error resume next
	Cdo.Send
	if Err.Number <> 0 then
		CDOSendMail = Err.Description
	else
		CDOSendMail = ""
	end if
	on error goto 0

End Function


REM ******************************************************
REM IE の BODY 内に HTML を読み込む
REM baseFunction が必要です
REM ******************************************************
Function LoadIEDocument( strPath )

	Call GetObj( "IEDocument", "InternetExplorer.Application" )
	IEDocument.Navigate( "about:blank" )
	IEDocument.document.getElementsByTagName("BODY")(0).innerHTML = _
		GetTextFile( strPath )

End Function
Function LoadIEUrlDocument( strUrl )

	Call GetObj( "IEDocument", "InternetExplorer.Application" )
	IEDocument.Navigate( strUrl )

End Function

REM ******************************************************
REM ファイル選択
REM baseFunction が必要です
REM ******************************************************
Function OpenFileName( )

	Call GetObj( "IEDocument", "InternetExplorer.Application" )
	IEDocument.Navigate( "about:blank" )
	IEDocument.document.getElementsByTagName("BODY")(0).innerHTML = "<INPUT id=FilePath type=file>"
REM	IEDocument.Visible = True
REM	IEDocument.document.parentWindow.focus
REM	IEDocument.Visible = False
	IEDocument.document.getElementById("FilePath").click
	if IEDocument.document.getElementById("FilePath").value = "" then
		OpenFileName = ""
		IEDocument.Quit
		Set IEDocument = Nothing
		Exit Function
	end if

	OpenFileName = IEDocument.document.getElementById("FilePath").value

	IEDocument.Quit
	Set IEDocument = Nothing

End Function
Function OpenFileName2( )

	if GetOSVersion > 5 then
		Call GetObj("CommonDialog", "UserAccounts.CommonDialog" )

		CommonDialog.Filter = "全て|*.*"
		if CommonDialog.ShowOpen <> 0 then
			OpenFileName2 = CommonDialog.FileName
		else
			OpenFileName2 = ""
		end if
	else
		OpenFileName2 = OpenFileName
	end if

End Function

Function OpenFileName3( )

	Dim strDownloadPlace,str

	strDownloadPlace = "http://homepage2.nifty.com/lightbox/OpenFileName.exe"
	ret = HTTPDownload( strDownloadPlace, TempDir & "\OpenFileName.exe" )
	if not ret then
		GetWshShell
		Call WshShell.Popup("OpenFileName.exe のダウンロードに失敗しました", 5 )
		Exit Function
	end if

	RunSync( Dd(TempDir & "\OpenFileName.exe") )

	str = GetTextFile( TempDir & "\OpenFileName.result" )

	OpenFileName3 = Split(str,vbCrLf)


End Function

REM ******************************************************
REM SHIFT キーの状態
REM baseFunction が必要です
REM ******************************************************
Function isShift( )

	Call GetObj( "IEDocument", "InternetExplorer.Application" )
	IEDocument.Navigate( "about:blank" )
	IEDocument.document.getElementsByTagName("BODY")(0).innerHTML = _
		"<INPUT id=ret><INPUT id=bt type=button " & _
		" onClick='document.getElementById(""ret"").value=window.event.shiftKey'>"
	IEDocument.document.getElementById("bt").click

	if Ucase(IEDocument.document.getElementById("ret").value) = "TRUE" then
		isShift = True
	else
		isShift = False
	end if

	IEDocument.Quit
	Set IEDocument = Nothing

End Function

REM ******************************************************
REM バイナリダウンロード
REM ******************************************************
Function HTTPDownload( strUrl, strPath )

	LoadMsxmlHTTP

	HTTPDownload = True

	on error resume next
	Call objSrvHTTP.Open("GET", strUrl, False )
	if Err.Number <> 0 then
		ErrorMessage = Err.Description
		HTTPDownload = False
		Exit Function
	end if
	on error goto 0

	objSrvHTTP.Send

	GetStream
	Stream.Open
	Stream.Type = 1	' バイナリ
	Stream.Write objSrvHTTP.responseBody
	Stream.SaveToFile strPath, 2
	Stream.Close

End Function

REM ******************************************************
REM MDB 作成
REM ******************************************************
Function CreateMdb( strPath )

	CreateMdb = True

	GetAdox

	on error resume next
	Adox.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
		"Data Source=" & strPath & ";"
	if Err.Number <> 0 then
		CreateMdb = False
		ErrorMessage = Err.Description
	end if
	on error goto 0


End Function

REM ******************************************************
REM 指定パスを選択させて regedit 起動
REM wmiReg が必要
REM ******************************************************
Function Regedit( strTarget )

	if ScriptType <> 1 then
		Exit Function
	end if

	strPath = "Software\Microsoft\Windows\CurrentVersion\Applets\Regedit"
	strRegPaht = "マイ コンピュータ\" & strTarget
	Call WMIRegSetStringValue( _
		HKEY_CURRENT_USER, _
		strPath, "LastKey", strRegPaht )
	
	Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
	Set colProcessList = objWMIService.ExecQuery _ 
		("Select * from Win32_Process Where Name = 'regedit.exe'") 
	For Each objProcess in colProcessList 
		objProcess.Terminate() 
	Next 

	Call RunAsync( "regedit.exe" )

End Function

REM ******************************************************
REM 書庫解凍( lzh と zip )
REM 書庫と同じ場所にディレクトリを作成して解凍する

REM Melt2 は、コマンドラインオプションを全て指定する

REM -d出力ディレクトリ
REM -d-	 アーカイブと同じディレクトリに解凍します。
REM -a	*アーカイブ毎にディレクトリを作ります。
REM -a-	 出力先にそのままファイルを出します。
REM -s	 常駐します。(Win95でも)
REM -s-	 常駐せずに処理がすんだらすぐ終わります。
REM -e	*解凍先フォルダを開きます。
REM -e-	 解凍先フォルダを開きません。
REM -q	 途中経過表示をしません。
REM -f	 解凍先に、より新しいファイルがあっても確認せずに上書きします。
REM -f-	*既存のファイルが解凍中のファイルより新しい場合確認します。

REM ******************************************************
Function Melt( strTarget )

	Melt = True

	GetFso

	if not Fso.FileExists(TempDir & "\Lhasa.exe") then
		strDownloadPlace = "http://homepage2.nifty.com/lightbox/Lhasa.exe"
		
		ret = HTTPDownload( strDownloadPlace, TempDir & "\Lhasa.exe" )
		if not ret then
			Melt = False
			Exit Function
		end if
	end if
	
	strCommand = Dd( TempDir & "\Lhasa.exe" ) & " -d- -a -q -f -e- " & strTarget
	RunSync(strCommand)

End Function

Function Melt2( strParam )

	Melt2 = True

	GetFso

	if not Fso.FileExists(TempDir & "\Lhasa.exe") then
		strDownloadPlace = "http://homepage2.nifty.com/lightbox/Lhasa.exe"
		
		ret = HTTPDownload( strDownloadPlace, TempDir & "\Lhasa.exe" )
		if not ret then
			Melt2 = False
			Exit Function
		end if
	end if
	
	strCommand = Dd( TempDir & "\Lhasa.exe " ) & strParam
	RunSync(strCommand)

End Function

REM ******************************************************
REM 指定ディレクトリ下にある .reg を全て結合して
REM 一つの .reg ファイルにする
REM ******************************************************
Function JoinRegfile( strTarget, strPath )

	Dim objFolder,colFiles,objFile,aData,strData,strOut

	GetFso

	Set objFolder = Fso.GetFolder( strTarget )

	Set colFiles = objFolder.Files

	Dim objHandle,bFlg

	bFlg = False

	on error resume next
	Set objHandle = Fso.CreateTextFile( strPath, True, True )
	if Err.Number <> 0 then
		Exit Function
	end if
	on error goto 0

	For Each objFile In colFiles
		aData = Split( objFile.Name, "." )
		strData = Ucase( aData( Ubound(aData) ) )
		if strData = "REG" then
			strData = GetTextFileUnicode( objFile.Path )
			if bFlg then
				aData = Split( strData, vbCrLf )
				aData( 0 ) = ""
				strData = Join( aData, vbCrLf )
			end if
			objHandle.Write( strData )
			bFlg = True
		end if
	Next

	objHandle.Close

End Function

REM ******************************************************
REM レジストリの ID より、実際のファイルのパスを取得
REM HKEY_CLASSES_ROOT\
REM ******************************************************
Function GetClassRealPath( strId )

	Dim str

	GetWshShell

	on error resume next
	str = WshShell.RegRead("HKCR\" & strId & "\CLSID\" )
	str = WshShell.RegRead("HKCR\CLSID\" & str & "\InProcServer32\" )
	on error goto 0

	GetClassRealPath = str

End Function

REM ******************************************************
REM FtpGet.exe をダウンロードしてから目的ファイルを
REM ダウンロードする
REM strTarget = "Server|Remote|Local|User|Pass"
REM ******************************************************
Function FtpGet( strTarget )

	GetFso

	if not Fso.FileExists(TempDir & "\FtpGet.exe") then
		strDownloadPlace = "http://homepage2.nifty.com/lightbox/FtpGet.exe"
		
		ret = HTTPDownload( strDownloadPlace, TempDir & "\FtpGet.exe" )
		if not ret then
			Melt = False
			Exit Function
		end if
	end if
	
	strCommand = Dd( TempDir & "\FtpGet.exe " ) & strTarget
	RunSync(strCommand)

End Function

REM ******************************************************
REM レジストリの ID より、タイプライブラリの表示名を取得
REM HKEY_CLASSES_ROOT\
REM ******************************************************
Function GetClassDisplayName( strId )

	Dim str,reg,aKeys

	GetWshShell

	on error resume next
	str = WshShell.RegRead("HKCR\" & strId & "\CLSID\" )
	str = WshShell.RegRead("HKCR\CLSID\" & str & "\TypeLib\" )
	on error goto 0

	Set reg = GetObject("Winmgmts:root\default:StdRegProv")
	on error resume next
	Call reg.EnumKey( &h80000000, "TypeLib\" & str, aKeys )
	on error goto 0

	on error resume next
	str = WshShell.RegRead( "HKCR\TypeLib\" & str & "\" & aKeys(0) & "\" )
	on error goto 0

	GetClassDisplayName = str

End Function