vb-oboegaki blog　ＶＢ開発者の覚書

WindowsＳｅｒｖｅｒのリスタート

Thu, 17 Sep 2009 11:13:53 +0900

'========================================
'WindowsServerのリスタート（リブート）を行います
'24H運転のサーバーで、データのバックアップを行った後に
'リスタート処理を行います。待ち受け処理をしているＰＲＧも
'あるので、メモリをクリーンにするためにも行っています。
'========================================
'いくつか方法があるようです。
'VBスクリプトによる方法
'IISによる方法
'プログラムによる方法
'　　この中で使用するＤＬＬは、「ＳＡＫ図書館」にある
'　　sakinfo.dll を使用します
'　　『sakif110.lzh 22,247 bytes』　検索してください。
'------------------------------------
01.VBスクリプトによる方法
　　'--------
　　ＲＥＳＴＡＲＴ.ＶＢＳを手に入れます。
　　以下のアドレスからダウンロードできるようです。
　　ftp://ftp.microsoft.com/reskit/win2000/restart.vbs
　　'--------
　　RESTART.VBSを　C:\　に登録します
　　（パスが通ればどこでもよいみたいです）
　　バッチファイルを作成します。
　　（ＲＥＳＴＡＲＴ.ＶＢＳと同じ場所に）
　　'-----
　　cscript c:\restart.vbs /S サーバー名 /R
　　'-----
　　このバッチファイルをタスクに設定して、動作を確認。
　　'======================
　　'注意点
　　'======================
　　WindowsServer2003,2008等は、何かプログラムが起動していると
　　このスクリプトが動作しないようです。
　　
'-------------------------------------
02.ＩＩＳによる方法（ＩＩＳが起動している必要があります）
'-------------------------------------
　　この方法は試していません。
　　> iisreset /reboot
　　これで、リブートするようです。
'-------------------------------------
03.プログラムによる方法
'-------------------------------------
　　以下の宣言をしておきます。
Public Declare Function ExitWin Lib "sakinfo.dll" (ByVal mode As Long, ByVal errmsg As String) As Long
'** ExitWindowsEx 定数
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const EWX_POWEROFF = 8
'------------------------------
'次の関数を定義して、コールすればリブートします。
'------------------------------
Sub ReBoot_Win()
Dim errmsg As String

'** 準備
errmsg = Space(300)

'** Windows リブート
If ExitWin(EWX_REBOOT, errmsg) = 0 Then
errmsg = Left(errmsg, InStrRev(errmsg, Chr(0)) - 1)
MsgBox("ExitWin エラー" & Chr(10) & Chr(10) & errmsg)
End If

'** 終了
End

End Sub

漢字入力時に自動的に振り仮名を取得

Thu, 17 Sep 2009 09:41:40 +0900

'=========================================
'漢字入力時にそのカナ入力を取得して、
'振り仮名として取得します。このルーチンは
' ( み～くんパパの仕事部屋 VB.NETサンプル)
' ( [IME]ふりがな取得クラス)
'を使用しています。
'=========================================
01.まず、「IMEComp.vb」を取得して、プロジェクトに追加します。
　　( み～くんパパの仕事部屋 VB.NETサンプル)を検索してください。
フォームには２つのＴｅｘｔＢｏｘを追加します
　SH_名称
SH_振り仮名

'-------
02.プロジェクトで以下の宣言をします。
Public Class サンプルＰＲＧ
Private WithEvents clsTextBox1Furi As IMEComp.Furigana
'-------
03.フォームのＬｏａｄルーチンに以下を追加します。
Private Sub サンプルＰＲＧ_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
clsTextBox1Furi = New IMEComp.Furigana(Me.SH_名称)
'--------
04.以下のルーチンを追加します。
Private Sub clsTextBox1Furi_Converted(ByVal sender As Object, ByVal e As IMEComp.ConvertedEventArgs) Handles clsTextBox1Furi.Converted

If sender.Equals(SH_名称) Then
If IsNarrow(e.FuriganaString) Then SH_振り仮名.Text &= e.FuriganaString
End If

End Sub

ＶＢで作成したプログラム用のＨＥＬPの作り方

Wed, 16 Sep 2009 14:50:41 +0900

