VB6編、Sampleのインデックス

VB Tips And Sample(HOME)

ちょっとしたこと データベース関係 コントロール関係 リリースする前に

自分の居場所を知る関数
自分の居場所というのは、EXEがいるフォルダなりファイルへのパスを取得することで知ることが出来ます。 アプリケーションの各種設定をテキストファイルに保存し、次回起動時にはそこから読み込んで起動させる ということが必要になってきます。その時そのテキストファイルはEXEがある場所にしなければいけませんが、 アプリケーションをインストール人によってまた、PCの環境によってEXEの場所はさまざまです。そんな時 EXEの場所を取得する関数が

App.Path


というものです。探すときに何だったっけ?と思わないようにこんなものも標準モジュールに置いておくと便利です。 とにかくよく使う関数は「標準モジュール」まとめておきましょう!!

IEを起動させる
 アプリケーションからIEを起動させるには、

Private Sub Command1_Click()
    Dim v
           'exeのある場所を指定                       表示方法を指定
    v = Shell("C:\Program Files\Internet Explorer\IEXPLORE.EXE", vbNormalFocus)
End Sub


とします。NTや2000などOSによってEXEの場所が違うことに注意してください。そういう場合を考えて Formに「WebBrowser」(インターネットコントロール)コントロールを追加して、

Private Sub Command1_Click()
    WebBrowser1.navigate "http://www22.0038.net/~sanjyuiti/"
End Sub


とやってしまう方法などがあります。
 もう一つ
Private Sub Command1_Click()

Dim ob As Object
Set ob = CreateObject("InternetExplorer.application")
ob.navigate "http://www22.0038.net/~sanjyuiti/"
ob.Visible = True
Set ob = Nothing

End Sub


てな方法もあります。いろいろ使い分けてください。

WebBrowserのメソッド
 WebBrowserのヘルプファイルは確かWIN98のCD-ROMの中にあります。
持ってない人は友達に分けてもらってください。こういうところがマイクロソフトって謎なんですよね。プログラマー泣かせでもあります。
 さて、そのWebBrowserで、よく使うのがプリントプレビューのメソッドです。

Private Sub Command1_Click()
   '印刷プレビュー
   WebBrowser1.ExecWB OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT
End Sub


この他にも、「ExecWB」の後にインテリセンスが出てきますので参考にすることが出来ます。

文字列の中の空白を削除する
 TirmやRtrim、LTrimは便利な空白スペース削除関数ですが、文字列の中のスペースを削除するには

Private Sub Command1_Click()
   Text1.Text = Replace(Text1.Text, " ", "")
   Text1.Text = Replace(Text1.Text, " ", "")
End Sub


とします。気をつけたいのが、半角スペースと全角スペースを両方処理することです。でないと、消えない?と悩むことになります。

Accessの操作などにはDAOを使う
 Accessの操作、例えばmdb間でのテーブルのリンク、テーブルのエクスポート等には、DAOが便利です。 でも、DAOのヘルプがなんかMSDNでは調べにくいし、見難いです。そこでですが、「プロジェクト」−「参照設定」 で、マイクロソフトDAO3.6オブジェクトライブラリを設定してから、コードに

Dim db As DAO.Database


と書いて、Databaseの中にカーソルを入れてF1キーを押してみてください。すると、複数の候補が出てくるので DAOを選びます。するとDAO3.6.CHMが開きます。CHMファイルはMSDNとは独立しているファイルのはずなので 「.CHM」で適当に検索しても見ることが出来ます。検索すると沢山のファイルが出てきます。適当にショートカットを作っておけば、いつでも見られるというわけです。
 ちなみに、サンプルも豊富ですので結構重宝します。他にも有効な.CHMを探しておくのもよいかと思います。結構面白い情報があるとおもいます。

.CHMとは?
 先ほど出てきたCHMですが、自分で作ることも出来ます。詳細はご自分のPCの「htmlhelp.chm」を広げてみて下さい。
