'================================================================== 'HTML用、画像のimgタグ作成しますYO! 'http://d.hatena.ne.jp/palm84/20100325/1269525360 'http://www10.plala.or.jp/palm84/wsh.html 'http://www10.plala.or.jp/palm84/archives/wsh/HTML_img_tag.vbs.txt 'https://eu7w9wsmf6a74xyjdfzl3q-on.drv.tw/archives/wsh/HTML_img_tag.vbs.txt '================================================================== 'On Error Resume Next Option Explicit If WScript.Arguments.Count = 0 Then MsgBox "コマンドライン引数が指定されてませんクマー (´・ω・`)",48 ,"クマー? (´;ω;`)" WScript.Quit End If Dim objFSO,objTxt,objShell,objFile Set objFSO = WScript.CreateObject("Scripting.FileSystemObject") ' 環境変数の値を取得 Set objShell = WScript.CreateObject("WScript.Shell") Dim TEMP TEMP = objShell.ExpandEnvironmentStrings("%Temp%") ' ログファイル Const ForReading = 1, ForWriting = 2, ForAppending = 8 Dim LogFile LogFile = TEMP & "\MyHTML_img_tag.txt" Set objTxt = objFSO.OpenTextFile(LogFile, ForWriting, true, -2) Dim strOSVersion 'Sub MyOperatingSystem MyImgTag objTxt.Close objShell.Run """" & LogFile & """" Set objTxt = Nothing Set objFSO = Nothing Set objShell = Nothing '********************************************************* '* Sub MyOperatingSystem '********************************************************* Sub MyOperatingSystem On Error Resume Next Dim strComputer, objWMIService, colItems, objItem strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem",,48) 'Const Reg_ProductName = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductName" For Each objItem in colItems strOSVersion = objItem.Version Next If InStr(strOSVersion, "5.0.") > 0 Then MsgBox "Windows 2000 では使えないクマー (´;ω;`) ",48 ,"I am Sorry, ヒゲソ..(ry" WScript.Quit End If Set objWMIService = Nothing On Error GoTo 0 End Sub '********************************************************* '* Sub MyImgTag -- 画像のimgタグ作成しますYO! '********************************************************* Sub MyImgTag Dim objShellApp ' Shell.Application オブジェクト作成 Set objShellApp = CreateObject("Shell.Application") ' 引数(指定ファイル)を strFilePath へ Dim strFilePath For Each strFilePath In WScript.Arguments If objFSO.FileExists(strFilePath) Then Set objFile = objFSO.GetFile(strFilePath) ' ファイル名を取得 Dim strFileName strFileName = objFSO.GetFileName(strFilePath) ' 親フォルダ名を取得 Dim strFolder strFolder = objFile.ParentFolder ' フォルダ情報取得 Dim objFolder, objFolderItems, objItem Set objFolder = objShellApp.Namespace(strFolder) Set objFolderItems = objFolder.Items Set objItem = objFolderItems.Item(strFileName) ' 番号を指定してデータを取得 Dim pxWidth, pxHeight Dim n, strName For n=18 to 400 strName = objFolder.GetDetailsOf(Nothing, n) If strName = "幅" Then pxWidth = objFolder.GetDetailsOf(objItem, n) End If Next Dim m, strName2 For m=18 to 400 strName2 = objFolder.GetDetailsOf(Nothing, m) If strName2 = "高さ" Then pxHeight = objFolder.GetDetailsOf(objItem, m) End If Next ' 数値以外を置換(消去) pxWidth = Replace(pxWidth, " ピクセル", "") pxHeight = Replace(pxHeight, " ピクセル", "") ' 7 / Vista なら先頭ユニコード文字を除去 If InStr(strOSVersion, "6.") > 0 Or InStr(strOSVersion, "10.") > 0 Then pxWidth = Mid(pxWidth, 2) pxHeight = Mid(pxHeight, 2) End If ' テキストへ書き出し objTxt.Write "" objTxt.Write "" objTxt.Write "

" objTxt.Write vbCrLf Set objItem = Nothing Set objFolderItems = Nothing Set objFolder = Nothing Set objFile = Nothing End If Next Set objShellApp = Nothing End Sub