VBで開発したプログラム用のＨＥＬPファイルを作成します。
'素材はＷＯＲＤのＤＯＣ形式で作成します。
'次にフリーの「doc2htmlhelp.vbs」を使用して、元のＨＥＬPファイルを作成します。
'ただしこのＨＥＬＰには、ＩＮＤＥＸが付いていないので、ＶＢから指定したＨＥＬＰを表示させる
'ことができません。
'次に「ヘルプましん」を利用してＩＮＤＥＸ付きのＨＥＬＰを作成します。
'そのＩＮＤＥＸをＶＢ内で指定してＨＥＬPを表示します。
01.ＷＯＲＤでＨＥＬＰ素材を作成する。
　　ＤＯＣ形式のファイルで、作成し、
　　処理ごとの「タイトルを」「スタイル」の「見出し1」に設定する。
　　必要なら、目次を作成する。
02.「doc2htmlhelp.vbs」を使用してＨＥＬＰファイルを作成する
　　 cscript.exe doc2htmlhelp.vbs [完全パス付きのＷＯＲDファイル名] /DivDocLevel:2

詳しくは、「doc2htmlhelp.vbs」のＨＥＬＰを見ること。
　　ＤＯＣファイルがあるディレクトリに、ＤＯＣ名のフォルダーが作成され、次に必要なファイルが
　　作成されている。
03.「ヘルプましん」を使用して、ＨＥＬＰファイルを作成する。
　　プロジェクトのフォルダー取り込みで、先ほど作成したフォルダーを指定します。
　　あとは、「ヘルプましん」の説明に従って、ＨＥＬPを作成します。
04.ＶＢ2005から、ＨＥＬＰの指定。
　　　　'ＨＥＬＰプロバイダーの設定
　　 Public HP1 As New HelpProvider
　　　 'ＨＥＬＰファイルの指定
'各フォーム内で指定します。
HP1.HelpNamespace = [完全パスのＨＥＬＰファイル名]
HP1.SetShowHelp(Me, True)
HP1.SetHelpNavigator(Me, HelpNavigator.KeywordIndex)
HP1.SetHelpKeyword(Me, [ＨＥＬＰを作成した時のＩＮＤEX名])

ADODB SqlServer接続文字列の作成時の注意点

Wed, 16 Sep 2009 08:40:49 +0900

SQLServeを使用して
ADODB SqlServer接続文字列の作成時の注意点の覚書
sa で　ログインする場合
'=============================
'Windows2000の(Server)場合、ＳＱＬ2008、ＳＱＬ2005の
Nativeクライアントをｲﾝｽﾄｰﾙ出来るが、
実際にはＯＤＢCの設定が出来ないので
標準のＳＱＬクライアントを使うしかない。

'-----------------------------------------------
Public xdb As New ADODB.Connection
dim LoginID as string
dim PWD_TXT as string 'パスワード文字列
dim XDB_NM as string 'データベース名
dim SV_NAME as string 'サーバー名
dim s as string
xdb.Mode = adModeReadWrite
xdb.CommandTimeout = 15000
'ログインＩＤの設定
LoginID = "TS00"
'SQLNCLI.1
'SQLOLEDB.1
'SQL2008 Nativeの場合の文字列
s = "Provider=SQLNCLI10.1;workstation id=" & LoginID & ";"
'SQL2005 Nativeの場合の文字列
s = "Provider=SQLNCLI1.1;workstation id=" & LoginID & ";"
'SQL2000 または,SQL2005,SQL2008でも使用可
s = "Provider=SQLOLEDB.1;workstation id=" & LoginID & ";"

If PWD_TXT <> "" Then
s = s & "Persist Security Info=false;User ID=sa;"
s = s & "Password=" & PWD_TXT & ";"
Else
s = s & "Persist Security Info=false;User ID=sa;"
End If
s = s & "data source=" & SV_NAME & ";"
s = s & "initial catalog=" & XDB_NM & ";"

xdb.ConnectionString = s

CrystalReportでバーコード画像を表示する方法ＶＢ6

Tue, 15 Sep 2009 11:37:46 +0900

CrystalReportで画像を表示する方法のＶＢ6版　覚書
'===========================================
'ローカルのアクセステーブルに印刷用のファイルを登録し
'CrystalReportで表示する
'このバーコードはフリーのMiBarcode.EXEのＤＤＥ機能を利用して
'印刷している
'=======================================
Option Explicit
'アクセスのＯＬＥオブジェクト型のデータに登録する場合
'アクセスで表示する場合は、ＢＩＴMAPをそのまま、Ｂｙｔｅ
'変数に変換して登録すればよいが、クリスタルレポートでは
'先頭にダミーバイトを挿入する必要がある。
'そのためのおまじない変数宣言
Dim CHUNK_B(98) As Byte
'BITMAPをＢｙｔｅ変数に格納するための宣言
Dim CH_BG() As Byte

'==============================================
'データをローカルのアクセスＤＢに登録するルーチン
'==============================================
Private Sub OK_B_Click()
Dim i%, j%, FH%
Dim S, XDIR, strDummy As String
Dim xdb As New ADODB.Connection
Dim ds As New ADODB.Recordset
Dim TEMP As Object
XDIR = App.Path
'実行環境ディレクトリ以下のＤＡＴＡディレクトリにデータベース
'を保存
S = ""
S = S & "Provider=Microsoft.Jet.OLEDB.4.0;"
S = S & "Data Source=" & App.Path & "\data\WORK.mdb;"
S = S & "Persist Security Info=False"
xdb.ConnectionString = S
xdb.Open