自作アプリのヘルプが簡単に出来ます。また、フリーの使い勝手のよいヘルプ作成アプリケーションもネットに転がっていますので私はよく使わせてもらっています。
 また、「KeiYu HelpLab」分かりやすくかつ詳しく解説されているホームページもあります。
 こちらに簡単にCHMを作成できるソフト「ヘルプましん」 が紹介されています。


SQL構文を調べるには?
 コードで

select


と書いてカーソルを合わせてF1キーを押してみてください。VB、とVBAの選択でVBを選べば、「Jet SQLリファレンス」 が開きます。ちょっとしたSQL文など使用例もありますので、役立つと思います。  

アイコンの作り方
 アプリケーションを自作した後,、オリジナルなアイコンを使いたいものです。
 フリー、シェアでも沢山のアイコンがネットにはありますが、自分でも作りたいものです。
 作成方法は簡単です。
 ビジュアルスタジオの二枚目のCD−ROMの中の何処だったかに「IMAGEDIT.EXE 」というファイルがあります。これガあるフォルダごとPCにコピーして、起動させるとイメージエディタが立ち上がります。
「フェイル」−「新規作成」-「アイコン」-「VGA」でマス目がいっぱいのエディタ画面が現われます。お好みの絵や文字を書き込んで保存すれば出来あがり!。
 とっても簡単に出来ます。シェアでなんて勿体無いです。と思うのは私だけか?


文字アイコンの作り方
   絵は何とか描けるが文字となると、とたんに苛立ちが出てきます。
 でも、方法が分かれば簡単です。その方法とは、
「ワードで好きな文字を好きな書体で書く」−「コピーしてペイントへ貼り付ける」−「ペイントからコピーしてイメージエディタへ貼り付ける」で、OK!
 後は色をつけたり変えたり。ディスクトップに文字アイコンの出現!
 文字アイコン

VBのソースをHTML化するサンプルコード

 フォームにボタン2つ、テキストボックス1つ、コモンダイアログボックスを1つ貼り付けて以下のコードを書いて実行。  因みに以下のHtmlはこのツールでコンバートしたものにちょっと手を加えたもの。

Private Sub Command1_Click()
  'ファイルを開く
On Error GoTo ErrHandler

’コモンダイアログボックス
     CommonDialog1.CancelError = True
     CommonDialog1.Filter = "すべてのファイル (*.*)|*.*|" _
     & "テキスト ファイル (*.txt)|*.txt|バッチ ファイル (*.bat)|*.bat"
     CommonDialog1.FilterIndex = 2
     CommonDialog1.ShowOpen
     Text1.Text = CommonDialog1.FileName
Exit Sub
ErrHandler:
  ' ユーザーが [キャンセル] ボタンをクリックしました。
End Sub

Private Sub Command2_Click()
     If Text1.Text <> "" Then
        Dim intFNo As Integer
        intFNo = FreeFile
        
        Dim Readline As String
        Dim stKakou As String
        
        Open Text1.Text For Input As #intFNo
        
’ファイル読み込み
                Do Until EOF(intFNo)
                    
                    Line Input #intFNo, Readline
                    stKakou = stKakou & vbCrLf & Readline
                Loop
        
        Close #intFNo
        
     Else
       Exit Sub
       
     End If
     
    Debug.Print stKakou
’自作関数へ処理を飛ばす
    stKakou = HtmlKakou(stKakou)
    
        intFNo = FreeFile
’ファイル書き込み
       Open Text1.Text For Output As #intFNo
          Print #intFNo, stKakou
       Close #intFNo
     MsgBox "加工終了", vbInformation, App.Title
End Sub

Private Function HtmlKakou(ByVal Moji As String) As String
'VBソースをHTML形式に書き換える
'全角スペースに変換
  Moji = Replace(Moji, " ", " ")
'HTMLタグの<>を<>全角に置き換える
 Moji = Replace(Moji, "<", "<")
 Moji = Replace(Moji, ">", ">")

