ぜんこうさん.com

2009年06月27日

テーブルのリンク／再リンク

別のデータベース(mdbファイル)にあるテーブルをリンクしたり、リンク済テーブルを再リンクするためのプロシージャです。

再リンクは、インストール先のディレクトリが変わった場合などに使えます。

relink.txt


' @(f)
'
' 機能      : テーブル リンク
'
' 引き数    : ARG1 - Databaseオブジェクト
'             ARG2 - ソーステーブル名
'             ARG3 - リンク元D/B名
'             ARG4 - リンク元D/Bパスワード ... 省略可
'             ARG5 - テーブル名 ... 省略可(省略時 ARG2)
'
' 機能説明  : ARG3(Database)の ARG2テーブルを ARG1(Database)にリンクする
'
' 備考      :
'
Public Sub pLinkTable(db As DAO.Database, _
                      ByVal strSourceTableName As String, _
                      ByVal strOriginalDbName As String, _
                      Optional ByVal vPassword As Variant, _
                      Optional ByVal strTableName As String = "")
    Dim strConnect  As String
    Dim td          As DAO.TableDef
    
    strConnect = ";DATABASE=" & strOriginalDbName
    If Not IsMissing(vPassword) Then
        strConnect = strConnect & ";PWD=" & vPassword
    End If
    
    If strTableName = "" Then strTableName = strSourceTableName
    
    For Each td In db.TableDefs
        '' Table Exist
        If UCase(td.Name) = UCase(strTableName) Then
            If UCase(td.SourceTableName) <> UCase(strSourceTableName) Then
                db.TableDefs.Delete strTableName
                db.TableDefs.Refresh
                Exit For
            End If
            If UCase(td.Connect) <> UCase(strConnect) Then
                td.Connect = strConnect
                td.RefreshLink
            End If
            Exit Sub
        End If
    Next td
    
    '' Link Table Create
    Set td = db.CreateTableDef(strTableName)
    With td
        .SourceTableName = strSourceTableName
        .Connect = strConnect
    End With
    db.TableDefs.Append td
    db.TableDefs.Refresh
    
    Set td = Nothing
End Sub

posted by ぜんこう at 15:10| Comment(0) | Microsoft Access 2000

データベースまたはオブジェクトは読み取り専用であるため、更新できません。

テキストファイルのインポートしようとすると「データベースまたはオブジェクトは読み取り専用であるため、更新できません。」というエラーになる場合があります。

この問題は、Jet 4.0 の Text IISAM ににおけるセキュリティ上の弱点に対応したために、特定の拡張子のファイルしかアクセスできないようにしたためです。

詳しくは Microsoft のサポート技術情報の

Jet 4.0 の Text IISAM によりシステムファイルに行を付加できる

[ACC2000]ファイルのインポート/エクスポートで '読み取り専用' のエラーが発生する

をご覧下さい。

posted by ぜんこう at 15:05| Comment(0) | Microsoft Access 2000

プリンタの列挙

実行するパソコンに設定されているプリンタ、および、そのプリンタが有する給紙方法をフォーム上のコンボボックスに列挙するサンプルです。

Access2000で作成してありますが、コンボボックスへの編集部分を書き直せば VB でも流用できます。

printer.zip

VB でも使えるかもしれません。

posted by ぜんこう at 15:00| Comment(0) | Microsoft Access 2000

実行時エラー '10': この配列は固定されているか、または一時的にロックされています

VB6で作成した exeファイルで、上記のようなエラーが出たことがありました。困ったことにプロジェクトを開いてデバッグしても発生しませんでした。

インターネットで検索をしてみたら、あるサイトに貴重な記載がありました（勝手にリンクしちゃってます ^^;）。

それによると（僕も実際確認しましたが）、ネイティブコンパイルした場合のみ発生する事象のようで、P-Codeコンパイルでは発生しません。

そのサイトに書かれていたように、With ～ End With の中にある Exit Sub や Exit Function など、End With が実行されないようなステートメントがあったのを、全てEnd With が実行されるようにしたら、エラーは発生しなくなりました。

VB に限らず VBA でも With を実行して End With が実行されないようなことがないようにしましょう。


    With なんちゃら
        If 条件 Then
            Exit Sub       ' ← コレはダメ～！
        End If
    End With

もし何か正式な情報をお持ちの方が居ましたら、教えて下さい。

