テックメモ – ページ 33 – 自分用のメモです。内容が間違っていたり、作りかけで動作しないコードなどあるのでご注意ください。

2017-11-032017-11-03

C# フォーム並べて追随させる

あまり使い道はないが、たまにこういう挙動を見かけることもある。

using System;
using System.Collections.Generic;
using System.ComponentModel;
using System.Data;
using System.Drawing;
using System.Linq;
using System.Text;
using System.Threading.Tasks;
using System.Windows.Forms;

namespace Test
{
    public partial class Form1 : Form
    {
        Form f = null;

        public Form1()
        {
            InitializeComponent();

            f = new Form2();
            
            f.FormClosed += new FormClosedEventHandler((object sender,FormClosedEventArgs e)=> { this.Close(); });
            f.Shown += new EventHandler((object sender, EventArgs e) => {
                f.Left = this.Left + this.Width;
                f.Top = this.Top;
                f.Height = this.Height;
                f.Width = this.Width;
            });
            f.Show();

        }
        private void Form1_ResizeEnd(object sender, EventArgs e)
        {
            f.Left = this.Left + this.Width;
            f.Top = this.Top;
            f.Height = this.Height;
            f.Width = this.Width;
        }

        private void button1_Click(object sender, EventArgs e)
        {
            ((Button)f.Controls["button1"]).Text = "hello world";
        }
    }
}

using System;

using System.Collections.Generic;

using System.ComponentModel;

using System.Data;

using System.Drawing;

using System.Linq;

using System.Text;

using System.Threading.Tasks;

using System.Windows.Forms;

namespace Test

{

public partial class Form1 : Form

{

Form f = null;

public Form1()

{

InitializeComponent();

f = new Form2();

f.FormClosed += new FormClosedEventHandler((object sender,FormClosedEventArgs e)=> { this.Close(); });

f.Shown += new EventHandler((object sender, EventArgs e) => {

f.Left = this.Left + this.Width;

f.Top = this.Top;

f.Height = this.Height;

f.Width = this.Width;

});

f.Show();

}

private void Form1_ResizeEnd(object sender, EventArgs e)

{

f.Left = this.Left + this.Width;

f.Top = this.Top;

f.Height = this.Height;

f.Width = this.Width;

}

private void button1_Click(object sender, EventArgs e)

{

((Button)f.Controls["button1"]).Text = "hello world";

}

2017-11-02

C# テキストファイル集計

テキストファイルを正規表現で集計する。

using System;
using System.Collections.Generic;
using System.ComponentModel;
using System.Data;
using System.Drawing;
using System.Linq;
using System.Text;
using System.Threading.Tasks;
using System.Windows.Forms;

using System.IO;
using System.Text.RegularExpressions;

namespace LineRegex
{
    public partial class Form1 : Form
    {
        public Form1()
        {
            InitializeComponent();
            listBox1.AllowDrop = true;
        }

