VB6.0

特殊フォルダの取得

API、定数宣言

'API定数宣言
Public Const CSIDL_ALTSTARTUP = &H1D
'Application Data
Public Const CSIDL_APPDATA = &H1A
Public Const CSIDL_BITBUCKET = &HA
Public Const CSIDL_COMMON_ALTSTARTUP = &H1E
'All Users\デスクトップ
Public Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19
'All Users\Favorites
Public Const CSIDL_COMMON_FAVORITES = &H1F
'All Users\スタートメニュー\プログラム
Public Const CSIDL_COMMON_PROGRAMS = &H17
'All Users\スタートメニュー
Public Const CSIDL_COMMON_STARTMENU = &H16
'All Users\スタートメニュー\プログラム\スタートアップ
Public Const CSIDL_COMMON_STARTUP = &H18
Public Const CSIDL_CONTROLS = &H3
'Cookies
Public Const CSIDL_COOKIES = &H21
'デスクトップ
Public Const CSIDL_DESKTOP = &H0
'デスクトップ
Public Const CSIDL_DESKTOPDIRECTORY = &H10
Public Const CSIDL_DRIVES = &H11
'Favorites
Public Const CSIDL_FAVORITES = &H6
'WINNT\Font
Public Const CSIDL_FONTS = &H14
'Local Settings\History
Public Const CSIDL_HISTORY = &H22
Public Const CSIDL_INTERNET = &H1
'Local Settings\Temporary Internet files
Public Const CSIDL_INTERNET_CACHE = &H20
'NetHood
Public Const CSIDL_NETHOOD = &H13
Public Const CSIDL_NETWORK = &H12
'My Documents
Public Const CSIDL_PERSONAL = &H5
Public Const CSIDL_PRINTERS = &H4
'PrintHood
Public Const CSIDL_PRINTHOOD = &H1B
'スタートメニュー\プログラム
Public Const CSIDL_PROGRAMS = &H2
'Recent
Public Const CSIDL_RECENT = &H8
'SendTo
Public Const CSIDL_SENDTO = &H9
'スタートメニュー
Public Const CSIDL_STARTMENU = &HB
'スタートメニュー\プログラム\スタートアップ
Public Const CSIDL_STARTUP = &H7
'Templates
Public Const CSIDL_TEMPLATES = &H15

Public Const MAX_PATH = 260

'API関数宣言
'-----------------------------------------------------------------------------------------------
'機能　: 特殊フォルダのパスを取得
'-----------------------------------------------------------------------------------------------
Public Declare Function SHGetSpecialFolderPath Lib "SHELL32" Alias
　　　　　　　　　　　　　　　　"SHGetSpecialFolderPathA" (ByVal hwndOwner As Long, _
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　ByVal strBuffer As String, _
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　ByVal lngSPFolder As Long, _
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　ByVal fCreate As Long) As Long

マイドキュメントのパス取得関数

'----------------------------------------------------------
'機能　: マイドキュメントのパス取得
'引数　: lnghWnd - ウィンドウズハンドル
'戻り値: SpecialFolder - マイドキュメントのフルパス
'----------------------------------------------------------
Public Function SpecialFolder(lnghWnd As Long) As String

　　Dim lngRet　　　 As Long
　　Dim lngSPFolder　As Long
　　Dim strBuffer　　As String

　　SpecialFolder=""

　　'フォルダ名を設定（例ではマイドキュメントを設定）
　　lngSPFolder = CSIDL_PERSONAL

　　'パス名を受け取るバッファを確保
　　strBuffer = String$(MAX_PATH, vbNullChar)

　　'関数の実行
　　lngRet = SHGetSpecialFolderPath(lnghWnd, strBuffer, lngSPFolder, 0)

　　'フォルダ名の取得
　　SpecialFolder = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1)

End Function

指定した時間だけ処理を中断させる方法

API、定数宣言

'API関数宣言
Private Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

処理中断関数呼び出し

'3秒間処理を中断させる
Sleep 3000

文字列を取得し配列に変換

Dim varDat　As Variant
Dim str 　　As String
Dim i 　　　As Integer

str = "区分,コード,名称"