posted by ぜんこう at 14:53| Comment(0) | Visual Basic 6.0(VB6)

文字列の固定長編集関数

全半角混在の文字列を固定長テキストファイルへ出力する時に、空白などを埋めるのが面倒だと感じたことありませんか？

昔のように(?)、半角は 1バイト、全角は 2バイトと計算し、編集するバイト長を与えて固定長文字列を編集する関数を作成しました。

下記ソース中の pAsciiLenB、pAsciiRightB、pAsciiLeftB は「バイト数を用いる文字列関数」をごらん下さい。

また pNzも末尾に書いてありますが、このプロシージャは Microsoft Access の Nz関数を VBで使用できるように作成したものです。

fix_string.txt


'' (文字列固定長編集用)文字詰方向
Public Enum Enum_EDITFIXSTRING_DIRECTION
    EDITFIXSTRING_DIRECTION_LEFT            ''' 左詰
    EDITFIXSTRING_DIRECTION_RIGHT           ''' 右詰
End Enum


' @(f)
'
' 機能      : 文字列固定長編集
'
' 返り値    : 編集後の文字列
'
' 引き数    : ARG1 - 文字列
'             ARG2 - 編集後の文字長 ... ASCIIでのバイト長
'             ARG3 - 文字詰方向 ... "R" - 右詰, 左記以外 - 左詰(規定値)
'             ARG4 - 付加する文字 ... 規定値 " "
'
' 機能説明  : 文字列を与えられた文字長に左詰または右詰し、
'             残りの文字数を付加文字で埋める。
'
' 備考      :
'
Public Function pEditFixString(ByVal varValue As Variant, _
    ByVal intLength As Integer, _
    Optional ByVal enmDirection As Enum_EDITFIXSTRING_DIRECTION _
        = EDITFIXSTRING_DIRECTION_LEFT, _
    Optional ByVal strFillChar As String = " ") As String
    Dim strWk       As String
    Dim intWkLen    As Integer
    
    strWk = pNz(varValue, ""): intWkLen = pAsciiLenB(strWk)
    If intWkLen < intLength Then
        If enmDirection = EDITFIXSTRING_DIRECTION_RIGHT Then
            pEditFixString = _
                pAsciiRightB(String(intLength, strFillChar) & strWk, _
                            intLength)
        Else
            pEditFixString = _
                pAsciiLeftB(strWk & String(intLength, strFillChar), _
                            intLength)
        End If
    ElseIf intWkLen = intLength Then
        pEditFixString = strWk
    Else
        If enmDirection = EDITFIXSTRING_DIRECTION_RIGHT Then
            pEditFixString = pAsciiRightB(strWk, intLength)
        Else
            pEditFixString = pAsciiLeftB(strWk, intLength)
        End If
    End If
End Function


' @(f)
'
' 機能　　　: Nullの場合の値変更
'
' 返り値    : 元の値が Null の時は 初期値 を返し、
'             Null以外の時は 元の値 を返す。
'
' 引き数　　: ARG1 - 元の値
'             ARG2 - 初期値(Nullの場合に返す値)
'
' 機能説明　: Null値の置き換え。
'
' 備考　　　:
'
Public Function pNz(ByVal varOriginalValue As Variant, _
                    ByVal varInitValue As Variant) As Variant
    If IsNull(varOriginalValue) Then
        pNz = varInitValue
    Else
        pNz = varOriginalValue
    End If
End Function

posted by ぜんこう at 14:50| Comment(0) | Visual Basic 6.0(VB6)/Visual Basic for Application(VBA)

バイト数を用いる文字列関数

VB や VBA の文字列関数である Left、Len、Mid、Right は全角文字でも半角文字でも 1文字と計算されてしまいます。

昔のように(?)、半角は 1バイト、全角は 2バイトとなる関数が欲しいと思ったことはないでしょうか？

例えば、全半角混在の固定長テキストファイルからある一部分(mバイト目から長さ nバイト)を切り出すようなことってありませんか？

StrConv関数を組み合わせているだけなんですが、通常の Left、Len、Mid、Right のような感覚で使える関数が欲しいと思って作成しました。

※全角途中指定時の補正を行う改造版をこちらに公開しています。

ascii_string.txt


