よく見かけるVBサンプル集 MENU　10～19

Sample 100

よく見かけるVBサンプル集

BACK -Page-Next- NEXT

［00～09］　［10～19］　［20～29］　［30～39］　［40～49］
［50～59］　［60～69］　［70～79］　［80～89］　［90～99］

indexへ戻る

MENU　10～19

10パス名を短いファイル名の形式で取得する　API

11長いフルパスのファイル名を「...」で省略する

12Systemフォルダー位置の取得　API

13Tempフォルダー位置を取得　API

14Windowsフォルダー位置を取得　API

15VBプロジェクトファイルのバージョンを取得する

16コンピューター名を取得　API

17ユーザー名を取得　API

18マウスポインタを非表示/表示にする　API

19フォームを最大化(タイトルとコントロールボックスは非表示)　API

パス名を短いﾌｧｲﾙ名の形式で取得する

使用API

'[指定された長いパス名から、短いパス名を取得]
Private Declare Function GetShortPathName Lib "kernel32" _
Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long

lpszLongPath
長いパス名(長いファイル名）を指定
lpszShortPath
ここに短いパス名が返されます。
cchBuffer
返されるバッファのサイズを、文字単位で指定します。

バッファのサイズが足りなかった場合は、必要なバッファのサイズが文字単位で返ります。その他の理由で関数が失敗した場合は、0 が返ります。

ショートパス名 = GetDosShortPathName（ロングパス）

使用例

X = GetDosShortPathName（"C:\WINDOWS\隅田川.bmp"）

'
'[パス名を短いﾌｧｲﾙ名の形式で取得する]
'
'■ 引数:ロングパス
'□ 戻り値:ショートパス名
Public Function GetDosShortPathName(ByVal strLongPath As String) As String
   Dim strShortPath As String * 300
   Dim ret As Long

   ret = GetShortPathName(strLongPath, strShortPath, Len(strShortPath))
   If ret = 0& Then
     '文字列の先頭と末尾に二重引用符がある場合、これらの引用符を削除します。
      If InStr(strLongPath, " ") Or InStr(strLongPath, ",") Then
         strLongPath = """" & strLongPath & """"
      Else
         strLongPath = strLongPath
      End If
   Else
      GetDosShortPathName = _
                         Left(strShortPath, InStr(strShortPath, vbNullChar) - 1)
   End If
End Function

TOP

長いフルパスのファイル名を「...」で省略する

使用API

使用APIなし

省略されたパス = OmitPathName(長いフルパス)

使用例

X = OmitPathName（"C:\WINDOWS\隅田川.bmp"）

'
'[長いフルパスのファイル名を「...」で省略する]
'
'■ 引数:長いフルパス
'□ 戻り値:省略されたパス
Public Function OmitPathName(ByVal strLongPathName As String) As String

   Dim strDriveName As String
   Dim strFileName As String
   Dim strLastPath As String
   Dim strWork As String
   Dim intLoopCount As Integer

   ' ドライブﾞ名を取り出す
   strDriveName = Left(strLongPathName, 3)
   ' ファイル名だけを取り出す
   strFileName = Mid(strLongPathName, 4)
   Do While InStr(strFileName, "\")
      strFileName = Mid(strFileName, InStr(strFileName, "\") + 1)
   Loop
   strWork = Mid(strLongPathName, 4)
   If InStr(strWork, strFileName) > 3 Then
      strLastPath = Left(strWork, InStr(strWork, strFileName) - 2)
   Else
      strWork = strLongPathName
      OmitPathName = strWork
      Exit Function
   End If

   Do While InStr(strLastPath, "\")
      strLastPath = Mid(strLastPath, InStr(strLastPath, "\") + 1)
   Loop
   strWork = strDriveName & "...\" & strLastPath & "\" & strFileName

   If Len(strWork) >= Len(strLongPathName) Then
      ' 得た文字列が元より長い
      strWork = strLongPathName
   End If

   ' メニューに表示するためにファイル名に'&'がある場合'&&'と変換する。
   For intLoopCount = Len(strWork) To 1 Step -1
      If Mid(strWork, intLoopCount, 1) = "&" Then
         strWork = Left(strWork, intLoopCount) & "&" & Mid(strWork, intLoopCount + 1)
      End If
   Next intLoopCount
   OmitPathName = strWork
End Function

TOP

Systemフォルダー位置の取得

使用API

'[Windows のシステムディレクトリパスを取得]
Public Const MAX_PATH = 260
Public Const MAX_PATH_PLUS1 = MAX_PATH + 1

Private Declare Function GetSystemDirectory Lib "kernel32" Alias _
"GetSystemDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) As Long

lpBuffer
システムディレクトリのパス名が NULL で終わる文字列として、ここに返されます
nSize
バッファのサイズを指定します。MAX_PATH 以上を指定してください。

関数が成功すると、0 以外の値が返ります。

システムディレクトリパス = SystemDirectory（）

使用例

X = SystemDirectory（）

'
'[Windows のシステムディレクトリパスを取得]
'
'■ 引数:なし
'□ 戻り値:Windows のシステムディレクトリパスを取得
Public Function SystemDirectory() As String
   Dim strBuffer As String * MAX_PATH_PLUS1
   Dim strTMP As String
   Dim ret As Long
   ret = GetSystemDirectory(strBuffer, Len(strBuffer))
   strTMP = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
   If right(strTMP,1) <> "\" Then strTMP = strTMP & "\"
   SystemDirectory = strTMP
End Function

TOP

Tempフォルダー位置を取得

使用API

'［テンポラリファイル用のディレクトリパスを取得］
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
　　(ByVal nBufferLength As Long, _
　　ByVal lpBuffer As String) As Long

nBufferLength
バッファのサイズを指定します。（文字数分必要）
lpBuffer
テンポラリファイル用のディレクトリパスここに返ります。

関数が成功すると、0 以外の値が返ります。

テンポラリファイル用のディレクトリパス = TempDirectory（）

使用例

X = TempDirectory（）

'
'[テンポラリファイル用のディレクトリパスを取得]
'
'■ 引数:なし
'□ 戻り値:テンポラリファイル用のディレクトリパスを取得
Public Function TempDirectory() As String
   Dim TempName As String * 512
   Dim strTMP As String
   Dim ret As Long
   ret = GetTempPath(Len(TempName), TempName)
   strTMP = Left(TempName, InStr(TempName, vbNullChar) - 1)
   If right(strTMP,1) <> "\" Then strTMP = strTMP & "\"
   TempDirectory = strTMP
End Function

TOP

Windowsフォルダー位置を取得

使用API

'［Windows ディレクトリパスを取得］
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias _
"GetWindowsDirectoryA" ( _
ByVal lpBuffer As String, _
ByVal nSize As Long) As Long

関数が成功すると、0 以外の値が返ります。

Windows ディレクトリパス = WindowsDirectory（）

使用例

X = WindowsDirectory（）

'
'[Windows ディレクトリパスを取得]
'
'■ 引数:なし
'□ 戻り値:Windows ディレクトリパスを取得
Public Function WindowsDirectory() As String
   Dim strBuffer As String * MAX_PATH_PLUS1
   Dim strTMP As String
   Dim ret As Long
   ret = GetWindowsDirectory(strBuffer, Len(strBuffer))
   strTMP = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
   If right(strTMP,1) <> "\" Then strTMP = strTMP & "\"
   WindowsDirectory = strTMP
End Function

TOP

VBプロジェクト（vbp）のバージョンを取得する

使用API

そのプロジェクトに関連するファイル内を検索して、ファイルのバージョンを返します。
(frm,vbp)ファイルの読込みに対応

使用APIなし

メインバージョン = GetVBPVersion（フルパスファイル名）

使用例

X = GetVBPVersion（"C:\WINDOWS\test.vbp"）

'ここから関数を呼んで使用してください。
'[VBプロジェクト（vbp）のバージョンを取得する]
'
'■ 引数:なし
'□ 戻り値:ファイルのバージョン(成功時　1以上)
Public Function GetVBPVersion(ByVal strFileName As String) As Long
On Error Resume Next
   Dim strFilePath As String 'ロードするファイルのフォルダ位置
   Dim LS(1) As String        '先頭から*行目のみ{LS(0)=1行目 (1)=2行目}
   Dim ret As Long             '戻り値を格納
   Dim i As Integer             'カウンタ

   '指定フルパス(strFileName)からフォルダ名を取得
   strFilePath = GetFullPathTOpathOnly(strFileName)
   '先頭から、1行目、2行目を読込む
   LS(0) = VBfrmFileOpen(strFileName, LS(1))
   'バージョンを抜き出す(0未満=エラー)
   ret = VBFileVersionChk(LS(0))
   If ret <= 0 Then
     If Len(LS(0)) >= 4 Then
      '4文字以上
      '見つからなかったので、
      '1、2行に記述してあるファイル名を読み込んでバージョンを確かめる
      'ファイル名が指定されてるかをチェック
      If Len(LS(0)) > 5 Then
         'カウンタを初期化
         i = 0
         '記述されているファイルをチェックする
         Do While i <= Len(LS(0))
            'ファイル名を抽出して、ファイルを読込みチェックする
            If Mid(LS(1), 1 + i, 1) = "=" Then
               'LS(1)からファイル名を取り出す
               LS(1) = Right(LS(1), Len(LS(1)) - i - 1)
               '
               '2行目の指定ファイルの内容をチェックする
               '先頭から、1行目、2行目を読込む
               LS(0) = VBfrmFileOpen(strFilePath & LS(1), LS(1))
               ret = VBFileVersionChk(LS(0)) '最終結果
               Exit Do
            End If
            i = i + 1
         Loop
      Else
         'ファイル指定もなかった
      End If
    End If
End If
'結果を返す
GetVBPVersion = ret
End Function

'
'[先頭から2行をファイルから読込みます]
'
'■ 引数:strFileName: ファイル名
'□ 戻り値:1行目の文字列
'     LINE2:2行目の文字列
Function VBfrmFileOpen(ByVal strFileName As String, _
                                  ByRef LINE2 As String) As String
   Dim h As Long 'ファイル番号
   Dim s As String '文字
   '空きファイル番号の取得
   h = FreeFile
   'ファイルの先頭の一行目のみを読込む
   Open strFileName For Input As #h
   Line Input #h, s
   Line Input #h, LINE2
   Close #h
   VBfrmFileOpen = s
End Function

'
'[ファイルバージョンのチェック]
'
'■ 引数:
'strLine:チェックする文字列
'□ 戻り値:1行目の文字列
'     LINE2:2行目の文字列　
' 戻り値:-1=失敗
Function VBFileVersionChk(ByVal strLine As String) As Long
   VBFileVersionChk = -1
   On Error Resume Next
   strLine = Mid(strLine, Len(strLine) - 3, 1)
   VBFileVersionChk = CLng(strLine)
End Function

' 簡易版（sample100_02 と置き換えても構いません。）
'[(ファイル名が指定された)フルパスから、パスのみを取得]
'
'■ 引数:
'strFullPathFileName:ファイル名が指定されたフルパス
'□ 戻り値:パスのみを取得
Function GetFullPathTOpathOnly(ByVal strFullPathFileName As String) As String
   Dim i As Integer 'ループカウンタ
   Dim FNSize As Long '(ファイルが指定された)フルパスの文字サイズ
   Dim strTMP As String '作業用
   Dim s As String 'フルパス
   'フルパスをｓへ格納
   s = strFullPathFileName
   '(ファイルが指定された)フルパスからサイズを取得
   FNSize = Len(s)
   '親か子フォルダかを判定
   If FNSize <= 3 Then
     '"c:" のみだった場合は、逆に"\" を付ける
     If Right(s, 1) <> "\" Then s = s & "\"
   Else
      '"\”を後ろから探す
     For i = 1 To FNSize
      strTMP = Mid(s, Len(s) - i, 1)
       '\を見つけた？　
       If strTMP = "\" Then
          'ファイル名を除いたパスを返す
         GetFullPathTOpathOnly = StrConv(Left(s, Len(s) - i), vbLowerCase)
          Exit For
      End If
    Next i
End If
End Function

TOP

コンピューター名を取得

使用API

'[コンピューター名を取得]
Public Const MAX_COMPUTERNAME_LENGTH = 15

Private Declare Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long

lpBuffer
ここに、コンピュータ名が NULL で終わる文字列として返されます
nSize
バッファのサイズは、MAX_COMPUTERNAME_LENGTH + 1 以上にしてください。

関数が成功すると、0 以外の値が返ります。

コンピュータ名 = ComputerName（）

使用例

X = ComputerName（）

'
'[コンピューター名を取得]
'
'■ 引数:なし
'□ 戻り値:ユーザー名
Public Function ComputerName() As String
   Const TCMPNAMBUF_LEN = MAX_COMPUTERNAME_LENGTH + 1
   Dim strCmpNameBuf As String * TCMPNAMBUF_LEN
   Dim CmpNameLen As Long
   Dim ret As Long
   ' コンピューター名の長さを設定
   CmpNameLen = Len(strCmpNameBuf)
   ' コンピューター名を取得
    ret = GetComputerName(strCmpNameBuf, CmpNameLen)
   ComputerName = Left(strCmpNameBuf, InStr(strCmpNameBuf, vbNullChar) - 1)
End Function

TOP

ユーザー名を取得

使用API

'[現在スレッドのユーザー名を取得]
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, _
nSize As Long) As Long

lpBuffer
ここに、ユーザー名が NULL で終わる文字列として返されます。
バッファのサイズが足りなかったときは、関数は失敗します。
nSize
バッファのサイズ

関数が成功すると、0 以外の値が返ります。

ユーザー名 = GetUserNameCode（）

使用例

X = GetUserNameCode（）

'
'[ユーザー名を取得]
'
'■ 引数:なし
'□ 戻り値:ユーザー名
Public Function GetUserNameCode() As String
   Dim UserNameBuf As String * 128
   Dim UserNameLen As Long
   Dim ret As Long
   ' ユーザー名の長さを設定
   UserNameLen = Len(UserNameBuf)
   ' ユーザー名を取得
   ret = GetUserName(UserNameBuf, UserNameLen)
   ' ユーザー名
   GetUserNameCode = Left(UserNameBuf, InStr(UserNameBuf, vbNullChar) - 1)
End Function

TOP

マウスポインタを非表示/表示にする

使用API

'[マウスポインタを非表示/表示にする]
Private Declare Function ShowCursor Lib "user32" _
(ByVal fShow As Integer) As Integer

fShow
マウスカーソルの内部的な表示カウントを増やすか減らすかを指定します。

表示カウントが 0 未満のとき、マウスカーソルは表示されません。
表示カウント 0 以上のとき、マウスカーソルは表示されます。

ユーザー名 = ShowMousePointerCursor（表示するか？）

使用例

call ShowMousePointerCursor（False） '非表示にする。

'
'[マウスポインタを非表示/表示にする]
'
'■ 引数
'ShowType:表示するか？(True = 表示　，　False =非表示)
'□ 戻り値なし
Public Sub ShowMousePointerCursor(ByVal ShowType As Boolean)
Call ShowCursor (Abs(ShowType))
End Sub

TOP

フォームを最大化(タイトルとコントロールボックスは非表示)

使用API

'[ウィンドウ操作]
Public Const SWP_SHOWWINDOW = &H40 'ウィンドウを表示します。
Public Const HWND_TOPMOST = -1& 'ウィンドウを最前面にします。

Private 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

hwnd
ウィンドウのハンドルを指定
hWndInsertAfter
hWnd で指定したウィンドウに先行するウィンドウのハンドルを指定
x，y
ウィンドウの左上隅の新しい x ，ｙ座標を指定します。
cx，cy
ウィンドウの新しい幅、高さをピクセル単位で指定します。
wFlags
ウィンドウのサイズおよび位置の変更に関するフラグを指定します

関数が成功すると、0 以外の値が返ります。

ユーザー名 = ScreenWindowPosMAX（ウィンドウハンドル）

使用例

call ScreenWindowPosMAX（me.hWnd）

'
'[フォームを最大化(タイトルとコントロールボックスは非表示)]
'
'■ 引数
'FormhWnd:ウィンドウハンドルを指定
'□ 戻り値なし
Public Sub ScreenWindowPosMAX(ByRef FormhWnd As Long)
   With Screen
      SetWindowPos FormhWnd, _
                           HWND_TOPMOST, 0, 0, _
                           .Width \ .TwipsPerPixelX, _
                           .Height \ .TwipsPerPixelY, _
                           SWP_SHOWWINDOW
   End With
End Sub

TOP