'クリスタルレポート上では、商品とＰＩＭAGEの２つのテーブルを
'使用して表示させる。
'商品データの登録
S = "select * from 商品"
S = S & " where PNO=" & Xtext(SH_PNO.Text)
ds.Open S, xdb, adOpenDynamic, adLockPessimistic
On Error Resume Next
ds.MoveFirst
If Err.Number = 0 And Not ds.EOF Then
Else
ds.AddNew
End If
On Error GoTo 0
ds("PNO").Value = SH_PNO.Text
ds("名称").Value = SH_名称.Text
ds("品番").Value = SH_品番.Text
ds("型番").Value = SH_型番.Text
ds.Update
ds.Close
'----
'ＤＤＥをサポートしたバーコード表示ルーチンを使用して
'フォーム上に張り付けたＰｉｃｔｕｒｅ1にバーコードを表示させる
'ルーチン
Call OLE_DISP

SavePicture Picture1.Image, XDIR & "\QRBAR.BMP"
DoEvents
'
S = "select * from PIMAGE"
S = S & " where PNO=" & Xtext(SH_PNO.Text)
ds.Open S, xdb, adOpenDynamic, adLockPessimistic
On Error Resume Next
ds.MoveFirst
If Err.Number = 0 And Not ds.EOF Then
Else
ds.AddNew
End If
On Error GoTo 0
ds("PNO").Value = SH_PNO.Text
On Error GoTo 0
'ビットマップをバイナリでオープンして、Ｂｙｔｅ配列に読み込む
FH = FreeFile
Open XDIR & "\QRBAR.bmp" For Binary As #FH
ReDim CH_BG(LOF(FH))
Get #FH, , CH_BG
Close #FH
'画像データはＯＬＥオブジェクト型で設定
'クリスタルレポート用に、ダミー配列を登録
ds("PIMAGE").AppendChunk (CHUNK_B)
'実際のＢＩＴＭＡＰデータを登録
ds("PIMAGE").AppendChunk (CH_BG)

ds.Update
ds.Close
xdb.Close

End Sub
'=======================================================
'DDE機能を使用して、PicturerにバーコードＢｉｔMapを張り付ける
'=======================================================
Sub OLE_DISP()
Dim MiBar As New Mibarcd.Auto
With MiBar
.Show (0)
.Code = "" & SH_PNO.Text & "::" & SH_名称.Text & "::" & SH_型番.Text & "::" & SH_品番.Text & ";"
.CodeType = 12 'QR2"QR2"
.QRVersion = 8
.QRErrLevel = 1 '"M"
.HMargin = 5
.BarScale = 2
.CopyType = 1
.Execute
Picture1.Picture = Clipboard.GetData
End With
End Sub

CrystalReportで画像を表示する方法

Tue, 15 Sep 2009 11:15:53 +0900

