| Sub シート作成_ABC () Dim aaa As String aaa = "AT" Dim i As Integer For i = 44 To 100 aaa = "AT" & i aaa = Range(aaa).Text If aaa = "" Then MsgBox ("終了 ") Exit Sub End If Sheets("ABC").Select Sheets("ABC").Copy Before:=Sheets(1) Sheets("ABC (2)").Select Sheets("ABC (2)").Name = aaa Range("G50:R52").Select ActiveCell.FormulaR1C1 = aaa Range("G53").Select Next End Sub ファイル名：form1.vb Imports Oracle.DataAccess.Client Imports Excel = Microsoft.Office.Interop.Excel Public Class Form1 'データベースデータの読み込み Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click Dim sConn As String = "User Id= rcs;password=rcs;Data Source=; Dim conn As OracleConnection conn = New OracleConnection(sConn) conn.Open() MessageBox.Show("データベースをオープンしました。") Dim aaa As String Dim bbb As String Dim ccc As String Dim cmd As OracleCommand cmd = New OracleCommand("select * from tbl_zaiseki", conn) Dim Rdr As OracleDataReader Rdr = cmd.ExecuteReader() Try Rdr.Read() aaa = Rdr("NAME") bbb = Rdr("BIRTH") ccc = Rdr("KINMUNO") MyListBox2.Items.Clear() MyListBox2.Items.Add(aaa) MyListBox3.Items.Clear() MyListBox3.Items.Add(bbb) MyListBox4.Items.Clear() MyListBox4.Items.Add(ccc) Catch MessageBox.Show("エラーが起こりました") Rdr.Close() Rdr.Dispose() End Try conn.Close() MessageBox.Show("データベースをクローズしました。") End Sub 'CSVファイルの読み込み Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click OpenFileDialog1.Filter = "CSVfile|*.csv" OpenFileDialog1.ShowDialog() Dim strFileName As String strFileName = OpenFileDialog1.FileName GetFileLines(strFileName) End Sub 'Fileの行数をカウントする Function GetFileLines(ByVal strFileName As String) As Long Dim i As Long i = 0 'ファイルをシステムの現在のエンコードで開く Dim srFile As New System.IO.StreamReader(strFileName, System.Text.Encoding.Default) 'ファイルの末尾に達するまで1行ずつ読み込む MyListBox1.Items.Clear() MyListBox2.Items.Clear() MyListBox3.Items.Clear() MyListBox4.Items.Clear() MyListBox5.Items.Clear() Do Until srFile.Peek = -1 Dim strLine As String = srFile.ReadLine() Console.WriteLine(strLine) 'ここがデバッグの時にでてくる Dim myArray() As String = Split(strLine, ",") If myArray(1).ToString = "" Then Exit Do End If MyListBox2.Items.Add(myArray(0)) MyListBox3.Items.Add(myArray(1)) MyListBox4.Items.Add(myArray(2)) i = i + 1 Loop 'ファイルを閉じる srFile.Close() GetFileLines = i End Function Private Class MyListBox Inherits ListBox Public Event Scroll() Protected Overrides Sub WndProc(ByRef m As Message) Const WM_VSCROLL As Integer = &H115I If m.Msg = WM_VSCROLL Then RaiseEvent Scroll() End If MyBase.WndProc(m) End Sub Protected Overrides Sub OnMouseWheel(ByVal e As MouseEventArgs) If e.Delta <> 0 Then RaiseEvent Scroll() End If End Sub Protected Overrides Sub OnSelectedIndexChanged(ByVal e As EventArgs) RaiseEvent Scroll() End Sub End Class Private WithEvents MyListBox1, MyListBox2, MyListBox3, MyListBox4, MyListBox5 As New MyListBox() Private Sub Form1_Load(ByVal sender As Object, ByVal e As EventArgs) Handles MyBase.Load SuspendLayout() 'カスタムListBoxの作成 MyListBox1.Name = "MyListBox1" MyListBox2.Name = "MyListBox2" MyListBox3.Name = "MyListBox3" MyListBox4.Name = "MyListBox4" MyListBox5.Name = "MyListBox5" MyListBox1.Size = New Size(100, 100) MyListBox2.Size = New Size(100, 100) MyListBox3.Size = New Size(100, 100) MyListBox4.Size = New Size(100, 100) MyListBox5.Size = New Size(100, 100) MyListBox1.Location = New Point(40, 40) MyListBox2.Location = New Point(140, 40) MyListBox3.Location = New Point(240, 40) MyListBox4.Location = New Point(340, 40) MyListBox5.Location = New Point(440, 40) 'ダミーデータの作成 Dim R As New Random() Dim I As Integer For I = 1 To 100 MyListBox1.Items.Add(New String("*"c, R.Next(1, 20))) MyListBox2.Items.Add(New String("@"c, R.Next(1, 20))) MyListBox3.Items.Add(New String("@"c, R.Next(1, 20))) MyListBox4.Items.Add(New String("@"c, R.Next(1, 20))) MyListBox5.Items.Add(New String("@"c, R.Next(1, 20))) Next Me.Controls.Add(MyListBox1) Me.Controls.Add(MyListBox2) Me.Controls.Add(MyListBox3) Me.Controls.Add(MyListBox4) Me.Controls.Add(MyListBox5) ResumeLayout() End Sub 'スクロールの同期 Private Sub MyListBox1_Scroll() Handles MyListBox1.Scroll MyListBox2.TopIndex = MyListBox1.TopIndex MyListBox3.TopIndex = MyListBox1.TopIndex MyListBox4.TopIndex = MyListBox1.TopIndex MyListBox5.TopIndex = MyListBox1.TopIndex End Sub Private Sub MyListBox2_Scroll() Handles MyListBox2.Scroll MyListBox1.TopIndex = MyListBox2.TopIndex MyListBox3.TopIndex = MyListBox2.TopIndex MyListBox4.TopIndex = MyListBox2.TopIndex MyListBox5.TopIndex = MyListBox2.TopIndex End Sub Private Sub MyListBox3_Scroll() Handles MyListBox3.Scroll MyListBox2.TopIndex = MyListBox3.TopIndex MyListBox1.TopIndex = MyListBox3.TopIndex MyListBox4.TopIndex = MyListBox3.TopIndex MyListBox5.TopIndex = MyListBox3.TopIndex End Sub Private Sub MyListBox4_Scroll() Handles MyListBox4.Scroll MyListBox1.TopIndex = MyListBox4.TopIndex MyListBox2.TopIndex = MyListBox4.TopIndex MyListBox3.TopIndex = MyListBox4.TopIndex MyListBox5.TopIndex = MyListBox4.TopIndex End Sub Private Sub MyListBox5_Scroll() Handles MyListBox5.Scroll MyListBox4.TopIndex = MyListBox5.TopIndex MyListBox3.TopIndex = MyListBox5.TopIndex MyListBox2.TopIndex = MyListBox5.TopIndex MyListBox1.TopIndex = MyListBox5.TopIndex End Sub '選択の同期 Private Sub MyListBox1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyListBox1.Click Dim i As Integer i = MyListBox1.SelectedIndex MyListBox1.SetSelected(i, True) MyListBox2.SetSelected(i, True) MyListBox3.SetSelected(i, True) MyListBox4.SetSelected(i, True) MyListBox5.SetSelected(i, True) End Sub Private Sub MyListBox2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyListBox2.Click Dim i As Integer i = MyListBox2.SelectedIndex MyListBox1.SetSelected(i, True) MyListBox2.SetSelected(i, True) MyListBox3.SetSelected(i, True) MyListBox4.SetSelected(i, True) MyListBox5.SetSelected(i, True) End Sub Private Sub MyListBox3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyListBox3.Click Dim i As Integer i = MyListBox3.SelectedIndex MyListBox1.SetSelected(i, True) MyListBox2.SetSelected(i, True) MyListBox3.SetSelected(i, True) MyListBox4.SetSelected(i, True) MyListBox5.SetSelected(i, True) End Sub Private Sub MyListBox4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyListBox4.Click Dim i As Integer i = MyListBox4.SelectedIndex MyListBox1.SetSelected(i, True) MyListBox2.SetSelected(i, True) MyListBox3.SetSelected(i, True) MyListBox4.SetSelected(i, True) MyListBox5.SetSelected(i, True) End Sub Private Sub MyListBox5_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyListBox5.Click Dim i As Integer i = MyListBox5.SelectedIndex MyListBox1.SetSelected(i, True) MyListBox2.SetSelected(i, True) MyListBox3.SetSelected(i, True) MyListBox4.SetSelected(i, True) MyListBox5.SetSelected(i, True) End Sub End Class // メモ帳04の続き1 b_stop = new Button("中 断"); // Suspendボタンを生成 b_reset = new Button("やり直し"); // Resetボタンを生成 add(b_start); add(b_stop); add(b_reset); // ボタンを取り付け add(new Label(" alpha=")); // ラベルを取り付け ch_alph = Choice();// チョイスを生成 ch_alph.addItem("0.0004"); // チョイスの項目設定 ch_alph.addItem("0.0006"); ch_alph.addItem("0.0008"); ch_alph.select(1); // alphaの初期値を2番目に設定 add(ch_alph); // alphaのチョイスを取り付け bt_start.addActionListener(this);// インターフェイスに関連付け bt_stop.addActionListener(this); bt_reset.addActionListener(this); ch_alph.addItemListener(this); setBackground(Color.lightGray); // 背景色設定 // ウィンドウ座標表示系の初期化 drw = new DrawCanvas(img,bg,wx,wy); // 初期条件の代入とその表示 sol.inputData(); drw.viewPort(20,0,false,sol.getRange());// ビューポート変換 AuthorAttribute Inherits Attribute Private _name As String Public Sub New(ByVal name as String) _name = name End Sub Public ReadOnly Property name() as String Get Return _name End Get End Property End Class End Class End Class End Class Inherits System.Windows.Forms.Form Public Sub dumpAuthor(ByVal classname as String) Dim targetType as Type = Type.GetType("Sample007n." + className) Dim list() as Object= _ targetType.GetCustomAttributes(GetType(AuthorAttribute),False) dim item as AuthorAttribute For Each item In list Trace.WriteLine("class " & className & "is written by " & item.name) Next End Sub Private Sub Form1_Load(ByVal sender as System.Object,ByVal e as System.EventArgs)Handles MyBase.Load dumpAuthor("Test1") dumpAuthor("Test2") dumpAuthor("Form1") End Sub End Class AuthorAttribute Inherits Attribute Private _name As String Public Sub New(ByVal name as String) _name = name End Sub Public ReadOnly Property name() as String Get Return _name End Get End Property End Class End Sub End Sub Dim info as System.Reflection.MethodInfo = me.GetType().GetMethod(methodName) Dim list() as Object= info.GetCustomAttributes(GetType(AuthorAttribute),False) dim item as AuthorAttribute For Each item In list Trace.WriteLine("method " & methodName & "is written by " & item.name) Next End Sub Private Sub Form1_Load(ByVal sender as System.Object,ByVal e as System.EventArgs)Handles MyBase.Load DumpAuthor("Test1") DumpAuthor("Test2") DumpAuthor("DumpAuthor") End Sub E F G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD AE AF AG AH AI AJ E7 2 月 16日 17日 18日 19日 20日 21日 22日 23日 24日 25日 26日 27日 28日 29日 30日 31日 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 E8 区分＼曜日 火 水 木 金 土 日 月 火 水 木 金 土 日 月 火 水 木 金 土 日 月 火 水 木 金 土 日 月 火 水 木 E9 勤務区分 日勤 日勤 日勤 日勤 日勤 日勤 日勤 夜勤 夜勤 夜勤 夜勤 夜勤 夜勤 夜勤 日勤 日勤 日勤 日勤 日勤 日勤 日勤 夜勤 夜勤 夜勤 夜勤 夜勤 夜勤 夜勤 日勤 日勤 日勤 E10 実働時間 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 7.75 E11 残業時間 E12 深夜時間 E13 休出時間 E14 法定休出 E15 食事 -------------------------------------------------------------------------------- From: "? [" To: sasasasasa854@hotmail.com Subject: マクロ（勤怠入力） Date: Fri, 16 Mar 2007 20:50:28 +0900 ’勤怠入力(ABC） Private Sub CommandButton1_Click() Dim strchar_conv As Variant Dim strint_conv As Integer Dim cell_conv As Variant Dim cell_conv_next As Variant Dim cnt_shifu As Integer Range(Selection.Address(0, 0)).Select str_cell = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False) strchar_conv = Mid(str_cell, 1, 1) strint_conv = Mid(str_cell, 2, 2) cnt_shifu = 1 '------------------------------------入力の開始 ---------------------------------------------- For aaa = Asc(strchar_conv) To Asc("Z") 'AからZになるまで繰り返す If UserForm1.ComboBox1.ListIndex = 0 Then '日勤を選択 Select Case cnt_shifu Case 1, 2, 3, 4, 5, 6, 7 _ , 15, 16, 17, 18, 19, 20, 21 _ , 29, 30, 31 cell_conv = Chr(aaa) & strint_conv cell_conv_next = Chr(aaa) & strint_conv + 1 Range(cell_conv).Value = UserForm1.ComboBox1.Value Range(cell_conv_next).Value = UserForm1.ComboBox2.Value cnt_shifu = cnt_shifu + 1 Case 8, 9, 10, 11, 12, 13, 14 _ , 22, 23, 24, 25, 26, 27, 28 '8日後からシフトの変更 cell_conv = Chr(aaa) & strint_conv cell_conv_next = Chr(aaa) & strint_conv + 1 Range(cell_conv).Value = "夜勤 " Range(cell_conv_next).Value = UserForm1.ComboBox2.Value cnt_shifu = cnt_shifu + 1 End Select Else Select Case cnt_shifu Case 1, 2, 3, 4, 5, 6, 7 _ , 15, 16, 17, 18, 19, 20, 21 _ , 29, 30, 31 cell_conv = Chr(aaa) & strint_conv cell_conv_next = Chr(aaa) & strint_conv + 1 Range(cell_conv).Value = UserForm1.ComboBox1.Value Range(cell_conv_next).Value = UserForm1.ComboBox2.Value cnt_shifu = cnt_shifu + 1 Case 8, 9, 10, 11, 12, 13, 14 _ , 22, 23, 24, 25, 26, 27, 28 cell_conv = Chr(aaa) & strint_conv cell_conv_next = Chr(aaa) & strint_conv + 1 Range(cell_conv).Value = "日勤 " Range(cell_conv_next).Value = UserForm1.ComboBox2.Value cnt_shifu = cnt_shifu + 1 End Select End If Next For aaa = Asc("A") To Asc("J") If UserForm1.ComboBox1.ListIndex = 0 Then Select Case cnt_shifu Case 1, 2, 3, 4, 5, 6, 7 _ , 15, 16, 17, 18, 19, 20, 21 _ , 29, 30, 31 cell_conv = "A" & Chr(aaa) & strint_conv cell_conv_next = "A" & Chr(aaa) & strint_conv + 1 Range(cell_conv).Value = UserForm1.ComboBox1.Value Range(cell_conv_next).Value = UserForm1.ComboBox2.Value cnt_shifu = cnt_shifu + 1 Case 8, 9, 10, 11, 12, 13, 14 _ , 22, 23, 24, 25, 26, 27, 28 cell_conv = "A" & Chr(aaa) & strint_conv cell_conv_next = "A" & Chr(aaa) & strint_conv + 1 Range(cell_conv).Value = "夜勤 " Range(cell_conv_next).Value = UserForm1.ComboBox2.Value cnt_shifu = cnt_shifu + 1 End Select Else Select Case cnt_shifu Case 1, 2, 3, 4, 5, 6, 7 _ , 15, 16, 17, 18, 19, 20, 21 _ , 29, 30, 31 cell_conv = "A" & Chr(aaa) & strint_conv cell_conv_next = "A" & Chr(aaa) & strint_conv + 1 Range(cell_conv).Value = UserForm1.ComboBox1.Value Range(cell_conv_next).Value = UserForm1.ComboBox2.Value cnt_shifu = cnt_shifu + 1 Case 8, 9, 10, 11, 12, 13, 14 _ , 22, 23, 24, 25, 26, 27, 28 cell_conv = "A" & Chr(aaa) & strint_conv cell_conv_next = "A" & Chr(aaa) & strint_conv + 1 Range(cell_conv).Value = "日勤 " Range(cell_conv_next).Value = UserForm1.ComboBox2.Value cnt_shifu = cnt_shifu + 1 End Select End If Next '-------------------------------------入力の終了 -------------------------------------------- '日勤 Dim RE, strPattern As String, r As Range Set RE = CreateObject("VBScript.RegExp") strPattern = "日勤 " ' strPattern = "^田(中|口).*(子|美)$" With RE .Pattern = strPattern ''検索パターンを設定 .IgnoreCase = True ''大文字と小文字を区別しない .Global = True ''文字列全体を検索 For Each r In ActiveSheet.UsedRange If .test(r.Formula) Then r.Interior.ColorIndex = 36 Next r End With strPattern = "夜勤 " With RE .Pattern = strPattern ''検索パターンを設定 .IgnoreCase = True ''大文字と小文字を区別しない .Global = True ''文字列全体を検索 For Each r In ActiveSheet.UsedRange If .test(r.Formula) Then r.Interior.ColorIndex = 34 Next r End With strPattern = "欠勤 " With RE .Pattern = strPattern ''検索パターンを設定 .IgnoreCase = True ''大文字と小文字を区別しない .Global = True ''文字列全体を検索 For Each r In ActiveSheet.UsedRange If .test(r.Formula) Then r.Font.ColorIndex = 3 Next r End With strPattern = "有給" With RE .Pattern = strPattern ''検索パターンを設定 .IgnoreCase = True ''大文字と小文字を区別しない .Global = True ''文字列全体を検索 For Each r In ActiveSheet.UsedRange If .test(r.Formula) Then r.Font.ColorIndex = 3 Next r End With Set RE = Nothing End Sub Private Sub CommandButton2_Click() UserForm1.Hide End Sub Private Sub UserForm_Initialize() UserForm1.ComboBox1.Clear UserForm1.ComboBox1.AddItem ("日勤") UserForm1.ComboBox1.AddItem ("夜勤") UserForm1.ComboBox2.Clear UserForm1.ComboBox2.AddItem ("7.75") UserForm1.ComboBox2.AddItem ("7.83") End Sub Sub Macro1() ' ' Macro1 Macro ' マクロ記録日 : 2007/3/2 ユーザー名 ' ' Range("E8").Select End Sub Sub AddressSamp1() MsgBox (Range(Selection.Address(0, 0)).Address) MsgBox (Range(Selection.Address(1, 0)).Address) MsgBox (Range(Selection.Address(0, 1)).Address) Cells(2, 1).Value = "@" Cells(2, 2).Value = ActiveCell.Address Cells(3, 1).Value = "A " Cells(3, 2).Value = ActiveCell.Address(RowAbsolute:=False) Cells(4, 1).Value = "B" Cells(4, 2).Value = ActiveCell.Address(ColumnAbsolute:=False) Cells(5, 1).Value = "C" Cells(5, 2).Value = ActiveCell.Address(RowAbsolute:=False, _ ColumnAbsolute:=False) Cells(6, 1).Value = "D " Cells(6, 2).Value = ActiveCell.Address(ReferenceStyle:=xlR1C1) Cells(7, 1).Value = "E" Cells(7, 2).Value = ActiveCell.Address(External:=True) Cells(8, 1).Value = "F" Cells(8, 2).Value = ActiveCell.Address(ColumnAbsolute:=False, _ RowAbsolute:=False, ReferenceStyle:=xlR1C1, Relativeto:=Cells(8, 2)) Dim aaa As Variant aaa = Range(Selection.Address(0, 0)).Address 'MsgBox (aaa) Range(aaa).Value = "aaaaaaaa" End Sub Const STR_APPNAME As String = "Devices" '目的のキーが所属しているセクションの名前（lpAppName） Const STR_DEFAULT As String = "見つかりませんでした" '規定の文字列(lpDefault) Const LNG_SIZE As Long = 1024 '情報を格納するバッファのサイズ(nSize) Const STR_KEYNAME As String = vbNullString 'セクション内の全てのキーを取得(NULLを指定) '**標準モジュール*******************************************: '━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ '【関数名】 GetProfileString '【機能】 WIN.INIから指定されたエントリの文字列を取得する '【引数】 ' lpAppName: String−エントリを検索するセクション ' lpKeyName: String−検索するキー名またはエントリ ' lpDefault: String−指定されたエントリが見つからなかった時に返される規定値 ' lpReturnedString:' String−nSizeバイトを割り当てる文字列バッファ ' nSize: Long−lpReturnedStringに格納できる最大文字数 '【戻り値】 lpReturnedStringバッファにコピーされたバイト数（最後のNull文字は含まれない） '━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ '■ GetProfileString API関数（WIN.INIから指定されたエントリの文字列を取得する） Private Declare Function GetProfileString Lib "kernel32.dll" Alias "GetProfileStringA" _ (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, _ ByVal lpReturnedString As String, ByVal nSize As Long) As Long '================================================================================================== 'プリンタ名一覧を取得する関数'戻り値：登録されているプリンタの数 'arg_vntPrinter():プリンタ名一覧（配列） 'arg_vntPort()：ポート名一覧（配列） 'arg_strErr:エラーメッセージ Public Function pb_fncGetPrinter(ByRef arg_vntPrinter() As Variant, _ ByRef arg_vntPort() As Variant, ByRef arg_strErr As String) As Long Dim lngRet As Long 'GetProfileString関数の戻り値 Dim strReturnedString As String * 1024 Dim strTmp As String Dim lngNull As Long Dim i As Long Dim lngStart As Long Dim strErr As String On Error GoTo ErrHandler '-Start--------------------------------------------------------- 'プリンタ一覧を取得 '指定したセクション名を検索、セクションの全キーを取得、該当データのバイト数を返す 'バッファ（strReturnedString）に格納された文字数が返る lngRet = GetProfileString(STR_APPNAME, STR_KEYNAME, STR_DEFAULT, strReturnedString, LNG_SIZE) '最後のNULLを除く strTmp = Left(strReturnedString, InStr(1, strReturnedString, Chr(0) & Chr(0)) - 1) '戻り値チェック If strTmp = STR_DEFAULT Then strErr = "プリンター名が取得できませんでした" GoTo ErrHandler End If lngNull = 0 i = 0 lngStart = 0 Do i = i + 1 lngNull = InStr(lngNull + 1, strTmp, Chr(0)) If lngNull = 0 Then lngNull = Len(strTmp) ReDim Preserve arg_vntPrinter(1 To i) arg_vntPrinter(i) = Mid(strTmp, lngStart + 1, lngNull - lngStart) If Right(arg_vntPrinter(i), 1) = Chr(0) Then '末尾のNULLを削除 arg_vntPrinter(i) = Left(arg_vntPrinter(i), Len(arg_vntPrinter(i)) - 1) End If lngStart = lngNull Loop Until lngNull = Len(strTmp) '-End----------------------------------------------------------- pb_fncGetPrinter = i ReDim arg_vntPort(1 To i) '-Start--------------------------------------------------------- 'ポート一覧を取得 For i = 1 To pb_fncGetPrinter lngRet = GetProfileString(STR_APPNAME, arg_vntPrinter(i), STR_DEFAULT, strReturnedString, LNG_SIZE) '最後のNULLを除く strTmp = Left(strReturnedString, InStr(1, strReturnedString, Chr(0)) - 1) strTmp = Mid(strTmp, InStr(1, strTmp, ",") + 1) '戻り値チェック If strTmp = STR_DEFAULT Then strErr = "ポート名が取得できませんでした" GoTo ErrHandler Else arg_vntPort(i) = strTmp End If Next i '-End----------------------------------------------------------- Exit Function ErrHandler: arg_strErr = strErr & vbCrLf & _ "フォームを閉じて終了させてください。" & _ vbCrLf & vbCrLf & Err.Number & " : " & Err.Description pb_fncGetPrinter = 0 End Function '**フォーム*******************************************: Private pr_strPrinterArray() As String 'プリンター＆ポートのフルネーム '================================================================================================== Private Sub CommandButton1_Click() With ListBox1 If .ListIndex = -1 Then MsgBox "なにも選択されていません" Else: MsgBox "選択されているプリンターは" & pr_strPrinterArray(.ListIndex + 1) & " です" End If End With End Sub '================================================================================================== Private Sub UserForm_Initialize() Dim strErrMsg As String Dim vntPrinter() As Variant 'プリンター名（配列） Dim vntPort() As Variant 'ポート名（配列） Dim lngPrinterCount As Long 'pb_fncGetPrinerの戻り値（登録されているプリンター数） Dim strActivePrinter As String Dim i As Long On Error GoTo ErrHandler '-Start--------------------------------------------------------- 'プリンター名、ポート名の設定 lngPrinterCount = pb_fncGetPrinter(vntPrinter(), vntPort(), strErrMsg) If lngPrinterCount = 0 Then Resume ErrHandler ReDim pr_strPrinterArray(1 To lngPrinterCount) strActivePrinter = Application.ActivePrinter If strActivePrinter Like "* on *" = True Then strActivePrinter = Trim(Left(strActivePrinter, InStr(strActivePrinter, " on ") - 1)) For i = 1 To lngPrinterCount pr_strPrinterArray(i) = vntPrinter(i) & " on " & vntPort(i) Next ElseIf strActivePrinter Like "* の *" = True Then strActivePrinter = Trim(Mid(strActivePrinter, InStr(strActivePrinter, " の ") + 3)) For i = 1 To lngPrinterCount pr_strPrinterArray(i) = vntPort(i) & " の " & vntPrinter(i) Next End If With ListBox1 For i = 1 To lngPrinterCount .AddItem vntPrinter(i) Next i End With '-End---------------------------------------------------------- Exit Sub ErrHandler: If Len(strErrMsg) = 0 Then strErrMsg = "フォームの表示段階でエラーが発生しました" & vbCrLf & _ "フォームを閉じて終了させてください。" & vbCrLf & vbCrLf & _ Err.Number & " : " & Err.Description End If MsgBox strErrMsg, vbCritical End Sub Sub test() If MsgBox("印刷しますか？", vbYesNo) = vbYes Then Application.Dialogs(xlDialogPrinterSetup).Show ActiveWindow.SelectedSheets.PrintOut Copies:=1 End If End Sub Option Explicit Option Base 0 Dim value() As Integer Sub bubble_sort() 'バブルソート '本体（大きいものを後ろに） Dim max As Integer Dim t As Integer Dim i As Variant ReDim value(9) value(0) = 1 value(1) = 8 value(2) = 3 value(3) = 2 value(4) = 9 value(5) = 4 value(6) = 10 value(7) = 6 value(8) = 5 value(9) = 7 For max = (10 - 1) - 1 To 0 Step -1 For t = 0 To max If value(t) > value(t + 1) Then Call swap(t, t + 1) End If Next Next ' For Each i In value() ' Debug.Print (value(i)) ' Next For i = 0 To 9 Debug.Print (value(i)) Next End Sub Sub swap(place1 As Integer, place2 As Integer) Dim temp As Integer temp = value(place1) value(place1) = value(place2) value(place2) = temp End Sub |