CDデバイス名からRecorderUniqueID取得、トレーEJECT処理

前回の投稿で使用したCDデバイス名一覧から選択したCDデバイスを特定する処理です

前投稿[CDデバイス一覧取得]のソースがある前提で

引数に選択したCDデバイス名を指定すれば対応するデバイスのIDを取得します

--------------------------------------------------------------------------------

    ''' <summary>
    ''' RecorderUniqueID取得
    ''' </summary>
    Public Function GetCDDevID(sProductId As String) As String
        Dim strRet As String = String.Empty
        Dim objDiscMaster As IMAPI2.MsftDiscMaster2 = Nothing
        Try
            'デバイス検索
            objDiscMaster = New IMAPI2.MsftDiscMaster2
            For Each sDev As String In objDiscMaster
                Dim objDev As New IMAPI2.MsftDiscRecorder2
                Try
                    objDev.InitializeDiscRecorder(sDev)
                    If Trim(objDev.ProductId) = sProductId Then
                        strRet = sDev
                        Exit For
                    End If
                Catch ex As Exception
                    Throw ex
                Finally
                    MarshalObject(objDev)
                End Try
            Next
        Catch ex As Exception
            Throw ex
        Finally
            MarshalObject(objDiscMaster)
        End Try
        Return strRet
    End Function

--------------------------------------------------------------------------------

これだけだと面白くないのでCDトレーのEJECTをさせる処理を

引数に選択したCDデバイス名を指定すれば対応するデバイスのトレーを開きます

--------------------------------------------------------------------------------

    ''' <summary>

    ''' EJECT TRAY

    ''' </summary>

    ''' <param name="sProductId">Device名</param>

    Public Sub TrayEJECT(sProductId As String)

        Dim objRecorder As New IMAPI2.MsftDiscRecorder2

        Dim sRecorderUniqueID As String = GetCDDevID(sProductId)

        Try

            If Not String.IsNullOrWhiteSpace(sRecorderUniqueID) Then

                'デバイス決定

                objRecorder.InitializeDiscRecorder(sRecorderUniqueID)

                'EJECT

                objRecorder.EjectMedia()

            End If

        Catch ex As Exception

            Throw ex

        Finally

            MarshalObject(objRecorder)

        End Try

    End Sub

--------------------------------------------------------------------------------

CDデバイス一覧取得

ネタが無いので小出しで

手が空いて何もすることが無いので以前作成したCD-R/RW のPGをWindows10,VB2019に移植。

とは言っても変えるところはw

IMAPI2はインストールした記憶が無いのでWindows10に初期から入ってる？

コンボボックスにCDドライブを表示させたいので一覧を取得する処理から

まず、必要な参照をImportsしておく

--------------------------------------------------------------------------------

Imports IMAPI2

Imports IMAPI2FS

Imports System.Runtime.InteropServices

--------------------------------------------------------------------------------

定番のCOM開放処理を作成

--------------------------------------------------------------------------------
    ''' <summary>
    ''' COMオブジェクト解放
    ''' </summary>
    ''' <param name="obj">対象オブジェクト</param>
    Private Sub MarshalObject(ByVal obj As Object)
        Try
            If (Not obj Is Nothing) AndAlso (Marshal.IsComObject(obj)) Then
                Marshal.ReleaseComObject(obj)
            End If
        Catch ex As Exception
            Throw ex
        Finally
            obj = Nothing
        End Try

    End Sub

--------------------------------------------------------------------------------

CDデバイス一覧取得

--------------------------------------------------------------------------------

    ''' <summary>

    ''' CDデバイス名一覧取得

    ''' </summary>

    Public Function GetCDDevName() As List(Of String)

        Dim lstRet As New List(Of String)

        Dim objDiscMaster As MsftDiscMaster2 = Nothing

        Dim objDev As MsftDiscRecorder2 = Nothing

        'デバイス一覧取得

        Try

            objDiscMaster = New MsftDiscMaster2

            For Each sDev As String In objDiscMaster

                objDev = New MsftDiscRecorder2

                objDev.InitializeDiscRecorder(sDev)

                lstRet.Add(Trim(objDev.ProductId))

                MarshalObject(objDev)

            Next

        Catch ex As Exception

            Throw ex

        Finally

            MarshalObject(objDev)

            MarshalObject(objDiscMaster)

        End Try

        Return lstRet

    End Function

--------------------------------------------------------------------------------

GetCDDevName() の戻り値を ComboBox の DataSource に設定すれば表示するはず

覚書の為、検証できていないので参考程度でお願いします

C#からEXCEL読込(一括)

もう１年以上更新してなかったw

