【
VB++ まめ知識】
VB++に関するメモを気づいた時点で随時メモしておく私的なものです。
◇TIPS
■部品上に描画された文字列の幅を計算する W = TextRenderer.MeasureText(item.Name.ToString(), cb.Font).Width ↓こっちは誤差が大きかったのでやめた Dim ds As System.Drawing.Graphics = Me.cb.CreateGraphics() ds.MeasureString(item.Name.ToString(), cb.Font).Width) ■KeyPressイベントをフェッチして、そこの処理だけで終わらせる（本体側に引き続き処理をさせない） Private Sub tx_KeyPress(sender As Object, e As KeyPressEventArgs) Handles tx.KeyPress If e.KeyChar = Chr(13) Then 'テキスト上でENTERキーを押下した場合 e.Handled = True '改行文字を挿入させない為の措置（部品高調節の為マルチライン化している為そのままでは改行挿入される） End If End Sub ■MaskedTextBodのTextChanged内からカーソル位置を動かす Private Sub myTextChanged(sender As Object, e As EventArgs) Handles mtb.TextChanged Dim th As New System.Threading.Thread(New System.Threading.ThreadStart(AddressOf childThread)) th.Start() End Sub Delegate Sub setCarretDelegate(ByVal pos As Integer) Private Sub childThread() Dim dlg As New setCarretDelegate(AddressOf setCarret) mtb.Invoke(dlg, New Object() {1/*カーソル位置*/}) End Sub Private Sub setCarret(ByVal pos As Integer) mtb.Select(pos, 0) End Sub ■パスの分解 '----------- 'パス分解 '----------- Public Sub SplitPath(ByVal path As String, ByRef folder As String, ByRef fname As String, ByRef fnamebase As String, ByRef ext As String) Dim i As Integer path = Trim(path) i = InStrRev(path, "\") If i > 0 Then folder = Left(path, i) fname = Right(path, Len(path) - i) Else folder = "" fname = path End If i = InStrRev(fname, ".") If i > 0 Then fnamebase = Left(fname, i - 1) ext = Right(fname, Len(fname) - i) Else fnamebase = fname ext = "" End If End Sub ■ファイル選択ダイアログ Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFO As BROWSEINFO) As Long Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) Public Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal FileName As String) As Long Public Type BROWSEINFO hwndOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As String iImage As Long End Type Public Const CSIDL_DESKTOP = &H0 Public Const BIF_RETURNONLYFSDIRS = &H1 Public Const MAX_PATH = 260 Public Const BIF_BROWSEINCLUDEFILES = &H4000 Public Const FILE_ATTRIBUTE_DIRECTORY = &H10 Public Const WM_USER = &H400 Public Const BFFM_SETSELECTIONA = (WM_USER + 102) Public Const BFFM_INITIALIZED = 1 Public Function FileSelect(hWnd As Long, title As String) Do While True Dim bInfo As BROWSEINFO Dim pID As Long Dim path As String With bInfo .hwndOwner = hWnd .pidlRoot = CSIDL_DESKTOP .lpszTitle = title .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_BROWSEINCLUDEFILES .lpfn = FARPROC(AddressOf BrowseCallbackProc) .lParam = App.path & "\sound" & vbNullChar End With pID = SHBrowseForFolder(bInfo) If pID Then path = String$(MAX_PATH, vbNullChar) SHGetPathFromIDList pID, path CoTaskMemFree pID n% = InStr(path, vbNullChar) If n% Then FileSelect = Left$(path, n% - 1) End If If (GetFileAttributes(FileSelect) And FILE_ATTRIBUTE_DIRECTORY) = 0 Then Exit Do End If Else Exit Do End If Loop End Function Private Function FARPROC(pfn As Long) As Long FARPROC = pfn End Function Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long If uMsg = BFFM_INITIALIZED Then SendMessage hWnd, BFFM_SETSELECTIONA, 1, ByVal lpData End If End Function ■フォルダ選択ダイアログ Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFO As BROWSEINFO) As Long Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) Public Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal FileName As String) As Long Public Type BROWSEINFO hwndOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As String iImage As Long End Type Public Const CSIDL_DESKTOP = &H0 Public Const BIF_RETURNONLYFSDIRS = &H1 Public Const MAX_PATH = 260 Public Const BIF_BROWSEINCLUDEFILES = &H4000 Public Const FILE_ATTRIBUTE_DIRECTORY = &H10 Public Const WM_USER = &H400 Public Const BFFM_SETSELECTIONA = (WM_USER + 102) Public Const BFFM_INITIALIZED = 1 Public Function FileSelect(hWnd As Long, title As String) Do While True Dim bInfo As BROWSEINFO Dim pID As Long Dim path As String With bInfo .hwndOwner = hWnd .pidlRoot = CSIDL_DESKTOP .lpszTitle = title .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_BROWSEINCLUDEFILES .lpfn = FARPROC(AddressOf BrowseCallbackProc) .lParam = App.path & "\sound" & vbNullChar End With pID = SHBrowseForFolder(bInfo) If pID Then path = String$(MAX_PATH, vbNullChar) SHGetPathFromIDList pID, path CoTaskMemFree pID n% = InStr(path, vbNullChar) If n% Then FileSelect = Left$(path, n% - 1) End If Exit Do Else Exit Do End If Loop End Function Private Function FARPROC(pfn As Long) As Long FARPROC = pfn End Function Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long If uMsg = BFFM_INITIALIZED Then SendMessage hWnd, BFFM_SETSELECTIONA, 1, ByVal lpData End If End Function ■色番号とRGB値の相互変換 '------------------------- '例：指定の色を明るくして返す '------------------------- Public Function gBRIGHTER(col As Long) As Long Dim r As Long Dim g As Long Dim b As Long r = (original_color And &HFF) g = (original_color And &HFF00&) \ &H100 b = (original_color And &HFF0000) \ &H10000 r = r + 30 g = g + 30 b = b + 30 If r < 0 Then r = 0 ElseIf r > 255 Then r = 255 End If If g < 0 Then g = 0 ElseIf g > 255 Then g = 255 End If If b < 0 Then b = 0 ElseIf b > 255 Then b = 255 End If gBRIGHTER = RGB(r, g, b) End Function ■時刻の比較、加算 Dim wD1 As Date Dim wD2 As Date wD1 = CDate("2007/02/28 23:59:59") wD2 = CDate("2007/03/01 00:00:12") If wD1 > wD2 Then MsgBox CStr(wD1) + " > " + CStr(wD2) ElseIf wD1 < wD2 Then MsgBox CStr(wD1) + " < " + CStr(wD2) Else MsgBox CStr(wD1) + " = " + CStr(wD2) End If wD1 = DateTime.DateAdd("s", 13, wD1) 'wD1に13秒加算してwD2と同時刻にする。注：比較結果がおかしいです。仕様？ If wD1 > wD2 Then MsgBox CStr(wD1) + " > " + CStr(wD2) ElseIf wD1 < wD2 Then MsgBox CStr(wD1) + " < " + CStr(wD2) Else MsgBox CStr(wD1) + " = " + CStr(wD2) End If wD1 = DateTime.DateAdd("s", 1, wD1) 'wD1にさらに1秒加算する。 If wD1 > wD2 Then MsgBox CStr(wD1) + " > " + CStr(wD2) ElseIf wD1 < wD2 Then MsgBox CStr(wD1) + " < " + CStr(wD2) Else MsgBox CStr(wD1) + " = " + CStr(wD2) End If ■ディスプレイのサイズを獲得する Screen.Width Screen.Height ■TWIPとピクセルの相互変換 Twip→ピクセル x= x\ Screen.TwipsPerPixelX y= y\ Screen.TwipsPerPixcelY ピクセル→Twip x= x* Screen.TwipsPerPixelX x= x* Screen.TwipsPerPixcelY ■ポイント（フォントサイズ等）とTWIP（画面の部品のサイズ等）の変換 points = Me.ScaleX(twips, vbTwips, vbPoints) twips = Me.ScaleX(points, vbPoints, vbTwips) ■テキストボックスに表示されたテキスト末にカーソルを表示する Text1.SelStart = Len(Text1.Text) ■テキストボックスTextBoxの配色を変えずに入力不可（ディスエイブル）とする Text1.Enabled = False Text1.ForeColor = &HE0E0E0 Text1.BackColor = &H400000 Call SendMessage(Text1.hwnd, &HA, 1, 0) ■日付のフォーマットを編集する Dim strMessage As String Dim strTime As String Dim strDate As String '日時を表示 Dim Taro As SYSTEMTIME Call GetSystemTime(Taro) strDate = Taro.wYear & "/" & Taro.wMonth & "/" & Taro.wDay strTime = Taro.wHour & ":" & Taro.wMinute & ":" & Taro.wSecond strMessage = "UTC-" & Format(strDate, "yyyy/mm/dd") & "-" & Format(strTime, "hh:mm:ss") ■システム時刻 ・単純にシステム時刻をおまかせフォーマットで取り出す場合 Now ・こまかくやりたい場合 [GMT] Public Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) [上記Nowと同じシステム時刻=通常はJSTでしょう。時計のタイムゾーンの設定次第。] Public Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) Public Type SYSTEMTIME wYear As Integer '西暦 wMonth As Integer '月 wDayOfWeek As Integer '曜日 wDay As Integer '日 wHour As Integer '時間 wMinute As Integer '分 wSecond As Integer '秒 wMilliseconds As Integer 'ミリ秒 End Type 'ここからはフォーム内の処理です Private Sub Command1_Click() Dim Taro As SYSTEMTIME List1.Clear Call GetSystemTime(Taro) List1.AddItem Taro.wYear List1.AddItem Taro.wMonth List1.AddItem Taro.wDayOfWeek List1.AddItem Taro.wDay List1.AddItem Taro.wHour List1.AddItem Taro.wMilliseconds End Sub ■文字列操作 chr キャラクタコードの文字を返す asc 文字のキャラクタコードを返す str 数値を文字列に変換 val 文字列を数値に変換 space n 個の空白を生成 string 特定文字を n 個生成 trim 左右の全角半角空白を削除 ltrim 左側の全角半角空白を削除 rtrim 右側の全角半角空白を削除 lcase 小文字に変換 ucase 大文字に変換 left 左側より n 個の文字列を切り出し mid n 番目から n 個の文字列を切り出し mid ステートメントして使用すると文字列を置き換える right 右側より n 個の文字列を切り出し len 何文字あるか数える instr 指定文字列が何番目から存在するか調べる format 書式指定変換をする now format と組み合わせて、today などを生成する ■数値演算 + 加算 - 減算 * 掛け算 / 割り算 \ 割り算(小数部切り捨て) 「a \ b = int (a / b)」 mod 余り ■外部コマンドを実行する Call Shell(コマンドのパス) ■ソケット（Winsock）通信をする 先ず、フォーム上にWinsockコントロールを貼り付ける。 もしツールバーにWinsockコントロールが表示されていなければ 「プロジェクト」「コンポーネント」で「Microsoft Winsock Control 6.0」を選択すると現れる。 あとは以下のソースを貼り付ければ ・起動とともに接続を開始し、 ・切断したら何度でも再接続する という動きをします。 イベントディスパッチの部分は勝手にやってくれているのでデータ受信待ちにべったり張り付く 必要もないし簡単です。 '-------------------------------- 'サーバ側ソケット通信プログラム ' ' '注：バイナリデータには対応していません '-------------------------------- Private Const D_HEADSIZE As Long = 4 'ヘッダ部のサイズ Private Const D_SIZEFROM As Long = 0 'ヘッダ部に続いて後続受信されるデータ部の「サイズ」がヘッダ部どこに入っているか Private Const D_SIZESIZE As Long = 4 '「サイズ」は何バイトか Private Const D_SIZEBASE As Long = 0 '「サイズ」に「ヘッダ部に続いて後続受信するデータ部の長さ」以外に＋αが含まれている場合はその値 Private B_TMP As String '一時受信用バッファ Private B_MSG As String 'メッセージ組み立て用バッファ Private B_DLEN As String 'データ部サイズ '-------------------------------- '初期化処理 '-------------------------------- Private Sub Form_Load() Winsock1.Protocol = sckTCPProtocol Winsock1.LocalPort = 6001 Call SockListen End Sub '-------------------------------- '接続待ち処理 '-------------------------------- Private Sub SockListen() L_LAMP.BackColor = vbRed 'ラベル「L_LAMP」を用意して下さい。 Winsock1.Close Winsock1.Listen End Sub '-------------------------------- '接続検出時処理 '-------------------------------- Private Sub Winsock1_ConnectionRequest(ByVal reqid As Long) B_TMP = "" B_MSG = "" B_DLEN = 0 L_LAMP.BackColor = vbGreen 'ラベル「L_LAMP」を用意して下さい。 Winsock1.Close Winsock1.Accept (reqid) End Sub '-------------------------------- 'データ受信時処理 '-------------------------------- Private Sub Winsock1_DataArrival(ByVal size As Long) Dim wbuf As String '------------------ 'とにかくドライバ側に溜まっているデータを引き取る '------------------ Winsock1.GetData wbuf, vbString, size B_TMP = B_TMP + wbuf Do While True If Len(B_MSG) < D_HEADSIZE Then '------------------ 'ヘッダ未受信ならばヘッダを切り出す '------------------ If Len(B_TMP) >= D_HEADSIZE Then B_MSG = Left(B_TMP, D_HEADSIZE) B_TMP = Right(B_TMP, Len(B_TMP) - D_HEADSIZE) B_DLEN = Val(Left(B_MSG, D_HEADSIZE)) - D_SIZEBASE Else Exit Sub End If ElseIf Len(B_MSG) < D_HEADSIZE + B_DLEN Then '------------------ 'ヘッダ受信済みならデータ部を切り出す '------------------ If Len(B_TMP) >= B_DLEN Then B_MSG = B_MSG + Left(B_TMP, B_DLEN) B_TMP = Right(B_TMP, Len(B_TMP) - B_DLEN) '------------------ 'メッセージを１つ受信完了した際の処理はここ（B_MSGに入っています） '------------------ MsgBox B_MSG '------------------ B_MSG = "" B_DLEN = 0 Else Exit Sub End If Else Exit Sub End If Loop End Sub '-------------------------------- 'エラー検出時処理 ' ' Number エラー番号 ' Description エラーメッセージ '-------------------------------- Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean) Call SockListen End Sub '-------------------------------- '切断検出時処理 '-------------------------------- Private Sub Winsock1_Close() Call SockListen End Sub '-------------------------------- 'データ送信処理 '-------------------------------- Private Sub BTN_SEND_Click() 'ボタン「BTN_SEND」を用意して下さい。 If Winsock1.State <> sckConnected Then MsgBox "Connection is not available" Else Winsock1.SendData "0045 Can " Winsock1.SendData "you he" Winsock1.SendData "ar me?" + vbNewLine Winsock1.SendData "I would always be with " Winsock1.SendData "you0040 Let me " Winsock1.SendData "take a quick trip of your house?" End If End Sub '-------------------------------- 'クライアント側ソケット通信プログラム ' ' '注：バイナリデータには対応していません '-------------------------------- Private Const D_HEADSIZE As Long = 4 'ヘッダ部のサイズ Private Const D_SIZEFROM As Long = 0 'ヘッダ部に続いて後続受信されるデータ部の「サイズ」がヘッダ部どこに入っているか Private Const D_SIZESIZE As Long = 4 '「サイズ」は何バイトか Private Const D_SIZEBASE As Long = 0 '「サイズ」に「ヘッダ部に続いて後続受信するデータ部の長さ」以外に＋αが含まれている場合はその値 Private B_TMP As String '一時受信用バッファ Private B_MSG As String 'メッセージ組み立て用バッファ Private B_DLEN As String 'データ部サイズ '-------------------------------- '初期化処理 '-------------------------------- Private Sub Form_Load() Call StartPolling End Sub '-------------------------------- 'ソケット接続開始処理 '-------------------------------- Private Sub StartPolling() Winsock1.Close Winsock1.Protocol = sckTCPProtocol 'TCPを指定 Winsock1.RemoteHost = "127.0.0.1" '接続先ホスト名 Winsock1.RemotePort = 6001 '接続先ポート番号 Winsock1.connect '接続開始 End Sub '-------------------------------- 'ソケット接続時の処理 '-------------------------------- Private Sub Winsock1_Connect() L_LAMP.BackColor = vbGreen 'ラベル「L_LAMP」を用意して下さい。 B_TMP = "" B_MSG = "" B_DLEN = 0 End Sub '-------------------------------- 'ソケット切断検出時の処理 '-------------------------------- Private Sub Winsock1_Close() L_LAMP.BackColor = vbRed 'ラベル「L_LAMP」を用意して下さい。 Winsock1.Close 'クローズして Winsock1.connect '再接続する End Sub '-------------------------------- 'ソケットからデータ受信時の処理 '-------------------------------- Private Sub Winsock1_DataArrival(ByVal size As Long) Dim wbuf As String '------------------ 'とにかくドライバ側に溜まっているデータを引き取る '------------------ Winsock1.GetData wbuf, vbString, size B_TMP = B_TMP + wbuf Do While True If Len(B_MSG) < D_HEADSIZE Then '------------------ 'ヘッダ未受信ならばヘッダを切り出す '------------------ If Len(B_TMP) >= D_HEADSIZE Then B_MSG = Left(B_TMP, D_HEADSIZE) B_TMP = Right(B_TMP, Len(B_TMP) - D_HEADSIZE) B_DLEN = Val(Left(B_MSG, D_HEADSIZE)) - D_SIZEBASE Else Exit Sub End If ElseIf Len(B_MSG) < D_HEADSIZE + B_DLEN Then '------------------ 'ヘッダ受信済みならデータ部を切り出す '------------------ If Len(B_TMP) >= B_DLEN Then B_MSG = B_MSG + Left(B_TMP, B_DLEN) B_TMP = Right(B_TMP, Len(B_TMP) - B_DLEN) '------------------ 'メッセージを１つ受信完了した際の処理はここ（B_MSGに入っています） '------------------ MsgBox B_MSG '------------------ B_MSG = "" B_DLEN = 0 Else Exit Sub End If Else Exit Sub End If Loop End Sub '-------------------------------- 'ソケット障害検出時の処理 ' ' Number エラー番号 ' Description エラーメッセージ '-------------------------------- Private Sub Winsock1_Error(ByVal Number As Integer, _ Description As String, _ ByVal Scode As Long, _ ByVal Source As String, _ ByVal HelpFile As String, _ ByVal HelpContext As Long, _ CancelDisplay As Boolean) L_LAMP.BackColor = vbRed 'ラベル「L_LAMP」を用意して下さい。 Winsock1.Close 'クローズして Winsock1.connect '再接続する End Sub '-------------------------------- 'クローズして切断されるまで待機 文字列を送信完了する前に切断するとエラーになることへの対処 '-------------------------------- 'Private Sub OffLine() ' Winsock1.Close ' Do While Not (Winsock1.State = sckClosed) '切断されるまで待機 ' DoEvents ' Loop 'End Sub '-------------------------------- 'データ送信処理 '-------------------------------- Private Sub BTN_SEND_Click() If Winsock1.State <> sckConnected Then MsgBox "Connection is not available" Else Winsock1.SendData "0024 Yes, of course." + vbNewLine + "But..." Winsock1.SendData "0031 Do you mind if I would be a..." Winsock1.SendData "0043 Widow?... I have one little baby. He is 3." End If End Sub ■コンボボックスで指定の行を選択状態にする Combo1.ListIndex = 3 '4行目を選択状態にする