ＶＳ2008でCrystalReportにバーコード画像を表示する場合の覚書
'デンソーウェーブのバーコードライブラリを使用している
'VS2005でも同様に使用できると思われる
'======================================================
'印刷用のルーチン
'======================================================
Sub PRLOOP(ByVal S99 As String, ByVal S00 As String, ByVal S11 As String)
Dim crExportOptions As CrystalDecisions.Shared.ExportOptions
Dim crDiskFileDestinationOptions As CrystalDecisions.Shared.DiskFileDestinationOptions
Dim fm As New PrintBase
Dim SQLC As New SqlClient.SqlConnection
Dim TR, DEF_P, S, S0, S9, PR_PATH, Fname, PPJ, D_NM, NOW_PRT As String
Dim i%
Dim DsP As New DataSet
With fm
'レポートファイルの実際の場所の特定
'実行時のディレクトリ以下の「ＲＰＴ」ディレクトリに格納
'
On Error GoTo 0
PPJ = AppName
i = InStr(AppName, ".")
If i > 0 Then
PPJ = Mid(PPJ, 1, i - 1)
End If
S = AppPath
i = InStr(UCase(S), UCase("\BIN\"))
If i > 0 Then
'DEBUG
S = Mid(AppPath, 1, i - 0) & "RPT\"
Else
S = AppPath & "\RPT\"
End If
'i = InStr(UCase(S), UCase(CStr(PPJ)))
'If i > 0 Then
'S = Mid(S, 1, i - 1) & PPJ & "\RPT\"
'End If
If Microsoft.VisualBasic.Right(S, 1) <> "\" Then S = S & "\"

PR_PATH = S
Fname = ""
D_NM = ""
S9 = ""
Fname = S & "QRTEST.rpt"
D_NM = "TESTDATA"

fm.Cr1.Load(Fname)
's = Cr1.FilePath

On Error Resume Next
S = ""
On Error GoTo 0
Dim tb2 As New DataTable
DsP.Tables.Add(tb2)
clmSet("PNO", DsP, "System.String")
　　　　　'イメージはＢｙｔｅ配列で格納
clmSet("PIMAGE", DsP, "System.Byte[]")
clmSet("HNO", DsP, "System.String")
　　　　　'印刷用テーブルにカラムをセット
fm.CR0.ReportSource = fm.Cr1
'------
For i = 1 To 5
Dim rr As DataRow = tb2.NewRow
S0 = nFormat(i, "000")
rr("PNO") = S0
　　　　　　　'ＱＲコードは改行も受け付ける
S = S0 & "//0900-234" & vbCrLf
S = S & "漢字テスト" & vbCrLf
S = S & "品名ＯＫ" & Format(Now, "yyyy/MM/dd") & vbCrLf
rr("HNO") = S
Dim BB As New Bitmap(300, 300)

Dim memstream As MemoryStream = New MemoryStream

Call QRDISP(S, BB)
PictureBox1.Image = BB
Dim byteData As Byte()
BB.Save(memstream, Imaging.ImageFormat.Bmp)
byteData = memstream.ToArray

rr("PIMAGE") = byteData
DsP.Tables(0).Rows.Add(rr)
memstream.Close()
Next

'
If DsP.Tables(0).Rows.Count > 0 Then

Dim sds As New DataSet

Dim clm As New DataColumn
'===============================================
DsP.Tables(0).TableName = D_NM
.Cr1.Database.Tables(D_NM).SetDataSource(DsP.Tables(D_NM))
'===============================================

.CR0.Text = "一覧表"

.CR0.RefreshReport()

.Width = Me.Width
.Height = Me.Height
.Top = Me.Top
.Left = Me.Left
.CR0.DisplayGroupTree = False
.CR0.ShowGroupTreeButton = False
.CR0.Left = 0
.CR0.Top = 0
.CR0.DisplayBackgroundEdge = True
TR = ""
S = Prt_GET_REG("NO04", TR)
'デフォルトプリンターの確認
DEF_P = Get_Def_Printer()
If S = "" Then
.Cr1.PrintOptions.PrinterName = DEF_P
Else
.Cr1.PrintOptions.PrinterName = S
Call Set_Printer(S)
End If
NOW_PRT = .Cr1.PrintOptions.PrinterName
.Cr1.PrintOptions.PaperSize = CrystalDecisions.[Shared].PaperSize.PaperA4
.Cr1.PrintOptions.PaperOrientation = CrystalDecisions.[Shared].PaperOrientation.Landscape '= CrystalDecisions.[Shared].PaperOrientation.Landscape
.CR0.Width = fm.Width - 0
.CR0.Height = fm.Height '- Me.STAT.Height
.CR0.Visible = True
.CR0.ShowCloseButton = True
.Text = "一覧表表示印刷"
.Top = Me.Top
.Left = Me.Left
.WindowState = FormWindowState.Maximized

Me.Visible = False
.ShowDialog(Me)
Me.Visible = True
'もしデフォルトプリンターに変更があれば元に戻す。
If NOW_PRT <> DEF_P Then
On Error Resume Next
Call Set_Printer(DEF_P)
On Error GoTo 0
End If
Else
MsgBox("該当するデータはありません。")
End If

End With

End Sub
'==========================================================
'DataSetにカラムを追加するサブルーチン
'==========================================================
Sub clmSet(ByVal nm As String, ByVal Dsp As DataSet, ByVal Tp As String)
Dim clm As New DataColumn
clm.ColumnName = nm
clm.DataType = Type.GetType(Tp)
If InStr(UCase(Tp), "STRING") > 0 Then
clm.DefaultValue = ""
Else
clm.DefaultValue = DBNull.Value
End If
Dsp.Tables(0).Columns.Add(clm)

End Sub
'=======================================================
'QRコードをビットマップに表示するルーチン
'=======================================================
Sub QRDISP(ByVal QR_S As String, ByVal PP As Bitmap)
Dim bc1 As System.DotNetBarcode = New System.DotNetBarcode
Dim g As Graphics = Graphics.FromImage(PP)
g.Clear(Color.White)

bc1.Type = System.DotNetBarcode.Types.QRCode
bc1.PrintCheckDigitChar = True
bc1.WriteBar(QR_S, 0, 0, PP.Width, PP.Height, g)
End Sub

vb-oboegaki blog ＶＢ開発者の覚書