'改行記号をタグと改行記号に置き換え
  Moji = Replace(Moji, vbCrLf, "<br>" & vbCrLf)
  
  
'コメント箇所を色タグで囲む
  Dim LoKomeHjime As Long: LoKomeHjime = 1
  Dim LoKomeOwari As Long
  
        Do
          LoKomeHjime = InStr(LoKomeHjime, Moji, "'")
            If LoKomeHjime = 0 Then
               Exit Do
            End If
          LoKomeOwari = InStr(LoKomeHjime + 1, Moji, vbCrLf)
             Moji = Left(Moji, LoKomeHjime) & "<font color=" & """" & "#008040" & """" & ">" & Mid(Moji, LoKomeHjime + 1, LoKomeOwari - LoKomeHjime) & "</font>" & Mid(Moji, LoKomeOwari)
        
          LoKomeHjime = LoKomeOwari
        Loop Until LoKomeHjime = 0
  
  Debug.Print Moji
'テーブルタグで囲む

VBコードから「”」を書き込む
  Moji = "<table bgcolor=" & """" & "#fdfeed" & """" & " width=" & """" & "100%" & """" & " cellspacing=" & """" & "2" & """" & "><tr><td>" & Moji & "<br><br></td></tr></table><br>"
  

  
  HtmlKakou = Moji
End Function




オブジェクトの参照渡しと値渡し
set = nothingの実行内容検分



Private Sub Command1_Click()
'ちょっと正確には解らないけれど、コントロールオブジェクトの場合アドレスが渡されるようです。
つまり、メモリ上の場所というわけ。MSDNでは参照渡しのほうが紹介されていました。CやC++のポインタ的なもの。多分。因みに参照渡しのほうが早いとのこと。
    Debug.Print ObjPtr(Me.RichTextBox1); "オブジェクトのアドレス"
    Call 参照渡し(Me.RichTextBox1)
    Call 値渡し(Me.RichTextBox1)
    
    End
    
End Sub
Option Explicit



Public Sub 参照渡し(ByRef Ob As RichTextBox)
    Ob.Text = "参照渡し"
    Ob.Left = Form1.ScaleWidth - Ob.Width
    Debug.Print Ob.Name
    Debug.Print VarPtr(Ob); "変数のアドレス"
    Debug.Print ObjPtr(Ob); "オブジェクトのアドレス"
    
    If Not Ob Is Nothing Then
      Set Ob = Nothing 'ただ単に参照を止めているだけの話 とうか処理である。
      MsgBox ""
    End If
       
    Debug.Print VarPtr(Ob); "変数のアドレス"
    Debug.Print ObjPtr(Ob); "オブジェクトのアドレス"
End Sub
Public Sub 値渡し(ByVal Ob As RichTextBox)
    Ob.Text = "値渡し"
    Ob.Left = 0
    Debug.Print Ob.Name
    
    Debug.Print VarPtr(Ob); "変数のアドレス"
    Debug.Print ObjPtr(Ob); "オブジェクトのアドレス" '参照渡しと 同じオブジェクトアドレスを参照している
End Sub


'AddressOf 関数のアドレスを得る演算子
'VarPtr() 変数のアドレスを得る関数
'StrPtr() 文字列のアドレスを得る関数
'ObjPtr() オブジェクトのアドレスを得る関数

'Hex


デバックの結果
 24551344 オブジェクトのアドレス
RichTextBox1
 8387028 変数のアドレス
 24551344 オブジェクトのアドレス
 8387028 変数のアドレス
 0 オブジェクトのアドレス
RichTextBox1
 8386872 変数のアドレス
 24551344 オブジェクトのアドレス


リッチテキストボックスのテキストの検索、色付け


’とにかく InStr(lngKoko, Rich2.Text, "検索文字")が味噌。これでかなり早くなります。
 Dim lngKoko as Long      
 lngKoko=1か0
 Do    
   lngKoko = InStr(lngKoko, Rich2.Text, "検索文字")
                                                          
     If lngKoko = 0 Then
         Exit Do
      Else
        Rich2.SelStart = lngKoko - 1
        Rich2.SelLength = Len("検索文字")
        Rich2.SelColor = RGB(255, 0, 0) 
                                                               
       lngKoko = lngKoko + Len("検索文字")
      end if
 Loop Until lngKoko=0