' @(f)
'
' 機能      : ASCIIでのLeftB
'
' 返り値    : 文字列
'
' 引き数    : ARG1 - 文字列(Unicode)
'             ARG2 - (ASCIIでの)文字列長
'
' 機能説明  : 文字列の左端からASCIIコードでのバイト数分の文字列を返す。
'
' 備考      :
'
Public Function pAsciiLeftB(ByVal strValue As String, _
                            ByVal intLength As Integer) As String
    pAsciiLeftB = StrConv(LeftB(StrConv(strValue, vbFromUnicode), _
                                intLength), vbUnicode)
End Function


' @(f)
'
' 機能      : ASCIIバイト長取得
'
' 返り値    : バイト長
'
' 引き数    : ARG1 - 文字列(Unicode)
'
' 機能説明  : ASCIIコードでのバイト長を返す。
'
' 備考      :
'
Public Function pAsciiLenB(ByVal strValue As String) As Integer
    pAsciiLenB = LenB(StrConv(strValue, vbFromUnicode))
End Function


' @(f)
'
' 機能      : ASCIIでのMidB
'
' 返り値    : 文字列
'
' 引き数    : ARG1 - 文字列(Unicode)
'             ARG2 - (ASCIIでの)開始位置
'             ARG3 - (ASCIIでの)文字列長(省略可)
'
' 機能説明  : 文字列のASCIIコードでの開始位置からバイト数分の文字列を返す。
'
' 備考      :
'
Public Function pAsciiMidB(ByVal strValue As String, _
                           ByVal intStart As Integer, _
                           Optional ByVal varLength As Variant) As String
    If IsMissing(varLength) Then
        pAsciiMidB = StrConv(MidB(StrConv(strValue, vbFromUnicode), _
                                    intStart), vbUnicode)
    Else
        pAsciiMidB = StrConv(MidB(StrConv(strValue, vbFromUnicode), _
                                    intStart, varLength), vbUnicode)
    End If
End Function


' @(f)
'
' 機能      : ASCIIでのRightB
'
' 返り値    : 文字列
'
' 引き数    : ARG1 - 文字列(Unicode)
'             ARG2 - (ASCIIでの)文字列長
'
' 機能説明  : 文字列の右端からASCIIコードでのバイト数分の文字列を返す。
'
' 備考      :
'
Public Function pAsciiRightB(ByVal strValue As String, _
                             ByVal intLength As Integer) As String
    pAsciiRightB = StrConv(RightB(StrConv(strValue, vbFromUnicode), _
                                    intLength), vbUnicode)
End Function

posted by ぜんこう at 14:46| Comment(11) | Visual Basic 6.0(VB6)/Visual Basic for Application(VBA)

年齢計算関数

年齢を計算する関数を僕なりに作成したものです。

age.txt


' @(f)
'
' 機能      : 年齢 取得
'
' 返り値    : 年齢
'
' 引き数    : ARG1 - 生年月日
'             ARG2 - 算出基準日
'
' 機能説明  : 年齢を計算・取得する。
'
' 備考      :
'
Public Function pGetAge(ByVal varBirthday As Variant, _
                        ByVal dtBaseYmd As Date) As Integer
    If IsDate(varBirthday) Then
        If Month(dtBaseYmd) * 100 + Day(dtBaseYmd) _
           < Month(CDate(varBirthday)) * 100 + Day(CDate(varBirthday)) Then
            pGetAge = DateDiff("yyyy", varBirthday, dtBaseYmd) - 1
        Else
            pGetAge = DateDiff("yyyy", varBirthday, dtBaseYmd)
        End If
    Else
        pGetAge = 0
    End If
End Function

posted by ぜんこう at 14:43| Comment(0) | Visual Basic 6.0(VB6)/Visual Basic for Application(VBA)

月末日取得関数

月末日を取得する関数を僕なりに作成したものです（関数にするほどでもないか？）。

lastday.txt


' @(f)
'
' 機能　　　: 月末日取得
'
' 返り値　　: 指定された年、月の月末日
'
' 引き数　　: ARG1 - 年
'　　　　     ARG2 - 月
'
' 機能説明　: 月末日を算出する
'
' 備考　　　:
'
Public Function pGetLastDay(ByVal intY As Integer, _
                            ByVal intM As Integer) As Date
    pGetLastDay = DateSerial(intY, intM + 1, 1) - 1
End Function

posted by ぜんこう at 14:42| Comment(0) | Visual Basic 6.0(VB6)/Visual Basic for Application(VBA)

テキストボックス(TextBox)の MaxLength をバイト数で指定する