''Split(文字列と区切り文字を含んだ文字列, [区切りを識別する文字],[配列の要素数],[比較のモード]) ''※区切りを識別する文字を省略するとスペース(" ")が識別する文字になる
varDat = Split(str,",")

For i = LBound(varDat) To UBound(varDat)
　　Debug.Print varDat(i)
Next

コマンドボタンで名称の改行を行った場合の対処

　コマンドボタンの名称を改行するとWindows2000の場合は左寄せ、WindowsXPの場合は中央寄せで表示される

　　対処方法：

OSに関わらず中央に表示させるには先頭と最後尾に空白を挿入する

''新規作成は8バイトなのでF1も8バイトになるように調整前後に3バイトの空白を挿入
btn.Caption = "新規作成" & vbCrLf & " F1 "

文字列の文字数取得

'----------------------------------------------------------
'機能　: 文字列の文字数取得
'引き数: str - 文字列
'戻り値: GetLen - 文字数
'----------------------------------------------------------
Public Function GetLen(ByVal str As String) As Long

　　GetLen = LenB(StrConv(str, vbFromUnicode))

End Function

文字列から指定した文字数分の文字列を取得

'-----------------------------------------------------------------------------------------------
'機能　: 文字列から指定した文字数分の文字列を取得
'引き数: str - 文字列
'　　　　lngStart - 開始桁数
'　　　　lngLength - 終了桁数(オプション) 初期値 = 0
'戻り値: GetMid - 取得文字
'-----------------------------------------------------------------------------------------------
Public Function GetMid( _
　　ByVal str As String, _
　　ByVal LngStart As Long, _
　　Optional lngLength As Long = 0 _
) As String

　　''終了桁数が０の場合
　　If lngLength = 0 Then
　　　　GetMid = StrConv(MidB(StrConv(str, vbFromUnicode), lngStart), vbUnicode)
　　Else
　　　　GetMid = StrConv(MidB(StrConv(str, vbFromUnicode), lngStart, lngLength), vbUnicode)
　　End If

End Function

コンボボックスにコードを持たす方法

Private Sub Form_Load()

　　'名称１をセット
　　Combo1.AddItem "名称１", 0
　　'コード1001をセット
　　Combo1.ItemData(0) = "1001"

　　'名称２をセット
　　Combo1.AddItem "名称２", 1
　　'コード1002をセット
　　Combo1.ItemData(1) = "1002"

End Sub

コマンドラインの引数を取得

Public Function GetCommandLine(Optional lngMaxArgs As Long) As Variant

　　Dim strChr As String
　　Dim strCmdLine As String
　　Dim lngCmdLineLen As Long
　　Dim blnWQuoat As Boolean
　　Dim blnInArg As Boolean
　　Dim intIndex As Integer
　　Dim lngNumArgs As Long

　　''lngMaxArgs が提供されている調べる
　　If IsMissing(lngMaxArgs) Then
　　　　lngMaxArgs = 10
　　End If

　　'' 現在サイズの配列作成
　　ReDim strArgArray(lngMaxArgs) As String

　　lngNumArgs = 0

　　blnWQuoat = False
　　blnInArg = False
　　''コマンドラインの引数を取得
　　strCmdLine = Command()
　　lngCmdLineLen = Len(strCmdLine)