久しぶりに小ネタを。

アプリからEXCELファイルを読み込むってのは業務アプリ開発で

ありがちな依頼だったりする。

で、オイラもそんなC#開発依頼を受けて。

まず、参照設定にMicrosoft.Office.Interop.Excelを追加

（サードパーティ使用不可だからw）

以下、データ取得のソース

-----------------------------------------------------------------------------------------

            // データ格納エリア

            object[,] RangeDatas = null;

            Microsoft.Office.Interop.Excel.Application Exl = null;
            Microsoft.Office.Interop.Excel.Workbooks xlsBooks = null;
            Microsoft.Office.Interop.Excel.Workbook xlsBook = null;
            Microsoft.Office.Interop.Excel.Sheets xlsSheets = null;
            Microsoft.Office.Interop.Excel.Worksheet xlsSheet = null;
            Microsoft.Office.Interop.Excel.Range xlsRange = null;

            try
            {
                // EXCEL起動
                Exl = new Microsoft.Office.Interop.Excel.Application
                {
                    DisplayAlerts = false
                };
                try
                {
                    // Books指定
                    xlsBooks = Exl.Workbooks;
                    try
                    {
                        // Book読込
                        xlsBook = xlsBooks.Open(FILENAME);
                        try
                        {
                            //EXCEL Sheets
                            xlsSheets = xlsBook.Sheets;
                            try
                            {
                                //EXCEL Sheet(1シート目)
                                xlsSheet = xlsSheets[1] as Microsoft.Office.Interop.Excel.Worksheet;
                                try
                                {
                                    //使用セル
                                    xlsRange = xlsSheet.UsedRange;
                                    RangeDatas = xlsRange.Value;
                                }
                                catch { }
                                finally
                                {
                                    if (xlsRange != null)
                                    {
                                        System.Runtime.InteropServices.Marshal.ReleaseComObject(xlsRange);
                                    }
                                    xlsRange = null;
                                }
                            }
                            catch { }
                            finally
                            {
                                if (xlsSheet != null)
                                {
                                    System.Runtime.InteropServices.Marshal.ReleaseComObject(xlsSheet);
                                }
                                xlsSheet = null;
                            }
                        }
                        catch { }
                        finally
                        {
                            if (xlsSheets != null)
                            {
                                System.Runtime.InteropServices.Marshal.ReleaseComObject(xlsSheets);
                            }
                            xlsSheets = null;
                        }
                    }
                    catch { }
                    finally
                    {
                        if (xlsBook != null)
                        {
                            System.Runtime.InteropServices.Marshal.ReleaseComObject(xlsBook);
                        }
                        xlsBook = null;
                    }
                }
                catch { }
                finally
                {
                    if (xlsBooks != null)
                    {
                        System.Runtime.InteropServices.Marshal.ReleaseComObject(xlsBooks);
                    }
                    xlsBooks = null;
                }
            }
            catch { }
            finally
            {
                if (Exl != null)
                {
                    System.Runtime.InteropServices.Marshal.ReleaseComObject(Exl);
                }
                Exl = null;
            }

-----------------------------------------------------------------------------------------

使用したオブジェクトを明示的に開放してやらないと駄目なんで

めんどくさいけど仕方ない。

これでRangeDatasにEXCELセルのデータが入るのだけど・・・・

日付データとかは日付型で入るわけでもない。

EXCELに表示されている値を取り込みたいとなると

ループで各セルを回して.Textを取得する必要があるみたい。

（一括で取得する方法があれば良いけど・・・・）

IMEからカナを取得

ＩＭＥ入力時に読みを別コントロールに設定できる仕様を追加して欲しいとの事。


結局、流れた案件だけど、ある程度の調査結果でも書いておきます。