Accessの2つのセキュリティー それぞれの接続方法。 ユーザー追加方法など


Private Sub Command1_Click()

On Error GoTo SOS

'データベースパスワード時の接続
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "User ID=admin;" _
& "Data Source=C:\db1.mdb;" _
& "Jet OLEDB:Database Password=123;" _
& "Persist Security Info=False"
cn.Open
cn.Close

'-----------------------------------------------------------------------------------------------
'ユーザーやグループごとにデータベースオブジェクト操作にたいする権限設定時
Dim cnn As New ADODB.Connection
cnn.Provider = "Microsoft.Jet.OLEDB.4.0;"
cnn.Properties("Jet OLEDB:System database") = "C:\Program Files\Common Files\System\SYSTEM.MDW"
cnn.Open "Data Source=\db2.mdb", "matu", "2", adConnectUnspecified
cnn.Close
         
MsgBox "成功"
         Exit Sub
SOS:
MsgBox Err.Description

End Sub

'因みにVBからAccessのユザー、権限などを設定するには「ADOX」を使用します。
具体的にはMSDNライブラリで「SYSTEM.MDW」を検索してみて下さい。
サンプルコードもきちんと載っています。


二分探索アルゴルズム[VB]

完全な例はダウンロードコーナーからダウンロードできます。

Private Function BSearch(ByVal kenmoji As String) As Long
' バイナリ検索

Dim FileNum As Integer
Dim Position As Long
Dim strR As yName 'ユーザー定義型 40バイト

Dim stmoji As String

' 次に使用可能なファイル番号を取得します。
FileNum = FreeFile
Position = 1

Dim low As Long, hei As Long
low = 1
hei = 47


' ファイルを Open ステートメントで開きます。
Open App.Path & "\都道府県1.dat" For Random As #FileNum Len = Len(strR)
 
 
Do Until low > hei
   Position = (low + hei) / 2
 
   'データの読み込み
   Get #FileNum, Position, strR
   
   'Debug.Print strR.oneline
   Dim stkana As String 'カタカナを入れる
   Dim intIti As String '数字を入れる
   
   Dim ArryH() As String
   ArryH = Split(strR.oneline, " ")
   stkana = ArryH(0)
   
   
   If Left(stkana, Len(kenmoji)) = kenmoji Then
    '一致すれば
   
        Dim i As Integer
        Do
             i = i + 1
             intIti = ArryH(i)
        Loop Until ArryH(i) <> ""
        Close #FileNum
        BSearch = intIti '位置を返す
        Exit Function
   End If
   
   If Left(stkana, Len(kenmoji)) > kenmoji Then
     hei = Position - 1
   Else
     low = Position + 1
   End If
Loop
   
Close #FileNum
    
BSearch = 0 '見つからない

    
End Function


二分探索アルゴルズム[C]

C言語版で使用している「都道府県1.dat」「都道府県1.dat」ファイルはVBで作成したものです。ダウンロードコーナーのVB版の中に入っています。

#include <stdio.h>
#include <string.h>//strlenに必要
#include <stdlib.h>//文字列を整数に変換して返す

/*最初の検索結果から位置情報を抜き出して返す関数*/
int itinuki(char *kekka);

