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 SubExit 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 AccessNz関数を 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

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

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

年齢計算関数

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

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

月末日取得関数

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

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

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

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

MaxLength2 としていても、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