Option Explicit 'ウィンドウを最前面表示 '手前 Call SetWindowPos(Me.hwnd, 0, 0, 0, 0, 0, &H3) '後ろ Call SetWindowPos(Me.hwnd, 1, 0, 0, 0, 0, &H3) '一番手前 Call SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, &H3) '解除 Call SetWindowPos(Me.hwnd, -2, 0, 0, 0, 0, &H3) '画面を中央に配置 Me.Top = (screen.Height - Me.Height) \ 2 Me.Left = (screen.Width - Me.Width) \ 2 '日付の足し算＆引き算 [オブジェクト].Text = Format(DateAdd("d", -1, "1999/01/01", "YYYY/MM/DD") 'マウスカーソルをデフォルトに設定 Screen.MousePointer = vbDefault 'マウスカーソルを砂時計に設定 Screen.MousePointer = vbHourglass 'ヘルプファイル起動 Ret = WinHelp(Me.hwnd, App.Path & "\" & App.HelpFile, &HB, 0) 'UNICODE対応分割処理 inputfile = StrConv(inputfile,vbFromUnicode) CODE1 = StrConv(MidB(inputfile,1,3),vbUnicode) DATA1 = StrConv(MidB(inputfile,4,6),vbUnicode) CODE2 = StrConv(MidB(inputfile,10,3),vbUnicode) 'ＮＴ系での全角半角チェック If Len(Hex(Asc("あ"))) = 4 Then If Len(Hex(Asc("A"))) = 2 Then 'うるう年チェック If intYear Mod 4 = 0 Then If intYear Mod 100 = 0 And intYear Mod 400 <> 0 Then 'うるう年でないと設定 Else 'うるう年であると設定 End If End If 'アイコン設定 Dim hIcon As Long hIcon = LoadImage(0&, "C:\icon.ico", 1, 1, 1, &H10) Call SendMessage(hWnd, &H80, 0, ByVal hIcon) Dim Ret As Long Dim hWindow As Long '親となるウィンドウを検索 hWindow = FindWindow(vbNullString, "explorer") '自分を子ウィンドウとして親ウィンドウに設定 Ret = SetParent(Me.hWnd, hWindow) Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer) '終了キャンセル If UnloadMode <> vbFormCode Then Cancel = True Exit Sub End If End Sub Public Sub Main() ' 二重起動防止 If App.PrevInstance Then Unload Me End If End Sub 'フォーカスを得た時に文字列を全選択にする Private Sub [テキストボックスオブジェクト]_GotFocus() 'テキストボックスの文字列を全体選択 [TextBoxオブジェクト].SelStart = 0 [TextBoxオブジェクト].SelLength = Len([TextBoxオブジェクト].Text) End Sub 'フォーム全体のキー入力処理 '備考：フォームの KeyPreview プロパティを True に設定して下さい Private Sub Form_KeyPress(KeyAscii As Integer) 'ＥＮＴＥＲキーが押されたらＴＡＢに変換 If KeyAscii = vbKeyReturn Then '入力時の音を消す KeyAscii = 0 'ＴＡＢキーの割り込み発生 SendKeys "{TAB}" End If End Sub 'メモリからプログラムを開放 '備考：フォームは Unload で開放してください Private Sub Form_Unload(Cancel As Integer) Set [Formオブジェクト] = Nothing End End Sub 'フォルダ選択ボックスでＥＮＴＥＲキーでも選択できる様に設定 Private Sub [オブジェクト]_KeyDown(KeyCode As Integer, Shift As Integer) 'エンターキーでも選択可能にする If KeyCode = vbKeyReturn Then '選択されたフォルダを設定 [ListBoxオブジェクト].Path = [ListBoxオブジェクト].List([ListBoxオブジェクト].ListIndex) End If End Sub 'フォントとフォントサイズの設定 Public Sub SetFontSize(Fm As Form) Dim MeObj As Object 'フォーム全体のオブジェクトを検索 For Each MeObj In Fm 'オブジェクト名の頭４文字をチェック Select Case UCase(Left(MeObj.Name, 4)) Case "FRM_" MeObj.FontSize = 10 MeObj.Font = "ＭＳ ゴシック" Case "TXT_" MeObj.FontSize = 10 MeObj.Font = "ＭＳ ゴシック" Case "LBL_" MeObj.FontSize = 10 MeObj.Font = "ＭＳ ゴシック" Case "CMD_" MeObj.FontSize = 10 MeObj.Font = "ＭＳ ゴシック" Case Else MeObj.FontSize = 8 MeObj.Font = "ＭＳ ゴシック" End Select Next End Sub Public Sub ContorlsClear(ByVal objFormName As Object) '処理概要 : フォーム上のすべてのコントロールをクリア Dim objOnForm As Object For Each objOnForm In objFormName.Controls Select Case UCase(TypeName(objOnForm)) 'テキストボックス Case "TEXTBOX", "IMDATE", "IMMASK", "IMNUMBER", "IMTEXT", "IMTIME", "IMNUMLITE" objOnForm.Text = "" 'ラベル Case "LABEL" If objOnForm.BorderStyle = 1 Then objOnForm.Caption = "" End If 'チェックボックス Case "CHECKBOX" objOnForm.Value = 0 'コンボボックスにスペースで作成した項目番号=0をセット Case "COMBOBOX" objOnForm.ListIndex = 0 'オプションボタン Case "OPTIONBUTTON" objOnForm.Value = False 'リストボックス Case "LISTBOX" objOnForm.Clear 'スプレッド Case "VASPREAD" With objOnForm .Col = -1: .Col2 = -1 .Row = -1: .Row2 = -1 .BlockMode = True .Action = ActionClearText .BlockMode = False .MaxRows = 0 End With End Select Next End Sub 'リストビュー設定値 Public Const LVM_FIRST As Long = &H1000 Public Const LVM_SETEXTENDEDLISTVIEWSTYLE As Long = LVM_FIRST + 54 Public Const LVM_GETEXTENDEDLISTVIEWSTYLE As Long = LVM_FIRST + 55 Public Const LVS_EX_FULLROWSELECT As Long = &H20 'リストビューに一行選択モードを設定する Dim Ret As Long Dim rStyle As Long '現在の状態（プロパティ）を取得 rStyle = SendMessage(Me.ListView.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&) '拡張スタイルビットをクリア ' rStyle = rStyle Xor LVS_EX_FULLROWSELECT '拡張スタイルビットをセット rStyle = rStyle Or LVS_EX_FULLROWSELECT '一行選択モード設定 Ret = SendMessage(Me.ListView.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle) Dim hWndList As Long, lngScrollWidth As Long '水平スクロールバーを表示 Call ShowScrollBar(hWndList, SB_HORZ, True) '水平スクロール範囲(lngScrollWidth)をピクセル単位で設定 Call SendMessage(Combo1.hWnd, CB_SETHORIZONTALEXTENT, _ lngScrollWidth, ByVal 0&) 'サブアイテム設定 ListView.ListItems(ListView.ListItems.count).SubItems(1) = "data" 'メッセージがキューから削除 Dim typMsg As MSG lngRetWin = PeekMessage(typMsg, Me.hWnd, 0, 0, PM_REMOVE) Dim Ret As Long Dim MRect As RECT Dim hMenu As Long, hSubMenu As Long, hSSubMenu As Long Dim XY_Point As POINTAPI 'メニューをポップアップ表示 ' If (GetWindowRect(Me.hwnd, MRect) = False) Then ' Exit Sub ' End If MRect.left = 0 MRect.top = 0 MRect.right = Screen.Width \ Screen.TwipsPerPixelX MRect.bottom = Screen.Height \ Screen.TwipsPerPixelY 'カーソル位置取得 Call GetCursorPos(XY_Point) hMenu = GetMenu(MenuOnlyForm.hwnd) hSubMenu = GetSubMenu(hMenu, 1) Ret = TrackPopupMenu(hSubMenu, 2, XY_Point.X, XY_Point.Y, 0, MenuOnlyForm.hwnd, MRect) 'スプレッドシートの行ごとのソート With vaSpread1 'ソート範囲設定 .Row = 1 .Col = 1 .Row2 = 13 .Col2 = 3 '行ソートモードに設定 .SortBy = 0 ' 第１ソートキーを設定 .SortKey(1) = Col ' 昇順に並べ替えに設定 .SortKeyOrder(1) = 1 '実行 .Action = 25 End With Public Declare Function GetSystemMenu Lib "user32" ( _ ByVal hWnd As Long, _ ByVal bRevert As Long) As Long '/ウィンドウメニューのハンドル取得 Public Declare Function EnableMenuItem Lib "user32" ( _ ByVal hMenu As Long, _ ByVal wIDEnableItem As Long, _ ByVal wEnable As Long) As Long '/×ボタンを無効化 ' 画面右上の×ボタン無効化 ' ウィンドウメニューのハンドルを取得 lnghMenu = GetSystemMenu(Me.hWnd, False) If lnghMenu = 0 Then ' エラー End If ' 無効化するハンドルの指定 lngRetWin = EnableMenuItem(lnghMenu, &HF060&, &H0& Or &H1&) If lngRetWin = -1 Then ' エラー End If '///// ウィンドウズＡＰＩ ///// Public Const HWND_TOP = 0 '/ウィンドウをZ順序の最上位に配置します Public Const HWND_BOTTOM = 1 '/ウィンドウをZ順序の最下位に配置します Public Const HWND_TOPMOST = -1 '/ウィンドウを最前面ではないほかのすべてのウィンドウよりも上位に配置します Public Const HWND_NOTOPMOST = -2 '/ウィンドウを最前面ウィンドウ以外のすべてのウィンドウの上位に配置し直します Public Const SWP_NOSIZE = &H1 '/現在の位置を変更しません (xパラメータとyパラメータを無視します) Public Const SWP_NOMOVE = &H2 '/現在のサイズを変更しません (cxパラメータとcyパラメータを無視します) Public Const SWP_NOREDRAW = &H8 '/変更を再描画しません Public Const SWP_NOACTIVATE = &H10 '/ウィンドウをアクティブ化しません '/ウィンドウポジション設定ＡＰＩ Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long '/次のウィンドウハンドル検索ＡＰＩ Public Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long '/ウィンドウキャプション取得ＡＰＩ Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long '/ウィンドウフォアグラウンド設定ＡＰＩ Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long '///////////////////////////////////////////////////////////////////////////////////////// '/ ＜プロシージャ名＞ gsubMeWindowPositionTopSet '/ ＜概要＞ ウィンドウ位置不正を調整 '/ ＜引数＞ lngMeWinHwnd (IN)：自分のＶＢウィンドウハンドル(.hWnd) '/ ScanWindowCaption (IN)：検索対象のウィンドウキャプション '/ ＜戻り値＞ なし '/ ＜備考＞ 検索対象のウィンドウ位置の上に自分のウィンドウを配置する '///////////////////////////////////////////////////////////////////////////////////////// Public Sub gsubMeWindowPositionTopSet(ByVal lngMeWinHwnd As Long, ByVal ScanWindowCaption As String) '///// 宣言 ///// Dim lngWinRet As Long Dim lngGetWinHwnd As Long Dim lngWinCaptionLen As Long Dim strWinCaption As String lngGetWinHwnd = lngMeWinHwnd '/ 検索開始位置に自分のウィンドウハンドルを設定 lngWinCaptionLen = Len(ScanWindowCaption) '/ 検索対象のウィンドウキャプションの文字長さ '///// 自分より上位に表示されてるウィンドウを検索 ///// Do '///// ウィンドウを検索 ///// lngGetWinHwnd = GetNextWindow(lngGetWinHwnd, 3) If lngGetWinHwnd <> 0 Then '///// ウィンドウのキャプション名を取得 ///// strWinCaption = Space(lngWinCaptionLen) lngWinRet = GetWindowText(lngGetWinHwnd, strWinCaption, lngWinCaptionLen) If Left(Trim(strWinCaption), lngWinCaptionLen) = ScanWindowCaption Then Exit Do '/ 対象ウィンドウを見つけたので次の処理へ End If Else Exit Sub '/ 上位のウィンドウが見つからないため終了 End If Loop '///// ウィンドウを１つ前面に表示 ///// Call SetWindowPos(lngGetWinHwnd, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOSIZE + SWP_NOMOVE) lngWinRet = SetForegroundWindow(lngMeWinHwnd) End Sub bytWrtBuf() As Byte '///// 変数の宣言 ///// Dim lngHandle As Long '/オブジェクトハンドル Dim lngRealWrtSize As Long '/書込みサイズ Dim uovrOverLapped As OVERLAPPED '/オーバーラッププロパティ Dim lngRetWin As Long '/Win32APIの戻り値 '///// ファイルオブジェクト取得 ///// lngHandle = CreateFile(strFileFullPath, _ GENERIC_WRITE, _ 0, _ usecSecurityArrtib, _ CREATE_ALWAYS, _ FILE_ATTRIBUTE_NORMAL, _ vbNull) inputfile = StrConv(inputfile,vbFromUnicode) '///// バッファをファイルに出力 ///// lngRetWin = WriteFile(lngHandle, bytWrtBuf(0), lngWrtSize, lngRealWrtSize, uovrOverLapped) '///// ファイルオブジェクト解放 ///// lngRetWin = CloseHandle(lngHandle) '///// 変数の宣言 ///// Dim objFso As Scripting.FileSystemObject '/ファイルシステムオブジェクト gfncDelFile = gintFNC_NOR '/正常の戻り値をセットする Set objFso = New Scripting.FileSystemObject '/ファイルシステムオブジェクトを作成 Call objFso.DeleteFile(strFileFullPath, True) '/ファイルの削除 Set objFso = Nothing '/オブジェクトの解放 Dim ShellTaskID As Long 'プログラムを実行 ShellTaskID = Shell("C:\P1.EXE", vbNormalFocus) '実行したプログラムのプロセスＩＤからハンドルを取得 ProcessHandle = OpenProcess(PROCESS_QUERY_INFORMATION, 1, ShellTaskID) Private Sub Timer1_Timer() Dim Ret As Long Dim EndCode As Long 'ハンドルからそのプログラムの実行状態を確認 Ret = GetExitCodeProcess(ProcessHandle, EndCode) 'プログラムが実行されていない場合 If EndCode <> STILL_ACTIVE Then Unload Me End If End Sub Public Const SPI_GETFOREGROUNDLOCKTIMEOUT As Long = &H2000 Public Const SPI_SETFOREGROUNDLOCKTIMEOUT As Long = &H2001 Public Declare Function GetForegroundWindow Lib "user32" () As Long Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long Public Declare Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long 'Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Public Sub gsubSetActiveWindow(lngSetWindowHD As Long) Dim lngForegroundID As Long '/現在のアクティブウィンドウＩＤ Dim lngMeWindowID As Long '/指定のウィンドウＩＤ Dim lngLockTime As Long '/ロックタイム '現在アクティブウィンドウのスレッドＩＤを取得 lngForegroundID = GetWindowThreadProcessId(GetForegroundWindow(), 0) '指定のウィンドウのスレッドＩＤを取得 lngMeWindowID = GetWindowThreadProcessId(lngSetWindowHD, 0) 'スレッドにアタッチ Call AttachThreadInput(lngMeWindowID, lngForegroundID, -1) '現在アクティブウィンドウのロックタイムアウトを取得 Call SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, lngLockTime, 0) '現在アクティブウィンドウのロックタイムアウトを設定 Call SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, 0, 0) '最前面化 ' Call SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3) '最前面化解除 ' Call SetWindowPos(Me.hwnd, -2, 0, 0, 0, 0, 3) 'アクティブ化 Call SetForegroundWindow(lngSetWindowHD) '現在アクティブウィンドウのロックタイムアウトを設定 Call SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, lngLockTime, 0) 'スレッドにアタッチ解除 Call AttachThreadInput(lngMeWindowID, lngForegroundID, 0) End Sub