<% function MidImagePath(strImgPath) Dim strImg Dim strImgMid Dim strFile Dim strFolder Dim lenImg1 Dim lenImg2 Dim ret Dim objBasp Dim iMuse On Error Resume Next Set iMuse = Server.CreateObject("iMuse.Functions") strImg = strImgPath lenImg1 = Len(Session("DBPictFolderPath")) lenImg2 = Len(strImg) strImg = Mid(strImg,lenImg1+1,lenImg2-lenImg1) strImg = Session("PictFolderPath") & strImg 'Mid画像のパスを取得 strImg = iMuse.GetMidImagePath(CStr(strImg)) '画像ファイルが存在するかチェックする Set objBasp = Server.CreateObject("BASP21") If objBasp.FileCheck(strImg) > 0 Then '相対パスに変換 lenImg1 = Len(Session("ASA_PATH")) lenImg2 = Len(strImg) strImg = Mid(strImg, lenImg1+2, lenImg2 - lenImg1-1) strImg = iMuse.ReplaceString(CStr(strImg),"\","/") Else strImg = "img/no_pic.gif" MidImagePath = strImg Exit Function End If If Err <> 0 Then Err.Clear MidImagePath = "img/no_pic.gif" Else If strImg <> "" Then MidImagePath = "../" & strImg Else MidImagePath = "" End If End If end function function LargeImagePath(strImgPath) Dim strImg Dim strImgMid Dim strFile Dim strFolder Dim lenImg1 Dim lenImg2 Dim ret Dim objBasp Dim iMuse On Error Resume Next Set iMuse = Server.CreateObject("iMuse.Functions") strImg = strImgPath lenImg1 = Len(Session("DBPictFolderPath")) lenImg2 = Len(strImg) strImg = Mid(strImg,lenImg1+1,lenImg2-lenImg1) strImg = Session("PictFolderPath") & strImg '画像ファイルが存在するかチェックする Set objBasp = Server.CreateObject("BASP21") If objBasp.FileCheck(strImg) > 0 Then '相対パスに変換 lenImg1 = Len(Session("ASA_PATH")) lenImg2 = Len(strImg) strImg = Mid(strImg, lenImg1+2, lenImg2 - lenImg1-1) strImg = iMuse.ReplaceString(CStr(strImg),"\","/") Else strImg = "img/no_pic.gif" LargeImagePath = strImg Exit Function End If If Err <> 0 Then Err.Clear LargeImagePath = "img/no_pic.gif" Else If strImg <> "" Then LargeImagePath = "../" & strImg Else LargeImagePath = "" End If End If end function function DocPath(strImgPath) Dim strImg Dim strImgMid Dim strFile Dim strFolder Dim lenImg1 Dim lenImg2 Dim ret Dim objBasp Dim iMuse On Error Resume Next Set iMuse = Server.CreateObject("iMuse.Functions") strImg = strImgPath lenImg1 = Len(Session("DBDocFolderPath")) lenImg2 = Len(strImg) strImg = Mid(strImg,lenImg1+1,lenImg2-lenImg1) strImg = Session("DocFolderPath") & strImg 'ファイルが存在するかチェックする Set objBasp = Server.CreateObject("BASP21") If objBasp.FileCheck(strImg) > 0 Then '相対パスに変換 lenImg1 = Len(Session("ASA_PATH")) lenImg2 = Len(strImg) strImg = Mid(strImg, lenImg1+2, lenImg2 - lenImg1-1) strImg = iMuse.ReplaceString(CStr(strImg),"\","/") Else strImg = "" End If If Err <> 0 Then Err.Clear DocPath = "" Else If strImg <> "" Then DocPath = "../" & strImg Else DocPath = "#" End If End If end function function ImageTitle(strTitle) Dim lenTitle Dim strTmp '15文字目に改行を入れて返す lenTitle = Len(strTitle) If lenTitle > 15 AND lenTitle < 30 Then strTmp = Mid(strTitle,1,15) strTmp = strTmp & "
" strTmp = strTmp & Mid(strTitle,16,lenTitle-15) ElseIf lenTitle > 29 Then strTmp = Mid(strTitle,1,15) strTmp = strTmp & "
" strTmp = strTmp & Mid(strTitle,16,13) & "..." Else strTmp = strTitle End If ImageTitle = strTmp end function function NullRepWSP(strVal) Dim strTmp Dim iMuse 'iMuse Set iMuse = Server.CreateObject("iMuse.Functions") If IsNull(strVal) = True OR strVal = "" Then strTmp = "
" Else If InStr(strVal,vbCrLf) > 0 Then strTmp = iMuse.ReplaceString(CStr(strVal),vbCrLf,"
") Else strTmp = strVal End If End If NullRepWSP = strTmp end function function InsCrLf(strVal,lngTarget) Dim ilen Dim i Dim strTmp Dim t If InStr(strVal," ") > 0 Then InsCrLf = strVal Exit function End If ilen = len(strVal) strTmp = "" t = 0 For i=1 To ilen t = t + 1 If t=lngTarget Then t=0 strTmp = strTmp & Mid(strVal,i,1) & "
" Else strTmp = strTmp & Mid(strVal,i,1) End If Next InsCrLf = strTmp end function function RegKeywordA(strVal) Dim cn Dim rs Dim id Dim strSQL Set cn = Server.CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & Session("MDB_KEYWORD") & ";" Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open "SELECT * FROM KEYWORD_A", cn, 1, 1 If rs.RecordCount > 99999 Then cn.Execute "DELETE FROM KEYWORD_A;" id = 1 strSQL = "INSERT INTO KEYWORD_A (ID,REQUEST_TIME,CONTENTS) VALUES (" strSQL = strSQL & id & "," strSQL = strSQL & "'" & Now() & "'," strSQL = strSQL & "'" & strVal & "')" cn.Execute strSQL Else id = rs.RecordCount + 1 strSQL = "INSERT INTO KEYWORD_A (ID,REQUEST_TIME,CONTENTS) VALUES (" strSQL = strSQL & id & "," strSQL = strSQL & "'" & Now() & "'," strSQL = strSQL & "'" & strVal & "')" cn.Execute strSQL End If cn.close end function function RegKeywordB(strVal) Dim cn Dim rs Dim id Dim strSQL Set cn = Server.CreateObject("ADODB.Connection") cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & Session("MDB_KEYWORD") & ";" Set rs = Server.CreateObject("ADODB.RecordSet") rs.Open "SELECT * FROM KEYWORD_B", cn, 1, 1 If rs.RecordCount > 99999 Then cn.Execute "DELETE FROM KEYWORD_B;" id = 1 strSQL = "INSERT INTO KEYWORD_B (ID,REQUEST_TIME,CONTENTS) VALUES (" strSQL = strSQL & id & "," strSQL = strSQL & "'" & Now() & "'," strSQL = strSQL & "'" & strVal & "')" cn.Execute strSQL Else id = rs.RecordCount + 1 strSQL = "INSERT INTO KEYWORD_B (ID,REQUEST_TIME,CONTENTS) VALUES (" strSQL = strSQL & id & "," strSQL = strSQL & "'" & Now() & "'," strSQL = strSQL & "'" & strVal & "')" cn.Execute strSQL End If cn.close end function Function quoteChg(encChange) '表示する文字列中の問題のある文字を変換する関数 encChange = Replace(encChange, " ", " ") encChange = Replace(encChange, """", """) encChange = Replace(encChange, "'", "''") encChange = Replace(encChange, "'", "''") encChange = Replace(encChange, "&","&") encChange = Replace(encChange, "<","<") encChange = Replace(encChange, ">",">") quoteChg = encChange End Function %>