（たまには技術屋らしい書き込みもしないとねσ(^_^汗


調べると、IME用のAPIを使うとの事。
で、WndProcをOverridesして操作が常道らしい。


まず、ModuleにAPI等を定義
------------------------------------------------------------
Imports System.Runtime.InteropServices


Public Module TestFuncs
#Region "API定数"
    ''' <summary>WindowMessage:WM_CHAR</summary>
    Public Const WM_CHAR As Integer = &H102
    ''' <summary>WindowMessage:WM_IME_COMPOSITION</summary>
    Public Const WM_IME_COMPOSITION As Integer = &H10F
    ''' <summary>ImmGetCompositionString用定数:GCS_RESULTREADSTR</summary>
    Public Const GCS_RESULTREADSTR As Integer = &H200
#End Region
#Region "API定義"
    ''' <summary>IMEハンドル取得</summary>
    <DllImport("Imm32.dll")> _
    Public Function ImmGetContext(ByVal hWnd As Integer) As Integer
    End Function
    ''' <summary>IMEハンドル解放</summary>
    <DllImport("Imm32.dll")> _
    Public Function ImmReleaseContext(ByVal hWnd As Integer, ByVal hIMC As Integer) As Integer
    End Function
    ''' <summary>フリガナ取得</summary>
    <DllImport("Imm32.dll")> _
    Public Function ImmGetCompositionString(ByVal hIMC As Integer, ByVal dwIndex As Integer, ByVal lpBuf As StringBuilder, ByVal dwBufLen As Integer) As Integer
    End Function
    ''' <summary>IME状態取得</summary>
    <DllImport("Imm32.dll")> _
    Public Function ImmGetOpenStatus(ByVal hIMC As Integer) As Integer
    End Function
#End Region
End Moudle
------------------------------------------------------------


あとはテキストボックス継承のコントロールを作成
------------------------------------------------------------
Imports System.ComponentModel


Public Class TestTextBox
    Inherits System.Windows.Forms.TextBox


    ''' <summary>読み設定先</summary>
    Private _YomiControl As Control = Nothing


    ''' <summary>読み設定先コントロール</summary>
    <Category("カスタム")> _
    <Description("読み設定先コントロール")>
    Public Property YomiControl() As Control
        Get
            Return _YomiControl
        End Get
        Set(ByVal value As Control)
            _YomiControl = value
        End Set
    End Property


#Region "WndProcフック"
    ''' <summary>ウィンドウプロシージャ</summary>
    Protected Overloads Overrides Sub WndProc(ByRef wm As System.Windows.Forms.Message)
        Try
            If Not _YomiControl Is Nothing Then
                Select Case wm.Msg
                    Case WM_IME_COMPOSITION
                        'IME確定
                        Dim InpStr As String = ""
                        If (CUInt(wm.LParam) And CUInt(GCS_RESULTREADSTR)) <> 0 Then
                            Dim hIM As Integer = ImmGetContext(Me.Handle.ToInt32())
                            Dim strLen = ImmGetCompositionString(hIM, GCS_RESULTREADSTR, Nothing, 0)
                            If strLen > 0 Then
                                Dim temp As New System.Text.StringBuilder(strLen)
                                ImmGetCompositionString(hIM, GCS_RESULTREADSTR, temp, strLen)
                                InpStr = temp.ToString()
                                If InpStr.Length > strLen Then
                                    InpStr = InpStr.Substring(0, strLen)
                                End If
                                Try
                                    If Not _YomiControl Is Nothing Then
                                        _YomiControl.Text = _YomiControl.Text & StrConv(InpStr, VbStrConv.Wide)
                                    End If
                                Catch ex As Exception
                                End Try
                            End If
                            ImmReleaseContext(Me.Handle.ToInt32(), hIM)
                        End If
                        Exit Select
                    Case WM_CHAR
                        '直接入力
                        Dim hIM As Integer = ImmGetContext(Me.Handle.ToInt32())
                        If ImmGetOpenStatus(hIM) = 0 Then
                            Dim InpChr As Char = Convert.ToChar(wm.WParam.ToInt32() And &HFF)
                            If wm.WParam.ToInt32() >= 32 Then
                                Dim InpStr As String = InpChr.ToString()
                                Try
                                    If Not _YomiControl Is Nothing Then
                                        _YomiControl.Text = _YomiControl.Text & InpStr
                                    End If
                                Catch ex As Exception
                                End Try
                            End If
                        End If
                        ImmReleaseContext(Me.Handle.ToInt32(), hIM)
                        Exit Select
                End Select
            End If
        Catch ex As Exception
        End Try
        MyBase.WndProc(wm)
    End Sub
#End Region
End Class
------------------------------------------------------------
とりあえずカナを取得して、指定の別コントロールに設定するソース。


２時間程度で調べて作ったものなのでバグ等があるやもしれませんがw

.NETでのPG間共通Configの更新方法

前回の共通ConfigでのConfig更新方法
（PGは再起動しないと取得できないので要注意）


前回は複数PGから同じConfigを参照する方法(applicationSettingだけ)を書いたけど
今回は、そのConfigの更新方法
(といってもxmlを更新する処理なだけだけどw）


いきなりサンプルソース


---------------------- コンフィグ更新用SUB[例] ----------------------------
    Public Sub WriteAppConf(ByVal sName As String, ByVal sVal As String)
        '構成ファイルのパスを取得
        Dim asm As System.Reflection.Assembly = _
            System.Reflection.Assembly.GetExecutingAssembly()
        Dim appConfigPath As String
        'ファイル指定
        appConfigPath = System.IO.Path.GetDirectoryName(asm.Location) & _
                             "TestCommon.config"
        '構成ファイルをXML DOMに読み込む
        Dim xmldoc As System.Xml.XmlDocument = New System.Xml.XmlDocument()
        xmldoc.Load(appConfigPath)
        Dim xmlnode As System.Xml.XmlNode = _
           xmldoc("TestSys.TestLibs.My.MySettings")
        'ノードを探す
        Dim n As System.Xml.XmlNode
        Dim b As Boolean = False
        For Each n In node.SelectNodes("setting")
            If n.Attributes.GetNamedItem("name").Value = sName Then
                For Each nn As System.Xml.XmlNode In n.SelectNodes("value")
                    nn.InnerText = sVal
                    b = True
                Next
                Exit For
            End If
        Next
        If Not b Then
            '新しいElementの作成
            Dim newNode As System.Xml.XmlElement = doc.CreateElement("setting")
            'Attributeを作成し、追加する
            newNode.SetAttribute("name", sName)
            newNode.SetAttribute("serializeAs", "String")
            Dim newVale As System.Xml.XmlElement = doc.CreateElement("value")
            newVale.InnerText = sVal
            newNode.AppendChild(newVale)
            node.AppendChild(newNode)
        End If
        '変更された構成ファイルを保存する
        doc.Save(appConfigPath)
    End Sub
---------------------------------------------------------------------------
   共通Configファイル名 "TestCommon.config" と
   DLL名前空間APPConfigノード名 "TestSys.TestLibs.My.MySettings" を
   環境に合わせて変更すればConfig変更用モジュールの完成


使い方は
   通常AppConfig
         my.setting.XXXX = AAAA
  共通AppConfig
         WriteAppConf("XXXX",AAAA)


ただし、文字列の情報のみ保存にしています。


　
　　　

.NETでのPG間共通Config

別ＰＧから同じＤＬＬを使用したシステム開発を依頼された。
で、外部に設定値としてConfigファイルを持たせることに。

ただ、通常ではEXE単位(userSettingsだとさらにユーザ単位）にConfigを持つわけで。
全ＰＧにＤＬＬの情報を持たせるのはめんどくさいし
出来れば変更内容を別EXEにも反映させたい。

で、お決まりのググる作業w

まず、設定の統一化
  各ＰＧの App.Config (コンパイル後は[PG名].exe.config）から同一のconfigファイルを参照させる
  各ＰＧのApp.configのApplicationSettingを改造
例　改造前　各ＰＧのApp.config
        <applicationSettings>
           <TestSys.TestLibs.My.MySettings>
               <setting name="TESTDATA" serializeAs="String">
                   <value>100</value>
               </setting>
           </TestSys.TestLibs.My.MySettings>
        </applicationSettings>
　↓
　　改造後　各ＰＧのApp.config
        <applicationSettings>
           <TestSys.TestLibs.My.MySettings configSource="TestCommon.config"/>
        </applicationSettings>

     共通のConfigファイル(ここでは仮にTestCommon.config)
           <TestSys.TestLibs.My.MySettings>
               <setting name="TESTDATA" serializeAs="String">
                   <value>100</value>
               </setting>
           </TestSys.TestLibs.My.MySettings>
これで同一ファイルへの参照が可能

でＰＧから設定内容を変更したい場合はTestCommon.configを直接変更かける仕組みを
追加する
 内容はSystem.Xml.XmlDocument でxmlファイルへ出力

色選択用コンボボックス

ＰＧから色を指定できる仕様にして欲しいとの依頼。
Configファイルでの指定では駄目らしい。

うむ。めんどくさい。
ColorDialogを出しても良いけど、色指定が微妙。
簡単に指定が良いなぁ・・・

で、ネットを検索して、コンボボックスを自分で描写する事に。

以下がそのソース
コンボボックスの継承クラスです。

################### ソースここから #################
Imports System.ComponentModel

''' <summary>
''' 色選択コンボボックス
''' </summary>
Public Class ColorComboBox
    Inherits System.Windows.Forms.ComboBox

#Region "内部変数"
    ''' <summary>カラー色表示</summary>
    Private _DispColorName As Boolean = True
    ''' <summary>サンプル文字</summary>
    Private _SampleString As String = ""
#End Region
#Region "プロパティ"
    ''' <summary>
    ''' カラー色表示
    ''' </summary>
    <Category("表示")> _
    <Description("色名の表示設定")> _
    Public Property DispColorName() As Boolean
        Get
            Return _DispColorName
        End Get
        Set(ByVal value As Boolean)
            _DispColorName = value
        End Set
    End Property
    ''' <summary>
    ''' サンプル文字
    ''' </summary>
    <Category("表示")> _
    <Description("色指定でのサンプル文字")> _
    Public Property SampleString() As String
        Get
            Return _SampleString
        End Get
        Set(ByVal value As String)
            _SampleString = value
        End Set
    End Property
#End Region

#Region "コンストラクタ"
    ''' <summary>
    ''' コンストラクタ
    ''' </summary>
    Public Sub New()
        MyBase.New()
        '固定プロパティ
        Me.DrawMode = Windows.Forms.DrawMode.OwnerDrawFixed
        Me.DropDownStyle = ComboBoxStyle.DropDownList
        '色設定
        Me.Items.Clear()
        For Each col As KnownColor In [Enum].GetValues(GetType(KnownColor))
            Me.Items.Add(Color.FromName(col.ToString))
        Next
    End Sub
#End Region

#Region "イベント"
    ''' <summary>
    ''' 行描写
    ''' </summary>
    Protected Overrides Sub OnDrawItem(ByVal e As System.Windows.Forms.DrawItemEventArgs)
        '領域
        Dim rCol As RectangleF
        Dim rText As RectangleF
        Dim rTextBack As RectangleF
        If DispColorName Then
            '色名あり
            Dim rWid As Single = 30
            If rWid > CSng(e.Bounds.Width * 0.9) Then
                rWid = CSng(e.Bounds.Width * 0.9)
            End If
            rCol = New RectangleF(e.Bounds.Left, e.Bounds.Top, rWid, e.Bounds.Height)
            If (rWid + 10) > e.Bounds.Width Then
                rWid = 0
            Else
                rWid = 10
            End If
            rText = New RectangleF(rCol.Right + rWid, e.Bounds.Top, e.Bounds.Width, e.Bounds.Height)
            rTextBack = New RectangleF(rCol.Right, e.Bounds.Top, e.Bounds.Width, e.Bounds.Height)

        Else
            '色名なし
            rCol = New RectangleF(e.Bounds.Left, e.Bounds.Top, e.Bounds.Width, e.Bounds.Height)
            rText = New RectangleF(e.Bounds.Left, e.Bounds.Top, e.Bounds.Width, e.Bounds.Height)
            rTextBack = New RectangleF(rCol.Right, e.Bounds.Top, e.Bounds.Width, e.Bounds.Height)
        End If
        If e.Index >= 0 Then
            '外枠   
            Using brush As New SolidBrush(Me.BackColor)
                e.Graphics.FillRectangle(brush, rTextBack)
            End Using
            '選択色   
            Dim objColor As Color = DirectCast(Me.Items(e.Index), Color)
            If DispColorName Then
                '色名称
                Dim txt As String = objColor.ToKnownColor.ToString
                Dim fmt As StringFormat = CType(StringFormat.GenericDefault.Clone, StringFormat)
                fmt.Alignment = StringAlignment.Near
                fmt.LineAlignment = StringAlignment.Center
                Using brush As New SolidBrush(Me.ForeColor)
                    e.Graphics.DrawString(txt, e.Font, brush, rText, fmt)
                End Using
            End If
            '色枠  
            Using backBrush As New SolidBrush(objColor)
                e.Graphics.FillRectangle(backBrush, rCol)
            End Using
            'サンプル文字
            Dim Samplefmt As StringFormat = CType(StringFormat.GenericDefault.Clone, StringFormat)
            Samplefmt.Alignment = StringAlignment.Center
            Samplefmt.LineAlignment = StringAlignment.Center
            Using brush As New SolidBrush(Me.ForeColor)
                e.Graphics.DrawString(Me.SampleString, e.Font, brush, rCol, Samplefmt)
            End Using
        End If
    End Sub
#End Region

End Class

################### ソースここまで #################

プロパティを２つほど追加しています。
DispColorName　　色名称の表示ON/OFF
SampleString       色にかぶせるサンプル文字

で、設定・取得は SelectItem を使用(colorオブジェクトでね)

いつもの通り、即席での作成です。
バグ等があるやも知りませんがwww

VB.NET NumericUpDownコントロール

VB.NET で、NumericUpDownを使用しようかと・・・
（いきなり本題w）

で、お決まりのEnterキーでの項目遷移

OnKeyDownイベントでSelectNextControlを動かせば良いらしい。

で、実行。

動くけどBeep音がやかましい。

ググってみたけどなかなかHitしない。
諦めかけた時、ありました。
で、下記が反映させたソース

    '''' <summary>
    '''' キーダウン
    '''' </summary>
    Protected Overrides Sub OnKeyDown(ByVal e As System.Windows.Forms.KeyEventArgs)
        If e.KeyCode = Keys.Enter Then
            e.SuppressKeyPress = True
            Me.FindForm.SelectNextControl(Me, True, True, True, True)
        End If
        MyBase.OnKeyDown(e)
    End Sub

NumericUpDownの派生クラスで作ってみたけど
まあ、普通にイベントを拾えばできるんじゃあないかなぁ・・・

これだけで反日もとい半日かかった　orz
（どうしてこんな誤変換を・・・w）

ACCESSの実行画面をMSペイントに出力

たまには技術ネタも書け！とお叱りを受けそうなのでw

ACCESSを使用したシステムでハードコピーをボタン等でしたい。
出来たハードコピーはペイントで見たい との案件。
とりあえず思いついたのがクリップボード経由での受け渡し。
ただ出力先がMSペイント指定なのでめんどくさい。
しかもACCESSにクリップボード操作はサポートされてないようだし。

安直に
[prt sc]を画面から投げてクリップボードに画面コピー後
MSペイントを起動させて[Ctr+v]を投げる事を考えた。

最初 SendKeysで[scr sc]を投げたけど取れない。
ググったらどうも使えない事があるらしい。
めんどくさいけどAPIを一部使用。

以下がそのソース（簡易版w）

--------------------------------------------------------------------------------------
Option Compare Database

Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
    ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

'画面をクリップボードにコピー
Public Sub subGetSnapShot()
   
    '[prt sc]Key 送信
    Call keybd_event(CByte(vbKeySnapshot), 0, 0, 0)
    Call keybd_event(CByte(vbKeySnapshot), 0, 2, 0)
   
End Sub

'ペイント起動後、クリップボードをペースト
Public Sub subOutClipBord()

    Dim objShell    As New WSHShell
    Dim objExe      As WshExec
   
    'MSPaint起動
    Set objExe = objShell.Exec("mspaint.exe")
   
    '起動待ち
    Do Until objShell.AppActivate(objExe.ProcessID)
    Loop
   
    '[Ctr+V]key 送信
    SendKeys "^v"
   
    '参照破棄
    Set objExe = Nothing
    Set objShell = Nothing

End Sub

'画面をペイントに出力
Public Sub subOutForm()

    '画面取得
    Call subGetSnapShot
   
    '制御をWindowsに一時戻す
    DoEvents
   
    'ペイントへ出力
    Call subOutClipBord

End Sub
--------------------------------------------------------------------------------------

参照設定に[Windows Script Host Object Model]を設定して
画面から上記[subOutForm]をコールすればとりあえず動くはず^_^;

マシンのスペックが古いと時間が掛かりますし
実行中の操作で不具合が発生する可能性もありますがw
参考程度に(^^ゞ

試行錯誤してたから１日掛かったorz・・・

MS-ACCESSのソース管理

それほど大きくないシステムでMS-ACCESSを利用して構築する案件は
予想外に多かったりする。
（オイラのまわりだけかもw）

で、単独での開発なら良いけど複数人での開発となると
ちょっと厄介。
どうしてもデグレが発生しやすい。

VBAのソースだけなら良いけど、フォーム等のプロパティもあるし。

ただ、各オブジェクトをテキストとして出力もできるんだよね。
ヘルプ等では公開されてないようだけど。
SaveAsText ってやつね。

で以下のモジュールをつくってみた。
'-----------------------------------------------
'モジュール一括出力
'-----------------------------------------------
Public Sub Addin_subOutModule(strFolder As String)
    Dim aObj As Object
    Dim FName As String
    On Error GoTo Err_Addin_subOutModule
    '全モジュール出力
    For Each aObj In CurrentProject.AllModules
        FName = strFolder & "module_" & aObj.Name & ".txt"
        Application.SaveAsText acModule, aObj.Name, FName
    Next
   
    '全フォーム出力
    For Each aObj In CurrentProject.AllForms
        FName = strFolder & "form_" & aObj.Name & ".txt"
        Application.SaveAsText acForm, aObj.Name, FName
    Next
   
    '全レポート出力
    For Each aObj In CurrentProject.AllReports
        FName = strFolder & "report_" & aObj.Name & ".txt"
        Application.SaveAsText acReport, aObj.Name, FName
    Next
   
    '全マクロ出力
    For Each aObj In CurrentProject.AllMacros
        FName = strFolder & "macro_" & aObj.Name & ".txt"
        Application.SaveAsText acMacro, aObj.Name, FName
    Next
   
    '全クエリ出力
    For Each aObj In CurrentData.AllQueries
        FName = strFolder & "querydef_" & aObj.Name & ".txt"
        Application.SaveAsText acQuery, aObj.Name, FName
    Next

    Set aObj = Nothing
   
    Exit Sub
   
Err_Addin_subOutModule:
   
    MsgBox Err.Description
    Resume Next
End Sub
-------------------------------------------
strFolder に出力先フォルダ名(最終文字に￥付き)を指定してコールするだけ。
ただオブジェクト名に"/"等があると駄目だけど^_^;

出力ファイルで差分を取れば変更箇所が判定できる。
（編集しなくても変わる項目もあるけど…）
以前アドインとして公開してるソースから引用してます。
VBAStepCounterForAccess2000 ってやつね(^^ゞ

ACCESS2000 ～ 2007までは出来るはず。2010は知らんw

AD(ActiveDirectory)サーバにユーザ確認

AD(ActiveDirectory)サーバ上のユーザを利用したユーザ認証
（単にユーザ・パスワードが有効なのかチェックするだけw）をVB.NETでって案件。

ADサーバをLDAPサーバ扱いすれば可能なようなので。

----------------------------------------------------------------------------
        Dim aName As String
        Dim aSn As String
        Dim aGivenName As String
        Dim aDescription As String

        Try
            Dim searcher As New System.DirectoryServices.DirectorySearcher()
            'サーバーが結果を返すまでのクライアント待機時間
            searcher.ClientTimeout = New TimeSpan(500)
            'サーバーが検索するための制限時間
            searcher.ServerTimeLimit = New TimeSpan(500)
            'サーバーが結果のページを検索するための時間
            searcher.ServerPageTimeLimit = New TimeSpan(500)
            '検索を開始する Active Directory 階層のノード
            searcher.SearchRoot = New System.DirectoryServices.DirectoryEntry(%サーバ名%, _
                                                        %ユーザ名% & "@" & %ドメイン名%, %パスワード%)
            searcher.Filter = "(sAMAccountName=" & %ユーザ名%  & ")"
            searcher.SearchScope = System.DirectoryServices.SearchScope.Subtree
            searcher.PageSize = 512
            '姓(漢字姓),名(漢字名),部署名(説明),ユーザID
            searcher.PropertiesToLoad.AddRange(New String() {"name", _
                                                        "sn", _
                                                        "givenName", _
                                                        "description", _
                                                        "sAMAccountName"})
            Dim results As System.DirectoryServices.SearchResult = searcher.FindOne
            'name
            If results.Properties("name").Count > 0 Then
                aName = results.Properties("name").Item(0).ToString
            End If
            'sn
            If results.Properties("sn").Count > 0 Then
                aSn = results.Properties("sn").Item(0).ToString
            End If
            'GivenName
            If results.Properties("givenName").Count > 0 Then
                aGivenName = results.Properties("givenName").Item(0).ToString
            End If
            'Description
            If results.Properties("description").Count > 0 Then
                aDescription = results.Properties("description").Item(0).ToString
            End If
        Catch ex As System.DirectoryServices.DirectoryServicesCOMException
            MsgBox(ex.Message)
        Catch ex As Exception
            MsgBox(ex.Message)
        End Try

ACCESSとVB.NETの色指定

以前、ACCESS(2003)とVB2008を使用したシステム構築の案件があったんだけど
当然、ACCESS側とVB.NETでのインターフェイス（見た目w）を統一したいと。
フォーム上の色はINIファイルから設定したいと。

で、ACCESSの色(RGB)とVB2008(ARGB)の色は形式が異なる訳で変換が必要。
例)
ACCESS-----------------------------
   me.詳細.BackColor = %指定色%

VB2008------------------------------
  Dim cl As New Color
  cl = ColorTranslator.FromWin32(%指定色%)
  me.BackColor = cl

VB.NETからCD-Rにデータ書込み

先日、PGのリプレースを依頼された。
PGは単純なんだけど、現状FDに出力するファイルをCD-Rに出力して欲しいと。

結構めんどくさいw
単純にCD-RドライブにCOPYって訳にもいかないようだし。

で、定番 ググってみた。
IMAPI2 なるAPIがあるようだ。（対象がWin7でVB2010だったから)

ただほとんどの情報は英語。まあ仕方ない。
無い頭を無理やり使って意訳w

で、出来たのが次のソース。
かなり簡略化してコメントもアバウト。
エラー処理などほぼ無視w
--------------------------------------------------------
参照  COM
  IMAPI2
  IMAPI2FS
--------------------------------------------------------
'CD-R書込み関連参照設定
Imports IMAPI2
Imports IMAPI2FS
Imports System.Runtime.InteropServices
Module modX
    Public Function fncBURNdata() As Boolean
        Dim bRet As Boolean = False
        Dim sRecorderId As String = String.Empty            'RecorderID
        Dim objDiscMaster As IMAPI2.MsftDiscMaster2 = Nothing   'DiscMaster2 Object connects
        Dim objRecorder As IMAPI2.MsftDiscRecorder2 = Nothing   'Recorder for BURNing device
        Dim DataWriter As IMAPI2.MsftDiscFormat2Data = Nothing  '
        Dim BurnRet As IMAPI2FS.FileSystemImageResult = Nothing '
        Dim Image As IMAPI2FS.MsftFileSystemImage = Nothing     '
        Dim ImageStreem As IMAPI2.IStream = Nothing             '
        'CD-R書込み
        Try
            'デバイス検索
            objDiscMaster = New IMAPI2.MsftDiscMaster2
            sRecorderId = ""
            For Each sDev As String In objDiscMaster
                Dim objDev As New IMAPI2.MsftDiscRecorder2
                Try
                    objDev.InitializeDiscRecorder(sDev)
                    If Trim(objDev.ProductId) = %デバイス名% Then
                        sRecorderId = sDev
                        Exit For
                    End If
                Catch ex As Exception
                    Throw ex
                Finally
                    MarshalObject(objDev)
                End Try
            Next
            'デバイス決定
            objRecorder = New IMAPI2.MsftDiscRecorder2
            objRecorder.InitializeDiscRecorder(sRecorderId)
            'メディア初期化
            Dim bRetErase As Boolean = fncEraseDisc(objRecorder)
            'ISOイメージ種別指定(Longファイル名使用可能)
            Image = New IMAPI2FS.MsftFileSystemImage
            Image.FileSystemsToCreate = (FsiFileSystems.FsiFileSystemISO9660 Or
                                          FsiFileSystems.FsiFileSystemJoliet)
            'CD-Rボリューム名設定
            Image.VolumeName = %ボリューム名%
            'ISO作成元フォルダ指定
            Image.Root.AddTree(%作成元フォルダパス%, False)
            'ISOイメージ作成
            DataWriter = New IMAPI2.MsftDiscFormat2Data
            DataWriter.Recorder = objRecorder
            DataWriter.ClientName = %本PG名%
            DataWriter.ForceMediaToBeClosed = True
            BurnRet = Image.CreateResultImage()
            'ISOイメージ書込み
            ImageStreem = DirectCast(BurnRet.ImageStream, IMAPI2.IStream)
            DataWriter.Write(ImageStreem)
            'メディア取り出し
            objRecorder.EjectMedia()
        Catch ex As System.Runtime.InteropServices.COMException
            '書込みエラー
            MsgBox(ex.Message ,
                   MsgBoxStyle.OkOnly Or MsgBoxStyle.Exclamation,
                   "エラー")
            bRet = False
        Catch ex As Exception
            '書込みエラー
            MsgBox(ex.Message ,
                   MsgBoxStyle.OkOnly Or MsgBoxStyle.Exclamation,
                   "エラー")
            bRet = False
        Finally
            '各ＣＯＭオブジェクト開放
            MarshalObject(ImageStreem)
            MarshalObject(BurnRet)
            MarshalObject(DataWriter)
            MarshalObject(Image)
            MarshalObject(objRecorder)
            MarshalObject(objDiscMaster)
        End Try
        Return bRet
    End Function
    Private Sub MarshalObject(ByVal obj As Object)
        Try
            If (Not obj Is Nothing) AndAlso (Marshal.IsComObject(obj)) Then
                Marshal.ReleaseComObject(obj)
            End If
        Catch ex As Exception
        Finally
            obj = Nothing
        End Try
    End Sub

    Public Function fncEraseDisc(ByVal Recorder As IMAPI2.MsftDiscRecorder2) As Boolean
        Dim Format As New IMAPI2.MsftDiscFormat2Erase
        Try
            Format.Recorder = Recorder
            If Not Format.IsCurrentMediaSupported(Recorder) Then
                Return False
            End If
            Format.ClientName = %本PG名%
            Format.EraseMedia()
        Catch ex As Exception
            'ここでのエラーはひとまず無視
        Finally
            'ＣＯＭオブジェクト開放
            MarshalObject(Format)
        End Try
        Return True
    End Function
End Module
--------------------------------------------------------
そうそうXP等で動かす時はIMAPI2をインストールする必要がある。
Win7は何も必要ないけど
XPだとIMAPI2をMSからダウンロードしてインストールしてね。
%～%は各環境に合わせれば良いと思います^^;