テキストボックス(TextBox)の MaxLengthプロパティの値が、VB5 になって、バイト数から文字数に変更されました。

MaxLengthに 2 としていても、VB4 までは半角だと「AB」というふうに 2文字、全角だと「あ」というふうに 1文字しか入力できなかったのですが、VB5 からは全角でも「あい」というふうに 2文字(4バイト)入力できるようになりました。

入力した文字列の長さの制限を文字数ではなくバイト数で行う場面はかなりあると思います。

以下のコードを Form_Loadイベントに書けば、バイト数で制限することが可能になります。必要に応じて Form内の全テキストボックスに適用するように書き換えてもいいと思います。

maxlength.txt


Private Const EM_LIMITTEXT          As Long = &HC5

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                                (ByVal hWnd As Long, ByVal wMsg As Long, _
                                 ByVal wParam As Long, lParam As Any) As Long

Private Sub Form_Load()

    (中略)

    With テキストボックス
        If .MaxLength <> 0 Then
            Call SendMessage(.hWnd, EM_LIMITTEXT, .MaxLength, 0)
            .MaxLength = 0
        End If
    End With

    (中略)

End Sub

posted by ぜんこう at 14:31| Comment(0) | Visual Basic 6.0(VB6)

ドライブの列挙とドライブの種類

ドライブを列挙するプロシージャと、ドライブの種類を取得するプロシージャです。

drive.txt


'' ドライブ調査用
''' 判断不能
Public Const DRIVE_NODETERMINE_DRIVETYPE    As Long = 0
''' ルートディレクトリなし
Public Const DRIVE_NOEXIST_ROOTDIRECTORY    As Long = 1
''' 取り外し可能
Public Const DRIVE_REMOVABLE                As Long = 2
''' 固定
Public Const DRIVE_FIXED                    As Long = 3
''' ネットワーク
Public Const DRIVE_REMOTE                   As Long = 4
''' CD-ROM
Public Const DRIVE_CDROM                    As Long = 5
''' RAMディスク
Public Const DRIVE_RAMDISK                  As Long = 6

Private Declare Function GetLogicalDriveStrings Lib "kernel32.dll" _
                        Alias "GetLogicalDriveStringsA" _
                                    (ByVal nBufferLength As Long, _
                                     ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" _
                            Alias "GetDriveTypeA" _
                                    (ByVal nDrive As String) As Long


' @(f)
'
' 機能      : ドライブ 取得
'
' 返り値    : ドライブの文字の配列 (異常時は Null)
'
' 機能説明  : ドライブを取得しVariant配列にして返す。
'
' 備考      :
'
Public Function pGetDrives() As Variant
    Dim strBuffer   As String * 256
    Dim strDrives   As String
    
    Call GetLogicalDriveStrings(Len(strBuffer), strBuffer)
    strDrives = pGetStringFromAPI(strBuffer, String$(2, vbNullChar))
    If strDrives = vbNullChar Or strDrives = "" Then
        pGetDrives = Null
    Else
        pGetDrives = Split(strDrives, vbNullChar)
    End If
End Function


' @(f)
'
' 機能      : ドライブ種類取得
'
' 返り値    : ドライブの種類 (上記 Public Const 参照)
'
' 機能説明  : ドライブの種類を返す。
'
' 備考      :
'
Public Function pGetDriveType(ByVal strDrive As String)
    pGetDriveType = GetDriveType(strDrive)
End Function


' @(f)
'
' 機能　　　: APIの引数からの文字列取得
'
' 返り値　　: 取得した文字列
'
' 引き数　　: ARG1 - APIの引数の文字列
'             ARG2 - 終端の文字 ... 既定値 vbNullChar
'
' 機能説明　: APIの引数で使用される文字列(Null文字が終端の固定長)から
'             Accessで使用する文字列(可変長)を取得する
'
' 備考　　　:
'
Public Function pGetStringFromAPI(strApiString As String, _
                Optional ByVal strEndChar As String = vbNullChar) As String
    Dim intPos      As Integer

    intPos = InStr(1, strApiString, strEndChar)
    If intPos > 0 Then
        pGetStringFromAPI = Left(strApiString, intPos - 1)
    Else
        pGetStringFromAPI = strApiString
    End If
End Function

posted by ぜんこう at 14:24| Comment(0) | Visual Basic 6.0(VB6)/Visual Basic for Application(VBA)

<<前の10件 1 2 3 4 5 次の10件>>