int main(void)
{
FILE *fp;
int stlen;//検索文字数
int low =0;
int hei=49;
int posi=0;//検索位置
char str[100];//100文字
char hstr[100];//検索した文字のうち、検索文字数ぶん入れる


fp=fopen("都道府県1.dat","rb");
if (fp==NULL){
printf("ファイルを開けませんでした\n");
return 1;
}
else{
printf("ファイルをオープンしました。\n検索文字を入力してください\n");

int ret=1;//比較した結果が入る
char ken[10];
scanf("%s",ken);//検索文字を入力  alt+半角/全角で日本語入力可能
stlen=strlen(ken);//検索文字の長さを取得
/*検索*/
while(low<=hei){
posi=(low+hei)/2;
fseek(fp,posi*40,SEEK_SET);
    fread(str,40,1,fp);
for (int i=0;i<=stlen;i++){
hstr[i]=str[i];
}
hstr[i]='\0';//これを入れておかないと意味不明になる
ret=strncmp(ken,hstr,stlen);//検索したものと、比較
if(ret<0){
hei=posi-1;
}else if(ret>0){
low=posi+1;
}else if(ret==0){
//ヒットすれば表示する
printf("%s\n",str);
int iti;
iti=itinuki(str);

FILE *ofp;
char strLast[100];
ofp=fopen("都道府県.dat","rb");
if (ofp==NULL){
printf("ファイルを開けませんでした\n");
return 1;
}else{
iti--;//VBでの位置なので1つ引いておく。
fseek(ofp,iti*50,SEEK_SET);
fread(strLast,50,1,ofp);
printf("%s\n",strLast);
fclose(ofp);
}

fclose(fp);
return 0;
}
} 
printf("該当なし\n");
}

fclose(fp);
return 0;

}



int itinuki(char *kekka){
char ret[100];
int flg=3;
while(*kekka!='\0'){
if((*kekka==' ') && (flg==3)){
flg=0;
}
if(((flg==0) || (flg==1)) && (*kekka!=' ')){
ret[flg]=*kekka;
flg++;
}
*kekka++;
}
return atoi(ret);//文字列を整数に変換して返す
}


ADO接続、DAO接続 クラスの基本


Option Explicit

Private rsDAO As DAO.Recordset
Private wks As DAO.Workspace
Private db As DAO.Database

Private rsADO As ADODB.Recordset
Private cone As ADODB.Connection
'プロパティ値を保持するためのローカル変数。
Private mvardbPath As String 'ローカル コピー
'プロパティ値を保持するためのローカル変数。
Private mvarAdoConeStr As String 'ローカル コピー

Public Property Let AdoConeStr(ByVal vData As String)
'プロパティに値を代入するときに、代入式の左辺で使用します。
'Syntax: X.AdoConeStr = 5
    mvarAdoConeStr = vData
End Property


Public Property Get AdoConeStr() As String
'プロパティの値を取得するときに、代入式の右辺で使用します。
'Syntax: Debug.Print X.AdoConeStr
    AdoConeStr = mvarAdoConeStr
End Property




Public Property Let dbPath(ByVal vData As String)
'プロパティに値を代入するときに、代入式の左辺で使用します。
'Syntax: X.dbPath = 5
    mvardbPath = vData
End Property


Public Property Get dbPath() As String
'プロパティの値を取得するときに、代入式の右辺で使用します。
'Syntax: Debug.Print X.dbPath
    dbPath = mvardbPath
End Property





Public Function DaoOpenRecordset(ByVal strSQL As String) As DAO.Recordset
'レコードセットを返します


'     Jet ワークスペース
'     Jet データベース接続を開きます。
    Set wks = CreateWorkspace("ma", "admin", "", dbUseJet)
   
    
    Dim prpLoop As Property
    
    With wks
        ' Jet ワークスペースの
        ' Properties コレクションを列挙します。
        Debug.Print _
            "Properties of unnamed Microsoft Jet workspace"
        On Error Resume Next
        For Each prpLoop In .Properties
            Debug.Print "    " & prpLoop.Name & " = " & prpLoop
        Next prpLoop
        On Error GoTo 0
    End With
    
   
    Set db = wks.OpenDatabase(mvardbPath)
    Set rsDAO = db.OpenRecordset(strSQL, dbOpenDynaset)
    If rsDAO.EOF = False Then
       rsDAO.MoveLast
       rsDAO.MoveFirst
    End If
    Set DaoOpenRecordset = rsDAO
    