　　For intIndex = 1 To LngCmdLineLen
　　　　strChr = Mid(strCmdLine,intIndex,1)
　　　　If strChr = """" Then
　　　　　　blnWQuoat = Not blnWQuoat
　　　　Else
　　　　''ダブルクォーテーション間は無条件、それ以外はスペースまたはタブまで読込
　　　　　　If (blnWQuoat) Or ((Not blnWQuoat) And strChr <> " " And strChr <> vbTab) Then
　　　　　　　　If Not bInArg Then
　　　　　　　　　　If lngNumArgs = lngMaxArgs Then Exit For
　　　　　　　　　　bInArg = True
　　　　　　　　End If
　　　　　　　　''現在の引数に文字を追加
　　　　　　　　strArgArray(lngNumArgs) = strArgArray(lngNumArgs) & strChr
　　　　　　Else
　　　　　　　　lngNumArgs = lngNumArgs + 1
　　　　　　　　bInArg = False
　　　　　　End If
　　　　End If
　　Next intIndex

　　''引数がすべて格納できるように配列のサイズを変更
　　ReDim Preserve strArgArray(lngNumArgs)

　　''関数名に配列を返す
　　GetCommandLine = strArgArray()

End Function

テキストファイルの内容を１行毎に読み込む

'----------------------------------------------------------------------------------
'機能　　テキストファイルの内容を１行毎に読み込む
'引数　　strFile テキストファイルフルパス名
'戻り値　読み込んだテキストファイル
'----------------------------------------------------------------------------------
Public Function GetText(strFile as String) As String

　　Dim intFileNo As Integer
　　Dim strtxtLine As String
　　Dim strData As String

　　''ファイル番号を取得
　　intFileNo = FreeFile

　　''テキストファイルをオープン
　　Open strFile For Input As #intFileNo

　　''ファイルの終端までループを繰り返す
　　Do While Not EOF(intFileNo)

　　　　''１行づつ変数に読み込む
　　　　Line Input #intFileNo, strTextLine

　　　　''１つの変数に結合
　　　　strTxtDat = strTxtDat & strTextLine

　　Loop

　　''ファイルを閉じる
　　Close #intFileNo

　　''結合した変数を戻す
　　GetText = strTxtD

End Function

アプリケーションを起動し終了するまで待つ

API、定数宣言

'------------------------------------------------------------------
'機能　：プロセスを起動する
'関数　：CreateProcess
'引数　：lpApplicationName　　実行するモジュール名
'　　　：lpCommandLine　　　　コマンドライン
'　　　：lpProcessAttributes　子プロセスへの継承を許可するか
'　　　：lpThreadAttributes 　子プロセスへの継承を許可するか
'　　　：bInheritHandles　　　呼び出し側プロセスのハンドルを継承させるか
'　　　：dwCreationFlags　　　制御フラグと優先順位クラス
'　　　：lpEnvironment　　　　環境ブロックへのポインタ
'　　　：lpCurrentDriectory 　カレントディレクトリ
'　　　：lpStartupInfo　　　　メインウィンドウの表示状態
'　　　：lpProcessInformation 新しいプロセスに関する情報
'戻り値：エラーコード
'------------------------------------------------------------------
Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" ( _
　　ByVal lpApplicationName As String, _
　　ByVal lpCommandLine As String, _
　　lpProcessAttributes As SECURITY_ATTRIBUTES, _
　　lpThreadAttributes As SECURITY_ATTRIBUTES, _
　　ByVal bInheritHandles As Long, _
　　ByVal dwCreationFlags As Long, _
　　lpEnvironment As Any, _
　　ByVal lpCurrentDriectory As String, _
　　lpStartupInfo As STARTUPINFO, _
　　lpProcessInformation As PROCESS_INFORMATION _
) As Long

'新プロセスに関する識別情報
Public Type PROCESS_INFORMATION
　　hProcess 　　As Long
　　hThread　　　As Long
　　dwProcessId　As Long
　　dwThreadID 　As Long
End Type

'セキュリティ属性に関する情報
Public Type SECURITY_ATTRIBUTES
　　nLength 　　　　　　　As Long
　　lpSecurityDescriptor　As Long
　　bInheritHandle　　　　As Long
End Type

'新しいプロセスのメインウィンドウの表示状態を定義する構造体
Public Type STARTUPINFO
　　cb　　　　　　　As Long
　　lpReserved　　　As Long
　　lpDesktop 　　　As Long
　　lpTitle 　　　　As Long
　　dwX 　　　　　　As Long
　　dwY 　　　　　　As Long
　　dwXSize 　　　　As Long
　　dwYSize 　　　　As Long
　　dwXCountChars 　As Long
　　dwYCountChars 　As Long
　　dwFillAttribute As Long
　　dwFlags 　　　　As Long
　　wShowWindow 　　As Integer
　　cbReserved2 　　As Integer
　　lpReserved2 　　As Long
　　hStdInput 　　　As Long
　　hStdOutput　　　As Long
　　hStdError 　　　As Long
End Type

'作成フラグ
Public Const DEBUG_PROCESS = &H1&
Public Const DEBUG_ONLY_THIS_PROCESS = &H2&
Public Const CREATE_SUSPENDED = &H4&
Public Const DETACHED_PROCESS = &H8&
Public Const CREATE_NEW_CONSOLE = &H10&
Public Const CREATE_NEW_PROCESS_GROUP = &H200&
Public Const CREATE_UNICODE_ENVIRONMENT = &H400&
Public Const CREATE_SEPARATE_WOW_VDM = &H800&
Public Const CREATE_SHARED_WOW_VDM = &H1000&
Public Const CREATE_DEFAULT_ERROR_MODE = &H4000000
Public Const CREATE_NO_WINDOW = &H8000000
'優先順位クラスフラグ
Public Const NORMAL_PRIORITY_CLASS = &H20&
Public Const IDLE_PRIORITY_CLASS = &H40&
Public Const HIGH_PRIORITY_CLASS = &H80&
Public Const REALTIME_PRIORITY_CLASS = &H100&
'表示状態
Public Const STARTF_USESHOWWINDOW = &H1&
Public Const STARTF_USESIZE = &H2&
Public Const STARTF_USEPOSITION = &H4&
Public Const STARTF_USECOUNTCHARS = &H8&
Public Const STARTF_USEFILLATTRIBUTE = &H10&
Public Const STARTF_RUNFULLSCREEN = &H20&
Public Const STARTF_FORCEONFEEDBACK = &H40&
Public Const STARTF_FORCEOFFFEEDBACK = &H80&
Public Const STARTF_USESTDHANDLES = &H100&
Public Const STARTF_USEHOTKEY = &H200&
Public Const SW_HIDE = 0
Public Const SW_SHOWNORMAL = 1
Public Const SW_NORMAL = 1
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_MAXIMIZE = 3
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOW = 5
Public Const SW_MINIMIZE = 6
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_RESTORE = 9
Public Const SW_SHOWDEFAULT = 10
Public Const SW_MAX = 10

'------------------------------------------------------------------
'機能　：指定オブジェクトがシグナル状態になるまで待避する
'関数　：WaitForSingleObject
'引数　：hHandle 　　　　オブジェクトのハンドル
'　　　：dwMilliseconds　タイムアウト時間（ミリ秒単位）
'　　　：　　　　　　　　=INFINITE : 待ち続ける
'　　　：　　　　　　　　=WAIT_ABANDONED:指定オブジェクトは放棄されたミューテックスオブジェクト
'　　　：　　　　　　　　=WAIT_OBJECT_0 :指定したオブジェクトがシグナル状態になった
'　　　：　　　　　　　　=WAIT_TIMEOUT :タイムアウト時間が経過
'戻り値：エラーコード
'------------------------------------------------------------------
Public Declare Function WaitForSingleObject Lib "kernel32" ( _
　　ByVal hHandle As Long, _
　　ByVal dwMilliseconds As Long _
) As Long

Public Const INFINITE = &HFFFF
Public Const SYNCHRONIZE = &H100000
Public Const STATUS_WAIT_0 = 0&
Public Const STATUS_TIMEOUT = &H102&
Public Const STATUS_ABANDONED_WAIT_0 = &H80&
Public Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0&)
Public Const WAIT_ABANDONED = ((STATUS_ABANDONED_WAIT_0) + 0&)
Public Const WAIT_TIMEOUT = STATUS_TIMEOUT

'------------------------------------------------------------------
'機能　：現在ユーザーが作業しているウィンドウを取得
'関数　：GetForegroundWindow
'戻り値：エラーコード
'------------------------------------------------------------------
Public Declare Function GetForegroundWindow Lib "user32.dll" () As Long

'------------------------------------------------------------------
'機能　：ウインドウを前面にする
'関数　：SetForegroundWindow
'戻り値：エラーコード
'------------------------------------------------------------------
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

'------------------------------------------------------------------
'機能　：スレッドのIDを取得
'関数　：GetWindowThreadProcessId
'戻り値：エラーコード
'------------------------------------------------------------------
Public Declare Function GetWindowThreadProcessId Lib "user32" ( _
　　ByVal hwnd As Long, _
　　lpdwProcessId As Long _
) As Long

'------------------------------------------------------------------
'機能　：現在の入力状態を目的のスレッドにアタッチ
'関数　：AttachThreadInput
'戻り値：エラーコード
'------------------------------------------------------------------
Public Declare Function AttachThreadInput Lib "user32" ( _
　　ByVal idAttach As Long, _
　　ByVal idAttachTo As Long, _
　　ByVal fAttach As Long _
) As Long

'------------------------------------------------------------------
'機能　：現在の設定を取得
'関数　：SystemParametersInfo
'戻り値：エラーコード
'------------------------------------------------------------------
Public Declare Function SystemParametersInfo Lib "user32.dll" Alias "SystemParametersInfoA" ( _
　　ByVal uiAction　As Long, _
　　ByVal uiParam 　As Long, _
　　pvParam 　　　　As Any, _
　　ByVal fWinIni 　As Long _
) As Long

Public Const SPI_GETFOREGROUNDLOCKTIMEOUT = 2000
Public Const SPI_SETFOREGROUNDLOCKTIMEOUT = 2001

'------------------------------------------------------------------
'機能　：オープンされているオブジェクトハンドルをクローズ
'関数　：CloseHandle
'戻り値：エラーコード
'------------------------------------------------------------------
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

アプリケーションを起動し終了するまで待つ関数

'----------------------------------------------------------------------------------
'機能　　アプリケーションを起動し、終了するまで待つ
'引数　　strAppPath 起動する実行ファイルフルパス
'　　　　strArgument 実行ファイルに渡す引数
'　　　　frmParent 親フォーム
'戻り値　TRUE 正常、FALSE 異常
'----------------------------------------------------------------------------------
Public Function Start_Shell(ByVal strAppPath As String, _
　　　　　　　　　　　　　　ByVal strArgument As String, _
　　　　　　　　　　　　　　ByVal frmParent As Form) As Boolean

　　Dim udtProcessAttributes　　As SECURITY_ATTRIBUTES
　　Dim udtThreadAttributes 　　As SECURITY_ATTRIBUTES
　　Dim udtStartupInfo　　　　　As STARTUPINFO
　　Dim udtProcessInfomation　　As PROCESS_INFORMATION
　　Dim lngRet　　　　　　　　　As Long
　　Dim strCmdLine　　　　　　　As String
　　Dim ThreadID1 　　　　　　　As Long
　　Dim ThreadID2 　　　　　　　As Long
　　Dim buf 　　　　　　　　　　As String

On Error GoTo Err_Start_Shell

　　'初期値を設定する
　　Start_Shell = False

　　If strAppPath = Empty Then
　　　　GoTo Err_Start_Shell
　　End If

　　If strArgument <> Empty Then
　　　　strCmdLine = strAppPath & " " & strArgument
　　End If

　　'セキュリティ構造体を初期化する
　　udtProcessAttributes.nLength = Len(udtProcessAttributes)
　　udtThreadAttributes.nLength = Len(udtThreadAttributes)

　　'プロセス起動
　　lngRet = CreateProcess(strAppPath, _
　　　　　　　　　　　　　　strCmdLine, _
　　　　　　　　　　　　　　udtProcessAttributes, _
　　　　　　　　　　　　　　udtThreadAttributes, _
　　　　　　　　　　　　　　False, _
　　　　　　　　　　　　　　NORMAL_PRIORITY_CLASS, _
　　　　　　　　　　　　　　ByVal 0&, _
　　　　　　　　　　　　　　vbNullString, _
　　　　　　　　　　　　　　udtStartupInfo, _
　　　　　　　　　　　　　　udtProcessInfomation)

　　If lngRet = 0 Then
　　　　GoTo Err_Start_Shell
　　End If

　　'終了するまで待機する
　　Do
　　　　'WaitForSingleObject を使う
　　　　'(100の引数にINFINITEを使用して終了するまで待機してもよいが親フォームがフリーズする)
　　　　lngRet = WaitForSingleObject(udtProcessInfomation.hProcess, 100)

　　　　DoEvents
　　Loop Until lngRet <> STATUS_TIMEOUT

　　If lngRet <> WAIT_OBJECT_0 Then
　　　　GoTo Err_Start_Shell
　　End If

　　'現在ユーザーが作業しているウィンドウを取得
　　lngRet = GetForegroundWindow()

　　'前面にする
　　Call SetForegroundWindow(frmParent.hwnd)

　　'フォアグラウンドウィンドウを作成したスレッドのIDを取得
　　ThreadID1 = GetWindowThreadProcessId(lngRet, ByVal 0&)

　　'目的のウィンドウを作成したスレッドのIDを取得
　　ThreadID2 = App.ThreadID

　　'現在の入力状態を目的のスレッドにアタッチ
　　AttachThreadInput ThreadID2, ThreadID1, 1

　　'現在の[フォアグラウンドロックタイムアウト]の設定を取得
　　SystemParametersInfo SPI_GETFOREGROUNDLOCKTIMEOUT, 0, VarPtr(buf), 0

　　'設定を 0ms に変更
　　SystemParametersInfo SPI_SETFOREGROUNDLOCKTIMEOUT, 0, ByVal 0&, 0

　　'本命の処理
　　SetForegroundWindow frmParent.hwnd

　　'設定を元に戻しす
　　SystemParametersInfo SPI_SETFOREGROUNDLOCKTIMEOUT, 0, VarPtr(buf), 0

　　'デタッチ
　　AttachThreadInput ThreadID2, ThreadID1, 0

　　'プロセスハンドルをクローズ
　　lngRet = CloseHandle(udtProcessInfomation.hProcess)

　　Start_Shell = True

Err_Start_Shell:

End Function

フォルダ選択ダイアログ表示

API、定数宣言

'API定数宣言
Public Const BIF_RETURNONLYFSDIRS = &H1&

'API型宣言
Public Type BROWSEINFO
　　hwndOwner As Long
　　pidlRoot As Long
　　pszDisplayName As String
　　lpszTitle As String
　　ulFlags As Long
　　lpfn As Long
　　lParam As Long
　　iImage As Long
End Type

'API関数宣言
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 Const GSCON_FOLDER_TITLE As String = "フォルダを選択してください"

フォルダ選択ダイアログの表示関数

'----------------------------------------------------------------------------------
'機能　　フォルダ選択ダイアログの表示
'引数　　frmOwner 呼出元画面、strFolderName 選択フォルダフルパス名
'戻り値　TRUE 正常、FALSE 異常
'----------------------------------------------------------------------------------
Public Function Show_Folder(ByVal frmOwner as Form, ByRef strFolderName As String) As Boolean

　　Dim lngRet As Long
　　Dim strDir As String
　　Dim BInfo As BROWSEINFO
　　Dim SelectPath As String * 128

On Error GoTo Err_Handler

　　Show_Folder = FALSE

　　'フォルダ選択ダイアログ表示
　　BInfo.hwndOwner = frmOwner.hwnd
　　BInfo.lpszTitle = GSCON_FOLDER_TITLE
　　BInfo.ulFlags = BIF_RETURNONLYFSDIRS
　　lngRet = SHBrowseForFolder(BInfo)
　　lngRet = SHGetPathFromIDList(lngRet, SelectPath)

　　'NULLの削除
　　strDir = Left(SelectPath, InStr(1, SelectPath, vbNullChar) - 1)

　　'最後尾に\がない場合付与
　　If Right(strDir, 1) <> "\" And strDir <> "" Then
　　　　strDir = strDir & "\"
　　End If

　　'フォルダパスセット
　　strFolderName = strDir

　　Show_Folder = True

Err_Handler:

End Function

ウインドウサイズ・位置・Zオーダーの設定

API、定数宣言

'ウィンドウのZオーダーの配置を示す定数宣言(hWndInsertAfteの値)
'ウインドウをZオーダーの一番上に配置
Public Const HWND_TOP = 0
'ウインドウをZオーダーの一番下に配置
Public Const HWND_BOTTOM = 1
'ウインドウをウインドウリストの一番上に配置
Public Const HWND_TOPMOST = (-1)
'ウインドウをウインドウリストの一番上(TOPMOSTの下)に配置
Public Const HWND_NOTOPMOST = (-2)

'ウィンドウ動作の定数宣言
'ウインドウの現在のサイズを保持
Public Const SWP_NOSIZE = &H1&
'ウインドウの現在位置を保持
Public Const SWP_NOMOVE = &H2&
'ウインドウリスト内での現在位置を保持
Public Const SWP_NOZORDER = &H4&
'ウインドウを自動的に再描画しない
Public Const SWP_NOREDRAW = &H8&
'ウインドウをアクティブにしない
Public Const SWP_NOACTIVATE = &H
'ウインドウのサイズ変更中でなくてもWM_NCCALCSIZEを送る
Public Const SWP_FRAMECHANGED = &H20&
'ウインドウを表示
Public Const SWP_SHOWWINDOW = &H40&
'ウインドウを隠す
Public Const SWP_HIDEWINDOW = &H80&
'クライアント領域の内容をクリア
Public Const SWP_NOCOPYBITS = &H100&
'オーナーウインドウのZオーダーは変更しない
Public Const SWP_NOOWNERZORDER = &H200&
'再描画のときウインドウを囲む枠も描画
Public Const SWP_DRAWFRAME = &H20&
'SWP_NOOWNERZORDER と同じ
Public Const SWP_NOREPOSITION =&h200&

'ウインドウサイズ・位置・Zオーダーの設定
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 lFlags As Long) As Long

ウインドウサイズ・位置・Zオーダーの設定関数

'----------------------------------------------------------------------------------
'機能　　現在の位置とサイズでウインドウリストの一番上に配置
'戻り値　TRUE 正常、FALSE 異常
'----------------------------------------------------------------------------------
Public Function Set_Window(ByVal frmOwner as Form, ByRef strFolderName As String) As Boolean

　　Dim lngRet As Long

On Error GoTo Err_Handler

　　Set_Window = FALSE

　　'現在の位置とサイズでウインドウリストの一番上に配置(API呼び出し)
　　lngRet = SetWindowPos(Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

　　Set_Window = True

Err_Handler:

End Function

※用途に応じて引数を変更する

正規化オブジェクトを使用し文字のチェックを行う

半角英数字のチェック

Public Function CHECK_NUM(Value As Variant) As Booean

　　CHECK_NUM = False

　　'RegExpのインスタンス生成
　　Set objRegExp = CreateObject("VBScript.RegExp")

　　'ここを変更するとチェック内容を変えることができる
　　objRegExp.Pattern = "[^A-Za-z0-9]"

　　'A～Z、a～z、0～9以外の場合はTrueを返す
　　If objRegExp.Test(Value) Then

　　　　Set objRegExp = Nothing

　　　　Exit Function
　　End If

　　CHECK_NUM = True

　　Set objRegExp = Nothing

End Function

オラクルDBへの接続

　オラクルDBへの接続はVBの参照設定で Oracle InProc Server 4.0 Type Library を設定しておく必要がある

'グローバル変数
Public gOraSession As oraSession 'oracleセッション
Public gOraDatabase As oraDataBase 'oracleデータベース

Public Function DB_Connect

　　Set gOraSession = New OraSessionClass
　　'DB接続処理
　　Set gOraDatabase = gOraSession.OpenDatabase("ホスト名","ユーザー名" & "/" & "パスワード", 0&)

End Function

オラクルDBへの接続が失敗する場合の対処方法（oo4o接続)

　Set OraSession = CreateObject("OracleInProcServer.XOraSession") で「ActiveX コンポーネントはオブジェクトを作成できません」と
　メッセージが表示される　

原因

　　オラクルクライアントのインストール時、不具合と思われる　　
1. XOraSessionに関するレジストリキーが存在しない([HKEY_CLASSES_ROOT\OracleInProcServer.XOraSession])
  　　　
2. XOraServerのCLSIDが間違っている
  　　　
3. OIPx.dllを指定しているレジストリキーが存在しない(レジストリー内を検索 CLSIDキー内に存在しない)
　
対処方法

　　オラクルクライアントを再インストールするかOIPx.dllをレジストリに登録する
1. OIPx.dllをレジストリに登録する
  
  ファイル名を指定して実行で regsvr32.exe [OIPx.dllのフルパス] を実行

VBからPL/SQLに配列を渡す

VB6.0側

'----------------------------------------------------------------------------------
' VB6.0側
' PL/SQLに配列を渡す例
'----------------------------------------------------------------------------------
Public Function PLSQL_LOAD_ARRAY()

　　Dim objArray As OraParamArray
　　Dim testArray(9) As String
　　Dim i As Integer

　　'配列サンプル
　　For i = 0 To 9
　　　　testArray(i) = "TEST" & i
　　Next

　　'配列作成
　　goraDatabase.Parameters.AddTable "SEND", ORAPARM_INPUT, ORATYPE_CHAR, 10, 10

　　Set objArray = goraDatabase.Parameters("SEND")

　　'配列に値セット
　　For i = 0 To 9
　　　　objArray.put_Value testArray(i), i
　　Next

　　'PL/SQLの呼び出し
　　goraDatabase.ExecuteSQL ("Begin PLSQL_TEST.ARRAY_TEST(":SEND");end;")

End Function

PL/SQL側

/* -------------------------------------------------------------------------------- */
/* PL/SQLパッケージ */
/* VBから配列の受け取り例 */
/* -------------------------------------------------------------------------------- */
CREATE OR REPLACE PACKAGE PLSQL_TEST IS
TYPE chrCODE IS TABLE OF CHAR(10) INDEX BY BINARY_INTEGER;

PROCEDURE ARRAY_TEST
(
pchrCODE IN chrCODE /* 配列をセット */
)
;

END;
/

/* -------------------------------------------------------------------------------- */
/* PL/SQLパッケージボディ */
/* VBから配列の受け取り例 */
/* -------------------------------------------------------------------------------- */
CREATE OR REPLACE PACKAGE BODY PLSQL_TEST IS

PROCEDURE ARRAY_TEST
(
pchrCODE IN chrCODE /* 配列をセット */
)
IS
BEGIN

　　-- TESTテーブルに配列に格納データをINSERT
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(1));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(2));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(3));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(4));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(5));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(6));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(7));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(8));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(9));
　　INSERT INTO TEST(CODE) VALUES (pchrCODE(10));

　　COMMIT;

END ARRAY_TEST;
END;
/

InputManを配布する場合の必要ファイル

InputMan のコントロールが動作するためには、OCX の他に imBase7.DLL、imShare7.DLL、OLEAUT32.DLL、OLEPRO32.DLL が必要
imShare7.DLL に関してはレジストリ登録も必要
OLEAUT32.DLL、OLEPRO32.DLL は配布先の OS に存在するものを使用（推奨）

EXCELファイルをスプレッドシートへの取込方法

SPREAD Ver6.0J

Dim strList(0) As String
Dim inthWorkBook As Integer
Dim intListCnt As Integer
Dim strFileName As String
Dim blnRet As Boolean

strFileName = "取込対象エクセルファイル名"
''指定したファイルがExcel形式のファイルかどうかを返す
blnRet = vaSpread1.IsExcelFile(strFileName)
if Not blnRet Then
　　MsgBox "Excel形式のファイルではありません"
　　Exit Sub
End if

''指定のExcelファイルから、ワークブックのハンドルとシート名リストを取得
blnRet = vaSpread1.GetExcelSheetList(strFileName,strList,strListCnt,"C:\temp\excel.log",inthWorkBook,True)
if blnRet Then
　　''スプレッドシートをExcel形式ファイルのシートにエクスポート
　　vaSpread1.ImportExcelSheet inthWorkBook,strList(0)
else
　　MsgBox "対象のエクセルファイルが起動中の為、読み込みに失敗しました"
End if

スプレッドシートをEXCELファイルに出力する方法

SPREAD Ver6.0J

''スプレッドシートをExcel形式ファイルのシートにエクスポート
spread1.ExportToExcel("作成するExcelファイル名", "Excelに作成するシート名", "作成するログファイル名")

Windwos 98でディストリビュージョンウイザードで作成したインストーラーが異常終了する

　Windows 2000環境でディストリビュージョンウイザードを使用し、作成したインストーラーをWindows 98にインストールすると異常終了する

Windows 98環境でインストーラーを作成する必要がある

※インストールする際にVFC40.dllのバージョン違いが発生する為

[トップページへ] [戻る]


	Copyright(c)2007-2008 Freedom.Net Co., Ltd. All rights reserved.