クリックしろ???
どうやって??
No.97 InternetExplorer.application操作 .Clickでクリック
http://www.ken3.org/vba/backno/vba097.html
データをフォームに
objIE.document.all.userid.Value = "Ken3" 'ユーザー名
objIE.document.all.pass.Value = "aaa" 'パスワード
でセットして、その後、
objIE.document.all.btn01.Click 'クリックメソッドを実行
単純にクリックメソッドを実行して、自動ログイン処理を作成しました。
とか、言ってるジャン。
だからそれは、フォームのボタンだからクリックできるんでしょ。
あっそ。リンクのアンカーは(Aタグは)クリックできないんだ。
リンク先へ飛ぶ時はいつもクリックしてるけどね。
あまりイジメナイデ下さいよ。ってことは、
あっでも、
<td><a HRef="JavaScript:gonumber();">検索</a></td>
とかで名前が付いていません。残念です。
なんですぐにあきらめるかなぁ。
名前が付いてなきゃ私を(IEを)操作できないのかよオマエは(プログラマーは)。
No.148 IE ラジオボタン(RADIO)の.Checkedと.Clickの違い
http://www.ken3.org/vba/backno/vba148.html
INPUT Type=RADIO(ラジオボタン)のオブジェクトに対して、
.Checkedだとイベントが起動しないが、
.ClickだとonClickのイベントが起動する、
そんな違いの話を少し書いてます。
この中で、
'区分を探してセットする
For Each objITEM In objIE.document.all '.allからオブジェクトを探す
'名前がsentakuで値がa?のラジオボタンを探す
If objITEM.TAGName = "INPUT" Then 'まず、タグでINPUTか判断
Debug.Print objITEM.Name 'TESTで値を表示
Debug.Print objITEM.Value 'TESTで値を表示
'↓の条件でクリックするオブジェクトを探す
If objITEM.Name = "sentaku" And objITEM.Value = strRADIO(nNO) Then
objITEM.Click '素直にクリックしてみた(笑)
Exit For '目的の処理が終わったので、ループを抜ける
End If
End If
Next
と、タグの名前と値を探して.Clickしてました。
だとすると、フレームのドキュメントからリンク情報を取り出し、
探したオブジェクトに対してクリック(.Click)すれば、起動するのかな???
リンク先を探すのは、
No.71 IE操作 リンク先を取出す .Document.links(i).href
http://www.ken3.org/vba/backno/vba071.html
で、
objIE.Document.links.Length
でリンクの数を取得できるので、
'リンク数分まわす
For i = 0 To objIE.Document.links.Length - 1
Cells(nYLINE, "A") = "'" & objIE.Document.links(i).outerText
Cells(nYLINE, "B") = "'" & objIE.Document.links(i).href
Cells(nYLINE, "C") = "'" & objIE.Document.links(i).outerHTML
nYLINE = nYLINE + 1 'セット位置を+1する
Next i
と
objIE.Document.links(i).outerText
objIE.Document.links(i).href
objIE.Document.links(i).outerHTML
をそれぞれセットしてみました。
これを使って、links(i).Clickしてみますか。
Sub ie_test_002()
Dim objIE As Object '型は何でも来い、得意のObject型
'インターネットエクスプローラーのオブジェクトを作る
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True '見えるようにする(お約束)
'フレームページを表示する
objIE.Navigate "http://www.ken3.org/vba/test170main.html"
'表示終了まで待つ
Do While objIE.Busy = True
'何もしないループ(笑)
DoEvents
Loop
'↑ステータスを見ないとフレームの場合は良くないよ、、、
'TOPのオブジェクトから項目まで.で行く(笑)
objIE.Document.frames("F_RIGHT").Document.all("Job").Value = "4649"
objIE.Document.frames("F_RIGHT").Document.all("Tan").Value = "114"
'フレームのドキュメントを変数に保存して、
'リンクのアンカーオブジェクトをクリックする
Dim n As Integer
Dim objFDOC As Object 'フレームのドキュメントを保存する
Set objFDOC = objIE.Document.frames("F_RIGHT").Document '代入
'リンク情報からオブジェクトを探し.Clickする
For n = 0 To objFDOC.links.Length - 1 'リンク数分まわす
Debug.Print objFDOC.links(n).href 'デバックで表示する
'リンク先(.href)をチェックする(文字列比較する)
If objFDOC.links(n).href = "javascript:gonumber();" Then
objFDOC.links(n).Click '.Clickでクリックしてみた
Exit For '見つかったので強制的にループを抜ける
End If
Next n
End Sub
処理のポイントは
Dim objFDOC As Object 'フレームのドキュメントを保存する
と1つ変数きって、
Set objFDOC = objIE.Document.frames("F_RIGHT").Document '代入
で、フレームのオブジェクトを代入しておいて、
ループでリンク情報.linksを探ります。
'リンク情報からオブジェクトを探し.Clickする
For n = 0 To objFDOC.links.Length - 1 'リンク数分まわす
Debug.Print objFDOC.links(n).href 'デバックで表示する
'リンク先(.href)をチェックする(文字列比較する)
If objFDOC.links(n).href = "javascript:gonumber();" Then
objFDOC.links(n).Click '.Clickでクリックしてみた
Exit For '見つかったので強制的にループを抜ける
End If
Next n
↑今回比較するのは飛び先の文字列でjavascript:gonumber();を探してます。
最大のポイントは.hrefの比較は、ソースそのままじゃなくって中身が
javascript:gonumber();
javascript:tanto();
になっていることに注意・・Debug.Print objFDOC.links(n).hrefで気が付いたよ
<td><a HRef="JavaScript:gonumber();">検索</a></td>
だから、そのままJavaScriptの大文字のまま、
If objFDOC.links(n).href = "JavaScript:gonumber();" Then
としたいけど、
If objFDOC.links(n).href = "javascript:gonumber();" Then
が正解
Sub aaa()
'Outlookを開き、フォルダー名をメッセージボックスでテスト表示
Dim objOL As Object 'OutLookのアプリケーションオブジェクト
Dim objNAMESPC As Object '名前空間
Dim n As Integer 'カウンター
'アプリケーションのオブジェクトを新規作成
Set objOL = CreateObject("Outlook.Application")
'Namespace オブジェクト作成
Set objNAMESPC = objOL.GetNamespace("MAPI")
'フォルダーの数を表示する
MsgBox "親のフォルダー数は" & objNAMESPC.Folders.Count
'フォルダーの下、第二階層でループさせる
For n = 1 To objNAMESPC.Folders(1).Folders.Count
'1番目のさらに下、n番目のフォルダー名を表示する
MsgBox objNAMESPC.Folders(1).Folders(n).Name
Debug.Print objNAMESPC.Folders(1).Folders(n).Name
Next n
'後始末
objOL.Quit
End Sub
Sub bbb()
'受信トレイを探し、メールの件名などを表示してみる
'Outlookを開き、フォルダー名をメッセージボックスでテスト表示
Dim objOL As Object 'OutLookのアプリケーションオブジェクト
Dim objNAMESPC As Object '名前空間
Dim objFLD As Object 'フォルダー保存用
Dim objMAIL As Object 'メールアイテム
Dim y As Integer 'カウンター
'アプリケーションのオブジェクトを新規作成
Set objOL = CreateObject("Outlook.Application")
'Namespace オブジェクト作成
Set objNAMESPC = objOL.GetNamespace("MAPI")
'フォルダーの下、第二階層.Foldersでループさせる
For Each objFLD In objNAMESPC.Folders(1).Folders
'フォルダー名が受信トレイか?
If objFLD.Name = "受信トレイ" Then
'テストでメールを新規ブックに書き出す
Workbooks.Add '新規ブックを作成する
y = 1 '1行目から書き込む
'フォルダーのアイテム数分ループ Folders.Items
For Each objMAIL In objFLD.Items
'セルに代入
Cells(y, "A") = objMAIL.CreationTime '作成日
Cells(y, "B") = objMAIL.Subject
Cells(y, "C") = objMAIL.Body
'セット位置を移動
y = y + 1
Next objMAIL
End If
Next objFLD
'後始末
objOL.Quit
End Sub
ポイントは、
For Each objFLD In objNAMESPC.Folders(1).Folders
Next
このループで、フォルダー(トレイ)をobjFLDに1つ1つ取り出しながらループさせます
次に、取り出したオブジェクトobjFLDの名前が受信トレイかチェックします。
If objFLD.Name = "受信トレイ" Then
と、.Nameプロパティを比較します。
フォルダー(トレイ)のItem数分(メールアイテム)を取り出すループを
'フォルダーのアイテム数分ループ Folders.Items
For Each objMAIL In objFLD.Items
Next
と作成しました。このループでobjFLDのアイテム単位に処理してます。
あとは、テストなので、アイテムの内容を
'セルに代入
Cells(y, "A") = objMAIL.CreationTime '作成日
Cells(y, "B") = objMAIL.Subject
Cells(y, "C") = objMAIL.Body
セルに代入しました。
テストプログラムでなんとなくイメージはつかめましたか?
受信トレイを.Nameを手がかりにフォルダーのループから探し、
その下のメールアイテム .Itemsから1件1件処理してます。
Private Sub UserForm_Initialize()
'フォームの初期化イベントでリストボックスにメールデータをセットする
Dim objOL As Object 'OutLookのアプリケーションオブジェクト
Dim objNAMESPC As Object '名前空間
Dim objFLD As Object 'フォルダー保存用
Dim objMAIL As Object 'メールアイテム
Dim strWORK As String
Me.lstMAIL.Clear '.Clearでリストボックスの内容を全てクリア
'アプリケーションのオブジェクトを新規作成
Set objOL = CreateObject("Outlook.Application")
'Namespace オブジェクト作成
Set objNAMESPC = objOL.GetNamespace("MAPI")
'フォルダーの下、第二階層.Foldersでループさせる
For Each objFLD In objNAMESPC.Folders(1).Folders
'フォルダー名が受信トレイか?
If objFLD.Name = "受信トレイ" Then
'フォルダーのアイテム数分ループ Folders.Items
For Each objMAIL In objFLD.Items
'作成日:題名で文字列を作成する
strWORK = objMAIL.CreationTime & ":" & objMAIL.Subject
'データをセット
Me.lstMAIL.AddItem (strWORK)
Next objMAIL
End If
Next objFLD
'後始末
objOL.Quit
End Sub
Private Sub btnSET_Click()
'ボタンが押されたらリストボックスで選択されている
'メールアイテムのフラグに実施済みの文字をセットする
Dim objOL As Object 'OutLookのアプリケーションオブジェクト
Dim objNAMESPC As Object '名前空間
Dim objFLD As Object 'フォルダー保存用
Dim objMAIL As Object 'メールアイテム
Dim strWORK As String
'アプリケーションのオブジェクトを新規作成
Set objOL = CreateObject("Outlook.Application")
'Namespace オブジェクト作成
Set objNAMESPC = objOL.GetNamespace("MAPI")
'フォルダーの下、第二階層.Foldersでループさせる
For Each objFLD In objNAMESPC.Folders(1).Folders
'フォルダー名が受信トレイか?
If objFLD.Name = "受信トレイ" Then
'フォルダーのアイテム数分ループ Folders.Items
For Each objMAIL In objFLD.Items
'作成日:題名で文字列を作成する
strWORK = objMAIL.CreationTime & ":" & objMAIL.Subject
'リストボックスとデータが一致するかチェック
If Me.lstMAIL.Text = strWORK Then
'フラグデータをセット(書き換える)
objMAIL.FlagStatus = 2 'olFlagMarked (2)をセット参照設定時は定数で
objMAIL.FlagRequest = "実施済み" 'フラグ内容をセット
'objMAIL.FlagDueBy = Now '今回は期限はセットしない
objMAIL.Save '忘れずに保存する
MsgBox "フラグメッセージを書き換えました"
Exit For 'ループを強制的に抜ける
End If
Next objMAIL
End If
Next objFLD
'後始末
objOL.Quit
End Sub
Function 全角ABCtoABC(strMOTO As String) As String
Dim strRET As String
'変換する
'ここの処理をヨロシクデス、
'変換結果を返す
全角ABCtoABC = strRET 'リターン値の代入(変換結果の代入)
End Function
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Else 'その他
strRET = strRET & strCHK '上記以外はそのまま+する
End Select
Next n
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function
Sub test()
Dim strWORK As String
strWORK = "Windows 2003 デバイスドライバ入門 "
MsgBox 全角ABCto半角ABC(strWORK)
End Sub
こんな感じで、
Windows 2003 デバイスドライバ入門
を
Windows 2003 デバイスドライバ入門
に変換できたよ、文句無いだろこれで。
プログラムのポイント? 特に無いな・・・あまり考えないでやっつけ仕事です。
Select Case 文字コード
Case Asc("0") To Asc("9") '文字コードが全角0〜9
と判断して、strRET = strRET & StrConv(strCHK, vbNarrow)としただけです。
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Else 'その他
strRET = strRET & strCHK '上記以外はそのまま+する
End Select
Next n
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function
Sub test() 'テスト確認用
Dim strWORK As String
strWORK = "Windows 2003 デバイスドライバ入門 "
MsgBox 全角ABCto半角ABC(strWORK)
End Sub
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Else 'その他
strRET = strRET & strCHK '上記以外はそのまま+する
End Select
Next n
'追加で()/.を変換する
strRET = Replace(strRET, "(", "(") 'カッコ
strRET = Replace(strRET, ")", ")")
strRET = Replace(strRET, "/", "/") 'スラッシュ
strRET = Replace(strRET, ".", ".") 'ドット
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function
Sub test()
Dim strWORK As String
Debug.Print "テスト結果:" & Now
strWORK = "Excel VBA(ブイビーエー) 2000/2002対応"
Debug.Print 全角ABCto半角ABC(strWORK)
strWORK = ".NETエンタープライズWebアプリケーション開発技術大全"
Debug.Print 全角ABCto半角ABC(strWORK)
End Sub
さてと、面白そうだからC君にも同じ修正を頼むかな
A君が作ったプログラムに
()/.
も半角に変換する処理を追加してくれよ
C君は素直に、
えっと、A→A,a→a,9→9の判断ができているので、
Case 文を付け足して変換てみます。
テストプログラムと追加修正したモジュール
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("(") '( カッコ
strRET = strRET & "(" '半角の(を+する
Case Asc(")") ') カッコ
strRET = strRET & ")" '半角の)を+する
Case Asc("/") '/ スラッシュ
strRET = strRET & "/" '半角の/を+する
Case Asc(".") '.ドット
strRET = strRET & "." '半角の.を+する
Case Else 'その他
strRET = strRET & strCHK '上記以外はそのまま+する
End Select
Next n
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function
Sub test()
Dim strWORK As String
Debug.Print "テスト結果:" & Now
strWORK = "Excel VBA(ブイビーエー) 2000/2002対応"
Debug.Print 全角ABCto半角ABC(strWORK)
strWORK = ".NETエンタープライズWebアプリケーション開発技術大全"
Debug.Print 全角ABCto半角ABC(strWORK)
End Sub
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("(") '( カッコ
strRET = strRET & "(" '半角の(を+する
Case Asc(")") ') カッコ
strRET = strRET & ")" '半角の)を+する
Case Asc("/") '/ スラッシュ
strRET = strRET & "/" '半角の/を+する
Case Asc(".") '.ドット
strRET = strRET & "." '半角の.を+する
Case Else 'その他
strRET = strRET & strCHK '上記以外はそのまま+する
End Select
Next n
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function
ところが、このプログラムだと、下記のデータで不具合が発生した
Sub test()
Dim strWORK As String
Debug.Print "テスト結果:" & Now
'2005-05-18 テスト
strWORK = "Excel VBA(ブイビーエー) 2000/2002対応"
Debug.Print 全角ABCto半角ABC(strWORK)
strWORK = ".NETエンタープライズWebアプリケーション開発技術大全"
Debug.Print 全角ABCto半角ABC(strWORK)
'2005-05-25 テスト
strWORK = "Visual C#.NETプログラミング入門"
Debug.Print 全角ABCto半角ABC(strWORK)
strWORK = "Microsoft Visual C++ .NETランゲージリファレンス"
Debug.Print 全角ABCto半角ABC(strWORK)
End Sub
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("(") '( カッコ
strRET = strRET & "(" '半角の(を+する
Case Asc(")") ') カッコ
strRET = strRET & ")" '半角の)を+する
Case Asc("/") '/ スラッシュ
strRET = strRET & "/" '半角の/を+する
Case Asc(".") '.ドット
strRET = strRET & "." '半角の.を+する
'2005-05-25 条件追加
Case Asc("#") '#シャープ
strRET = strRET & "#" '半角の#を+する
Case Asc("+") '+プラス
strRET = strRET & "+"
Case Asc(" ") '□(全角スペース)
strRET = strRET & " " '半角のスペースを+する
Case Else 'その他
strRET = strRET & strCHK '上記以外はそのまま+する
End Select
Next n
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
'2005-05-25 追加
Dim str全角(8) As String
Dim str半角(8) As String
Dim nLOOPCNT As Integer 'ループのカウンタ
'配列に文字をセットする
str全角(0) = " ": str半角(0) = " " '□(全角スペース)
str全角(1) = "(": str半角(1) = "(" '( カッコ
str全角(2) = ")": str半角(2) = ")" ') カッコ
str全角(3) = "/": str半角(3) = "/" '/ スラッシュ
str全角(4) = ".": str半角(4) = "." '.ドット
str全角(5) = "#": str半角(5) = "#" '#シャープ
str全角(6) = "+": str半角(6) = "+" '+プラス
str全角(7) = "−": str半角(7) = "-" '−マイナス、ハイフン
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Else 'その他
'配列の文字と一致するかチェックする 2005-05-25修正
For nLOOPCNT = 0 To 7
If strCHK = str全角(nLOOPCNT) Then 'チェックする全角文字と一致するか?
strCHK = str半角(nLOOPCNT) '対応する半角文字をセットする
Exit For 'ループを強制的に抜ける
End If
Next nLOOPCNT
strRET = strRET & strCHK 'strCHKを+する
End Select
Next n
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
'2005-05-25 追加
Dim str全角 As Variant '*1 変数をVariantで宣言
Dim str半角 As Variant
Dim nLOOPCNT As Integer 'ループのカウンタ
'Array関数で配列を初期化する
str全角 = Array(" ", "(", ")", "/", ".", "#", "+", "−")
str半角 = Array(" ", "(", ")", "/", ".", "#", "+", "-")
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Else 'その他
'配列の文字と一致するかチェックする 2005-05-25修正
For nLOOPCNT = 0 To 7
If strCHK = str全角(nLOOPCNT) Then 'チェックする全角文字と一致するか?
strCHK = str半角(nLOOPCNT) '対応する半角文字をセットする
Exit For 'ループを強制的に抜ける
End If
Next nLOOPCNT
strRET = strRET & strCHK 'strCHKを+する
End Select
Next n
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function
ここまで読んだ読者の感想を予想すると、
一文字探すんだったら文字列からInStr関数でいいんじゃないの?
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
※心の中で文句を言われていた読者の方、お待たせしました。
(オイオイ、待ってないって?)
配列を作成して、
For nLOOPCNT = 0 To UBound(str全角)
If strCHK = str全角(nLOOPCNT) Then 'チェックする全角文字と一致するか?
strCHK = str半角(nLOOPCNT) '対応する半角文字をセットする
Exit For 'ループを強制的に抜ける
End If
Next nLOOPCNT
と
配列内に該当する文字があったら、自分で置換してましたが、
この処理を
配列内を0からループで探す そんな考え方
から
文字列の中から該当する文字(1文字)を探す
に
方針を変更してみたいと思います。
文字列から文字列を探す場合、便利なInStr関数があります。
この関数を使って修正してみます。
Function 全角ABCto半角ABC(strMOTO As String) As String
Dim strRET As String
Dim strCHK As String
Dim n As Integer
Dim lngCODE As Long
'2005-05-25 追加
Dim str全角 As String
Dim str半角 As String
Dim nSERCH As Integer '場所を覚える変数
'全角の文字列と半角の文字列を作成する
str全角 = " ()/.#+−*"
str半角 = " ()/.#+-*"
strRET = "" 'リターン値の初期化
'文字数分コードを調べて変換して、strRETに+する
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'n番目の文字を取り出す
Select Case Asc(strCHK)
Case Asc("0") To Asc("9") '全角0〜9
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("a") To Asc("z") '全角a〜z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Asc("A") To Asc("Z") '全角A〜Z
strRET = strRET & StrConv(strCHK, vbNarrow) '変換して+
Case Else 'その他
'変換候補の変数 str全角の中に存在するか?チェックする 2005-05-25修正
nSERCH = InStr(str全角, strCHK) 'InStr関数でstr全角からstrCHKを探す
If nSERCH > 0 Then '見つかった、場所が0以上か?
strCHK = Mid(str半角, nSERCH, 1) '半角のn番目を代入する(に置き換える)
End If
strRET = strRET & strCHK 'strCHKを+する
End Select
Next n
'変換結果を返す
全角ABCto半角ABC = strRET 'リターン値の代入(変換結果の代入)
End Function