'シートに読み込み(言語コードを指定して(エディタクライアント定義専用))
Sub in_ex_euc_bak(xmlName As String, tabName As String, flg As Integer, pas As String)
' UNIX上で作成されたテキストファイルとして
' 文字コード:EUC-JP 改行コード:LF(\n) として読み込む例
Const adTypeText = 2 ' adTypeBinary = 1
Const adReadLine = -2 ' adReadAll = -1
Const adLF = 10 ' adCR = 13, adCRLF = -1
Dim str As String
If Left(xmlName, 7) = "Client_" Then
'クライアント定義ファイル場合
Con = LenB(xmlName) / 2
sxmlName = Mid(xmlName, 8, Con)
Else
'サーバ定義ファイル場合
sxmlName = Replace(xmlName, "_", "\")
End If
If flg <> 0 Then
With CreateObject("ADODB.Stream")
.Open
' テキストタイプ
.Type = adTypeText
' EUCコード
.Charset = "EUC-JP"
' 改行コードは LF
.LineSeparator = adLF
' 読み込むファイルを指定
.LoadFromFile Sheets("共通定義").Range("B17") & "\" & pas & "\" & sxmlName & ".xml"
' 読み込む位置は先頭から
.Position = 0
x = 1
' テキストの終わりまで1行ずつ読み込む
Do Until .EOS
'MsgBox .ReadText(adReadLine)
str = .ReadText(adReadLine)
Sheets(xmlName).Cells(x, 20) = str
x = x + 1
Loop
.Close
End With
End If
End Sub
'定義ファイルに書き込み(言語コードを指定して(エディタクライアント定義専用))
Sub out_ex_euc(xmlName As String, tabName As String, pas As String)
Dim myADOstr
'xmlNameシートの貼り付けたデータの総行数
r = Sheets(xmlName).Range("A65536").End(xlUp).Row
'ファイル書込み合否をチェック
'①書き込みデータが無い場合
If r = 1 Then
Sheets(tabName).Activate
'エラーのダイアログ
MsgBox "書き込み失敗しました。書き込み用データがないです。"
Exit Sub
End If
'②キー値が無い場合
t = WorksheetFunction.CountA(Sheets(tabName).Range("C18:C" & r))
If t = 0 Then
Sheets(tabName).Activate
'エラーのダイアログ
MsgBox "書き込み失敗しました。書き込みデータにキーの値がないです。"
Exit Sub
End If
'③xmlフォーマットチェック
For i = 1 To r
Set obj1 = Sheets(xmlName).Cells(i, 1).Find("<entry key=")
If Not obj1 Is Nothing Then
Set obj2 = Sheets(xmlName).Cells(i, 1).Find(Chr(34) & ">")
If obj2 Is Nothing Then
Sheets(tabName).Activate
'エラーのダイアログ
MsgBox "書き込み失敗しました。書き込み用データのフォーマットが間違っています。"
Exit Sub
End If
Set obj3 = Sheets(xmlName).Cells(i, 1).Find("</entry>")
If obj3 Is Nothing Then
Sheets(tabName).Activate
'エラーのダイアログ
MsgBox "書き込み失敗しました。書き込み用データのフォーマットが間違っています。"
Exit Sub
End If
Else
'何もしない
End If
Next i
'サーバ系、クライアント系判断
If Left(xmlName, 7) = "Client_" Then
'クライアント定義ファイル場合
Con = LenB(xmlName) / 2
sxmlName = Mid(xmlName, 8, Con)
Else
'サーバ定義ファイル場合
sxmlName = Replace(xmlName, "_", "\")
End If
'定義ファイルに書き込み処理
Set myADOstr = CreateObject("ADODB.Stream")
myADOstr.Charset = "EUC-JP" '←重要!ここで文字コード指定。
myADOstr.Open
Dim xlRow As Long
For xlRow = 1 To r
myADOstr.WriteText (Sheets(xmlName).Cells(xlRow, 1).Text) & vbLf
Next xlRow '↓ファイル名は適切に指定。後ろの「2」は上書きモード
myADOstr.SaveToFile Sheets("共通定義").Range("B17").Text & "\" & pas & "\" & sxmlName & ".xml", 2
myADOstr.Close
Set myADOstr = Nothing
End Sub