End Function



Public Function ADOOpenRecordset(ByVal strSQL As String) As ADODB.Recordset


    Set cone = New ADODB.Connection
'    Debug.Print mvarAdoConeStr
    cone.ConnectionString = mvarAdoConeStr
    cone.Open
    Set rsADO = New ADODB.Recordset
    rsADO.Open strSQL, cone, adOpenStatic, adLockOptimistic
       Set ADOOpenRecordset = rsADO
End Function


Private Sub Class_Terminate()
On Error Resume Next

        rsDAO.Close
        Set rsDAO = Nothing
        db.Close
        Set db = Nothing
        wks.Close
        Set wks = Nothing
        
        rsADO.Close
        Set rsADO = Nothing
        cone.Close
        Set cone = Nothing
End Sub


データグリッドでの改行

Private Sub Command3_Click()
'ADOでデータベースに接続、検索する
'[プロジェクト]-[参照設定]でMicrosoft ActiveX 2.6を参照する
'サンプルのDBは[NWIND.MDB]の中の[Customers]テーブルを[db1.mdb]にインポートして使用

Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection


Dim str As String

'インスタンスを作成する
'NewとSetについてはここを参照して下さい。
'http://www7.big.or.jp/~pinball/discus/vb/56108.html
Set cn = New ADODB.Connection

cn.CursorLocation = adUseClient  'これを書かないとデータグリッドに放り込めません
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
             "Data Source=" & App.Path & "\db1.mdb;"
'コネクションを開いておいて
cn.Open

''こちらもコメントをはずして実行してみてください
'レコードセットを取得します こちらの場合はデータグリッドの設定はほとんど必要なし
'レコードセットを返さない時にもExecuteは使えます。削除、更新など とても便利です。
'Set rs = cn.Execute("SELECT * FROM Customers", , adCmdText)



'DBに改行された言葉があたらそのまま表示するには 例えば...
Set rs = cn.Execute("SELECT CustomerID,CompanyName,Country FROM Customers", , adCmdText)

'フィルター
rs.Filter = "Country = 'UK'"

'レコードセットから文字列として取得
str = rs.GetString(adClipString)

'一発で保存する
Open App.Path & "\Test.xls" For Output As #1
      Print #1, str
Close #1


'行を付け足して
DataGrid1.Columns.Add (2)

'DBで改行 されている場合、改行されたまま表示するには
'データグリッドでの改行表示の場合はこれを書く
'Accessでフィールド内に改行を入れるには[Ctrl]+[Enter]
'Excelでは[Alt]+[Enter]で改行できます
DataGrid1.Columns(0).Caption = "CustomerID"
DataGrid1.Columns(0).WrapText = True
DataGrid1.Columns(0).DataField = "CustomerID"
DataGrid1.Columns(1).Caption = "CompanyName"
DataGrid1.Columns(1).WrapText = True
DataGrid1.Columns(1).DataField = "CompanyName"
DataGrid1.Columns(2).Caption = "Country"
DataGrid1.Columns(2).WrapText = True
DataGrid1.Columns(2).DataField = "Country"

'データグリッドに表示
Set DataGrid1.DataSource = rs

'パフォーマンス 速度チェックには以下のAPIを使用する
Dim X, ti
ti = timeGetTime

'リストビューに表示する
ListView1.ListItems.Clear

Dim myli As ListItem
Do Until rs.EOF
    
    Set myli = ListView1.ListItems.Add()
    myli.Text = rs.Fields(0).Value
    myli.SubItems(1) = rs.Fields(1).Value
    rs.MoveNext

Loop


ti = timeGetTime - ti
Debug.Print ti

'作成したインスタンスを削除します ここで削除するとデータグリッドの表示が消える
'変数をフォームレベルにあげれば問題なし インスタンスの削除は必要な時に行う。
'rs.Close
'Set rs = Nothing
'cn.Close
'Set cn = Nothing

End Sub



VB Tips And Sample(HOME)