        private void listBox1_DragDrop(object sender, DragEventArgs e)
        {
            listBox1.Items.AddRange((string[])e.Data.GetData(DataFormats.FileDrop, false));
        }
        private void listBox1_DragEnter(object sender, DragEventArgs e)
        {
            if (e.Data.GetDataPresent(DataFormats.FileDrop)) e.Effect = DragDropEffects.Copy;
        }
        private void button1_Click(object sender, EventArgs e)
        {
            dataGridView1.Rows.Clear();

            DataTable dt = new DataTable("tbl");
            dt.Columns.Add("日付");
            dt.Columns.Add("番号");
            dt.Columns.Add("数量");
            dt.Columns.Add("金額");
            dt.Columns.Add("名称");

            DataSet ds = new DataSet();
            ds.Tables.Add(dt);

            foreach (string s in listBox1.Items)
            {
                using (StreamReader sr = new StreamReader(s,System.Text.Encoding.GetEncoding("shift_jis")))
                {
                    string r_d = "";
                    string r_j = "";
                    List<string[]> r_j_list = new List<string[]>();
                    string r_q = "";
                    string r_a = "";
                    string r_n = "";

                    while (sr.Peek() > -1)
                    {
                        string ln = sr.ReadLine(); 

                        if (new Regex("--------------------------------").IsMatch(ln))
                        {
                            r_d = "";
                            r_j = "";
                            r_j_list.Clear();
                            r_q = "";
                            r_a = "";
                            r_n = "";
                        }
                        else if (new Regex(@"^\d{4}年\d{2}月\d{2}日").IsMatch(ln))
                        {
                            Match m = new Regex(@"^\d{4}年\d{2}月\d{2}日").Match(ln);
                            r_d = m.Groups[0].Value;
                        }
                        else if (new Regex(@"^\d+\s{1}JAN").IsMatch(ln))
                        {
                            Match m = new Regex(@"^(\d+)\s{1}JAN").Match(ln);
                            r_j = m.Groups[1].Value;
                        }
                        else if (new Regex(@"^\s+[0-9]+ｺ").IsMatch(ln))
                        {
                            Match m = new Regex(@"^\s+([0-9]+)ｺ").Match(ln);
                            r_q = m.Groups[1].Value;
                        }
                        else if (new Regex(@"^\s{1}[1-9]+.+\\[0-9,]+$").IsMatch(ln))
                        {
                            Match m = new Regex(@"^\s{1}[1-9]+.+\\([0-9,]+)$").Match(ln);
                            r_a = m.Groups[1].Value;

                            if (r_q == "") r_q = "1";

                            if (r_j != "")
                            {
                                r_j_list.Add(new string[] { r_j, r_q, r_a });
                                r_j = "";
                                r_q = "";
                                r_a = "";
                            }
                        }
                        else if (new Regex(@"^\s+\S+\s+様").IsMatch(ln))
                        {
                            Match m = new Regex(@"^\s+(\S+)\s+様").Match(ln);
                            r_n = m.Groups[1].Value;

                            foreach (string[] j in r_j_list)
                            {
                                DataRow dr = ds.Tables["tbl"].NewRow();
                                dr["日付"] = r_d;
                                dr["番号"] = j[0];
                                dr["数量"] = j[1];
                                dr["金額"] = j[2];
                                dr["名称"] = r_n;
                                ds.Tables["tbl"].Rows.Add(dr);
                            }
                        }
                    }
                }
            }
                dataGridView1.DataSource = ds.Tables["tbl"];
        }
    }
}

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

using System;

using System.Collections.Generic;

using System.ComponentModel;

using System.Data;

using System.Drawing;

using System.Linq;

using System.Text;

using System.Threading.Tasks;

using System.Windows.Forms;

using System.IO;

using System.Text.RegularExpressions;

namespace LineRegex

{

public partial class Form1 : Form

{

public Form1()

{

InitializeComponent();

listBox1.AllowDrop = true;

}

private void listBox1_DragDrop(object sender, DragEventArgs e)

{

listBox1.Items.AddRange((string[])e.Data.GetData(DataFormats.FileDrop, false));

}

private void listBox1_DragEnter(object sender, DragEventArgs e)

{

if (e.Data.GetDataPresent(DataFormats.FileDrop)) e.Effect = DragDropEffects.Copy;

}

private void button1_Click(object sender, EventArgs e)

{

dataGridView1.Rows.Clear();

DataTable dt = new DataTable("tbl");

dt.Columns.Add("日付");

dt.Columns.Add("番号");

dt.Columns.Add("数量");

dt.Columns.Add("金額");

dt.Columns.Add("名称");

DataSet ds = new DataSet();

ds.Tables.Add(dt);

foreach (string s in listBox1.Items)

{

using (StreamReader sr = new StreamReader(s,System.Text.Encoding.GetEncoding("shift_jis")))

{

string r_d = "";

string r_j = "";

List<string[]> r_j_list = new List<string[]>();

string r_q = "";

string r_a = "";

string r_n = "";

while (sr.Peek() > -1)

{

string ln = sr.ReadLine();

if (new Regex("--------------------------------").IsMatch(ln))

{

r_d = "";

r_j = "";

r_j_list.Clear();

r_q = "";

r_a = "";

r_n = "";

}

else if (new Regex(@"^\d{4}年\d{2}月\d{2}日").IsMatch(ln))

{

Match m = new Regex(@"^\d{4}年\d{2}月\d{2}日").Match(ln);

r_d = m.Groups[0].Value;

}

else if (new Regex(@"^\d+\s{1}JAN").IsMatch(ln))

{

Match m = new Regex(@"^(\d+)\s{1}JAN").Match(ln);

r_j = m.Groups[1].Value;

}

else if (new Regex(@"^\s+[0-9]+ｺ").IsMatch(ln))

{

Match m = new Regex(@"^\s+([0-9]+)ｺ").Match(ln);

r_q = m.Groups[1].Value;

}

else if (new Regex(@"^\s{1}[1-9]+.+\\[0-9,]+$").IsMatch(ln))

{

Match m = new Regex(@"^\s{1}[1-9]+.+\\([0-9,]+)$").Match(ln);

r_a = m.Groups[1].Value;

if (r_q == "") r_q = "1";

if (r_j != "")

{

r_j_list.Add(new string[] { r_j, r_q, r_a });

r_j = "";

r_q = "";

r_a = "";

}

else if (new Regex(@"^\s+\S+\s+様").IsMatch(ln))

{

Match m = new Regex(@"^\s+(\S+)\s+様").Match(ln);

r_n = m.Groups[1].Value;

foreach (string[] j in r_j_list)

{

DataRow dr = ds.Tables["tbl"].NewRow();

dr["日付"] = r_d;

dr["番号"] = j[0];

dr["数量"] = j[1];

dr["金額"] = j[2];

dr["名称"] = r_n;

ds.Tables["tbl"].Rows.Add(dr);

}

dataGridView1.DataSource = ds.Tables["tbl"];

}

2017-11-012022-12-16

VBA 条件付き書式

Sub CellsCondition()

' 条件付書式クリア

Set w = Sheets("11月")

'w.Cells.FormatConditions.Delete
w.Columns("J").FormatConditions.Delete

' 最終行取得

'b = w.UsedRange.Rows.Count
b = 324

For r = 2 To b
  For c = 10 To 10 ' J列のみ
  
    ' A列の値(Weekday)が1なら赤
    'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=Weekday(A" & r & ")=1")
    'f.Interior.Color = RGB(255, 200, 200)
    'f.StopIfTrue = False

    ' A列の値(Weekday)が7なら青(複数条件)
    'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=AND(B" & r & "=0,Weekday(A" & r & ")=7)")
    'f.Interior.Color = RGB(200, 200, 255)
    'f.StopIfTrue = False

    ' 重複チェック＋特定の単語を除外
    'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=AND(COUNTIF(J2:J324,J" & r & ")>1,J" & r & "<>""ｼｺﾐ"")")
    'f.Interior.Color = RGB(255, 0, 0)
    'f.StopIfTrue = False

    ' A列の値が1なら書式設定
    'Set f = w.Cells(r, 1).FormatConditions.Add(xlExpression, xlEqual, "=Day(A" & r & ")=1")
    'f.NumberFormat = "mm/dd(aaa)"
    'f.StopIfTrue = False

  Next c
Next r

End Sub

Sub CellsCondition()

' 条件付書式クリア

Set w = Sheets("11月")

'w.Cells.FormatConditions.Delete

w.Columns("J").FormatConditions.Delete

' 最終行取得

'b = w.UsedRange.Rows.Count

b = 324

For r = 2 To b

For c = 10 To 10 ' J列のみ

' A列の値(Weekday)が1なら赤

'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=Weekday(A" & r & ")=1")

'f.Interior.Color = RGB(255, 200, 200)

'f.StopIfTrue = False

' A列の値(Weekday)が7なら青(複数条件)

'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=AND(B" & r & "=0,Weekday(A" & r & ")=7)")

'f.Interior.Color = RGB(200, 200, 255)

'f.StopIfTrue = False

' 重複チェック＋特定の単語を除外

'Set f = w.Cells(r, c).FormatConditions.Add(xlExpression, xlEqual, "=AND(COUNTIF(J2:J324,J" & r & ")>1,J" & r & "<>""ｼｺﾐ"")")

'f.Interior.Color = RGB(255, 0, 0)

'f.StopIfTrue = False

' A列の値が1なら書式設定

'Set f = w.Cells(r, 1).FormatConditions.Add(xlExpression, xlEqual, "=Day(A" & r & ")=1")

'f.NumberFormat = "mm/dd(aaa)"

'f.StopIfTrue = False

Next c

Next r

End Sub

2017-10-312024-05-03

C# FFmpegにコマンド投げる②

ちょっと動画の長さを調整したいとき用。

実行ファイルと同じ場所にffmpeg.exeを置く。

using System;
using System.Collections.Generic;
using System.ComponentModel;
using System.Data;
using System.Drawing;
using System.Linq;
using System.Text;
using System.Threading.Tasks;
using System.Windows.Forms;

using System.Runtime.InteropServices;
using QuartzTypeLib;

namespace FFMPEG_UI
{
    public partial class Form1 : Form
    {
        public Form1()
        {
            InitializeComponent();

            listBox1.AllowDrop = true;

            textBox1.Text = "00";
            textBox2.Text = "00";
            textBox3.Text = "00";
            textBox4.Text = "000";
            textBox5.Text = "00";
            textBox6.Text = "00";
            textBox7.Text = "00";
            textBox8.Text = "000";
        }

        private void listBox1_DragEnter(object sender, DragEventArgs e)
        {
            if (e.Data.GetDataPresent(DataFormats.FileDrop)) e.Effect = DragDropEffects.Copy;
        }

        private void listBox1_DragDrop(object sender, DragEventArgs e)
        {
            listBox1.Items.AddRange((string[])e.Data.GetData(DataFormats.FileDrop, false));
        }

        private void button2_Click(object sender, EventArgs e)
        {
            listBox1.Items.Clear();

            textBox1.Text = "00";
            textBox2.Text = "00";
            textBox3.Text = "00";
            textBox4.Text = "000";
            textBox5.Text = "00";
            textBox6.Text = "00";
            textBox7.Text = "00";
            textBox8.Text = "000";
        }

        private void button1_Click(object sender, EventArgs e)
        {
            string s_h = textBox1.Text;
            string s_m = textBox2.Text;
            string s_s = textBox3.Text;
            string s_ms = textBox4.Text;
            string e_h = textBox5.Text;
            string e_m = textBox6.Text;
            string e_s = textBox7.Text;
            string e_ms = textBox8.Text;

            TimeSpan start_position = new TimeSpan(0, int.Parse(s_h), int.Parse(s_m), int.Parse(s_s), int.Parse(s_ms));
            TimeSpan end_position = new TimeSpan(0, int.Parse(e_h), int.Parse(e_m), int.Parse(e_s), int.Parse(e_ms));
            string interval = (end_position - start_position).TotalSeconds.ToString();

            foreach (string s in listBox1.Items)
            {

                string filePath = System.IO.Path.GetDirectoryName(s) + @"\out_" + System.IO.Path.GetFileName(s);
                
                System.Diagnostics.Process p =
                System.Diagnostics.Process.Start(
                    Application.StartupPath + @"\ffmpeg.exe"
                    , "-ss " + start_position.TotalSeconds.ToString() + " -i \"" + s.ToString() + "\" -t " + interval + " \"" + filePath + "\"");

                p.WaitForExit();
                
            }
        }
    }
}

using System;

using System.Collections.Generic;

using System.ComponentModel;

using System.Data;

using System.Drawing;

using System.Linq;

using System.Text;

using System.Threading.Tasks;

using System.Windows.Forms;

using System.Runtime.InteropServices;

using QuartzTypeLib;

namespace FFMPEG_UI

{

public partial class Form1 : Form

{

public Form1()

{

InitializeComponent();

listBox1.AllowDrop = true;

textBox1.Text = "00";

textBox2.Text = "00";

textBox3.Text = "00";

textBox4.Text = "000";

textBox5.Text = "00";

textBox6.Text = "00";

textBox7.Text = "00";

textBox8.Text = "000";

}

private void listBox1_DragEnter(object sender, DragEventArgs e)

{

if (e.Data.GetDataPresent(DataFormats.FileDrop)) e.Effect = DragDropEffects.Copy;

}

private void listBox1_DragDrop(object sender, DragEventArgs e)

{

listBox1.Items.AddRange((string[])e.Data.GetData(DataFormats.FileDrop, false));

}

private void button2_Click(object sender, EventArgs e)

{

listBox1.Items.Clear();

textBox1.Text = "00";

textBox2.Text = "00";

textBox3.Text = "00";

textBox4.Text = "000";

textBox5.Text = "00";

textBox6.Text = "00";

textBox7.Text = "00";

textBox8.Text = "000";

}

private void button1_Click(object sender, EventArgs e)

{

string s_h = textBox1.Text;

string s_m = textBox2.Text;

string s_s = textBox3.Text;

string s_ms = textBox4.Text;

string e_h = textBox5.Text;

string e_m = textBox6.Text;

string e_s = textBox7.Text;

string e_ms = textBox8.Text;

TimeSpan start_position = new TimeSpan(0, int.Parse(s_h), int.Parse(s_m), int.Parse(s_s), int.Parse(s_ms));

TimeSpan end_position = new TimeSpan(0, int.Parse(e_h), int.Parse(e_m), int.Parse(e_s), int.Parse(e_ms));

string interval = (end_position - start_position).TotalSeconds.ToString();

foreach (string s in listBox1.Items)

{

string filePath = System.IO.Path.GetDirectoryName(s) + @"\out_" + System.IO.Path.GetFileName(s);

System.Diagnostics.Process p =

System.Diagnostics.Process.Start(

Application.StartupPath + @"\ffmpeg.exe"

, "-ss " + start_position.TotalSeconds.ToString() + " -i \"" + s.ToString() + "\" -t " + interval + " \"" + filePath + "\"");

p.WaitForExit();

}

2017-10-302024-05-03

VBA 工数管理プログラム変更版

前回作成したファイルにマスタ管理機能を追加しフォームを少し変更。

Module1

Sub auto_open()

SetStyle

If (StrConv(Sheets("設定").Range("B5").Value, 10) = "on") Then
  Sheets("作業登録").Activate
  UserForm1.Show
End If

On Error Resume Next

Application.CommandBars("cell").Controls("フォーム表示").Delete
Application.CommandBars("cell").Controls("フォーム表示").Delete

With Application.CommandBars("cell").Controls.Add
.Caption = "フォーム表示"
.OnAction = "FormShow"
End With

End Sub

Sub auto_close()

On Error Resume Next

Application.CommandBars("cell").Controls("フォーム表示").Delete
Application.CommandBars("cell").Controls("フォーム表示").Delete

End Sub

Sub FormShow()

Sheets("作業登録").Activate
UserForm1.Show

End Sub

Sub SetStyle()

'マスタ管理

Sheets("マスタ管理").Cells(3, 2).NumberFormatLocal = "@"

'登録者

Sheets("登録者").Cells(3, 2).NumberFormatLocal = "@"
Sheets("登録者").Cells(5, 2).NumberFormatLocal = "@"
Sheets("登録者").Cells(7, 2).NumberFormatLocal = "@"
Sheets("登録者").Cells(11, 2).NumberFormatLocal = "@"

'作業登録

Sheets("作業登録").Cells.NumberFormatLocal = ""
Sheets("作業登録").Columns("A").NumberFormatLocal = "@"
Sheets("作業登録").Columns("B").NumberFormatLocal = "@"

For c = 8 To 101 Step 3

  Sheets("作業登録").Cells(1, c).Value = "種"
  Sheets("作業登録").Cells(1, c + 1).Value = "スタート"
  Sheets("作業登録").Cells(1, c + 2).Value = "ストップ"
  
  Sheets("作業登録").Columns(c).NumberFormatLocal = ""
  Sheets("作業登録").Columns(c + 1).NumberFormatLocal = "mm/dd hh:mm"
  Sheets("作業登録").Columns(c + 2).NumberFormatLocal = "mm/dd hh:mm"

  Sheets("作業登録").Columns(c).ColumnWidth = "2.5"
  Sheets("作業登録").Columns(c + 1).ColumnWidth = "12"
  Sheets("作業登録").Columns(c + 2).ColumnWidth = "12"
  
Next c

End Sub

Sub WorkTimeAdd()

Set w = Sheets("作業登録")

For r = 2 To w.UsedRange.Rows.Count

  w.Cells(r, 5) = ""
  w.Cells(r, 6) = ""

  If w.Cells(r, 4).Text = "完了" And w.Cells(r, 7).Text <> "" Then
  
    n = 0
    f = 0
  
    For c = 8 To w.Cells(r, 7).Text Step 3
    
      Select Case w.Cells(r, c).Text
        Case "作"
          n = n + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text)
        Case "修"
          f = f + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text)
      End Select
      
    Next c
    
    w.Cells(r, 5) = Int(n / 60) & "." & Format(n Mod 60, "00") & " H"
    w.Cells(r, 6) = Int(f / 60) & "." & Format(f Mod 60, "00") & " H"
      
  End If

Next r

w.Activate

End Sub

Function WorkTime(date_s, date_e)

On Error GoTo try

date_s = CDate(date_s)
date_e = CDate(date_e)

ts = 0

Do While date_s < date_e

  ts = ts + 1
 
  If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:00:00") And _
      date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:15:00") Then
    ts = ts - 1
  End If
  
  If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:00:00") And _
      date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:50:00") Then
    ts = ts - 1
  End If
  
  If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:00:00") And _
      date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:15:00") Then
    ts = ts - 1
  End If
  
  If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:20:00") And _
      date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:30:00") Then
    ts = ts - 1
  End If
  
  date_s = DateAdd("n", 1, date_s)
  
Loop

WorkTime = ts

Exit Function

try:

  WorkTime = 0

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

Sub auto_open()

SetStyle

If (StrConv(Sheets("設定").Range("B5").Value, 10) = "on") Then

Sheets("作業登録").Activate

UserForm1.Show

End If

On Error Resume Next

Application.CommandBars("cell").Controls("フォーム表示").Delete

With Application.CommandBars("cell").Controls.Add

.Caption = "フォーム表示"

.OnAction = "FormShow"

End With

End Sub

Sub auto_close()

On Error Resume Next

Application.CommandBars("cell").Controls("フォーム表示").Delete

End Sub

Sub FormShow()

Sheets("作業登録").Activate

UserForm1.Show

End Sub

Sub SetStyle()

'マスタ管理

Sheets("マスタ管理").Cells(3, 2).NumberFormatLocal = "@"

'登録者

Sheets("登録者").Cells(3, 2).NumberFormatLocal = "@"

Sheets("登録者").Cells(5, 2).NumberFormatLocal = "@"

Sheets("登録者").Cells(7, 2).NumberFormatLocal = "@"

Sheets("登録者").Cells(11, 2).NumberFormatLocal = "@"

'作業登録

Sheets("作業登録").Cells.NumberFormatLocal = ""

Sheets("作業登録").Columns("A").NumberFormatLocal = "@"

Sheets("作業登録").Columns("B").NumberFormatLocal = "@"

For c = 8 To 101 Step 3

Sheets("作業登録").Cells(1, c).Value = "種"

Sheets("作業登録").Cells(1, c + 1).Value = "スタート"

Sheets("作業登録").Cells(1, c + 2).Value = "ストップ"

Sheets("作業登録").Columns(c).NumberFormatLocal = ""

Sheets("作業登録").Columns(c + 1).NumberFormatLocal = "mm/dd hh:mm"

Sheets("作業登録").Columns(c + 2).NumberFormatLocal = "mm/dd hh:mm"

Sheets("作業登録").Columns(c).ColumnWidth = "2.5"

Sheets("作業登録").Columns(c + 1).ColumnWidth = "12"

Sheets("作業登録").Columns(c + 2).ColumnWidth = "12"

Next c

End Sub

Sub WorkTimeAdd()

Set w = Sheets("作業登録")

For r = 2 To w.UsedRange.Rows.Count

w.Cells(r, 5) = ""

w.Cells(r, 6) = ""

If w.Cells(r, 4).Text = "完了" And w.Cells(r, 7).Text <> "" Then

n = 0

f = 0

For c = 8 To w.Cells(r, 7).Text Step 3

Select Case w.Cells(r, c).Text

Case "作"

n = n + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text)

Case "修"

f = f + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text)

End Select

Next c

w.Cells(r, 5) = Int(n / 60) & "." & Format(n Mod 60, "00") & " H"

w.Cells(r, 6) = Int(f / 60) & "." & Format(f Mod 60, "00") & " H"

End If

Next r

w.Activate

End Sub

Function WorkTime(date_s, date_e)

On Error GoTo try

date_s = CDate(date_s)

date_e = CDate(date_e)

ts = 0

Do While date_s < date_e

ts = ts + 1

If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:00:00") And _

date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:15:00") Then

ts = ts - 1

End If

If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:00:00") And _

date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:50:00") Then

ts = ts - 1

End If

If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:00:00") And _

date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:15:00") Then

ts = ts - 1

End If

If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:20:00") And _

date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:30:00") Then

ts = ts - 1

End If

date_s = DateAdd("n", 1, date_s)

Loop

WorkTime = ts

Exit Function

try:

WorkTime = 0

End Function

UserForm1

Function form_query()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
rs.Open "select ID,customer,model,serial,quantity,notes from orders where serial = '" & UserForm1.TextBox1.Text & "';", cn

Do Until rs.EOF

  UserForm1.TextBox8.Text = rs(0)
  UserForm1.TextBox2.Text = rs(1)
  UserForm1.TextBox3.Text = rs(2)
  UserForm1.TextBox1.Text = rs(3)
  UserForm1.TextBox7.Text = rs(4)
  UserForm1.TextBox4.Text = rs(5)

rs.movenext
Loop

If UserForm1.TextBox8.Text <> "" And UserForm1.TextBox7.Text > 0 Then
    
  For i = 1 To UserForm1.TextBox7.Text
    UserForm1.ComboBox2.AddItem i
    UserForm1.ComboBox3.AddItem i
  Next i

  UserForm1.ComboBox2.Text = "1"
  UserForm1.ComboBox3.Text = UserForm1.TextBox7.Text
  
End If

If rs.state = 1 Then rs.Close
Set rs = Nothing

If cn.state = 1 Then cn.Close
Set cn = Nothing

form_query = True

Exit Function

try:

  If rs.state = 1 Then rs.Close
  Set rs = Nothing

  If cn.state = 1 Then cn.Close
  Set cn = Nothing

  MsgBox Err.Description
  form_query = False
  
End Function

Private Sub CommandButton1_Click()
Sheets("作業登録").Activate

If UserForm1.TextBox1.Text = "" Then
  MsgBox "工番を入力してください。"
  Exit Sub
End If

If db_chk = False Then Exit Sub
form_clear
form_query

End Sub

Sub form_clear()

UserForm1.TextBox8.Text = ""
UserForm1.TextBox2.Text = ""
UserForm1.TextBox3.Text = ""
UserForm1.TextBox7.Text = ""
UserForm1.TextBox4.Text = ""

UserForm1.ComboBox2.Clear
UserForm1.ComboBox3.Clear
UserForm1.ComboBox2.Text = ""
UserForm1.ComboBox3.Text = ""

UserForm1.ComboBox1.Text = ""

End Sub

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close
Set cn = Nothing

db_chk = True

Exit Function

try:

  If cn.state = 1 Then cn.Close
  Set cn = Nothing
  
  MsgBox "DBに接続できません。"
  db_chk = False
  
End Function

Function qty_parse()

On Error GoTo try

If UserForm1.ComboBox2.Text = "" Or UserForm1.ComboBox3.Text = "" Then
  MsgBox "対象枝を入力してください。"
  qty_parse = False
  Exit Function
End If

qty = CInt(UserForm1.TextBox7.Text)
suffix_s = CInt(UserForm1.ComboBox2.Text)
suffix_e = CInt(UserForm1.ComboBox3.Text)

If suffix_s = 0 Or suffix_e = 0 Then
  MsgBox "対象枝は1以上の数字を指定する必要があります。"
  qty_parse = False
  Exit Function
End If

If suffix_e > qty Or suffix_s > suffix_e Then
  MsgBox "対象枝の指定範囲に問題があります。"
  qty_parse = False
  Exit Function
End If

qty_parse = True

Exit Function

try:

  MsgBox "対象枝が数字ではありません。"
  qty_parse = False

End Function

Private Sub CommandButton2_Click()
Sheets("作業登録").Activate
Call MainWrite("1", "スタート", "作")
MsgBox "完了しました。"
End Sub

Private Sub CommandButton3_Click()
Sheets("作業登録").Activate
Call MainWrite("1", "スタート", "修")
MsgBox "完了しました。"
End Sub

Private Sub CommandButton4_Click()
Sheets("作業登録").Activate
Call MainWrite("3", "ストップ", "")
MsgBox "完了しました。"
End Sub

Private Sub CommandButton5_Click()
Sheets("作業登録").Activate
Call MainWrite("4", "完了", "")
MsgBox "完了しました。"
End Sub

Private Sub CommandButton6_Click()
Sheets("作業登録").Activate
UserForm1.TextBox1.Text = ""
form_clear
End Sub

Private Sub CommandButton7_Click()
Sheets("作業登録").Activate
WorkTimeAdd
MsgBox "完了しました。"
End Sub

Sub MainWrite(mark, state, typ)

If ActiveSheet.Name <> "作業登録" Then
  MsgBox "作業登録で実施してください。"
  Exit Sub
End If

If UserForm1.TextBox8.Text = "" Then
  MsgBox "対象のIDが空白です。取得してください。"
  Exit Sub
End If

If UserForm1.ComboBox1.Text = "" Then
  MsgBox "作業者を選んでください。"
  Exit Sub
End If

If qty_parse = False Then Exit Sub

Set w = Sheets("作業登録")

serial = UserForm1.TextBox1.Text
worker = UserForm1.ComboBox1.Text

For suffix = CInt(UserForm1.ComboBox2.Text) To CInt(UserForm1.ComboBox3.Text)

  f = False

  For r = 2 To w.UsedRange.Rows.Count
    If worker = w.Cells(r, 1).Text And serial = w.Cells(r, 2).Text And suffix = w.Cells(r, 3) Then
      f = True
      Call WriteCol(r, worker, serial, suffix, mark, state, typ)
      w.Cells(r, 1).Select
    End If
  Next r
  
  If f = False Then
    Call WriteCol(r, worker, serial, suffix, mark, state, typ)
    w.Cells(r, 1).Select
  End If

Next suffix

End Sub

Sub WriteCol(r, worker, serial, suffix, mark, state, typ)

Set w = Sheets("作業登録")

If w.Cells(r, 4).Value = "完了" Then
  MsgBox serial & "-" & suffix & "は既に完了しています。"
  Exit Sub
End If

Select Case mark

Case "1" '作業スタート

  If w.Cells(r, 4).Value = "スタート" Then
    MsgBox serial & "-" & suffix & "は既にスタートしています。"
    Exit Sub
  End If
  
  If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then
    c = 9
  End If
  
Case "2" '修正スタート

  If w.Cells(r, 4).Value = "スタート" Then
    MsgBox serial & "-" & suffix & "は既にスタートしています。"
    Exit Sub
  End If
  
  If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then
    c = 9
  End If
  
Case "3" 'ストップ

  If w.Cells(r, 4).Value = "スタート" Then
    c = 10
  End If
  
  If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then
    MsgBox serial & "-" & suffix & "はスタートしていません。"
    Exit Sub
  End If
  
Case "4" '指定工番の完了

  If w.Cells(r, 4).Value = "スタート" Then
    MsgBox serial & "-" & suffix & "はスタートしているため完了できません。"
    Exit Sub
  End If

  If w.Cells(r, 4).Value = "ストップ" Or w.Cells(r, 4).Value = "" Then
    w.Cells(r, 1).Value = worker
    w.Cells(r, 2).Value = serial
    w.Cells(r, 3).Value = suffix
    w.Cells(r, 4).Value = "完了"
    w.Cells(r, 4).Interior.ColorIndex = 0
    Exit Sub
  End If
  
End Select

Do While True

  If w.Cells(r, c).Value = "" Then
  
    w.Cells(r, 1).Value = worker
    w.Cells(r, 2).Value = serial
    w.Cells(r, 3).Value = suffix
    w.Cells(r, 4).Value = state
    
    If (mark = 1 Or mark = 2) Then 'スタート
      w.Cells(r, 4).Interior.Color = RGB(255, 0, 0)
      w.Cells(r, 7).Value = ""
      w.Cells(r, c - 1).Value = typ
    End If
    
    If (mark = 3) Then 'ストップ
      w.Cells(r, 4).Interior.Color = RGB(255, 255, 0)
      w.Cells(r, 7).Value = c - 2
    End If
    
    w.Cells(r, c).Value = Format(Now(), "yyyy/mm/dd hh:mm:00")
    
    Exit Do
    
  End If
  
c = c + 3
Loop

End Sub

Private Sub UserForm_Initialize()

On Error GoTo try

UserForm1.ComboBox1.Clear

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
rs.Open "select ID,worker from worker;", cn

Do Until rs.EOF

  If rs(1) <> "" Then
    UserForm1.ComboBox1.AddItem rs(1)
  End If
  
rs.movenext
Loop

If rs.state = 1 Then rs.Close
Set rs = Nothing

If cn.state = 1 Then cn.Close
Set cn = Nothing

Exit Sub

try:

  If rs.state = 1 Then rs.Close
  Set rs = Nothing

  If cn.state = 1 Then cn.Close
  Set cn = Nothing

  MsgBox Err.Description

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

Function form_query()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

rs.Open "select ID,customer,model,serial,quantity,notes from orders where serial = '" & UserForm1.TextBox1.Text & "';", cn

Do Until rs.EOF

UserForm1.TextBox8.Text = rs(0)

UserForm1.TextBox2.Text = rs(1)

UserForm1.TextBox3.Text = rs(2)

UserForm1.TextBox1.Text = rs(3)

UserForm1.TextBox7.Text = rs(4)

UserForm1.TextBox4.Text = rs(5)

rs.movenext

Loop

If UserForm1.TextBox8.Text <> "" And UserForm1.TextBox7.Text > 0 Then

For i = 1 To UserForm1.TextBox7.Text

UserForm1.ComboBox2.AddItem i

UserForm1.ComboBox3.AddItem i

Next i

UserForm1.ComboBox2.Text = "1"

UserForm1.ComboBox3.Text = UserForm1.TextBox7.Text

End If

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

form_query = True

Exit Function

try:

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox Err.Description

form_query = False

End Function

Private Sub CommandButton1_Click()

Sheets("作業登録").Activate

If UserForm1.TextBox1.Text = "" Then

MsgBox "工番を入力してください。"

Exit Sub

End If

If db_chk = False Then Exit Sub

form_clear

form_query

End Sub

Sub form_clear()

UserForm1.TextBox8.Text = ""

UserForm1.TextBox2.Text = ""

UserForm1.TextBox3.Text = ""

UserForm1.TextBox7.Text = ""

UserForm1.TextBox4.Text = ""

UserForm1.ComboBox2.Clear

UserForm1.ComboBox3.Clear

UserForm1.ComboBox2.Text = ""

UserForm1.ComboBox3.Text = ""

UserForm1.ComboBox1.Text = ""

End Sub

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close

Set cn = Nothing

db_chk = True

Exit Function

try:

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox "DBに接続できません。"

db_chk = False

End Function

Function qty_parse()

On Error GoTo try

If UserForm1.ComboBox2.Text = "" Or UserForm1.ComboBox3.Text = "" Then

MsgBox "対象枝を入力してください。"

qty_parse = False

Exit Function

End If

qty = CInt(UserForm1.TextBox7.Text)

suffix_s = CInt(UserForm1.ComboBox2.Text)

suffix_e = CInt(UserForm1.ComboBox3.Text)

If suffix_s = 0 Or suffix_e = 0 Then

MsgBox "対象枝は1以上の数字を指定する必要があります。"

qty_parse = False

Exit Function

End If

If suffix_e > qty Or suffix_s > suffix_e Then

MsgBox "対象枝の指定範囲に問題があります。"

qty_parse = False

Exit Function

End If

qty_parse = True

Exit Function

try:

MsgBox "対象枝が数字ではありません。"

qty_parse = False

End Function

Private Sub CommandButton2_Click()

Sheets("作業登録").Activate

Call MainWrite("1", "スタート", "作")

MsgBox "完了しました。"

End Sub

Private Sub CommandButton3_Click()

Sheets("作業登録").Activate

Call MainWrite("1", "スタート", "修")

MsgBox "完了しました。"

End Sub

Private Sub CommandButton4_Click()

Sheets("作業登録").Activate

Call MainWrite("3", "ストップ", "")

MsgBox "完了しました。"

End Sub

Private Sub CommandButton5_Click()

Sheets("作業登録").Activate

Call MainWrite("4", "完了", "")

MsgBox "完了しました。"

End Sub

Private Sub CommandButton6_Click()

Sheets("作業登録").Activate

UserForm1.TextBox1.Text = ""

form_clear

End Sub

Private Sub CommandButton7_Click()

Sheets("作業登録").Activate

WorkTimeAdd

MsgBox "完了しました。"

End Sub

Sub MainWrite(mark, state, typ)

If ActiveSheet.Name <> "作業登録" Then

MsgBox "作業登録で実施してください。"

Exit Sub

End If

If UserForm1.TextBox8.Text = "" Then

MsgBox "対象のIDが空白です。取得してください。"

Exit Sub

End If

If UserForm1.ComboBox1.Text = "" Then

MsgBox "作業者を選んでください。"

Exit Sub

End If

If qty_parse = False Then Exit Sub

Set w = Sheets("作業登録")

serial = UserForm1.TextBox1.Text

worker = UserForm1.ComboBox1.Text

For suffix = CInt(UserForm1.ComboBox2.Text) To CInt(UserForm1.ComboBox3.Text)

f = False

For r = 2 To w.UsedRange.Rows.Count

If worker = w.Cells(r, 1).Text And serial = w.Cells(r, 2).Text And suffix = w.Cells(r, 3) Then

f = True

Call WriteCol(r, worker, serial, suffix, mark, state, typ)

w.Cells(r, 1).Select

End If

Next r

If f = False Then

Call WriteCol(r, worker, serial, suffix, mark, state, typ)

w.Cells(r, 1).Select

End If

Next suffix

End Sub

Sub WriteCol(r, worker, serial, suffix, mark, state, typ)

Set w = Sheets("作業登録")

If w.Cells(r, 4).Value = "完了" Then

MsgBox serial & "-" & suffix & "は既に完了しています。"

Exit Sub

End If

Select Case mark

Case "1" '作業スタート

If w.Cells(r, 4).Value = "スタート" Then

MsgBox serial & "-" & suffix & "は既にスタートしています。"

Exit Sub

End If

If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then

c = 9

End If

Case "2" '修正スタート

If w.Cells(r, 4).Value = "スタート" Then

MsgBox serial & "-" & suffix & "は既にスタートしています。"

Exit Sub

End If

If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then

c = 9

End If

Case "3" 'ストップ

If w.Cells(r, 4).Value = "スタート" Then

c = 10

End If

If w.Cells(r, 4).Value = "" Or w.Cells(r, 4).Value = "ストップ" Then

MsgBox serial & "-" & suffix & "はスタートしていません。"

Exit Sub

End If

Case "4" '指定工番の完了

If w.Cells(r, 4).Value = "スタート" Then

MsgBox serial & "-" & suffix & "はスタートしているため完了できません。"

Exit Sub

End If

If w.Cells(r, 4).Value = "ストップ" Or w.Cells(r, 4).Value = "" Then

w.Cells(r, 1).Value = worker

w.Cells(r, 2).Value = serial

w.Cells(r, 3).Value = suffix

w.Cells(r, 4).Value = "完了"

w.Cells(r, 4).Interior.ColorIndex = 0

Exit Sub

End If

End Select

Do While True

If w.Cells(r, c).Value = "" Then

w.Cells(r, 1).Value = worker

w.Cells(r, 2).Value = serial

w.Cells(r, 3).Value = suffix

w.Cells(r, 4).Value = state

If (mark = 1 Or mark = 2) Then 'スタート

w.Cells(r, 4).Interior.Color = RGB(255, 0, 0)

w.Cells(r, 7).Value = ""

w.Cells(r, c - 1).Value = typ

End If

If (mark = 3) Then 'ストップ

w.Cells(r, 4).Interior.Color = RGB(255, 255, 0)

w.Cells(r, 7).Value = c - 2

End If

w.Cells(r, c).Value = Format(Now(), "yyyy/mm/dd hh:mm:00")

Exit Do

End If

c = c + 3

Loop

End Sub

Private Sub UserForm_Initialize()

On Error GoTo try

UserForm1.ComboBox1.Clear

Set cn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

rs.Open "select ID,worker from worker;", cn

Do Until rs.EOF

If rs(1) <> "" Then

UserForm1.ComboBox1.AddItem rs(1)

End If

rs.movenext

Loop

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

Exit Sub

try:

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox Err.Description

End Sub

Sheet5(マスタ管理)

Function BuildQuery(mark)

q_i = Sheets("マスタ管理").Range("B9").Value
q_c = Sheets("マスタ管理").Range("B3").Value

q_i = StrConv(q_i, vbNarrow)

q_i = Replace(q_i, "'", "’")
q_c = Replace(q_c, "'", "’")

q_i = Replace(q_i, """", "’")
q_c = Replace(q_c, """", "’")

If mark = "s" Then q = "select ID,worker from worker;"
If mark = "i" Then q = "insert into worker (worker) values ('" & q_c & "');"
If mark = "u" Then q = "update worker set worker = '" & q_c & "' where ID = " & q_i & ";"
If mark = "d" Then q = "delete from worker where ID = " & q_i & ";"

BuildQuery = q

End Function

Private Sub CommandButton1_Click()

If db_chk = False Then Exit Sub
If form_chk = False Then Exit Sub

If form_query("i") = False Then Exit Sub

grid_clear
If grid_load("s") = False Then Exit Sub

form_clear
 
End Sub

Private Sub CommandButton2_Click()

If db_chk = False Then Exit Sub
If id_chk = False Then Exit Sub
If form_chk = False Then Exit Sub

If form_query("u") = False Then Exit Sub

grid_clear
If grid_load("s") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton3_Click()

If db_chk = False Then Exit Sub
If id_chk = False Then Exit Sub

yn = MsgBox("削除しますか？", vbYesNo)
If yn = vbNo Then Exit Sub

If form_query("d") = False Then Exit Sub

grid_clear
If grid_load("s") = False Then Exit Sub

form_clear

End Sub

Function id_chk()

On Error GoTo try

If Sheets("マスタ管理").Range("B9").Value = "" Then GoTo try

v = CLng(Sheets("マスタ管理").Range("B9").Value)

id_chk = True

Exit Function

try:

  MsgBox "IDが正しくありません。"
  id_chk = False

End Function

Function form_chk()

If Sheets("マスタ管理").Range("B3").Value = "" Then GoTo try

form_chk = True

Exit Function

try:

  MsgBox "入力が不足しています。"
  form_chk = False

End Function

Sub grid_clear()

Sheets("マスタ管理").Range("G4:H100").Delete

End Sub

Sub form_clear()

Sheets("マスタ管理").Range("B3").Value = ""
Sheets("マスタ管理").Range("B9").Value = ""

End Sub

Function form_query(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
cn.Execute BuildQuery(mark)

If cn.state = 1 Then cn.Close
Set cn = Nothing

form_query = True

Exit Function

try:

  If cn.state = 1 Then cn.Close
  Set cn = Nothing
  
  MsgBox Err.Description
  form_query = False

End Function

Function grid_load(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
rs.Open BuildQuery(mark), cn

r = 4
Do Until rs.EOF

  Sheets("マスタ管理").Cells(r, 7).Value = rs(0)
  Sheets("マスタ管理").Cells(r, 8).Value = rs(1)

  Sheets("マスタ管理").Range("G" & r & ":H" & r & "").Borders.LineStyle = True

r = r + 1
rs.movenext
Loop

If rs.state = 1 Then rs.Close
Set rs = Nothing

If cn.state = 1 Then cn.Close
Set cn = Nothing

grid_load = True

Exit Function

try:

  If rs.state = 1 Then rs.Close
  Set rs = Nothing

  If cn.state = 1 Then cn.Close
  Set cn = Nothing

  grid_load = False
    
End Function

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close
Set cn = Nothing

db_chk = True

Exit Function

try:

  If cn.state = 1 Then cn.Close
  Set cn = Nothing
  
  MsgBox "DBに接続できません。"
  db_chk = False
  
End Function

Private Sub CommandButton4_Click()

If db_chk = False Then Exit Sub

grid_clear
If grid_load("s") = False Then Exit Sub

form_clear

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Row >= 4 And Target.Column = 7 And Target.Text <> "" Then

  ActiveSheet.Cells(3, 2).Value = ActiveSheet.Cells(Target.Row, 8).Value
  ActiveSheet.Cells(9, 2).Value = ActiveSheet.Cells(Target.Row, 7).Value
  
ElseIf Target.Row >= 4 And Target.Column = 7 And Target.Text = "" Then

  ActiveSheet.Cells(3, 2).Value = ""
  ActiveSheet.Cells(9, 2).Value = ""
  
End If

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

Function BuildQuery(mark)

q_i = Sheets("マスタ管理").Range("B9").Value

q_c = Sheets("マスタ管理").Range("B3").Value

q_i = StrConv(q_i, vbNarrow)

q_i = Replace(q_i, "'", "’")

q_c = Replace(q_c, "'", "’")

q_i = Replace(q_i, """", "’")

q_c = Replace(q_c, """", "’")

If mark = "s" Then q = "select ID,worker from worker;"

If mark = "i" Then q = "insert into worker (worker) values ('" & q_c & "');"

If mark = "u" Then q = "update worker set worker = '" & q_c & "' where ID = " & q_i & ";"

If mark = "d" Then q = "delete from worker where ID = " & q_i & ";"

BuildQuery = q

End Function

Private Sub CommandButton1_Click()

If db_chk = False Then Exit Sub

If form_chk = False Then Exit Sub

If form_query("i") = False Then Exit Sub

grid_clear

If grid_load("s") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton2_Click()

If db_chk = False Then Exit Sub

If id_chk = False Then Exit Sub

If form_chk = False Then Exit Sub

If form_query("u") = False Then Exit Sub

grid_clear

If grid_load("s") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton3_Click()

If db_chk = False Then Exit Sub

If id_chk = False Then Exit Sub

yn = MsgBox("削除しますか？", vbYesNo)

If yn = vbNo Then Exit Sub

If form_query("d") = False Then Exit Sub

grid_clear

If grid_load("s") = False Then Exit Sub

form_clear

End Sub

Function id_chk()

On Error GoTo try

If Sheets("マスタ管理").Range("B9").Value = "" Then GoTo try

v = CLng(Sheets("マスタ管理").Range("B9").Value)

id_chk = True

Exit Function

try:

MsgBox "IDが正しくありません。"

id_chk = False

End Function

Function form_chk()

If Sheets("マスタ管理").Range("B3").Value = "" Then GoTo try

form_chk = True

Exit Function

try:

MsgBox "入力が不足しています。"

form_chk = False

End Function

Sub grid_clear()

Sheets("マスタ管理").Range("G4:H100").Delete

End Sub

Sub form_clear()

Sheets("マスタ管理").Range("B3").Value = ""

Sheets("マスタ管理").Range("B9").Value = ""

End Sub

Function form_query(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

cn.Execute BuildQuery(mark)

If cn.state = 1 Then cn.Close

Set cn = Nothing

form_query = True

Exit Function

try:

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox Err.Description

form_query = False

End Function

Function grid_load(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

rs.Open BuildQuery(mark), cn

r = 4

Do Until rs.EOF

Sheets("マスタ管理").Cells(r, 7).Value = rs(0)

Sheets("マスタ管理").Cells(r, 8).Value = rs(1)

Sheets("マスタ管理").Range("G" & r & ":H" & r & "").Borders.LineStyle = True

r = r + 1

rs.movenext

Loop

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

grid_load = True

Exit Function

try:

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

grid_load = False

End Function

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close

Set cn = Nothing

db_chk = True

Exit Function

try:

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox "DBに接続できません。"

db_chk = False

End Function

Private Sub CommandButton4_Click()

If db_chk = False Then Exit Sub

grid_clear

If grid_load("s") = False Then Exit Sub

form_clear

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Row >= 4 And Target.Column = 7 And Target.Text <> "" Then

ActiveSheet.Cells(3, 2).Value = ActiveSheet.Cells(Target.Row, 8).Value

ActiveSheet.Cells(9, 2).Value = ActiveSheet.Cells(Target.Row, 7).Value

ElseIf Target.Row >= 4 And Target.Column = 7 And Target.Text = "" Then

ActiveSheet.Cells(3, 2).Value = ""

ActiveSheet.Cells(9, 2).Value = ""

End If

End Sub

Sheet3(作業登録)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If UserForm1.Visible And UserForm1.TextBox8.Text = "" And _
  Target.Row >= 2 And Target.Column = 2 And Target.Text <> "" Then
  UserForm1.TextBox1.Text = Target.Text
End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If UserForm1.Visible And UserForm1.TextBox8.Text = "" And _

Target.Row >= 2 And Target.Column = 2 And Target.Text <> "" Then

UserForm1.TextBox1.Text = Target.Text

End If

End Sub

Sheet1(登録者)

Function BuildQuery(mark)

q_i = Sheets("登録者").Range("B21").Value
q_c = Sheets("登録者").Range("B3").Value
q_m = Sheets("登録者").Range("B5").Value
q_s = Sheets("登録者").Range("B7").Value
q_q = Sheets("登録者").Range("B9").Value
q_n = Sheets("登録者").Range("B11").Value

q_i = StrConv(q_i, vbNarrow)
q_s = StrConv(q_s, vbNarrow)
q_q = StrConv(q_q, vbNarrow)

q_i = Replace(q_i, "'", "’")
q_c = Replace(q_c, "'", "’")
q_m = Replace(q_m, "'", "’")
q_s = Replace(q_s, "'", "’")
q_q = Replace(q_q, "'", "’")
q_n = Replace(q_n, "'", "’")

q_i = Replace(q_i, """", "’")
q_c = Replace(q_c, """", "’")
q_m = Replace(q_m, """", "’")
q_s = Replace(q_s, """", "’")
q_q = Replace(q_q, """", "’")
q_n = Replace(q_n, """", "’")

If mark = "s1" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'true';"
If mark = "s2" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'false';"

If mark = "i" Then q = "insert into orders (customer,model,serial,quantity,notes,visible) values ('" & q_c & "','" & q_m & "','" & q_s & "'," & q_q & ",'" & q_n & "','true');"
If mark = "u" Then q = "update orders set customer = '" & q_c & "', model = '" & q_m & "', serial = '" & q_s & "', quantity = " & q_q & ", notes = '" & q_n & "' where ID = " & q_i & ";"
If mark = "d" Then q = "delete from orders where ID = " & q_i & ";"
If mark = "h" Then q = "update orders set visible = 'false' where ID = " & q_i & ";"

BuildQuery = q

End Function

Private Sub CommandButton6_Click()

If db_chk = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton5_Click()

If db_chk = False Then Exit Sub

grid_clear
If grid_load("s2") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton1_Click()

If db_chk = False Then Exit Sub
If form_chk = False Then Exit Sub
If qty_parse = False Then Exit Sub

If form_query("i") = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear
 
End Sub

Private Sub CommandButton2_Click()

If db_chk = False Then Exit Sub
If id_chk = False Then Exit Sub
If form_chk = False Then Exit Sub
If qty_parse = False Then Exit Sub

If form_query("u") = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton3_Click()

If db_chk = False Then Exit Sub
If id_chk = False Then Exit Sub

yn = MsgBox("削除しますか？", vbYesNo)
If yn = vbNo Then Exit Sub

If form_query("d") = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton4_Click()

If db_chk = False Then Exit Sub
If id_chk = False Then Exit Sub

If form_query("h") = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Function id_chk()

On Error GoTo try

If Sheets("登録者").Range("B21").Value = "" Then GoTo try

v = CLng(Sheets("登録者").Range("B21").Value)

id_chk = True

Exit Function

try:

  MsgBox "IDが正しくありません。"
  id_chk = False

End Function

Function form_chk()

If Sheets("登録者").Range("B3").Value = "" Then GoTo try
If Sheets("登録者").Range("B5").Value = "" Then GoTo try
If Sheets("登録者").Range("B7").Value = "" Then GoTo try
If Sheets("登録者").Range("B9").Value = "" Then GoTo try

form_chk = True

Exit Function

try:

  MsgBox "入力が不足しています。"
  form_chk = False

End Function

Sub grid_clear()

Sheets("登録者").Range("G4:L1000").Delete

End Sub

Sub form_clear()

Sheets("登録者").Range("B3").Value = ""
Sheets("登録者").Range("B5").Value = ""
Sheets("登録者").Range("B7").Value = ""
Sheets("登録者").Range("B9").Value = ""
Sheets("登録者").Range("B11").Value = ""
Sheets("登録者").Range("B21").Value = ""

End Sub

Function qty_parse()

On Error GoTo try

qty = CLng(Sheets("登録者").Range("B9").Value)
If qty = 0 Then GoTo try

qty_parse = True

Exit Function

try:

  MsgBox "数量が正しくありません。"
  qty_parse = False

End Function

Function form_query(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
cn.Execute BuildQuery(mark)

If cn.state = 1 Then cn.Close
Set cn = Nothing

form_query = True

Exit Function

try:

  If cn.state = 1 Then cn.Close
  Set cn = Nothing
  
  MsgBox Err.Description
  form_query = False

End Function

Function grid_load(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
rs.Open BuildQuery(mark), cn

r = 4
Do Until rs.EOF

  Sheets("登録者").Cells(r, 7).Value = rs(0)
  Sheets("登録者").Cells(r, 8).Value = rs(1)
  Sheets("登録者").Cells(r, 9).Value = rs(2)
  Sheets("登録者").Cells(r, 10).Value = rs(3)
  Sheets("登録者").Cells(r, 11).Value = rs(4)
  Sheets("登録者").Cells(r, 12).Value = rs(5)

  Sheets("登録者").Range("G" & r & ":L" & r & "").Borders.LineStyle = True

r = r + 1
rs.movenext
Loop

If rs.state = 1 Then rs.Close
Set rs = Nothing

If cn.state = 1 Then cn.Close
Set cn = Nothing

grid_load = True

Exit Function

try:

  If rs.state = 1 Then rs.Close
  Set rs = Nothing

  If cn.state = 1 Then cn.Close
  Set cn = Nothing

  grid_load = False
    
End Function

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close
Set cn = Nothing

db_chk = True

Exit Function

try:

  If cn.state = 1 Then cn.Close
  Set cn = Nothing
  
  MsgBox "DBに接続できません。"
  db_chk = False
  
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Row >= 4 And Target.Column = 7 And Target.Text <> "" Then

  ActiveSheet.Cells(3, 2).Value = ActiveSheet.Cells(Target.Row, 8).Value
  ActiveSheet.Cells(5, 2).Value = ActiveSheet.Cells(Target.Row, 9).Value
  ActiveSheet.Cells(7, 2).Value = ActiveSheet.Cells(Target.Row, 10).Value
  ActiveSheet.Cells(9, 2).Value = ActiveSheet.Cells(Target.Row, 11).Value
  ActiveSheet.Cells(11, 2).Value = ActiveSheet.Cells(Target.Row, 12).Value
  ActiveSheet.Cells(21, 2).Value = ActiveSheet.Cells(Target.Row, 7).Value
  
ElseIf Target.Row >= 4 And Target.Column = 7 And Target.Text = "" Then

  ActiveSheet.Cells(3, 2).Value = ""
  ActiveSheet.Cells(5, 2).Value = ""
  ActiveSheet.Cells(7, 2).Value = ""
  ActiveSheet.Cells(9, 2).Value = ""
  ActiveSheet.Cells(11, 2).Value = ""
  ActiveSheet.Cells(21, 2).Value = ""
  
End If

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

Function BuildQuery(mark)

q_i = Sheets("登録者").Range("B21").Value

q_c = Sheets("登録者").Range("B3").Value

q_m = Sheets("登録者").Range("B5").Value

q_s = Sheets("登録者").Range("B7").Value

q_q = Sheets("登録者").Range("B9").Value

q_n = Sheets("登録者").Range("B11").Value

q_i = StrConv(q_i, vbNarrow)

q_s = StrConv(q_s, vbNarrow)

q_q = StrConv(q_q, vbNarrow)

q_i = Replace(q_i, "'", "’")

q_c = Replace(q_c, "'", "’")

q_m = Replace(q_m, "'", "’")

q_s = Replace(q_s, "'", "’")

q_q = Replace(q_q, "'", "’")

q_n = Replace(q_n, "'", "’")

q_i = Replace(q_i, """", "’")

q_c = Replace(q_c, """", "’")

q_m = Replace(q_m, """", "’")

q_s = Replace(q_s, """", "’")

q_q = Replace(q_q, """", "’")

q_n = Replace(q_n, """", "’")

If mark = "s1" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'true';"

If mark = "s2" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'false';"

If mark = "i" Then q = "insert into orders (customer,model,serial,quantity,notes,visible) values ('" & q_c & "','" & q_m & "','" & q_s & "'," & q_q & ",'" & q_n & "','true');"

If mark = "u" Then q = "update orders set customer = '" & q_c & "', model = '" & q_m & "', serial = '" & q_s & "', quantity = " & q_q & ", notes = '" & q_n & "' where ID = " & q_i & ";"

If mark = "d" Then q = "delete from orders where ID = " & q_i & ";"

If mark = "h" Then q = "update orders set visible = 'false' where ID = " & q_i & ";"

BuildQuery = q

End Function

Private Sub CommandButton6_Click()

If db_chk = False Then Exit Sub

grid_clear

If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton5_Click()

If db_chk = False Then Exit Sub

grid_clear

If grid_load("s2") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton1_Click()

If db_chk = False Then Exit Sub

If form_chk = False Then Exit Sub

If qty_parse = False Then Exit Sub

If form_query("i") = False Then Exit Sub

grid_clear

If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton2_Click()

If db_chk = False Then Exit Sub

If id_chk = False Then Exit Sub

If form_chk = False Then Exit Sub

If qty_parse = False Then Exit Sub

If form_query("u") = False Then Exit Sub

grid_clear

If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton3_Click()

If db_chk = False Then Exit Sub

If id_chk = False Then Exit Sub

yn = MsgBox("削除しますか？", vbYesNo)

If yn = vbNo Then Exit Sub

If form_query("d") = False Then Exit Sub

grid_clear

If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton4_Click()

If db_chk = False Then Exit Sub

If id_chk = False Then Exit Sub

If form_query("h") = False Then Exit Sub

grid_clear

If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Function id_chk()

On Error GoTo try

If Sheets("登録者").Range("B21").Value = "" Then GoTo try

v = CLng(Sheets("登録者").Range("B21").Value)

id_chk = True

Exit Function

try:

MsgBox "IDが正しくありません。"

id_chk = False

End Function

Function form_chk()

If Sheets("登録者").Range("B3").Value = "" Then GoTo try

If Sheets("登録者").Range("B5").Value = "" Then GoTo try

If Sheets("登録者").Range("B7").Value = "" Then GoTo try

If Sheets("登録者").Range("B9").Value = "" Then GoTo try

form_chk = True

Exit Function

try:

MsgBox "入力が不足しています。"

form_chk = False

End Function

Sub grid_clear()

Sheets("登録者").Range("G4:L1000").Delete

End Sub

Sub form_clear()

Sheets("登録者").Range("B3").Value = ""

Sheets("登録者").Range("B5").Value = ""

Sheets("登録者").Range("B7").Value = ""

Sheets("登録者").Range("B9").Value = ""

Sheets("登録者").Range("B11").Value = ""

Sheets("登録者").Range("B21").Value = ""

End Sub

Function qty_parse()

On Error GoTo try

qty = CLng(Sheets("登録者").Range("B9").Value)

If qty = 0 Then GoTo try

qty_parse = True

Exit Function

try:

MsgBox "数量が正しくありません。"

qty_parse = False

End Function

Function form_query(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

cn.Execute BuildQuery(mark)

If cn.state = 1 Then cn.Close

Set cn = Nothing

form_query = True

Exit Function

try:

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox Err.Description

form_query = False

End Function

Function grid_load(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

rs.Open BuildQuery(mark), cn

r = 4

Do Until rs.EOF

Sheets("登録者").Cells(r, 7).Value = rs(0)

Sheets("登録者").Cells(r, 8).Value = rs(1)

Sheets("登録者").Cells(r, 9).Value = rs(2)

Sheets("登録者").Cells(r, 10).Value = rs(3)

Sheets("登録者").Cells(r, 11).Value = rs(4)

Sheets("登録者").Cells(r, 12).Value = rs(5)

Sheets("登録者").Range("G" & r & ":L" & r & "").Borders.LineStyle = True

r = r + 1

rs.movenext

Loop

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

grid_load = True

Exit Function

try:

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

grid_load = False

End Function

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close

Set cn = Nothing

db_chk = True

Exit Function

try:

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox "DBに接続できません。"

db_chk = False

End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Row >= 4 And Target.Column = 7 And Target.Text <> "" Then

ActiveSheet.Cells(3, 2).Value = ActiveSheet.Cells(Target.Row, 8).Value

ActiveSheet.Cells(5, 2).Value = ActiveSheet.Cells(Target.Row, 9).Value

ActiveSheet.Cells(7, 2).Value = ActiveSheet.Cells(Target.Row, 10).Value

ActiveSheet.Cells(9, 2).Value = ActiveSheet.Cells(Target.Row, 11).Value

ActiveSheet.Cells(11, 2).Value = ActiveSheet.Cells(Target.Row, 12).Value

ActiveSheet.Cells(21, 2).Value = ActiveSheet.Cells(Target.Row, 7).Value

ElseIf Target.Row >= 4 And Target.Column = 7 And Target.Text = "" Then

ActiveSheet.Cells(3, 2).Value = ""

ActiveSheet.Cells(5, 2).Value = ""

ActiveSheet.Cells(7, 2).Value = ""

ActiveSheet.Cells(9, 2).Value = ""

ActiveSheet.Cells(11, 2).Value = ""

ActiveSheet.Cells(21, 2).Value = ""

End If

End Sub

2017-10-272024-05-03

VBA 工数管理プログラム

前回のC#版を中止してから即席で作った。C#のときはMySQLだったが、今回はmdbファイルとした。使うのが1~2名であっても複数箇所で開く場合、データは別ファイルの方がいいだろうと判断。

今回は使う場面を想像できたので、あまりしっかり対策していないが、使う人が書式や関数を変更してしまっても大丈夫なように、起動時にしっかり設定し直す処理をいれれば、エクセルVBAでもDBのクライアントとしてかなり使えそう。

UserForm1

Function form_query()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
rs.Open "select ID,customer,model,serial,quantity,notes from orders where serial = '" & UserForm1.TextBox1.Text & "';", cn

Do Until rs.EOF

  UserForm1.TextBox8.Text = rs(0)
  UserForm1.TextBox2.Text = rs(1)
  UserForm1.TextBox3.Text = rs(2)
  UserForm1.TextBox1.Text = rs(3)
  UserForm1.TextBox7.Text = rs(4)
  UserForm1.TextBox4.Text = rs(5)

rs.movenext
Loop

If UserForm1.TextBox8.Text <> "" Then
  UserForm1.TextBox5.Text = "1"
  UserForm1.TextBox6.Text = UserForm1.TextBox7.Text
End If

If rs.state = 1 Then rs.Close
Set rs = Nothing

If cn.state = 1 Then cn.Close
Set cn = Nothing

form_query = True

Exit Function

try:

  If rs.state = 1 Then rs.Close
  Set rs = Nothing

  If cn.state = 1 Then cn.Close
  Set cn = Nothing

  MsgBox Err.Description
  form_query = False
  
End Function

Private Sub CommandButton1_Click()

If UserForm1.TextBox1.Text = "" Then
  MsgBox "工番を入力してください。"
  Exit Sub
End If

If db_chk = False Then Exit Sub

form_clear
form_query

End Sub

Sub form_clear()

UserForm1.TextBox8.Text = ""
UserForm1.TextBox2.Text = ""
UserForm1.TextBox3.Text = ""
UserForm1.TextBox7.Text = ""
UserForm1.TextBox4.Text = ""
UserForm1.TextBox5.Text = ""
UserForm1.TextBox6.Text = ""

End Sub

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close
Set cn = Nothing

db_chk = True

Exit Function

try:

  If cn.state = 1 Then cn.Close
  Set cn = Nothing
  
  MsgBox "DBに接続できません。"
  db_chk = False
  
End Function

Function qty_parse()

On Error GoTo try

If UserForm1.TextBox5.Text = "" Or UserForm1.TextBox6.Text = "" Then
  MsgBox "対象枝を入力してください。"
  qty_parse = False
  Exit Function
End If

qty = CInt(UserForm1.TextBox7.Text)
suffix_s = CInt(UserForm1.TextBox5.Text)
suffix_e = CInt(UserForm1.TextBox6.Text)

If suffix_s = 0 Or suffix_e = 0 Then
  MsgBox "対象枝は1以上の数字を指定する必要があります。"
  qty_parse = False
  Exit Function
End If

If suffix_e > qty Or suffix_s > suffix_e Then
  MsgBox "対象枝の指定範囲に問題があります。"
  qty_parse = False
  Exit Function
End If

qty_parse = True

Exit Function

try:

  MsgBox "対象枝が数字ではありません。"
  qty_parse = False

End Function

Private Sub CommandButton2_Click()
Call MainWrite("1", "スタート", "作")
End Sub

Private Sub CommandButton3_Click()
Call MainWrite("1", "スタート", "修")
End Sub

Private Sub CommandButton4_Click()
Call MainWrite("3", "ストップ", "")
End Sub

Private Sub CommandButton5_Click()
Call MainWrite("4", "完了", "")
WorkTimeAdd
End Sub

Sub MainWrite(mark, state, typ)

If ActiveSheet.Name <> "作業登録" Then
  MsgBox "作業登録で実施してください。"
  Exit Sub
End If

If UserForm1.TextBox8.Text = "" Then
  MsgBox "対象のIDが見つかりません。"
  Exit Sub
End If

If qty_parse = False Then Exit Sub

Set w = Sheets("作業登録")

serial = UserForm1.TextBox1.Text

For suffix = CInt(UserForm1.TextBox5.Text) To CInt(UserForm1.TextBox6.Text)

  f = False

  For r = 2 To w.UsedRange.Rows.Count
    If serial = w.Cells(r, 1).Text And suffix = w.Cells(r, 2) Then
      f = True
      Call WriteCol(r, serial, suffix, mark, state, typ)
    End If
  Next r
  
  If f = False Then
    Call WriteCol(r, serial, suffix, mark, state, typ)
  End If

Next suffix

End Sub

Sub WriteCol(r, serial, suffix, mark, state, typ)

Set w = Sheets("作業登録")

If w.Cells(r, 3).Value = "完了" Then
  MsgBox serial & "-" & suffix & "は既に完了しています。"
  Exit Sub
End If

Select Case mark

Case "1" '作業スタート

  If w.Cells(r, 3).Value = "スタート" Then
    MsgBox serial & "-" & suffix & "は既にスタートしています。"
    Exit Sub
  End If
  
  If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then
    c = 8
  End If
  
Case "2" '修正スタート

  If w.Cells(r, 3).Value = "スタート" Then
    MsgBox serial & "-" & suffix & "は既にスタートしています。"
    Exit Sub
  End If
  
  If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then
    c = 8
  End If
  
Case "3" 'ストップ

  If w.Cells(r, 3).Value = "スタート" Then
    c = 9
  End If
  
  If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then
    MsgBox serial & "-" & suffix & "はスタートしていません。"
    Exit Sub
  End If
  
Case "4" '指定工番の完了

  If w.Cells(r, 3).Value = "スタート" Then
    MsgBox serial & "-" & suffix & "はスタートしているため完了できません。"
    Exit Sub
  End If

  If w.Cells(r, 3).Value = "ストップ" Or w.Cells(r, 3).Value = "" Then
    w.Cells(r, 1).Value = serial
    w.Cells(r, 2).Value = suffix
    w.Cells(r, 3).Value = "完了"
    w.Cells(r, 3).Interior.ColorIndex = 0
    Exit Sub
  End If
  
End Select

Do While True

  If w.Cells(r, c).Value = "" Then
  
    w.Cells(r, 1).Value = serial
    w.Cells(r, 2).Value = suffix
    w.Cells(r, 3).Value = state
    
    If (mark = 1 Or mark = 2) Then 'スタート
      w.Cells(r, 3).Interior.Color = RGB(255, 0, 0)
      w.Cells(r, 6).Value = ""
      w.Cells(r, c - 1).Value = typ
    End If
    
    If (mark = 3) Then 'ストップ
      w.Cells(r, 3).Interior.Color = RGB(255, 255, 0)
      w.Cells(r, 6).Value = c - 2
    End If
    
    w.Cells(r, c).Value = Format(Now(), "yyyy/mm/dd hh:mm:00")
    
    Exit Do
    
  End If
  
c = c + 3
Loop

End Sub

Private Sub CommandButton6_Click()

UserForm1.TextBox1.Text = ""
form_clear

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

Function form_query()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

rs.Open "select ID,customer,model,serial,quantity,notes from orders where serial = '" & UserForm1.TextBox1.Text & "';", cn

Do Until rs.EOF

UserForm1.TextBox8.Text = rs(0)

UserForm1.TextBox2.Text = rs(1)

UserForm1.TextBox3.Text = rs(2)

UserForm1.TextBox1.Text = rs(3)

UserForm1.TextBox7.Text = rs(4)

UserForm1.TextBox4.Text = rs(5)

rs.movenext

Loop

If UserForm1.TextBox8.Text <> "" Then

UserForm1.TextBox5.Text = "1"

UserForm1.TextBox6.Text = UserForm1.TextBox7.Text

End If

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

form_query = True

Exit Function

try:

If rs.state = 1 Then rs.Close

Set rs = Nothing

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox Err.Description

form_query = False

End Function

Private Sub CommandButton1_Click()

If UserForm1.TextBox1.Text = "" Then

MsgBox "工番を入力してください。"

Exit Sub

End If

If db_chk = False Then Exit Sub

form_clear

form_query

End Sub

Sub form_clear()

UserForm1.TextBox8.Text = ""

UserForm1.TextBox2.Text = ""

UserForm1.TextBox3.Text = ""

UserForm1.TextBox7.Text = ""

UserForm1.TextBox4.Text = ""

UserForm1.TextBox5.Text = ""

UserForm1.TextBox6.Text = ""

End Sub

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close

Set cn = Nothing

db_chk = True

Exit Function

try:

If cn.state = 1 Then cn.Close

Set cn = Nothing

MsgBox "DBに接続できません。"

db_chk = False

End Function

Function qty_parse()

On Error GoTo try

If UserForm1.TextBox5.Text = "" Or UserForm1.TextBox6.Text = "" Then

MsgBox "対象枝を入力してください。"

qty_parse = False

Exit Function

End If

qty = CInt(UserForm1.TextBox7.Text)

suffix_s = CInt(UserForm1.TextBox5.Text)

suffix_e = CInt(UserForm1.TextBox6.Text)

If suffix_s = 0 Or suffix_e = 0 Then

MsgBox "対象枝は1以上の数字を指定する必要があります。"

qty_parse = False

Exit Function

End If

If suffix_e > qty Or suffix_s > suffix_e Then

MsgBox "対象枝の指定範囲に問題があります。"

qty_parse = False

Exit Function

End If

qty_parse = True

Exit Function

try:

MsgBox "対象枝が数字ではありません。"

qty_parse = False

End Function

Private Sub CommandButton2_Click()

Call MainWrite("1", "スタート", "作")

End Sub

Private Sub CommandButton3_Click()

Call MainWrite("1", "スタート", "修")

End Sub

Private Sub CommandButton4_Click()

Call MainWrite("3", "ストップ", "")

End Sub

Private Sub CommandButton5_Click()

Call MainWrite("4", "完了", "")

WorkTimeAdd

End Sub

Sub MainWrite(mark, state, typ)

If ActiveSheet.Name <> "作業登録" Then

MsgBox "作業登録で実施してください。"

Exit Sub

End If

If UserForm1.TextBox8.Text = "" Then

MsgBox "対象のIDが見つかりません。"

Exit Sub

End If

If qty_parse = False Then Exit Sub

Set w = Sheets("作業登録")

serial = UserForm1.TextBox1.Text

For suffix = CInt(UserForm1.TextBox5.Text) To CInt(UserForm1.TextBox6.Text)

f = False

For r = 2 To w.UsedRange.Rows.Count

If serial = w.Cells(r, 1).Text And suffix = w.Cells(r, 2) Then

f = True

Call WriteCol(r, serial, suffix, mark, state, typ)

End If

Next r

If f = False Then

Call WriteCol(r, serial, suffix, mark, state, typ)

End If

Next suffix

End Sub

Sub WriteCol(r, serial, suffix, mark, state, typ)

Set w = Sheets("作業登録")

If w.Cells(r, 3).Value = "完了" Then

MsgBox serial & "-" & suffix & "は既に完了しています。"

Exit Sub

End If

Select Case mark

Case "1" '作業スタート

If w.Cells(r, 3).Value = "スタート" Then

MsgBox serial & "-" & suffix & "は既にスタートしています。"

Exit Sub

End If

If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then

c = 8

End If

Case "2" '修正スタート

If w.Cells(r, 3).Value = "スタート" Then

MsgBox serial & "-" & suffix & "は既にスタートしています。"

Exit Sub

End If

If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then

c = 8

End If

Case "3" 'ストップ

If w.Cells(r, 3).Value = "スタート" Then

c = 9

End If

If w.Cells(r, 3).Value = "" Or w.Cells(r, 3).Value = "ストップ" Then

MsgBox serial & "-" & suffix & "はスタートしていません。"

Exit Sub

End If

Case "4" '指定工番の完了

If w.Cells(r, 3).Value = "スタート" Then

MsgBox serial & "-" & suffix & "はスタートしているため完了できません。"

Exit Sub

End If

If w.Cells(r, 3).Value = "ストップ" Or w.Cells(r, 3).Value = "" Then

w.Cells(r, 1).Value = serial

w.Cells(r, 2).Value = suffix

w.Cells(r, 3).Value = "完了"

w.Cells(r, 3).Interior.ColorIndex = 0

Exit Sub

End If

End Select

Do While True

If w.Cells(r, c).Value = "" Then

w.Cells(r, 1).Value = serial

w.Cells(r, 2).Value = suffix

w.Cells(r, 3).Value = state

If (mark = 1 Or mark = 2) Then 'スタート

w.Cells(r, 3).Interior.Color = RGB(255, 0, 0)

w.Cells(r, 6).Value = ""

w.Cells(r, c - 1).Value = typ

End If

If (mark = 3) Then 'ストップ

w.Cells(r, 3).Interior.Color = RGB(255, 255, 0)

w.Cells(r, 6).Value = c - 2

End If

w.Cells(r, c).Value = Format(Now(), "yyyy/mm/dd hh:mm:00")

Exit Do

End If

c = c + 3

Loop

End Sub

Private Sub CommandButton6_Click()

UserForm1.TextBox1.Text = ""

form_clear

End Sub

Module1

Sub auto_open()

SetStyle

If (StrConv(Sheets("設定").Range("B5").Value, 10) = "on") Then
  Sheets("作業登録").Activate
  UserForm1.Show
End If

On Error Resume Next

Application.CommandBars("cell").Controls("フォーム表示").Delete
Application.CommandBars("cell").Controls("フォーム表示").Delete

With Application.CommandBars("cell").Controls.Add
.Caption = "フォーム表示"
.OnAction = "FormShow"
End With

End Sub

Sub auto_close()

On Error Resume Next

Application.CommandBars("cell").Controls("フォーム表示").Delete
Application.CommandBars("cell").Controls("フォーム表示").Delete

End Sub

Sub FormShow()

Sheets("作業登録").Activate
UserForm1.Show

End Sub

Sub SetStyle()

Sheets("登録者").Cells(3, 2).NumberFormatLocal = "@"
Sheets("登録者").Cells(5, 2).NumberFormatLocal = "@"
Sheets("登録者").Cells(7, 2).NumberFormatLocal = "@"
Sheets("登録者").Cells(11, 2).NumberFormatLocal = "@"

Sheets("作業登録").Cells.NumberFormatLocal = ""
Sheets("作業登録").Columns("A").NumberFormatLocal = "@"

For c = 7 To 100 Step 3

  Sheets("作業登録").Cells(1, c).Value = "種"
  Sheets("作業登録").Cells(1, c + 1).Value = "スタート"
  Sheets("作業登録").Cells(1, c + 2).Value = "ストップ"
  
  Sheets("作業登録").Columns(c).NumberFormatLocal = ""
  Sheets("作業登録").Columns(c + 1).NumberFormatLocal = "mm/dd hh:mm"
  Sheets("作業登録").Columns(c + 2).NumberFormatLocal = "mm/dd hh:mm"

  Sheets("作業登録").Columns(c).ColumnWidth = "2.5"
  Sheets("作業登録").Columns(c + 1).ColumnWidth = "12"
  Sheets("作業登録").Columns(c + 2).ColumnWidth = "12"
  
Next c

End Sub

Sub WorkTimeAdd()

Set w = Sheets("作業登録")

For r = 2 To w.UsedRange.Rows.Count

  w.Cells(r, 4) = ""
  w.Cells(r, 5) = ""

  If w.Cells(r, 3).Text = "完了" And w.Cells(r, 6).Text <> "" Then
  
    n = 0
    f = 0
  
    For c = 7 To w.Cells(r, 6).Text Step 3
    
      Select Case w.Cells(r, c).Text
        Case "作"
          n = n + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text)
        Case "修"
          f = f + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text)
      End Select
      
    Next c
    
    w.Cells(r, 4) = Int(n / 60) & "." & Format(n Mod 60, "00") & " H"
    w.Cells(r, 5) = Int(f / 60) & "." & Format(f Mod 60, "00") & " H"
      
  End If

Next r

w.Activate

End Sub

Function WorkTime(date_s, date_e)

On Error GoTo try

date_s = CDate(date_s)
date_e = CDate(date_e)

ts = 0

Do While date_s < date_e

  ts = ts + 1
 
  If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:00:00") And _
      date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:15:00") Then
    ts = ts - 1
  End If
  
  If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:00:00") And _
      date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:50:00") Then
    ts = ts - 1
  End If
  
  If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:00:00") And _
      date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:15:00") Then
    ts = ts - 1
  End If
  
  If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:20:00") And _
      date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:30:00") Then
    ts = ts - 1
  End If
  
  date_s = DateAdd("n", 1, date_s)
  
Loop

WorkTime = ts

Exit Function

try:

  WorkTime = 0

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

Sub auto_open()

SetStyle

If (StrConv(Sheets("設定").Range("B5").Value, 10) = "on") Then

Sheets("作業登録").Activate

UserForm1.Show

End If

On Error Resume Next

Application.CommandBars("cell").Controls("フォーム表示").Delete

With Application.CommandBars("cell").Controls.Add

.Caption = "フォーム表示"

.OnAction = "FormShow"

End With

End Sub

Sub auto_close()

On Error Resume Next

Application.CommandBars("cell").Controls("フォーム表示").Delete

End Sub

Sub FormShow()

Sheets("作業登録").Activate

UserForm1.Show

End Sub

Sub SetStyle()

Sheets("登録者").Cells(3, 2).NumberFormatLocal = "@"

Sheets("登録者").Cells(5, 2).NumberFormatLocal = "@"

Sheets("登録者").Cells(7, 2).NumberFormatLocal = "@"

Sheets("登録者").Cells(11, 2).NumberFormatLocal = "@"

Sheets("作業登録").Cells.NumberFormatLocal = ""

Sheets("作業登録").Columns("A").NumberFormatLocal = "@"

For c = 7 To 100 Step 3

Sheets("作業登録").Cells(1, c).Value = "種"

Sheets("作業登録").Cells(1, c + 1).Value = "スタート"

Sheets("作業登録").Cells(1, c + 2).Value = "ストップ"

Sheets("作業登録").Columns(c).NumberFormatLocal = ""

Sheets("作業登録").Columns(c + 1).NumberFormatLocal = "mm/dd hh:mm"

Sheets("作業登録").Columns(c + 2).NumberFormatLocal = "mm/dd hh:mm"

Sheets("作業登録").Columns(c).ColumnWidth = "2.5"

Sheets("作業登録").Columns(c + 1).ColumnWidth = "12"

Sheets("作業登録").Columns(c + 2).ColumnWidth = "12"

Next c

End Sub

Sub WorkTimeAdd()

Set w = Sheets("作業登録")

For r = 2 To w.UsedRange.Rows.Count

w.Cells(r, 4) = ""

w.Cells(r, 5) = ""

If w.Cells(r, 3).Text = "完了" And w.Cells(r, 6).Text <> "" Then

n = 0

f = 0

For c = 7 To w.Cells(r, 6).Text Step 3

Select Case w.Cells(r, c).Text

Case "作"

n = n + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text)

Case "修"

f = f + WorkTime(w.Cells(r, c + 1).Text, w.Cells(r, c + 2).Text)

End Select

Next c

w.Cells(r, 4) = Int(n / 60) & "." & Format(n Mod 60, "00") & " H"

w.Cells(r, 5) = Int(f / 60) & "." & Format(f Mod 60, "00") & " H"

End If

Next r

w.Activate

End Sub

Function WorkTime(date_s, date_e)

On Error GoTo try

date_s = CDate(date_s)

date_e = CDate(date_e)

ts = 0

Do While date_s < date_e

ts = ts + 1

If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:00:00") And _

date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 10:15:00") Then

ts = ts - 1

End If

If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:00:00") And _

date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 12:50:00") Then

ts = ts - 1

End If

If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:00:00") And _

date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 15:15:00") Then

ts = ts - 1

End If

If date_s >= CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:20:00") And _

date_s < CDate(Year(date_s) & "/" & Month(date_s) & "/" & Day(date_s) & " 17:30:00") Then

ts = ts - 1

End If

date_s = DateAdd("n", 1, date_s)

Loop

WorkTime = ts

Exit Function

try:

WorkTime = 0

End Function

Sheet1(登録者)

Function BuildQuery(mark)

q_i = Sheets("登録者").Range("B21").Value
q_c = Sheets("登録者").Range("B3").Value
q_m = Sheets("登録者").Range("B5").Value
q_s = Sheets("登録者").Range("B7").Value
q_q = Sheets("登録者").Range("B9").Value
q_n = Sheets("登録者").Range("B11").Value

q_i = StrConv(q_i, vbNarrow)
q_s = StrConv(q_s, vbNarrow)
q_q = StrConv(q_q, vbNarrow)

q_i = Replace(q_i, "'", "’")
q_c = Replace(q_c, "'", "’")
q_m = Replace(q_m, "'", "’")
q_s = Replace(q_s, "'", "’")
q_q = Replace(q_q, "'", "’")
q_n = Replace(q_n, "'", "’")

q_i = Replace(q_i, """", "’")
q_c = Replace(q_c, """", "’")
q_m = Replace(q_m, """", "’")
q_s = Replace(q_s, """", "’")
q_q = Replace(q_q, """", "’")
q_n = Replace(q_n, """", "’")

If mark = "s1" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'true'"
If mark = "s2" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'false'"

If mark = "i" Then q = "insert into orders (customer,model,serial,quantity,notes,visible) values ('" & q_c & "','" & q_m & "','" & q_s & "'," & q_q & ",'" & q_n & "','true');"
If mark = "u" Then q = "update orders set customer = '" & q_c & "', model = '" & q_m & "', serial = '" & q_s & "', quantity = " & q_q & ", notes = '" & q_n & "' where ID = " & q_i & ";"
If mark = "d" Then q = "delete from orders where ID = " & q_i & ";"
If mark = "h" Then q = "update orders set visible = 'false' where ID = " & q_i & ";"

BuildQuery = q: Debug.Print q

End Function

Private Sub CommandButton6_Click()

If db_chk = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton5_Click()

If db_chk = False Then Exit Sub

grid_clear
If grid_load("s2") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton1_Click()

If db_chk = False Then Exit Sub
If form_chk = False Then Exit Sub
If qty_parse = False Then Exit Sub

If form_query("i") = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear
 
End Sub

Private Sub CommandButton2_Click()

If db_chk = False Then Exit Sub
If id_chk = False Then Exit Sub
If form_chk = False Then Exit Sub
If qty_parse = False Then Exit Sub

If form_query("u") = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton3_Click()

If db_chk = False Then Exit Sub
If id_chk = False Then Exit Sub

yn = MsgBox("削除しますか？", vbYesNo)
If yn = vbNo Then Exit Sub

If form_query("d") = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Private Sub CommandButton4_Click()

If db_chk = False Then Exit Sub
If id_chk = False Then Exit Sub

If form_query("h") = False Then Exit Sub

grid_clear
If grid_load("s1") = False Then Exit Sub

form_clear

End Sub

Function id_chk()

On Error GoTo try

If Sheets("登録者").Range("B21").Value = "" Then GoTo try

v = CLng(Sheets("登録者").Range("B21").Value)

id_chk = True

Exit Function

try:

  MsgBox "IDが正しくありません。"
  id_chk = False

End Function

Function form_chk()

If Sheets("登録者").Range("B3").Value = "" Then GoTo try
If Sheets("登録者").Range("B5").Value = "" Then GoTo try
If Sheets("登録者").Range("B7").Value = "" Then GoTo try
If Sheets("登録者").Range("B9").Value = "" Then GoTo try

form_chk = True

Exit Function

try:

  MsgBox "入力が不足しています。"
  form_chk = False

End Function

Sub grid_clear()

Sheets("登録者").Range("G4:L1000").Delete

End Sub

Sub form_clear()

Sheets("登録者").Range("B3").Value = ""
Sheets("登録者").Range("B5").Value = ""
Sheets("登録者").Range("B7").Value = ""
Sheets("登録者").Range("B9").Value = ""
Sheets("登録者").Range("B11").Value = ""
Sheets("登録者").Range("B21").Value = ""

End Sub

Function qty_parse()

On Error GoTo try

qty = CLng(Sheets("登録者").Range("B9").Value)
If qty = 0 Then GoTo try

qty_parse = True

Exit Function

try:

  MsgBox "数量が正しくありません。"
  qty_parse = False

End Function

Function form_query(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
cn.Execute BuildQuery(mark)

If cn.state = 1 Then cn.Close
Set cn = Nothing

form_query = True

Exit Function

try:

  If cn.state = 1 Then cn.Close
  Set cn = Nothing
  
  MsgBox Err.Description
  form_query = False

End Function

Function grid_load(mark)

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"
rs.Open BuildQuery(mark), cn

r = 4
Do Until rs.EOF

  Sheets("登録者").Cells(r, 7).Value = rs(0)
  Sheets("登録者").Cells(r, 8).Value = rs(1)
  Sheets("登録者").Cells(r, 9).Value = rs(2)
  Sheets("登録者").Cells(r, 10).Value = rs(3)
  Sheets("登録者").Cells(r, 11).Value = rs(4)
  Sheets("登録者").Cells(r, 12).Value = rs(5)

  Sheets("登録者").Range("G" & r & ":L" & r & "").Borders.LineStyle = True

r = r + 1
rs.movenext
Loop

If rs.state = 1 Then rs.Close
Set rs = Nothing

If cn.state = 1 Then cn.Close
Set cn = Nothing

grid_load = True

Exit Function

try:

  If rs.state = 1 Then rs.Close
  Set rs = Nothing

  If cn.state = 1 Then cn.Close
  Set cn = Nothing

  grid_load = False
    
End Function

Function db_chk()

On Error GoTo try

Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Sheets("設定").Range("B3").Value & ";"

If cn.state = 1 Then cn.Close
Set cn = Nothing

db_chk = True

Exit Function

try:

  If cn.state = 1 Then cn.Close
  Set cn = Nothing
  
  MsgBox "DBに接続できません。"
  db_chk = False
  
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Row >= 4 And Target.Column = 7 And Target.Text <> "" Then

  ActiveSheet.Cells(3, 2).Value = ActiveSheet.Cells(Target.Row, 8).Value
  ActiveSheet.Cells(5, 2).Value = ActiveSheet.Cells(Target.Row, 9).Value
  ActiveSheet.Cells(7, 2).Value = ActiveSheet.Cells(Target.Row, 10).Value
  ActiveSheet.Cells(9, 2).Value = ActiveSheet.Cells(Target.Row, 11).Value
  ActiveSheet.Cells(11, 2).Value = ActiveSheet.Cells(Target.Row, 12).Value
  ActiveSheet.Cells(21, 2).Value = ActiveSheet.Cells(Target.Row, 7).Value
  
ElseIf Target.Row >= 4 And Target.Column = 7 And Target.Text = "" Then

  ActiveSheet.Cells(3, 2).Value = ""
  ActiveSheet.Cells(5, 2).Value = ""
  ActiveSheet.Cells(7, 2).Value = ""
  ActiveSheet.Cells(9, 2).Value = ""
  ActiveSheet.Cells(11, 2).Value = ""
  ActiveSheet.Cells(21, 2).Value = ""
  
End If

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

Function BuildQuery(mark)

q_i = Sheets("登録者").Range("B21").Value

q_c = Sheets("登録者").Range("B3").Value

q_m = Sheets("登録者").Range("B5").Value

q_s = Sheets("登録者").Range("B7").Value

q_q = Sheets("登録者").Range("B9").Value

q_n = Sheets("登録者").Range("B11").Value

q_i = StrConv(q_i, vbNarrow)

q_s = StrConv(q_s, vbNarrow)

q_q = StrConv(q_q, vbNarrow)

q_i = Replace(q_i, "'", "’")

q_c = Replace(q_c, "'", "’")

q_m = Replace(q_m, "'", "’")

q_s = Replace(q_s, "'", "’")

q_q = Replace(q_q, "'", "’")

q_n = Replace(q_n, "'", "’")

q_i = Replace(q_i, """", "’")

q_c = Replace(q_c, """", "’")

q_m = Replace(q_m, """", "’")

q_s = Replace(q_s, """", "’")

q_q = Replace(q_q, """", "’")

q_n = Replace(q_n, """", "’")

If mark = "s1" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'true'"

If mark = "s2" Then q = "select ID,customer,model,serial,quantity,notes from orders where visible = 'false'"

If mark = "i" Then q = "insert into orders (customer,model,serial,quantity,notes,visible) values ('" & q_c & "','" & q_m & "','" & q_s & "'," & q_q & ",'" & q_n & "','true');"

If mark = "u" Then q = "update orders set customer = '" & q_c & "', model = '" & q_m & "', serial = '" & q_s & "', quantity = " & q_q & ", notes = '" & q_n & "' where ID = " & q_i & ";"

If mark = "d" Then q = "delete from orders where ID = " & q_i & ";"

If mark = "h" Then q = "update orders set visible = 'false' where ID = " & q_i & ";"

BuildQuery = q: Debug.Print q