Private Sub txt印刷日_AfterUpdate()
'テキストボックスの更新後にカレンダーの値も変更したいので
If IsDate(Me!txt印刷日) Then '日付と認識できる?
Me!OLE_Calendar.Value = Me!txt印刷日
Else
MsgBox "日付として認識できませんよ・・・"
End If
End Sub
口直しのデザートじゃないけど、
カレンダーコントロールってコントロールなので、
フォームに配置します。
わけわかんないけど、それでいいんじゃないの?
ですよね、言い方が悪かった。
えっと、画面上に表示したくない(日付のボタンが押されたら選択画面を起動)
開始日、終了日など複数のテキストボックスで選択を使いたい
なんて用途があると勝手に思い込んで、
カレンダー選択フォームを作ってみます。
オレは使わないけど、勝手に作るなら作ったら?
冷たいなぁみんな(笑)
チョット前、ダイアログフォームを使用して、
INPUT BOX もどきを作成しました。
No.91 Access ダイアログフォームって?何? acDialogとPublic変数を使用
http://www.ken3.org/backno/backno_vba19.html#91
↑そのまんまなんだけど、ただ、カレンダーコントロールを使っただけ(笑)
関数仕様 Function INPUT_HIZUKE_Form() As String
カレンダーコントロール付きのフォームを表示して、日付を選択させる。
選択されたらCDateで変換した日付文字列を返す。
キャンセルだったら""の空文字列を返します。
Option Compare Database
Option Explicit
Public INPUT_HIZUKE_RET As String 'グローバルにリターン値受取り用
Function INPUT_HIZUKE_Form() As String
Dim stDocName As String
Dim stLinkCriteria As String
INPUT_HIZUKE_RET = "" 'リターン値を初期化
'ダイアログモードでフォームを開く
stDocName = "日付選択"
DoCmd.OpenForm stDocName, , , stLinkCriteria, , acDialog
'リターン値をセットして、関数を終わる
'フォーム側でpublic変数にセットされていることを信じて(笑)
INPUT_HIZUKE_Form = INPUT_HIZUKE_RET
End Function
Private Sub btn開始_Click()
Dim strWORK As String
strWORK = INPUT_HIZUKE_Form() '日付の入力フォームを起動
If strWORK <> "" Then '入力されていたら
Me!txt開始日 = strWORK 'フォームのリターン値をセット
End If
End Sub
Private Sub btn終了_Click()
Dim strWORK As String
strWORK = INPUT_HIZUKE_Form() '日付の入力フォームを起動
If strWORK <> "" Then '入力されていたら
Me!txt終了日 = strWORK 'フォームのリターン値をセット
End If
End Sub
って感じで、
strWORK = INPUT_HIZUKE_Form() '日付の入力フォームを起動
で日付選択フォームを起動、
リターン値を判断して選択されていたら自分のテキストボックスに代入
If strWORK <> "" Then '入力されていたら
Me!txt終了日 = strWORK 'フォームのリターン値をセット
End If
と、
共通に使うことが出来ます。
日付の入力処理の隠し味として、使えそうなら使ってみてください。
隣のメルマガ、ASP系で、ログイン処理を作りました。
No.68 DBでユーザー管理、ログイン処理(復習で作成)
http://www.ken3.org/backno/backno_asp14.html#68
あとは、個人的なことで、
http://www.ken3.org/etc/okozukai.html
で、小金稼ぎ系をやってて、
自動でログインできたらいいなぁ・・と思い、探ってみました。
And
だいぶ前に読者から下記のヒントもらっていたので(感謝)
In message "リンク クリック",
しょうもさん wrote...
>[ VBAで楽しくプログラミング No.071 ] 2003/05/06 火曜日 より
>
>> 読者からの要望は、広告自動クリックソフトだったけど
>
>その名の通り、Clickメソッドが使えますよ。
>今回も、IHTMLElementオブジェクトを操っています。
>「Microsoft HTML Object Library」参照設定です。
>
>'-----------
> Dim objElement As IHTMLElement
> Dim strTempText As String
>
> For Each objElement In objIE.Document.all.tags(tagName:="a")
> strTempText = objElement.getAttribute _
> (strAttributeName:="href")
> Debug.Print strTempText
> If InStr(strTempText, "top10") Then
> objElement.Click
> Exit For
> End If
> Next
------------
そんな感じの三流君書いてみようポイントが貯まって(←何それ?)
今回の発行となりました。
※今回の自動ログイン処理、まだまだですが、
応用すれば、1日一回の人気投票システムなどにも応用可能かなぁ。
サンプルファイルは、
http://www.ken3.org/vba/lzh/vba097.lzh
にtest097-Book.xlsが保存されています。
/*
* 2.IEのオブジェクトを作成、操作する
*/
インターネットエクスプローラー(IE)を起動するには、
Sub ie_test()
Dim objIE As Object 'IEオブジェクト参照用
'インターネットエクスプローラーのオブジェクトを作る
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True '見えるようにする(お約束)
End Sub
Sub ie_test()
Dim objIE As Object 'IEオブジェクト参照用
'インターネットエクスプローラーのオブジェクトを作る
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True '見えるようにする(お約束)
'文字列で指定したURLに飛ぶ
objIE.Navigate "http://www.ken3.org/cgi-bin/test/test068.html"
'表示終了まで待つ
Do While objIE.Busy = True
'何もしないループ(笑)
DoEvents
Loop
'項目名を指定して、データをセットする
objIE.document.all.userid.Value = "Ken3" 'ユーザー名
objIE.document.all.pass.Value = "aaa" 'パスワード
End Sub
隣や下のセルをつなげて、1つのセルにする。
そんな表を見たことありますよね。
↑セルプロパティの設定画面
プロパティを知りたかったので、
いつものマクロ記録で記録してみました。
^^^^^^^^^^^^^^^^^^
Range("B6:C6").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Range("D6:D7").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
さてと、それらしいのは、
おっ、.MergeCells = Trueってのが怪しそうですね。
.MergeCellsにカーソルを合わせて、
F1(Help)を押して、探ってみます。
MergeCells プロパティ
True の場合、セル範囲またはスタイルが結合セルを含みます。
値の取得および設定が可能です。バリアント型 (Variant) の値を使用します。
解説
結合されたセルが含まれるセル範囲を選択すると、指定したセル範囲と実際の
セル範囲が異なる場合があります。選択したセル範囲のアドレスを調べるには、
Address プロパティを使用します。
使用例
次の使用例は、セル A3 がある結合セル範囲に値を設定します。
Set ma = Range("a3").MergeArea
If Range("a3").MergeCells Then
ma.Cells(1, 1).Value = "42"
End If
なんだか、よくわからないなぁ(笑)。
/*
* 2.簡単に確認してみる。
*/
Range("B6:C6").Select
を結合したので、
? Range("A6").MergeCells
False
? Range("B6").MergeCells
True
? Range("C6").MergeCells
True
と、B6とC6が結合されているのは、わかった。
Dim ma As Range
Set ma = Range("b6").MergeArea
Debug.Print ma.Address
Set ma = Range("c6").MergeArea
Debug.Print ma.Address
とやると、
$B$6:$C$6
$B$6:$C$6
と同じ値が表示される。
左上の値を(1,1)判断するために、
Dim ma As Range
Set ma = Range("b6").MergeArea
Debug.Print ma.Address
Debug.Print ma.Cells(1, 1).Address
とテストすると、
$B$6:$C$6
$B$6
cells(1,1)で左上を判断できるので、(結合されたはじめの位置を知りたいので)
現在のセルが結合されているか?は、
.MergeCellsで判断
.MergeAreaで結合範囲を取り出しcells(1,1).addressで左上判断
これを組み込んでみます。
/*
* 3.HTML作成データに組み込む
*/
Sub Main()
'Application.InputBoxでセルを選択させる
Dim objTARGET As Range '選択されたセルの集合
Set objTARGET = Application.InputBox(prompt:="セルを選択", Type:=8)
If IsEmpty(objTARGET) Then 'キャンセルが押されたかチェックする
MsgBox "キャンセルが押されました"
Exit Sub
End If
'ファイル名を作成 ファイル名は自分のパス+\test.html
Dim strFNAME As String 'ファイル名保存用
strFNAME = ThisWorkbook.Path & "\test.html" 'ファイル名を作る
'テーブルデータを作成する
Call MAKE_HTML_TABLE(strFNAME, objTARGET)
'できたファイルをIEで表示して確認する
Call IE_OPEN_URL(strFNAME) 'ファイル名を渡す
'終わりの挨拶
MsgBox strFNAME & "を作成しました"
End Sub
'ファイル名とセルの範囲RANGEを受け取り、
'ファイルを開きHTMLのテーブルを作成する
Sub MAKE_HTML_TABLE(strFNAME As String, objHANI As Range)
Dim strCOLOR As String
Dim strR As String
Dim strG As String
Dim strB As String
Dim objMA As Range 'リンクの範囲
Dim strTD As String
'ファイルをオープンする
Dim FNO As Integer 'ファイル番号
FNO = FreeFile '空いてるファイル番号を取出す
Open strFNAME For Output As #FNO 'テキストファイルを新規作成
'HTMLのヘッダーを書く
Print #FNO, "<HTML><HEAD><TITLE>"
Print #FNO, "テーブル作成してみました"
Print #FNO, "</TITLE></HEAD>"
Print #FNO, "<BODY>"
Print #FNO, "<TABLE border=1>" 'テーブルの開始
'行、列でループを作る
Dim y As Integer
Dim x As Integer
For y = 1 To objHANI.Rows.Count '行のループ
Print #FNO, "<TR>" '行の開始タグ
For x = 1 To objHANI.Columns.Count '列のループ
'ALIGNを調べて書き込む
Select Case objHANI.Cells(y, x).HorizontalAlignment
Case xlRight:
strTD = "<TD ALIGN='RIGHT'"
Case xlLeft:
strTD = "<TD ALIGN='LEFT'"
Case xlCenter:
strTD = "<TD ALIGN='CENTER'"
Case Else 'その他設定無しのとき
strTD = "<TD"
End Select
'バックカラーを調べる
strCOLOR = Right("000000" & Hex(objHANI.Cells(y, x).Interior.Color), 6)
If strCOLOR <> "FFFFFF" Then '白以外の時処理
strR = Mid(strCOLOR, 5, 2)
strG = Mid(strCOLOR, 3, 2)
strB = Mid(strCOLOR, 1, 2)
strTD = strTD & " BGCOLOR=#" & strR & strG & strB
End If
'セルの結合を判断する
If objHANI.Cells(y, x).MergeCells = True Then '結合セルか?
Set objMA = objHANI.Cells(y, x).MergeArea 'エリアを取り出す
If objMA.Cells(1, 1).Address = objHANI.Cells(y, x).Address Then
'左上なら
If objMA.Columns.Count <> 1 Then
strTD = strTD & " COLSPAN=" & objMA.Columns.Count
End If
If objMA.Rows.Count <> 1 Then
strTD = strTD & " ROWSPAN=" & objMA.Rows.Count
End If
Print #FNO, strTD & ">"; 'タグを閉じ出力
Else
'結合セルでその他なら、データを書かないでOKなら
strTD = "" 'タグをクリア(データを出さない)
End If
Else
Print #FNO, strTD & ">"; 'タグを閉じ出力
End If
'フォントの色を調べる
strCOLOR = Right("000000" & Hex(objHANI.Cells(y, x).Font.Color), 6)
If strCOLOR <> "000000" Then '黒以外の時処理
strR = Mid(strCOLOR, 5, 2)
strG = Mid(strCOLOR, 3, 2)
strB = Mid(strCOLOR, 1, 2)
If strTD <> "" Then '出力ありなら
Print #FNO, "<Font Color=#" & strR & strG & strB & ">";
End If
End If
If strTD <> "" Then '出力ありなら
'セルの中身を変換して書き込む*018で追加
Print #FNO, htmlEnCode(objHANI.Cells(y, x).Value);
'フォントのタグを閉じる
If strCOLOR <> "000000" Then '黒以外の時処理
Print #FNO, "</Font>";
End If
'タグを閉じる
Print #FNO, "</TD>";
End If
Next x
Print #FNO, "</TR>" '行の終了タグ
Next y
'HTMLのタグを閉める
Print #FNO, "</TABLE>"
Print #FNO, "</BODY></HTML>"
'ファイルをクローズする
Close #FNO
End Sub
'URLを受け取り、IEを起動、URLを開く
Sub IE_OPEN_URL(strURL As String)
'IEを起動して、表示
Dim objIE As Object 'IEオブジェクト参照用
'インターネットエクスプローラーのオブジェクトを作る
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True '見えるようにする(お約束)
objIE.Navigate strURL '文字列で指定したURLに飛ぶ
End Sub
'文字列を受け取り、変換結果を返す
Function htmlEnCode(strMOTO As String) As String
Dim strCHK As String 'チェックする文字
Dim strSET As String 'セットする文字
Dim strWORK As String '結果を入れる作業変数
Dim n As Integer 'カウンター
'結果をまず初期化する
strWORK = ""
'文字数分ループする
For n = 1 To Len(strMOTO)
strCHK = Mid(strMOTO, n, 1) 'チェックする文字を取り出す
Select Case Asc(strCHK) '文字をチェックする
Case &H20: strSET = " " 'スペース
Case &H3C: strSET = "<" '<
Case &H3E: strSET = ">" '>
Case &H26: strSET = "&" '&
Case &H22: strSET = """ '"
Case &HA: strSET = "<br>" '改行
Case Else: strSET = strCHK 'その他の文字はそのままセット
End Select
'文字列を作る
strWORK = strWORK & strSET
Next n
'作られた文字列をリターン値としてセットする
htmlEnCode = strWORK
End Function
ポイントは、
~~~~~~~~~~~~
'セルの結合を判断する
If objHANI.Cells(y, x).MergeCells = True Then '結合セルか?
Set objMA = objHANI.Cells(y, x).MergeArea 'エリアを取り出す
If objMA.Cells(1, 1).Address = objHANI.Cells(y, x).Address Then
'左上なら
If objMA.Columns.Count <> 1 Then
strTD = strTD & " COLSPAN=" & objMA.Columns.Count
End If
If objMA.Rows.Count <> 1 Then
strTD = strTD & " ROWSPAN=" & objMA.Rows.Count
End If
Print #FNO, strTD & ">"; 'タグを閉じ出力
Else
'結合セルでその他なら、データを書かないでOKなら
strTD = "" 'タグをクリア(データを出さない)
End If
Else
Print #FNO, strTD & ">"; 'タグを閉じ出力
End If
と、結合セルか判断して、
COLSPAN=,ROWSPAN=とTDの結合タグ指定しました。
結合されていれば、その分、COLSPAN=2やROWSPAN=2で、HTMLの結合表を作成してます。
結合セルの初め(左上の1,1)以外は出力しなくていいので、
※COLSPAN=2やROWSPAN=2で指定されているので、
'結合セルでその他なら、データを書かないでOKなら
strTD = "" 'タグをクリア(データを出さない)
と変数をクリア。
もし、TDタグの出力が無ければ、値も出さなくていいので、
If strTD <> "" Then '出力ありなら
'セルの中身を変換して書き込む*018で追加
Print #FNO, htmlEnCode(objHANI.Cells(y, x).Value);
'フォントのタグを閉じる
If strCOLOR <> "000000" Then '黒以外の時処理
Print #FNO, "</Font>";
End If
'タグを閉じる
Print #FNO, "</TD>";
End If
と、
データの出力の判断で使用しました。
↑テスト画面、なんとか動作しました。。。
-【けんぞう!】---------------------------------------------------------
転職関係、在宅プログラマー、SOHOの広告まとめました
http://www.ken3.org/etc/500yen/zaitaku.html いろいろとあるので転機の人はぜひ
『だだ、広告料稼ぎたいだけだろ、紹介料300円〜1500円の小金稼ぎ』
ギクっ、、、バレた(笑)登録料無料、匿名で探せるので在宅で小金稼ぎの人も見てね
------------------------------------------------------------------------
Private Sub tab_ctl_TEST_Change()
Dim select_page As Integer
'選択ページの番号を代入する
select_page = Me![tab_ctl_TEST].Value
'メッセージを表示する
MsgBox select_page & "番目のタブが選択されました"
End Sub
Private Sub TAB_SELECT_Change()
Dim strチーム名 As Variant 'チーム名を配列で受け取る
'タブの順番と同じ名前の配列を作成する
strチーム名 = Array("ALL", "横浜", "阪神", "巨人", "ヤクルト", "中日", "広島")
Dim strTNAME As String '選択されたチーム名を受け取る
'選択されたタブに対応したチーム名を配列から代入
strTNAME = strチーム名(Me![TAB_SELECT].Value)
'データソース用のSQL文を作成する
Dim strSQL As String
If strTNAME = "ALL" Then '全てのデータ条件無しなら
strSQL = "select * from T_AVG Order By 打率順位"
'↑T_AVGテーブルから全ての項目をセレクト、打率順位順とする
Else
'T_AVGテーブルから全ての項目をセレクト、
'条件はチーム名が一致するデータ、打率順位順とする
strSQL = "Select * From T_AVG " _
& "Where チーム = '" & strTNAME & "' " _
& "Order By 打率順位"
End If
'データを絞り込むSQL文が完成したので、
'それをフォームのレコードソースにセットする
Me.RecordSource = strSQL '単にSQL文を代入するだけでOKなんですよ
End Sub