toolFunction


  CDOSendMail




  

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
  







  CDOSendMail2




  

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
  

  LoadIEDocument

  

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
  

  OpenFileName,OpenFileName2,OpenFileName3

  

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 = ""
		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
  

  isShift

  

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
  

  HTTPDownload

  

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
  

  CreateMdb

  

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
  

  Regedit

WSH のみ

  

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
  

  Melt、Melt2

  

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

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

End Function

Function Melt2( strParam )

	Melt2 = True

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

End Function
  


  JoinRegfile

  

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

	strOut = ""

	For Each objFile In colFiles
		aData = Split( objFile.Name, "." )
		strData = Ucase( aData( Ubound(aData) ) )
		if strData = "REG" then
			strData = GetTextFileUnicode( objFile.Path )
			if strOut <> "" then
				aData = Split( strData, vbCrLf )
				aData( 0 ) = ""
				strData = Join( aData, vbCrLf )
			end if
			strOut = strOut & strData
		end if
	Next

	Call PutTextFileUnicode( strPath, strOut )

End Function
  

  GetClassRealPath

  

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 & "\LocalServer32\" )
	on error goto 0

	GetClassRealPath = str

End Function
  

  FtpGet

  

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
  




yahoo  google  MSDN  MSDN(us)  WinFAQ  Win Howto  tohoho  ie_DHTML  vector  wdic  辞書  天気 


[webwsh]
CCBot/2.0 (https://commoncrawl.org/faq/)
19/07/24 11:59:27
InfoBoard Version 1.00 : Language=Perl

BatchHelper COMprog CommonSpec Cprog CprogBase CprogSAMPLE CprogSTD CprogSTD2 CprogWinsock Cygwin GameScript HTML HTMLcss InstallShield InstallShieldFunc JScript JScriptSAMPLE Jsfuncs LLINK OldProg OracleGold OracleSilver PRO PRObrowser PROc PROconePOINT PROcontrol PROftpclient PROjscript PROmailer PROperl PROperlCHAT PROphp PROphpLesson PROphpLesson2 PROphpLesson3 PROphpfunction PROphpfunctionArray PROphpfunctionMisc PROphpfunctionString PROsql PROvb PROvbFunction PROvbString PROvbdbmtn PROvbonepoint PROwebapp PROwin1POINT PROwinSYSTEM PROwinYOROZU PROwindows ProjectBoard RealPHP ScriptAPP ScriptMaster VBRealtime Vsfuncs a1root access accreq adsi ajax amazon argus asp aspSample aspVarious aspdotnet aw2kinst cappvariety centura ckeyword classStyle cmaterial cmbin cmdbapp cmenum cmlang cmlistbox cmstd cmstdseed cmtxt cs daz3d db dbCommon dbaccess dnettool dos download flex2 flex3 flex4 framemtn framereq freeWorld freesoft gimp ginpro giodownload google hdml home hta htmlDom ie9svg install java javaSwing javascript jetsql jquery jsp jspTest jspVarious lightbox listasp listmsapi listmsie listmsiis listmsnt listmspatch listmsscript listmsvb listmsvc memo ms msde mysql netbeans oraPlsql oracle oracleWiper oraclehelper orafunc other panoramio pear perl personal pgdojo pgdojo_cal pgdojo_holiday pgdojo_idx pgdojo_ref pgdojo_req php phpVarious phpguide plsql postgres ps r205 realC realwebapp regex rgaki ruby rule sboard sc scprint scquest sdb sdbquest seesaa setup sh_Imagick sh_canvas sh_dotnet sh_google sh_tool sh_web shadowbox shgm shjquery shvbs shweb sjscript skadai skywalker smalltech sperl sqlq src systemdoc tcpip tegaki three toolbox twitter typeface usb useXML vb vbdb vbsfunc vbsguide vbsrc vpc wcsignup webanymind webappgen webclass webparts webtool webwsh win8 winofsql wmi work wp youtube