V/B/A

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

import os

from PIL import Image,ImageGrab

import pyocr

import pyperclip as pc

import datetime

import streamlit as st

#インストールしたTesseract-OCRのパスを環境変数「PATH」へ追記する。

#OS自体に設定してあれば以下の2行は不要

#path='C:\\Program Files\\Tesseract-OCR'

#os.environ['PATH'] = os.environ['PATH'] + path

#pyocrへ利用するOCRエンジンをTesseractに指定する。

tools = pyocr.get_available_tools()

print(tools[0].get_name())

tool = tools[0]

#OCR対象の画像ファイルを読み込む

img = ImageGrab.grabclipboard()

#img = Image.open("test2.jpg")

#画像を読みやすいように加工。

#img=img.convert('RGB')

#size=img.size

#img2=Image.new('RGB',size)

#border=245

#for x in range(size[0]):

# for y in range(size[1]):

# r,g,b=img.getpixel((x,y))

# if r > border or g > border or b > border:

# r = 255

# g = 255

# b = 255

# img2.putpixel((x,y),(r,g,b))

if img is None:

print("そのようなデータは存在しません。")

text = "none"

else:

img.save(r"C:\Users\USER\OneDrive\ドキュメント\program\streamlit_app\jpg001.png")

#画像から文字を読み込む

builder = pyocr.builders.TextBuilder(tesseract_layout=6)

text = tool.image_to_string(img, lang="jpn", builder=builder)

print(text)

pc.copy(text)

#text_file = open(r"C:\Users\USER\OneDrive\ドキュメント\program\OCR\out.txt"out.txt", "a")

#text_file.write(text + "\n")

#text_file.close()

st.title('サプーアプリ')

st.caption('読み取りテストアプリ')

st.subheader(text)

st.text('pythonに関する情報\n'

'よろしく')

code = '''

import streamlit as st

st.title('サプーアプリ')

'''

st.code(code, language='python')

#画像

image = Image.open(r"C:\Users\USER\OneDrive\ドキュメント\program\streamlit_app\パイモン001.png")

st.image(image,width=200)

image = Image.open(r"C:\Users\USER\OneDrive\ドキュメント\program\streamlit_app\jpg001.png")

st.image(image,width=200)

with st.form(key='profile_form'):

#テキストボックス

name = st.text_input('名前',text)

address = st.text_input('住所')

#日付

start_date = st.date_input(

"When's your birthday",

datetime.date.today())

#ボタン

submit_btn = st.form_submit_button('送信')

cancel_btn = st.form_submit_button('キャンセル')

#print(f'submit_btn: {submit_btn}')

#print(f'cancel_btn: {cancel_btn}')

if submit_btn:

st.text(f'ようこそ！{name}さん！{address}に送ります')

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

import os

from PIL import Image,ImageGrab

import pyocr

import pyperclip as pc

#インストールしたTesseract-OCRのパスを環境変数「PATH」へ追記する。

#OS自体に設定してあれば以下の2行は不要

#path='C:\\Program Files\\Tesseract-OCR'

#os.environ['PATH'] = os.environ['PATH'] + path

#pyocrへ利用するOCRエンジンをTesseractに指定する。

tools = pyocr.get_available_tools()

print(tools[0].get_name())

tool = tools[0]

#OCR対象の画像ファイルを読み込む

img = ImageGrab.grabclipboard()

#img = Image.open("test2.jpg")

#画像を読みやすいように加工。

img=img.convert('RGB')

size=img.size

img2=Image.new('RGB',size)

border=245

for x in range(size[0]):

for y in range(size[1]):

r,g,b=img.getpixel((x,y))

if r > border or g > border or b > border:

r = 255

g = 255

b = 255

img2.putpixel((x,y),(r,g,b))

#画像から文字を読み込む

builder = pyocr.builders.TextBuilder(tesseract_layout=6)

text = tool.image_to_string(img2, lang="jpn", builder=builder)

print(text)

pc.copy(text)

text_file = open("out.txt", "a")

text_file.write(text + "\n")

text_file.close()

＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

Private Sub 製造仕様書番号_Plan_Click()

Dim strSpecNo As String

On Error GoTo Err_製造仕様書番号_Plan_Click

If IsNull(Me.仕様書番号) Then

MsgBox "Nullです。"

Else

strSpecNo = Me.仕様書番号

MsgBox "Null以外です。" & strSpecNo

Const BookFolder As String = "C:\Users\USER\OneDrive\ドキュメント\work\access\"

Dim key As String

Dim AC As String

Dim len1, len2 As Long

Dim hkey As String

Dim fkey As String

Dim fname As String

Dim count As Long

Dim fnames() As String

Dim filestr As String

Dim URLname As String

Dim ret As Long

Dim I As Long

'Dim cl As Range

'AC = ActiveCell.Address(False, False)

'Set cl = ActiveWindow.ActiveCell

If Left(strSpecNo, 1) = 3 Then '左から一文字目が3なら

key = Left(strSpecNo, 6) 'keyへ左から6文字で代入

Else

key = strSpecNo 'そうでないならそのまま代入

End If

'key = txts3

If key = "" Then

MsgBox "製品仕様書番号や原反等の仕様書番号の入力されたセル等を選択してから実行してください"

Exit Sub 'keyが空白なら終了

End If

len1 = Len(key)

len2 = LenB(StrConv(key, vbFromUnicode))

'全て半角の場合、コードが指定されたと判断する

If len1 = len2 And Left(key, 3) = "PCD" Then

hkey = "PCD"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 3) = "PCT" Then

hkey = "PCT"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 3) = "PEL" Then

hkey = "PEL"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 3) = "PGR" Then

hkey = "PGR"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 3) = "PNL" Then

hkey = "PNL"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 3) = "PDL" Then

hkey = "PDL"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 3) = "PBC" Then

hkey = "PBC"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 3) = "YOU" Then

hkey = "YOU"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 3) = "HAI" Then

hkey = "HAI"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Left(key, 2) = "KH" Then

hkey = "KH"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Mid(key, 6, 1) = "T" Then

hkey = "TSO"

fkey = "*" & key & "*.pdf"

ElseIf len1 = len2 And Mid(key, 6, 1) = "G" Then

hkey = "GSO"

fkey = "*" & key & "*.pdf"

Else

'全角が含まれる場合、仕入先が指定されたと判断する

MsgBox "【" & AC & "選択】不明なデータ"

End If

On Error GoTo エラー処理

fname = Dir(BookFolder & hkey & "\" & fkey)

If fname = "" Then

'MsgBox ("該当ファイルなし")

Exit Sub

End If

count = 0

filestr = ""

'ファイル一覧取得

Do While fname <> ""

ReDim Preserve fnames(count)

fnames(count) = fname

count = count + 1

filestr = filestr & fname & vbCrLf

fname = Dir()

Loop

ret = MsgBox(filestr, vbOKCancel)

If ret <> vbOK Then Exit Sub

For I = 0 To UBound(fnames)

CreateObject("Shell.Application").shellExecute BookFolder & "\" & hkey & "\" & fnames(I)

'CreateObject("Shell.Application").shellExecuteで所定のアプリで開く

'ファイル一覧取得

' Do While fname <> ""

' ReDim Preserve fnames(count)

' fnames(count) = fname

' count = count + 1

' filestr = filestr & fname ' & vbCrLf

' fname = Dir()

' Loop

' ret = MsgBox("【" & AC & "選択】" & filestr, vbOKCancel)

' If ret <> vbOK Then Exit Sub

' For i = 0 To UBound(fnames)

' '日本語のみURLエンコード*************************************************************

' '一文字づつ取り出し、半角記号以外をURLエンコードします。

' URLname = Replace(BookFolder & hkey, "http", "file")

' URLname = Replace(BookFolder & hkey, "ぎじゅなびWF承認", "%E3%81%8E%E3%81%98%E3%82%85%E3%81%AA%E3%81%B3WF%E6%89%BF%E8%AA%8D")

' URLname = "file:" & Replace(URLname, "\", "/")

' filestr = Replace(filestr, "\", "/")

' Dim objApp As New Excel.Application

' For K = 1 To Len(filestr)

' strMoji = Mid(filestr, K, 1)

' If strMoji Like "[ -/:-@\[-~]" Then

' strMojiTemp = strMojiTemp & strMoji

' Else

' strMojiTemp = strMojiTemp & objApp.WorksheetFunction.EncodeURL(strMoji)

' End If

' Next

'

' 'URLエンコード後の文字列を結合していきます。

' If strEncodeMoji = "" Then

' strEncodeMoji = strMojiTemp

' Else

' strEncodeMoji = strEncodeMoji & vbLf & strMojiTemp

' End If

'

' 'URLエンコード処理をおこなった文字列を出力します。

' filestr = Replace(strEncodeMoji, " ", "%20")

' URLname = URLname & "/" & filestr

' 'エンコード済************************************************************************

' CreateObject("WScript.Shell").Run ("MicrosoftEdge.exe -url " & URLname) '("chrome.exe -url " & URLname)

'

Next

'MsgBox BookFolder & hkey & "\" & filestr

'ActiveSheet.Hyperlinks.add Anchor:=cl, Address:=BookFolder & hkey & "\" & filestr

'ハイパーリンクの設定

Exit Sub 'On Error GoTo エラー処理

エラー処理:

MsgBox "ぎじゅなびアクセス権がありません。"

End If

Exit_製造仕様書番号_Plan_Click:

Exit Sub

Err_製造仕様書番号_Plan_Click:

MsgBox Err.Description

Resume Exit_製造仕様書番号_Plan_Click

End Sub

＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

@@@@@@@@@@@@@@@@@@@@@@@@@

'OSのビット数（32bit/64bit）及びExcelのビット数に応じて、以下の部分を書き換えて下さい

'(a) OS、Excelいずれも64bitのケース（SheepSmartCard64.dllをC:\Windows\System32に置いて下さい）

Private Declare PtrSafe Function GetSmartCardUID Lib "SheepSmartCard64.dll" (ByVal SCardUID As String) As Integer

'(b) OSは64bit、Excelは32bitのケース（SheepSmartCard32.dllをC:\Windows\SysWOW64に置いて下さい）

'Private Declare Function GetSmartCardUID Lib "SheepSmartCard32.dll" (ByVal SCardUID As String) As Integer

'(c) OS、Excelいずれも32bitのケース（SheepSmartCard32.dllをC:\Windows\System32に置いて下さい）

'Private Declare Function GetSmartCardUID Lib "SheepSmartCard32.dll" (ByVal SCardUID As String) As Integer

'dllをシステムフォルダ以外に置く場合は上記のSheepSmartCard64.dll（SheepSmartCard32.dll）の部分をフルパスで記述して下さい

Private Sub Btn_ReadUID_Click()

Dim i As Long

Dim sID As String

Dim sName As String

Dim colIDName As New Collection

For i = 1 To 2

sID = Sheet3.Cells(i, 1).Value

sName = Sheet3.Cells(i, 2).Value

Call colIDName.Add(sName, sID)

Next

Dim ret As Integer

Dim strCardUID As String

strCardUID = String$(128, vbNullChar) '70 15-30 T. Null

ret = GetSmartCardUID(strCardUID)

strCardUID = Replace(strCardUID, vbNullChar, "") '5 Null

If ret = 0 Then

'ActiveSheet.Cells(5, 3).Value = strCardUID

On Error Resume Next

ActiveSheet.Cells(5, 3).Value = colIDName.Item(strCardUID)

If CBool(Err) Then

ActiveSheet.Cells(5, 3).Value = "該当無し"

Call Err.Clear

End If

On Error GoTo 0

ActiveSheet.Cells(7, 3).Value = Null

Else

ActiveSheet.Cells(5, 3).Value = Null

If ret = 100 Then

ActiveSheet.Cells(7, 3).Value = "カードがセットされていないか、 または読み取りできないカードがセットされています。"

ElseIf ret = 200 Then

ActiveSheet.Cells(7, 3).Value = "カードリーダーを認識できません。 接続されているかご確認下さい。"

ElseIf ret = 300 Then

ActiveSheet.Cells(7, 3).Value = "スマートカードサービスが起動していないか、またはインストールされていません。 "

ElseIf ret = 400 Then

ActiveSheet.Cells(7, 3).Value = "カードIDの取得に失敗しました。"

Else

ActiveSheet.Cells(7, 3).Value = "予期しないエラーが発生しました。"

End If

End If

End Sub

''OSのビット数（32bit/64bit）及びExcelのビット数に応じて、以下の部分を書き換えて下さい

'

''(a) OS、Excelいずれも64bitのケース（SheepSmartCard64.dllをC:\Windows\System32に置いて下さい）

'Private Declare PtrSafe Function GetSmartCardUID Lib "SheepSmartCard64.dll" (ByVal SCardUID As String) As Integer

'

''(b) OSは64bit、Excelは32bitのケース（SheepSmartCard32.dllをC:\Windows\SysWOW64に置いて下さい）

''Private Declare Function GetSmartCardUID Lib "SheepSmartCard32.dll" (ByVal SCardUID As String) As Integer

'

''(c) OS、Excelいずれも32bitのケース（SheepSmartCard32.dllをC:\Windows\System32に置いて下さい）

''Private Declare Function GetSmartCardUID Lib "SheepSmartCard32.dll" (ByVal SCardUID As String) As Integer

'

''dllをシステムフォルダ以外に置く場合は上記のSheepSmartCard64.dll（SheepSmartCard32.dll）の部分をフルパスで記述して下さい

'

'Private Sub Btn_ReadUID_Click()

'

' Dim ret As Integer

' Dim strCardUID As String

'

' strCardUID = String$(128, vbNullChar) '空文字のままで関数に渡すとエラーとなるので、Null文字で埋めておきます

'

' ret = GetSmartCardUID(strCardUID)

'

' strCardUID = Replace(strCardUID, vbNullChar, "") '文字列からNull文字を除去

'

' If ret = 0 Then

' ActiveSheet.Cells(5, 3).Value = strCardUID

' ActiveSheet.Cells(7, 3).Value = Null

' Else

' ActiveSheet.Cells(5, 3).Value = Null

' If ret = 100 Then

' ActiveSheet.Cells(7, 3).Value = "カードがセットされていないか、または読み取りできないカードがセットされています。"

' ElseIf ret = 200 Then

' ActiveSheet.Cells(7, 3).Value = "カードリーダーを認識できません。接続されているかご確認下さい。"

' ElseIf ret = 300 Then

' ActiveSheet.Cells(7, 3).Value = "スマートカードサービスが起動していないか、またはインストールされていません。"

' ElseIf ret = 400 Then

' ActiveSheet.Cells(7, 3).Value = "カードＩＤの取得に失敗しました。"

' Else

' ActiveSheet.Cells(7, 3).Value = "予期しないエラーが発生しました。"

' End If

' End If

'

'End Sub

'

@@@@@@@@@@@@@@@@@@@@@@@@@@@

＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

Sub 選択メールを転送する()

Dim objFwItem As Outlook.MailItem

'現在表示中のメールアイテムを転送メールとしてセットします。

Set objFwItem = ActiveInspector.CurrentItem.Forward

'転送先を指定します。

'転送先アドレスを指定してください。

objFwItem.To = "test@extan.jp; test@extan.jp"

'CCを指定してください。

objFwItem.CC = "test1@extan.jp; test2@extan.jp"

objFwItem.Recipients.ResolveAll

'表示します。

objFwItem.Display

'オブジェクトの開放

Set objFwItem = Nothing

End Sub

＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

Sub ForwardTest()

'023 Outlook VBA 転送メールを作成

'受信ボックスで選択している1番目のメールを抽出する

Dim objSelect As Outlook.Selection

Dim objItem As Object

Set objSelect = Outlook.Application.ActiveExplorer.Selection

Set objItem = objSelect.Item(1)

'返信メールとしてobjReplyを作成する

Dim objFW As Object

Set objFW = objItem.Forward

'転送メールを記述する。

'件名や宛先はReplyメソッドで返信設定されるので、BodyだけでOK

'Bodyに返信元の文章データが入っているので、最後に+.Bodyを書く

With objFW

'転送先を指定します。

'転送先アドレスを指定してください。

.To = "test@extan.jp; test@extan.jp"

' 'CCを指定してください。

' .CC = "test1@extan.jp; test2@extan.jp"

'件名を指定します。

.Subject = .Subject & "＜メール転送します＞"

.Body = "各位" & vbCrLf & vbCrLf & _

"お疲れ様です。" & vbCrLf & vbCrLf & _

"転送です" + .Body

.Display 'ウィンドウ表示する

' .Save '下書き保存する

' .Send '送信ボックスへ送る

End With

End Sub

＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

’＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

’Outlookオブジェクトを利用してVBScriptでメールを送信する方法

'Outlookオブジェクトの変数宣言

Dim olObj

Set olObj = CreateObject("Outlook.Application")

'メール送信用のオブジェクト作成

Dim mailObj

Set mailObj = olObj.CreateItem(olMailItem)

'メール送信内容の作成

With mailObj

.To = "admin@selifelog.com" '宛先

.CC = "admin@selifelog.com" 'CCに指定する宛先、不要なら行ごと削除

.BCC = "admin@selifelog.com" 'BCCに指定する宛先、不要なら行ごと削除

.Subject = "テストメール" 'メールの件名

.Body = "お疲れさまです。" 'メールの本文

.BodyFormat = 1 'メールの形式(1:テキスト形式)

End With

'メール送信

mailObj.Send

’＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

’＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

Public Function fncXlsOpen(strBookName As String) As Boolean

'◆ブックが開いているか確認用Function

Dim objWB As Workbook

fncXlsOpen = False

For Each objWB In Workbooks

If objWB.Name = strBookName Then

fncXlsOpen = True

End If

Next objWB

End Function

Sub 選択データ転記()

Dim c As Range

Dim add1 As Long 'String '元アドレス格納

Dim add2 As Long 'String '先アドレス格納

Dim slctcol As Long

Dim strcol1 As Long '元シート開始Col

Dim endcol1 As Long '元シート終了Col

Dim strcol2 As Long '転記先シート開始Col

Dim endcol2 As Long '転記先シート終了Col

Dim slctLOT As String '検索文字

Dim bkname1 As String '元ブック名

Dim bkname2 As String '転記先ブック名

Dim shname1 As String '元シート名

Dim shname2 As String '転記先シート名

Dim shnameE As String '転記先エラーログ用シート名

Dim path As String

Dim strFileName As String

bkname1 = "A検査データ"

bkname2 = "A検査DB"

shname1 = "A検査DBP"

shname2 = "A検査DB"

shnameE = "エラーログ"

strcol1 = 6

endcol1 = strcol1 + 5

strcol2 = 9

endcol2 = strcol2 + 5

'Range(Cells(2, 1), Cells(8, 7))

Application.ScreenUpdating = False

'************************************************************************************************

path = "C:\Users\USER\OneDrive\ドキュメント\work\A検査DB.xlsm"

If Dir(path) <> "" Then

'ブックが開いているか確認する()

strFileName = "A検査DB.xlsm"

'◆ブックが開いているか確認して、開いていなかったら終了

If fncXlsOpen(strFileName) = False Then

' Workbooks.Open ThisWorkbook.path & "\" & strFileName

Workbooks.Open path

Workbooks(bkname1).Activate

' ActiveWindow.Visible = False

' MsgBox strFileName & "を開いてから実行してください。"

' End

' Else

' MsgBox strFileName & "はすでに開いています。"

End If

Else

' MsgBox path & "が存在しません！"

MsgBox strFileName & "を開いてから実行してください。"

End If

'************************************************************************************************

slctcol = ActiveCell.Column

If slctcol = "5" Then

For Each c In Selection.Cells

c.Select

'MsgBox c.Address(False, False)

slctLOT = c.Value

add1 = c.Row 'c.Address

' MsgBox slctLOT

' Workbooks(bkname2).Worksheets(shname2).Cells.Find (slctLOT)

'On Error GoTo notfind

add2 = Workbooks(bkname2).Worksheets(shname2).Range("E11:E200000").Find(slctLOT).Row '.Address

'MsgBox Workbooks(bkname2).Worksheets(shname2).Range("E11:E200000").Find(slctLOT).Address

Workbooks(bkname1).Worksheets(shname1).Range(add1).Offset(0, 1).Resize(, 5).Copy

Workbooks(bkname2).Worksheets(shname2).Range(add2).Offset(0, 4).PasteSpecial Paste:=xlPasteValues

'Workbooks(bkname2).Worksheets(shname2).Range(Cells(add2, strcol2), Cells(add2, endcol2)).FormulaR1C1 = Workbooks(bkname1).Worksheets(shname1).Range(Cells(add1, strcol1), Cells(add1, endcol1)).FormulaR1C1

Next

End If

Application.ScreenUpdating = True

Exit Sub

notfind:

MsgBox slctLOT & "_not find"

n = Workbooks(bkname2).Worksheets(shnameE).Cells(Rows.Count, "A").End(xlUp).Row + 1

' Workbooks(bkname2).Worksheets(shnameE).Range("E" & n).Offset(0, 4).PasteSpecial Paste:=xlPasteValues

Workbooks(bkname2).Worksheets(shname2).Range(Cells(add2, strcol2), Cells(add2, endcol2)).Value = Workbooks(bkname1).Worksheets(shname1).Range(Cells(add1, strcol1), Cells(add1, endcol1)).Value

Workbooks(bkname2).Worksheets(shnameE).Range("E" & n).Value = slctLOT

Workbooks(bkname2).Worksheets(shnameE).Range("A" & n).Value = Format(Now, "yyyy/mm/dd hh:nn")

Resume Next

End Sub

’＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠

■1920-1080.bat■■■■■■

powershell -NoProfile -ExecutionPolicy Unrestricted .\1920-1080.ps1

■1920-1080.ps1■■■■■■

Function Set-ScreenResolution {

<#

.Synopsis

Sets the Screen Resolution of the primary monitor

.Description

Uses Pinvoke and ChangeDisplaySettings Win32API to make the change

.Example

Set-ScreenResolution -Width 1024 -Height 768

#>

param (

[Parameter(Mandatory=$true,

Position = 0)]

[int]

$Width,

[Parameter(Mandatory=$true,

Position = 1)]

[int]

$Height

)

$pinvokeCode = @"

using System;

using System.Runtime.InteropServices;

namespace Resolution

{

[StructLayout(LayoutKind.Sequential)]

public struct DEVMODE1

{

[MarshalAs(UnmanagedType.ByValTStr, SizeConst = 32)]

public string dmDeviceName;

public short dmSpecVersion;

public short dmDriverVersion;

public short dmSize;

public short dmDriverExtra;

public int dmFields;

public short dmOrientation;

public short dmPaperSize;

public short dmPaperLength;

public short dmPaperWidth;

public short dmScale;

public short dmCopies;

public short dmDefaultSource;

public short dmPrintQuality;

public short dmColor;

public short dmDuplex;

public short dmYResolution;

public short dmTTOption;

public short dmCollate;

[MarshalAs(UnmanagedType.ByValTStr, SizeConst = 32)]

public string dmFormName;

public short dmLogPixels;

public short dmBitsPerPel;

public int dmPelsWidth;

public int dmPelsHeight;

public int dmDisplayFlags;

public int dmDisplayFrequency;

public int dmICMMethod;

public int dmICMIntent;

public int dmMediaType;

public int dmDitherType;

public int dmReserved1;

public int dmReserved2;

public int dmPanningWidth;

public int dmPanningHeight;

};

class User_32

{

[DllImport("user32.dll")]

public static extern int EnumDisplaySettings(string deviceName, int modeNum, ref DEVMODE1 devMode);

[DllImport("user32.dll")]

public static extern int ChangeDisplaySettings(ref DEVMODE1 devMode, int flags);

public const int ENUM_CURRENT_SETTINGS = -1;

public const int CDS_UPDATEREGISTRY = 0x01;

public const int CDS_TEST = 0x02;

public const int DISP_CHANGE_SUCCESSFUL = 0;

public const int DISP_CHANGE_RESTART = 1;

public const int DISP_CHANGE_FAILED = -1;

}

public class PrmaryScreenResolution

{

static public string ChangeResolution(int width, int height)

{

DEVMODE1 dm = GetDevMode1();

if (0 != User_32.EnumDisplaySettings(null, User_32.ENUM_CURRENT_SETTINGS, ref dm))

{

dm.dmPelsWidth = width;

dm.dmPelsHeight = height;

int iRet = User_32.ChangeDisplaySettings(ref dm, User_32.CDS_TEST);

if (iRet == User_32.DISP_CHANGE_FAILED)

{

return "Unable To Process Your Request. Sorry For This Inconvenience.";

}

else

{

iRet = User_32.ChangeDisplaySettings(ref dm, User_32.CDS_UPDATEREGISTRY);

switch (iRet)

{

case User_32.DISP_CHANGE_SUCCESSFUL:

{

return "Success";

}

case User_32.DISP_CHANGE_RESTART:

{

return "You Need To Reboot For The Change To Happen.\n If You Feel Any Problem After Rebooting Your Machine\nThen Try To Change Resolution In Safe Mode.";

}

default:

{

return "Failed To Change The Resolution";

}

}

}

}

else

{

return "Failed To Change The Resolution.";

}

}

private static DEVMODE1 GetDevMode1()

{

DEVMODE1 dm = new DEVMODE1();

dm.dmDeviceName = new String(new char[32]);

dm.dmFormName = new String(new char[32]);

dm.dmSize = (short)Marshal.SizeOf(dm);

return dm;

}

}

}

"@

Add-Type $pinvokeCode -ErrorAction SilentlyContinue

[Resolution.PrmaryScreenResolution]::ChangeResolution($width,$height)

}

Set-ScreenResolution -Width 1920 -Height 1080

★

Sub 発注依頼()

OrderForm.Show

End Sub

'____________________

Private Sub CommandButton1_Click() '処理ボタン

Dim myRange As Range

Dim rngSearch As Range

Dim chk_flg As Boolean

If Me.TextBox1 = "" Or Me.TextBox2 = "" Then

MsgBox "TextBoxが空白です。"

Exit Sub

End If

Set myRange = ActiveSheet.Range("A3:C7")

Set rngSearch = myRange.Find(What:=TextBox1.Value, LookAt:=xlPart)

ActiveSheet.Cells(rngSearch.Row, rngSearch.Column + 7).Value = "発注依頼"

ActiveSheet.Cells(rngSearch.Row, rngSearch.Column + 8).Value = Format(Now, "yyyy年mm月dd日 hh時mm分ss秒")

'ログ

Me.Hide 'フォームを閉じる

' Dim chk_flg As Boolean

'

' If Me.CommandButton2.Caption = "削除" Then '削除ボタンの場合

' If MsgBox("表示中のレコードを削除します。よろしいですか？", vbOKCancel) <> 1 Then Exit Sub '確認

' Call TranDataCheck '販売データチェック（本文未収録エラー処理）

' Call DBdelete '削除プロシージャ呼び出し

' Else '追加・更新ボタンの場合

' '処理前にチェック

' If Me.TextBox3 = "" Then chk_flg = True '日付が空欄ならフラグを立てる

' If IsNumeric(Me.TextBox4) = False Then chk_flg = True '数量が数字じゃなければフラグを立てる

' '条件を加えたかったらここへ追加

' If chk_flg = True Then 'フラグが立っていたら

' MsgBox "NG項目があります。"

' Exit Sub

' End If

'

' '------------ここより本文未収録のエラー処理------------

' If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Or Me.ComboBox3 = "" Then

' MsgBox "コンボボックスが空白です。"

' Exit Sub

' End If

' If IsDate(Me.TextBox3) = False Then

' MsgBox "日付の形式が正しくありません。"

' Exit Sub

' End If

' If Me.TextBox3 <> StrConv(Me.TextBox3, vbNarrow) Then

' MsgBox "日付は半角で入力してください。"

' Exit Sub

' End If

' If IsNumeric(Me.TextBox4) = False Or IsNumeric(Me.TextBox5) = False Then

' MsgBox "数量が空白、または形式が正しくありません。"

' Exit Sub

' End If

' If Me.TextBox4 <> StrConv(Me.TextBox4, vbNarrow) Or Me.TextBox5 <> StrConv(Me.TextBox5, vbNarrow) Then

' MsgBox "数値は半角で入力してください。"

' Exit Sub

' End If

'

' Call MasterDataCheck1 'マスターデータチェック（本文未収録エラー処理）

' If Me.CommandButton2.Caption = "更新" Then Call TranDataCheck '販売データチェック（本文未収録エラー処理）

' '------------ここまで本文未収録のエラー処理------------

'

' If Me.CommandButton2.Caption = "追加" Then Call DBinsert '追加プロシージャ呼び出し

' If Me.CommandButton2.Caption = "更新" Then Call DBupdate '更新プロシージャ呼び出し

' End If

' Me.Hide 'フォームを閉じる

' Call DBselect '読込プロシージャ呼び出し

End Sub

Private Sub CommandButton3_Click() '閉じるボタン

Me.Hide 'フォームを閉じる

End Sub

Private Sub CommandButton4_Click()

Dim myRange As Range

Dim rngSearch As Range

Dim chk_flg As Boolean

If Me.TextBox1 = "" Or Me.TextBox2 = "" Then

MsgBox "TextBoxが空白です。"

Exit Sub

End If

Set myRange = ActiveSheet.Range("A3:C7")

Set rngSearch = myRange.Find(What:=TextBox1.Value, LookAt:=xlPart)

ActiveSheet.Cells(rngSearch.Row, rngSearch.Column + 7).Value = ""

Me.Hide 'フォームを閉じる

End Sub

Private Sub TextBox1_AfterUpdate()

Dim myRange As Range

Dim rngSearch As Range

Set myRange = ActiveSheet.Range("A3:C7")

Set rngSearch = myRange.Find(What:=TextBox1.Value, LookAt:=xlPart)

If Not rngSearch Is Nothing Then

'ヒットした値をテキストボックス2にセット

TextBox2.Value = ActiveSheet.Cells(rngSearch.Row, rngSearch.Column + 2).Value

End If

End Sub

Private Sub UserForm_Click()

End Sub

★

Sub グラフ位置取得()

'選択していること

With ActiveSheet.ChartObjects(1)

MsgBox "左からの位置は　" & .Left & vbCrLf & _

"上からの位置は　" & .Top & vbCrLf & _

"幅は　　　" & .Width & vbCrLf & _

"高さは　　" & .Height

End With

With ActiveSheet.ChartObjects(2)

MsgBox "左からの位置は　" & .Left & vbCrLf & _

"上からの位置は　" & .Top & vbCrLf & _

"幅は　　　" & .Width & vbCrLf & _

"高さは　　" & .Height

End With

End Sub

★

Option Explicit

Public Sub シート追加()

Dim addedSheet As Worksheet

Dim myWBName As String

myWBName = ActiveWorkbook.Name

MsgBox myWBName

Dim i As Long

i = InStrRev(myWBName, ".")

If i > 0 Then myWBName = Left(myWBName, i - 1)

MsgBox "拡張子を除いたブック名： " & myWBName

Dim ws As Worksheet, flag As Boolean

For Each ws In Worksheets

If ws.Name = myWBName Then flag = True

Next ws

If flag = True Then

MsgBox "シートがあります", vbInformation

Else

MsgBox "シートはありません", vbInformation

'先頭にシートを追加

Set addedSheet = Worksheets.Add(Before:=Worksheets(1))

addedSheet.Name = myWBName

End If

End Sub

★アクセス

Option Explicit '変数の宣言を強制する

'---ACCESS接続用

Public adoCn As Object 'ADOコネクションオブジェクト

Public adoRs As Object 'ADOレコードセットオブジェクト

Public strSQL As String 'SQL文

'---カレンダー用

Public clndr_date As Date '日付を格納する変数

Public clndr_flg As Boolean 'カレンダーがクリックされたか判定するフラグ

Sub DBconnect(flg As Boolean) 'DB接続プロシージャ

Dim DBpath As String

DBpath = ThisWorkbook.Path 'DBが同じ階層にある場合

'DBpath = "C:\Users\user1\Documents" 'DBが違う階層にある場合はパスを指定

Set adoCn = CreateObject("ADODB.Connection") 'ADOコネクションオブジェクトを作成

If flg = True Then Set adoRs = CreateObject("ADODB.Recordset") 'ADOレコードセットオブジェクトを作成

adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _

"Data Source=" & DBpath & "\DataExchange.accdb;" 'Accessファイルを開く

End Sub

Sub DBcut_off(flg As Boolean) 'DB切断プロシージャ

If flg = True Then adoRs.Close 'レコードセットのクローズ

adoCn.Close 'コネクションのクローズ

Set adoRs = Nothing 'オブジェクトの破棄

Set adoCn = Nothing

End Sub

Sub DBinsert_all() '一括書込

Dim start_i As Long, end_i As Long, n As Long, ShtName As String

ShtName = ActiveSheet.Name 'アクティブシート名を取得

Select Case ShtName

Case "販売データ", "商品マスター", "取引先マスター", "営業所マスター", "社員マスター"

If MsgBox("一括書込を実行しようとしています。続けますか？", vbOKCancel) <> 1 Then 'メッセージ

Exit Sub 'OK以外なら終了

End If

Case Else

MsgBox "このシートからは一括書込できません。"

Exit Sub '終了

End Select

If MsgBox( _

"Accessの「" & ShtName & "」テーブルのデータを一度削除し、" & vbCrLf & _

"現在このシートにある情報のみが書き込まれます。" & vbCrLf & _

"書込み終了後、このシートは削除されます。" & vbCrLf & _

vbCrLf & _

"実行してよろしいですか？", vbOKCancel + vbExclamation, "一括書込み") <> 1 Then 'メッセージ

Exit Sub 'OK以外なら終了

End If

start_i = 2 'スタート行

end_i = Range("A1").End(xlDown).Row '最終行取得

Call DBconnect(False) 'DB接続

On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ

adoCn.BeginTrans 'トランザクション開始

strSQL = "DELETE FROM " & ShtName & ";" 'テーブル内データを全削除

adoCn.Execute strSQL '削除実行

For n = start_i To end_i 'データのある行を繰り返す

Select Case ShtName 'シート名を判別して対応するSQLを作成

Case "販売データ"

strSQL = _

"INSERT INTO " & ShtName & "(" & _

"商品コード, " & _

"売上日, " & _

"数量, " & _

"売価, " & _

"取引先コード, " & _

"社員コード) " & _

"VALUES(" & _

"'" & Cells(n, 1) & "', " & _

"#" & CDate(Cells(n, 2)) & "#, " & _

Cells(n, 3) & ", " & _

Cells(n, 4) & ", " & _

"'" & Cells(n, 5) & "', " & _

"'" & Cells(n, 6) & "');"

Case "商品マスター"

strSQL = _

"INSERT INTO " & ShtName & "(" & _

"商品コード, " & _

"商品名, " & _

"製造場所, " & _

"定価, " & _

"原価) " & _

"VALUES(" & _

"'" & Cells(n, 1) & "', " & _

"'" & Cells(n, 2) & "', " & _

"'" & Cells(n, 3) & "', " & _

Cells(n, 4) & ", " & _

Cells(n, 5) & ");"

Case "取引先マスター"

strSQL = _

"INSERT INTO " & ShtName & "(" & _

"取引先コード, " & _

"取引先, " & _

"住所, " & _

"電話番号) " & _

"VALUES(" & _

"'" & Cells(n, 1) & "', " & _

"'" & Cells(n, 2) & "', " & _

"'" & Cells(n, 3) & "', " & _

"'" & Cells(n, 4) & "');"

Case "営業所マスター"

strSQL = _

"INSERT INTO " & ShtName & "(" & _

"営業所コード, " & _

"営業所, " & _

"住所, " & _

"電話番号) " & _

"VALUES(" & _

"'" & Cells(n, 1) & "', " & _

"'" & Cells(n, 2) & "', " & _

"'" & Cells(n, 3) & "', " & _

"'" & Cells(n, 4) & "');"

Case "社員マスター"

strSQL = _

"INSERT INTO " & ShtName & "(" & _

"社員コード, " & _

"社員名, " & _

"入社日, " & _

"住所, " & _

"電話番号, " & _

"営業所コード) " & _

"VALUES(" & _

"'" & Cells(n, 1) & "', " & _

"'" & Cells(n, 2) & "', " & _

"#" & Cells(n, 3) & "#, " & _

"'" & Cells(n, 4) & "', " & _

"'" & Cells(n, 5) & "', " & _

"'" & Cells(n, 6) & "');"

End Select

adoCn.Execute strSQL '書込実行

Next n

adoCn.CommitTrans 'トランザクション終了（確定処理）

Call DBcut_off(False) 'DB切断

MsgBox "正常に完了しました。" & vbCrLf & "「" & ShtName & "」シートを削除します。"

Application.DisplayAlerts = False '警告オフ

Sheets(ShtName).Delete 'シート削除

Application.DisplayAlerts = True '警告オン

Exit Sub '正常ならここで終了

Err_Handler: 'エラーが起きたらここへ飛ぶ

adoCn.RollbackTrans 'ロールバック

Call DBcut_off(False) 'DB切断

MsgBox Error$ 'エラーメッセージ表示

Debug.Print Error$ 'デバッグ表示

Debug.Print strSQL

End Sub

Sub MainStart()

If ActiveSheet.Name <> "販売管理" Then '「販売管理」以外のシートだったら

MsgBox "このシートからはメインフォームを起動できません。"

Exit Sub '終了

End If

MainForm.Show '「MainForm」を開く

End Sub

Sub DBselect() 'DB読込

Dim i As Long, end_i As Long, chk_flg As Boolean

Dim check1 As String, check2 As String, check3 As String, check4 As String

On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ

With SelectForm

'条件1

If .TextBox1 = "" Then '商品コードが空欄の場合

check1 = ""

Else '商品コードが記入済の場合

check1 = "WHERE 販売データ.商品コード = '" & .TextBox1 & "' " '条件作成

chk_flg = True

End If

'条件2

If .TextBox2 = "" Or .TextBox3 = "" Then '日付がどちらか空欄の場合

check2 = ""

Else '日付が記入済の場合

If chk_flg = False Then '初めての条件なら

check2 = "WHERE"

chk_flg = True

Else

check2 = "AND"

End If

check2 = check2 & " 販売データ.売上日 BETWEEN #" & .TextBox2 & "# AND #" & .TextBox3 & "# " '条件作成

End If

'条件3

If .TextBox4 = "" Then '数量が空欄の場合

check3 = ""

Else '数量が記入済の場合

If chk_flg = False Then '初めての条件なら

check3 = "WHERE"

chk_flg = True

Else

check3 = "AND"

End If

check3 = check3 & " 販売データ.数量"

Select Case .ComboBox1

Case "以上"

check3 = check3 & " >= "

Case "以下"

check3 = check3 & " <= "

Case Else

check3 = check3 & " = "

End Select

check3 = check3 & .TextBox4 & " "

End If

'条件4

If .TextBox5 = "" Then '検索テキストが空欄の場合

check4 = ""

Else '検索テキストが記入済の場合

If chk_flg = False Then '初めての条件なら

check4 = "WHERE"

chk_flg = True

Else '2番目以降なら

check4 = "AND"

End If

Select Case .ComboBox2

Case "商品名", "製造場所"

check4 = check4 & " 商品マスター." & .ComboBox2

Case "取引先"

check4 = check4 & " 取引先マスター." & .ComboBox2

Case "営業所"

check4 = check4 & " 営業所マスター." & .ComboBox2

Case "社員名"

check4 = check4 & " 社員マスター." & .ComboBox2

End Select

check4 = check4 & " LIKE '%" & .TextBox5 & "%' " '～を含む

End If

End With

Call DBconnect(True) 'DB接続

strSQL = _

"SELECT " & _

"販売データ.販売コード, " & _

"販売データ.商品コード, " & _

"商品マスター.商品名, " & _

"販売データ.売上日, " & _

"販売データ.数量, " & _

"販売データ.売価, " & _

"商品マスター.製造場所, " & _

"商品マスター.定価, " & _

"商品マスター.原価, " & _

"取引先マスター.取引先, " & _

"営業所マスター.営業所, " & _

"社員マスター.社員名 " & _

"FROM ((( 販売データ " & _

"INNER JOIN 商品マスター ON 販売データ.商品コード = 商品マスター.商品コード ) " & _

"INNER JOIN 社員マスター ON 販売データ.社員コード = 社員マスター.社員コード ) " & _

"INNER JOIN 取引先マスター ON 販売データ.取引先コード = 取引先マスター.取引先コード ) " & _

"INNER JOIN 営業所マスター ON 社員マスター.営業所コード = 営業所マスター.営業所コード " & _

check1 & _

check2 & _

check3 & _

check4 & _

"ORDER BY 売上日 DESC;"

adoRs.Open strSQL, adoCn 'SQLを実行して対象をRecordSetへ

If adoRs.BOF = True And adoRs.EOF = True Then 'データがなかったら

Call DBcut_off(True) 'DB切断

MsgBox "対象データがありません。"

Exit Sub '終了

End If

i = 2 'スタート行

end_i = Range("A1").End(xlDown).Row 'エンド行

Range("A" & i & ":L" & end_i).ClearContents '前のデータクリア

'レコードセットからの取り出し方法1

Do Until adoRs.EOF 'レコードセットが終了するまで処理を繰り返す

Cells(i, 1) = adoRs!販売コード

Cells(i, 2) = adoRs!商品コード

Cells(i, 3) = adoRs!商品名

Cells(i, 4) = adoRs!売上日

Cells(i, 5) = adoRs!数量

Cells(i, 6) = adoRs!売価

Cells(i, 7) = adoRs!製造場所

Cells(i, 8) = adoRs!定価

Cells(i, 9) = adoRs!原価

Cells(i, 10) = adoRs!取引先

Cells(i, 11) = adoRs!営業所

Cells(i, 12) = adoRs!社員名

i = i + 1 '行をカウントアップする

adoRs.MoveNext '次のレコードに移動する

Loop

'レコードセットからの取り出し方法2

'Range("A2").CopyFromRecordset adoRs 'A2セルを起点にデータを貼り付け

Call DBcut_off(True) 'DB切断

Exit Sub '正常ならここで終了

Err_Handler: 'エラーが起きたらここへ飛ぶ

Call DBcut_off(False) 'DB切断

MsgBox Error$ 'エラーメッセージ表示

Debug.Print Error$ 'デバッグ表示

Debug.Print strSQL

End Sub

Sub DBinsert() 'DB追加

Call DBconnect(False) 'DB接続

On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ

adoCn.BeginTrans 'トランザクション開始

With ManagementForm

strSQL = _

"INSERT INTO 販売データ(" & _

"商品コード, " & _

"売上日, " & _

"数量, " & _

"売価, " & _

"取引先コード, " & _

"社員コード) " & _

"VALUES(" & _

"'" & .ComboBox1 & "', " & _

"#" & CDate(.TextBox3) & "#, " & _

.TextBox4 & ", " & _

.TextBox5 & ", " & _

"'" & .ComboBox2.Column(1) & "', " & _

"'" & .ComboBox3.Column(1) & "');"

End With

adoCn.Execute strSQL '実行

adoCn.CommitTrans 'トランザクション終了（確定処理）

Call DBcut_off(False) 'DB切断

MsgBox "正常に完了しました"

Exit Sub '正常ならここで終了

Err_Handler: 'エラーが起きたらここへ飛ぶ

adoCn.RollbackTrans 'ロールバック

Call DBcut_off(False) 'DB切断

MsgBox Error$ 'エラーメッセージ表示

Debug.Print Error$ 'デバッグ表示

Debug.Print strSQL

End Sub

Sub DBupdate() 'DB更新

Call DBconnect(False) 'DB接続

On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ

adoCn.BeginTrans 'トランザクション開始

With ManagementForm

strSQL = _

"UPDATE 販売データ " & _

"SET " & _

"商品コード = '" & .ComboBox1 & "', " & _

"売上日 = #" & CDate(.TextBox3) & "#, " & _

"数量 = " & .TextBox4 & ", " & _

"売価 = " & .TextBox5 & ", " & _

"取引先コード = '" & .ComboBox2.Column(1) & "', " & _

"社員コード = '" & .ComboBox3.Column(1) & "' " & _

"WHERE 販売コード = " & .TextBox1 & ";"

End With

adoCn.Execute strSQL '実行

adoCn.CommitTrans 'トランザクション終了（確定処理）

Call DBcut_off(False) 'DB切断

MsgBox "正常にデータ更新しました"

Exit Sub '正常ならここで終了

Err_Handler: 'エラーが起きたらここへ飛ぶ

adoCn.RollbackTrans 'ロールバック

Call DBcut_off(False) 'DB切断

MsgBox Error$ 'エラーメッセージ表示

Debug.Print Error$ 'デバッグ表示

Debug.Print strSQL

End Sub

Sub DBdelete() 'DB削除

Call DBconnect(False) 'DB接続

On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ

adoCn.BeginTrans 'トランザクション開始

strSQL = _

"DELETE FROM 販売データ WHERE 販売コード = " & ManagementForm.TextBox1 & ";"

adoCn.Execute strSQL '実行

adoCn.CommitTrans 'トランザクション終了（確定処理）

Call DBcut_off(False) 'DB切断

MsgBox "正常に削除しました"

Exit Sub '正常ならここで終了

Err_Handler: 'エラーが起きたらここへ飛ぶ

adoCn.RollbackTrans 'ロールバック

Call DBcut_off(False) 'DB切断

MsgBox Error$ 'エラーメッセージ表示

Debug.Print Error$ 'デバッグ表示

Debug.Print strSQL

End Sub

★マネジメントフォーム

Option Explicit

Private Sub CommandButton1_Click() 'カレンダー表示

clndr_flg = False

If Me.TextBox3 = "" Or IsDate(Me.TextBox3) = False Then

clndr_date = Date

Else

clndr_date = Me.TextBox3 '日付を格納

End If

CalenderForm.Show 'カレンダーを開く

If clndr_flg = True Then Me.TextBox3 = Format(clndr_date, "yyyy/mm/dd") 'クリックされた日付を上書き

End Sub

Private Sub CommandButton2_Click() '処理ボタン

Dim chk_flg As Boolean

If Me.CommandButton2.Caption = "削除" Then '削除ボタンの場合

If MsgBox("表示中のレコードを削除します。よろしいですか？", vbOKCancel) <> 1 Then Exit Sub '確認

Call TranDataCheck '販売データチェック（本文未収録エラー処理）

Call DBdelete '削除プロシージャ呼び出し

Else '追加・更新ボタンの場合

'処理前にチェック

If Me.TextBox3 = "" Then chk_flg = True '日付が空欄ならフラグを立てる

If IsNumeric(Me.TextBox4) = False Then chk_flg = True '数量が数字じゃなければフラグを立てる

'条件を加えたかったらここへ追加

If chk_flg = True Then 'フラグが立っていたら

MsgBox "NG項目があります。"

Exit Sub

End If

'------------ここより本文未収録のエラー処理------------

If Me.ComboBox1 = "" Or Me.ComboBox2 = "" Or Me.ComboBox3 = "" Then

MsgBox "コンボボックスが空白です。"

Exit Sub

End If

If IsDate(Me.TextBox3) = False Then

MsgBox "日付の形式が正しくありません。"

Exit Sub

End If

If Me.TextBox3 <> StrConv(Me.TextBox3, vbNarrow) Then

MsgBox "日付は半角で入力してください。"

Exit Sub

End If

If IsNumeric(Me.TextBox4) = False Or IsNumeric(Me.TextBox5) = False Then

MsgBox "数量が空白、または形式が正しくありません。"

Exit Sub

End If

If Me.TextBox4 <> StrConv(Me.TextBox4, vbNarrow) Or Me.TextBox5 <> StrConv(Me.TextBox5, vbNarrow) Then

MsgBox "数値は半角で入力してください。"

Exit Sub

End If

Call MasterDataCheck1 'マスターデータチェック（本文未収録エラー処理）

If Me.CommandButton2.Caption = "更新" Then Call TranDataCheck '販売データチェック（本文未収録エラー処理）

'------------ここまで本文未収録のエラー処理------------

If Me.CommandButton2.Caption = "追加" Then Call DBinsert '追加プロシージャ呼び出し

If Me.CommandButton2.Caption = "更新" Then Call DBupdate '更新プロシージャ呼び出し

End If

Me.Hide 'フォームを閉じる

Call DBselect '読込プロシージャ呼び出し

End Sub

Private Sub CommandButton3_Click() '閉じるボタン

Me.Hide 'フォームを閉じる

End Sub

Private Sub ComboBox1_Change() '商品コードが変更されたとき

If Me.ComboBox1 <> "" Then

Call MasterDataCheck2("商品マスター", "商品コード", Me.ComboBox1) 'マスターデータチェック（本文未収録エラー処理）

Call DBconnect(True) 'DB接続

strSQL = "SELECT * FROM 商品マスター WHERE 商品コード = '" & Me.ComboBox1 & "';"

adoRs.Open strSQL, adoCn 'SQLを実行して対象をRecordSetへ

Me.TextBox2 = adoRs!商品名

Me.TextBox6 = adoRs!製造場所

Me.TextBox7 = adoRs!定価

Me.TextBox8 = adoRs!原価

Call DBcut_off(True) 'DB切断

End If

End Sub

Private Sub ComboBox3_Change() '社員名が変更されたとき

If Me.ComboBox3 <> "" Then

Call MasterDataCheck2("社員マスター", "社員名", Me.ComboBox3) 'マスターデータチェック（本文未収録エラー処理）

Call DBconnect(True) 'DB接続

strSQL = _

"SELECT 営業所マスター.営業所 " & _

"FROM 社員マスター INNER JOIN 営業所マスター " & _

"ON 社員マスター.営業所コード = 営業所マスター.営業所コード " & _

"WHERE 社員マスター.社員コード = '" & Me.ComboBox3.Column(1) & "';"

adoRs.Open strSQL, adoCn 'SQLを実行して対象をRecordSetへ

Me.TextBox9 = adoRs!営業所

Call DBcut_off(True) 'DB切断

End If

End Sub

'------------ここから先は本文未収録のエラー処理プロシージャ------------

Private Sub ComboBox2_Change() 'コンボボックス2直接入力時のエラー回避

If Me.ComboBox2 <> "" Then Call MasterDataCheck2("取引先マスター", "取引先", Me.ComboBox2)

End Sub

Private Sub MasterDataCheck1() 'マスターデータがAccessに存在するかチェック

Dim chk_flg As Boolean

'商品マスターチェック

Call DBconnect(True)

adoRs.Open "SELECT * FROM 商品マスター;", adoCn

If adoRs.BOF = True And adoRs.EOF = True Then chk_flg = True 'データがなかったらフラグを立てる

Call DBcut_off(True)

'取引先マスターチェック

Call DBconnect(True)

adoRs.Open "SELECT * FROM 取引先マスター;", adoCn

If adoRs.BOF = True And adoRs.EOF = True Then chk_flg = True

Call DBcut_off(True)

'社員マスターチェック

Call DBconnect(True)

adoRs.Open "SELECT * FROM 社員マスター;", adoCn

If adoRs.BOF = True And adoRs.EOF = True Then chk_flg = True

Call DBcut_off(True)

'営業所マスターチェック

Call DBconnect(True)

adoRs.Open "SELECT * FROM 営業所マスター;", adoCn

If adoRs.BOF = True And adoRs.EOF = True Then chk_flg = True

Call DBcut_off(True)

If chk_flg = True Then

MsgBox "必要なマスターデータが登録されていません。" & vbCrLf & "動作を中止します。"

End

End If

End Sub

'指定のマスターデータがAccessに存在するかチェック（コンボボックス直接入力時のエラー回避）

Private Sub MasterDataCheck2(tbl As String, fld As String, key As String)

Dim chk_flg As Boolean

'指定マスターチェック

Call DBconnect(True)

strSQL = "SELECT * FROM " & tbl & " WHERE " & fld & " = '" & key & "';"

adoRs.Open strSQL, adoCn

If adoRs.BOF = True And adoRs.EOF = True Then chk_flg = True

Call DBcut_off(True)

If chk_flg = True Then

MsgBox "コンボボックスに直接入力はできません。" & vbCrLf & "動作を中止します。"

End

End If

End Sub

Private Sub TranDataCheck() '販売データテーブルにレコードが存在するかチェック

Dim chk_flg As Boolean

'販売データチェック

Call DBconnect(True)

strSQL = "SELECT * FROM 販売データ WHERE 販売コード = " & ManagementForm.TextBox1 & ";"

adoRs.Open strSQL, adoCn

If adoRs.BOF = True And adoRs.EOF = True Then chk_flg = True 'データがなかったらフラグを立てる

Call DBcut_off(True)

If chk_flg = True Then

MsgBox "該当の販売データが存在しないため、" & vbCrLf & "この操作はできません。動作を中止します。"

End

End If

End Sub

Private Sub TextBox1_Change()

End Sub

★メインフォーム

Option Explicit

Private Sub CommandButton1_Click() '閉じるボタン

Me.Hide 'メインフォームを閉じる

End Sub

Private Sub CommandButton2_Click() '読込ボタン

Dim baff As String

Me.Hide 'メインフォームを閉じる

With SelectForm

With .ComboBox1

baff = .Value '前のデータを一時保管

.Clear 'リセット

.AddItem "以上"

.AddItem "以下"

.Value = baff '前のデータを入れる

End With

With .ComboBox2

baff = .Value '前のデータを一時保管

.Clear 'リセット

.AddItem "商品名"

.AddItem "製造場所"

.AddItem "取引先"

.AddItem "営業所"

.AddItem "社員名"

.Value = baff '前のデータを入れる

End With

.Show 'SelectForm表示

End With

End Sub

Private Sub CommandButton3_Click() '追加ボタン

Me.Hide 'メインフォームを閉じる

Call SetForm '販売管理フォームのクリアや値セット

With ManagementForm

.CommandButton2.Caption = "追加" '処理ボタンのCaptionを変更

.Show '表示

End With

End Sub

Private Sub CommandButton4_Click() '更新ボタン

Dim n As Long

n = ActiveCell.Row '選択されているセルの行を取得

If n = 1 Or Cells(n, 1) = "" Then '1行目、もしくは空セルだったら

MsgBox "対象データを選択してください。"

Exit Sub '終了

End If

Me.Hide 'メインフォームを閉じる

Call SetForm '販売管理フォームのクリアや値セット

Call FillForm(n) '販売管理フォームを埋める

With ManagementForm

.CommandButton2.Caption = "更新" '処理ボタンのCaptionを変更

.Show '表示

End With

End Sub

Private Sub CommandButton5_Click() '削除ボタン

Dim n As Long

n = ActiveCell.Row '選択されているセルの行を取得

If n = 1 Or Cells(n, 1) = "" Then '1行目、もしくは空セルだったら

MsgBox "対象データを選択してください。"

Exit Sub '終了

End If

Me.Hide 'メインフォームを閉じる

Call SetForm '販売管理フォームのクリアや値セット

Call FillForm(n) '販売管理フォームを埋める

With ManagementForm

.CommandButton2.Caption = "削除" '処理ボタンのCaptionを変更

.Show '表示

End With

End Sub

Private Sub SetForm() '販売管理フォームのクリアや値セット

Dim i As Long, cmb_item() As String

With ManagementForm

For i = 1 To 9 '1～9まで繰り返す

.Controls("TextBox" & i).Value = "" 'テキストボックスをクリア

Next i

For i = 1 To 3 '1～3まで繰り返す

.Controls("ComboBox" & i).Clear 'コンボボックスをクリア

Next i

'商品情報をComboBox1へ

Call DBconnect(True) 'DB接続

strSQL = "SELECT 商品コード FROM 商品マスター;"

adoRs.Open strSQL, adoCn 'SQLを実行して対象をRecordSetへ

Do Until adoRs.EOF 'レコードセットが終了するまで処理を繰り返す

.ComboBox1.AddItem adoRs!商品コード

adoRs.MoveNext '次のレコードに移動する

Loop

Call DBcut_off(True) 'DB切断

'取引先情報をComboBox2へ

Call DBconnect(True) 'DB接続

strSQL = "SELECT 取引先コード, 取引先 FROM 取引先マスター;"

adoRs.Open strSQL, adoCn, 1 'SQLを実行して対象をRecordSetへ（CursorType定数1=adOpenKeyset）

If Not (adoRs.BOF = True Or adoRs.EOF = True) Then 'データがあれば

ReDim cmb_item(adoRs.RecordCount - 1, 1) As String 'レコード数で配列を再定義

i = 0

Do Until adoRs.EOF 'レコードセットが終了するまで処理を繰り返す

cmb_item(i, 0) = adoRs!取引先 'i番目の配列の1列目

cmb_item(i, 1) = adoRs!取引先コード 'i番目の配列の2列目

i = i + 1

adoRs.MoveNext '次のレコードに移動する

Loop

.ComboBox2.List = cmb_item 'コンボボックス2へ配列を入れる

End If

Call DBcut_off(True) 'DB切断

'社員情報をComboBox3へ

Call DBconnect(True) 'DB接続

strSQL = "SELECT 社員コード, 社員名 FROM 社員マスター;"

adoRs.Open strSQL, adoCn, 1 'SQLを実行して対象をRecordSetへ（CursorType定数1=adOpenKeyset）

If Not (adoRs.BOF = True Or adoRs.EOF = True) Then 'データがあれば

ReDim cmb_item(adoRs.RecordCount - 1, 1) As String 'レコード数で配列を再定義

i = 0

Do Until adoRs.EOF 'レコードセットが終了するまで処理を繰り返す

cmb_item(i, 0) = adoRs!社員名 'i番目の配列の1列目

cmb_item(i, 1) = adoRs!社員コード 'i番目の配列の2列目

i = i + 1

adoRs.MoveNext '次のレコードに移動する

Loop

.ComboBox3.List = cmb_item 'コンボボックス3へ配列を入れる

End If

Call DBcut_off(True) 'DB切断

End With

End Sub

Private Sub FillForm(n As Long) '販売管理フォームを埋める

With ManagementForm

.TextBox1 = Cells(n, 1) '販売コード

.ComboBox1 = Cells(n, 2) '商品コード

.TextBox3 = Cells(n, 4) '売上日

.TextBox4 = Cells(n, 5) '数量

.TextBox5 = Cells(n, 6) '売価

.ComboBox2 = Cells(n, 10) '取引先

.ComboBox3 = Cells(n, 12) '社員名

End With

End Sub

Private Sub UserForm_Click()

End Sub

★

Sub SelectionReplaceTest()

Dim rSelection As Range '// 選択セル範囲

Dim r As Range '// １セル

Dim sFind '// 検索文字列

Dim sFind2 '// 検索文字列

Dim sReplace '// 置換文字列

Dim f '// Formula値

Dim v '// Value値

sFind = "(1)"

sFind2 = "(2)"

sReplace = ""

Set rSelection = Range("B2:B10000") 'Selection

'// 選択セル範囲を１セルずつループ

For Each r In rSelection

f = r.Formula

v = r.Value

'// セルが数式の場合

If (Left(f, 1) = "=") And (f <> v) Then

'// 数式を置換

r.Formula = Replace(f, sFind, sReplace)

'// セルが数式でない場合

Else

'// Value値を置換

r.Value = Replace(v, sFind, sReplace)

' r.Value = Replace(v, sFind2, sReplace)

End If

Next

End Sub

★

Sub 配列の行列入れ替え()

Dim arr_1 As Variant

Dim arr_2 As Variant

Dim r1 As Long, r2 As Long

Dim c1 As Long, c2 As Long

Dim myR As Long

Dim sheetName As String

r1 = 2 '貼り付け行開始

r2 = 301 '貼り付け行終了

sheetName = ActiveSheet.Name

Range("A:H").ClearContents 'データを削除

Range("A1").Value = "lot"

Range("B1").Value = "1m"

Range("C1").Value = "1c"

Range("D1").Value = "1g"

Range("E1").Value = "2m"

Range("F1").Value = "2c"

Range("G1").Value = "2g"

arr_1 = Sheets("元1").Range("C3:KP3").Value

Sheets(sheetName).Range("A" & r1, "A" & r2) = WorksheetFunction.Transpose(arr_1)

arr_1 = Sheets("元1").Range("C4:KP4").Value

Sheets(sheetName).Range("B" & r1, "B" & r2) = WorksheetFunction.Transpose(arr_1)

arr_1 = Sheets("元1").Range("C5:KP5").Value

Sheets(sheetName).Range("C" & r1, "C" & r2) = WorksheetFunction.Transpose(arr_1)

arr_1 = Sheets("元1").Range("C6:KP6").Value

Sheets(sheetName).Range("D" & r1, "D" & r2) = WorksheetFunction.Transpose(arr_1)

arr_1 = Sheets("元2").Range("C4:KP4").Value

Sheets(sheetName).Range("E" & r1, "E" & r2) = WorksheetFunction.Transpose(arr_1)

arr_1 = Sheets("元2").Range("C5:KP5").Value

Sheets(sheetName).Range("F" & r1, "F" & r2) = WorksheetFunction.Transpose(arr_1)

arr_1 = Sheets("元2").Range("C6:KP6").Value

Sheets(sheetName).Range("G" & r1, "G" & r2) = WorksheetFunction.Transpose(arr_1)

arr_2 = Array("東京都", "北海道", "愛知県")

' Range("B1").Value = arr_2(0)

Range("B2:D2").Value = arr_2

End Sub

★

Option Explicit

Private Sub CheckBox1_Click()

Dim rc As String

If CheckBox1.Value = True Then

rc = Me.Controls("CheckBox1").Caption

MsgBox rc & "チェックが付けられました！"

Unload MainForm

Else

MsgBox "チェックが外されました！"

End If

End Sub

Private Sub CheckBox2_Click()

Dim rc As String

If CheckBox1.Value = True Then

rc = Me.Controls("CheckBox2").Caption

MsgBox rc & "チェックが付けられました！"

Unload MainForm

Else

MsgBox "チェックが外されました！"

End If

End Sub

Private Sub CommandButton1_Click()

Call putCalenderDate(Me.TextBox1)

End Sub

Private Sub CommandButton2_Click()

Call putCalenderDate(Me.TextBox2)

End Sub

Private Sub CommandButton3_Click()

Dim OptionAry As Variant

Dim flg As Boolean

Dim i As Integer

'複数のオプションボタンを配列として格納

OptionAry = Array(OptionButton1, OptionButton2, OptionButton3)

'選択フラグの初期化

flg = False

'オプションボタンのチェック

For i = 0 To UBound(OptionAry)

If OptionAry(i).Value Then

'フラグに True を設定して、チェック処理を抜ける。

flg = True

Exit For

End If

Next

'チェック結果の表示

If flg Then

MsgBox "『" & OptionAry(i).Caption & "』が選択されました。"

If i = 0 Then MsgBox "0"

Unload MainForm

If i = 1 Then MsgBox "1"

Unload MainForm

If i = 2 Then MsgBox "2"

Unload MainForm

Else

MsgBox "項目が選択されていません。", vbExclamation

End If

'チェックボックステスト

' Dim c, buf As String

' Dim i As Long

' i = 0

' For Each c In Controls

' If Left(c.Name, 8) = "CheckBox" Then

' If c.Value Then buf = buf & c.Caption & vbCrLf

'

' End If

' Next c

' MsgBox buf & "が" & i & "個オンです"

MsgBox txtbx1

'期間フィルターテスト

' ActiveSheet.Range("A3").AutoFilter field:=1, Criteria1:=">=" & TextBox1.Value, Operator:=xlAnd, Criteria2:="<=" & TextBox2.Value

' Range("A3").CurrentRegion.Copy Sheets("転記").Range("A3")

' Range("A3").AutoFilter

' Call 期間フィルター

End Sub

★

フルパス　="=HYPERLINK(""" & LEFT(CELL("filename",A1),FIND("[",CELL("filename",A1))-1) & MID(CELL("filename"),SEARCH("[",CELL("filename"))+1, SEARCH("]",CELL("filename"))-SEARCH("[",CELL("filename"))-1) & """)"

シート名　=RIGHT(CELL("filename",A1),LEN(CELL("filename",A1))-FIND("]",CELL("filename",A1)))

ファイル名　=MID(CELL("filename",A2),FIND("[",CELL("filename",A2))+1,FIND("]",CELL("filename",A2))-(FIND("[",CELL("filename",A2))+1))

★

Sub 横縦TEST()

Dim r As Long, c As Long, c2 As Long

Dim myR As Long

Range("P:S").ClearContents

'F:G列のデータを削除

Range("P1").Value = "lot"

Range("Q1").Value = "m"

Range("R1").Value = "c"

Range("S1").Value = "g"

'F1,G1に見出しを設定

' myR = 1

'見出し行が3行目（4行目からデータを配置）

r = 3

For c2 = 16 To 19

myR = 1

'見出し行

'2行目から最終行までループ

For c = 3 To 6

'行方向のループの中で、列方向に6列目（F列）までループ

' If Cells(r, c).Value <> "" Then

' 'r行,c列 のセルの値が "" でない時

myR = myR + 1 '書き出す行を一つ下に

Cells(myR, c2).Value = Cells(r, c).Value

' End If

Next c

r = r + 1

Next c2

End Sub

★

Option Explicit

Private Sub CommandButton1_Click()

Call putCalenderDate(Me.TextBox1)

End Sub

Private Sub CommandButton2_Click()

Call putCalenderDate(Me.TextBox2)

End Sub

Private Sub CommandButton3_Click()

ActiveSheet.Range("A3").AutoFilter field:=1, Criteria1:=">=" & TextBox1.Value, Operator:=xlAnd, Criteria2:="<=" & TextBox2.Value

Range("A3").CurrentRegion.Copy Sheets("転記").Range("A3")

Range("A3").AutoFilter

' Call 期間フィルター

End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Click()

End Sub

★カレンダーフォーム

https://ateitexe.com/excel-vba-calendar-control/

★

Sub マップから管理へ()

Dim c As Range

Dim cd As String

Dim objWbk As Workbook

Dim sh1 As Worksheet

Dim sh2 As Worksheet

Set Wbk = ThisWorkbook

Set sh1 = Worksheets("マップ")

Set sh2 = Worksheets("管理")

Set c = ActiveCell

cd = Application.InputBox(Prompt:="管理番号入力")

If cd = "False" Then Exit Sub

sh2.Select

'検索範囲のセル(Range)を指定する

Dim SearchArea As Range

Set SearchArea = Range(Cells(1, 1), Cells(100, 1)) '(=A1:A100)

'指定の検索範囲を検索する

Dim result As Range

Set result = SearchArea.Find(what:=cd, LookAt:=xlWhole)

'①検索範囲にcdが見つからなかった場合

If result Is Nothing Then

MsgBox cd & "は見つかりませんでした。登録してください。"

sh1.Select

End If

'②検索範囲にcdが見つかった場合

If result Is Nothing = False Then

MsgBox cd & "が見つかりました。場所の転記します。"

'その行の値を取得し隣に場所を選択した場所を表記　更新日時

result.Offset(0, 5).Value = c

result.Offset(0, 6).Value = Format(Now, "yyyy/mm/dd hh:mm")

End If

End Sub

http://www.orangemaker.sakura.ne.jp/product/Kokomite/

★Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Row < 2 Then Exit Sub '〇行未満だと終了

Cancel = True 'ダブルクリックしてセルが編集状態となっているのを解除するために使用

Dim targ As String 'Wクリックセル値

Dim kanri As String '管理番号値

If Target.Cells(1).Value = "" Then Exit Sub '結合セル用

' If Target.Value = "" Then Exit Sub '単セル用

targ = Target.Cells(1).Value

kanri = Application.InputBox(Prompt:="場所『" & targ & "』の管理番号を入力してください")

If kanri = "False" Then Exit Sub

Range("Z1") = Target.Value

Range("AA1") = kanri

End Sub

★エクセルマクロVBAで大量データを比較・照合してマッチングする方法

★Sub myFunc管理物をプロットする()

’フロアレイアウトの 作成と連動方法

Dim ws As Worksheet, bContinue As Boolean

Dim sLocation As String

Dim rRow As Range

Dim myRowNo As Long

bContinue = True

sLocation = ""

Set rRow = Nothing

myRowNo = ActiveCell.Row 'カレント行を保存する。

If ActiveSheet.Name = "管理" Then

Else

bContinue = False

End If

If bContinue Then

bContinue = False

For Each ws In Worksheets

If ws.Name = "マップ" Then

bContinue = True

Exit For

End If

Next ws

If bContinue = False Then

Debug.Print "E:「マップ」シートが見つからない。"

End If

End If

If bContinue Then 'ロケーション日本語名を取得する

Dim nRow As Long, nCol As Long

Set rRow = Cells.Find(what:="場所", _

LookIn:=xlValues, _

lookat:=xlWhole)

If rRow Is Nothing Then

bContinue = False

Debug.Print "E:「場所」列が見つからない。"

Else

sLocation = ""

sLocation = Cells(myRowNo, rRow.Column).Value

If sLocation = "" Then bContinue = False

End If

End If

If bContinue Then 'シートを切替える

On Error Resume Next

Worksheets("マップ").Activate

End If

If bContinue Then 'ロケーションを探す

Set rRow = Cells.Find(what:=sLocation, _

LookIn:=xlValues, _

lookat:=xlWhole)

If rRow Is Nothing Then

Debug.Print "E:「" & sLocation & "」セルが見つからない。"

Else

Range("B2", "CK501").Interior.Color = RGB(255, 255, 255)

rRow.Select 'カーソルを位置づける

rRow.Interior.Color = RGB(255, 0, 0)

End If

End If

End Sub

★

次のVBA①はセルとセルをWクリックで選択し直線を引くサンプルです。②のVBAは選択した直線を消去するサンプルです。

①セルWクリックで直線を引く。望みのWorkSheetのイベントにして下さい。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim MyRange As String

Dim L_Weight As Single, L_styl As String

Dim XB As Single, YB As Single, XE As Single, YE As Single

MyRange = "B2:BS42" '''作図範囲指定実情に合わせ変更する事'''

''MyRange指定域以外は作図しない。

If Intersect(Target, Range(MyRange)) Is Nothing Then Exit Sub

Static cellB As Range '開始cell

Cancel = True

If cellB Is Nothing Then

Set cellB = Target

Else

If Target.Address = cellB.Address Then

Set cellB = Nothing

Exit Sub

End If

With cellB

XB = .Left

YB = .Top + .Height / 2

End With

With Target

XE = .Left

YE = .Top + .Height / 2

End With

ActiveSheet.Shapes.AddLine(XB, YB, XE, YE).Select

Selection.OnAction = "shape消去"

With Selection.ShapeRange.Line

.Weight = 0.75

.DashStyle = msoLineSolid

' .BeginArrowheadStyle = msoArrowheadTriangle '始まり矢印

' .EndArrowheadStyle = msoArrowheadTriangle '終わり矢印

End With

Range(cellB.Address).Select

Set cellB = Nothing

End If

End Sub

②直線消去。標準モジュールに作成します。これは上のコード中に

Selection.OnAction = "shape消去" で呼び出しています。

Sub shape消去()

'------------------------------------------------------

'直線をクリックすることで消去させるコード

Dim x As Variant

x = Application.Caller

If VarType(x) <> 8 Then Exit Sub

ActiveSheet.Shapes(x).Delete

End Sub

背景壁紙の場所

C:\Windows\Web\Wallpaper

ロック画面のありか(隠しフォルダ)

%LOCALAPPDATA%\Packages\Microsoft.Windows.ContentDeliveryManager_cw5n1h2txyewy\LocalState\Assets

Xperia壁紙

http://butsu-yoku.net/wp-content/themes/butsuyoku-style/bigfile/xperia_Z_wpp_01.jpg

Sub 引き当て参照()

Sub 選択列の書き換え()

Option Explicit

Sub 保存()

Dim xSheet As Worksheet

Dim myFile As String

Dim myName As String

Set xSheet = ActiveSheet

ThisWorkbook.Worksheets(3).Copy

'myName = ActiveWorkbook.Worksheets(1).Name

'myFile = ThisWorkbook.Path & "\" & myName & ".xls"

myFile = ThisWorkbook.Path & "\" & xSheet.Range("A1").Value & ".xls"

'A1セルに　=TODAY()

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:=myFile

Application.DisplayAlerts = True

ActiveWorkbook.Close

End Sub

Sub 特定シートだけ別のフォルダに保存()

'シートの複製（複製すると新しいブックが立ち上がります）

Sheets("Sheet1").Copy '名前を付け、ファイル形式も決めて特定の場所に保存する。

ActiveWorkbook.SaveAs _

Filename:="C:\Users\user\Documents\保存ファイル", _

FileFormat:=xlOpenXMLWorkbook

End Sub

Sub 配列使用し検索貼付()

Dim start As Date: start = Time '★処理時間計測開始

Dim rw As Long 'Variant

'=MATCH(検査値,検査範囲,照合の種類)

Dim rng As Range

Dim sheet1 As Worksheet

Dim sheet2 As Worksheet

Dim a As Variant

Dim b As Variant

Dim i As Long

Dim r As Long

Dim ar1 As Variant

Dim ar2 As Variant

Dim LASTROW As Long

Set sheet1 = Sheets("全機") '元シートデータ

Set sheet2 = Sheets("抽出") '転記先シート

Application.ScreenUpdating = False '★描写停止

Application.EnableEvents = False '★イベント停止

'Application.Calculation = xlCalculationManual '★自動計算手動

' 最終行の取得

LASTROW = Cells(Rows.Count, 1).End(xlUp).Row

MsgBox LASTROW & " 行目が最終行です。"

i = 2 '見出し行を除く

sheet1.Select '元シートデータ

'仕様書番号

ar1 = WorksheetFunction.Transpose(sheet1.Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp)).Value)

'機械名

ar2 = WorksheetFunction.Transpose(sheet1.Range(Range("B1"), Cells(Rows.Count, 2).End(xlUp)).Value)

For i = LBound(ar1) To UBound(ar1)

ar1(i) = ar1(i) & "," & ar2(i)

Next i

For r = 2 To LASTROW '見出し行を除く～最終行まで

sheet2.Select '転記先シート

a = sheet2.Range("C" & r).Value '仕様書番号

b = sheet2.Range("A" & r).Value '機械名

rw = WorksheetFunction.Match(a & "," & b, ar1, 0) '関数 MATCH(検査値,検査範囲,照合の種類)

' MsgBox rw

If IsNumeric(rw) Then

' MsgBox rw & "番めのデータです"

Set rng = sheet1.Range("A" & rw)

sheet2.Range("E" & r).Resize(1, 5).Value = rng.Resize(1, 5).Value

' Worksheets("抽出").Range("E" & r, "G" & r) = Worksheets("全機").Range("A" & rw, "D" & rw)

Else

MsgBox "該当データが見つかりません", vbExclamation

End If

Next r

'Application.Calculation = xlCalculationAutomatic '★自動計算再開

Application.ScreenUpdating = True '★イベント再開

Application.EnableEvents = True '★描写再開

Dim finish As Date: finish = Time '★処理時間計測終了

MsgBox "処理時間 " & Format(finish - start, "nn分ss秒") & " 。", vbInformation + vbOKOnly '★処理時間表示

End Sub

'// オートフィルタ解除関数

Sub AutoFilterOff()

'// オートフィルタが解除されている場合

If (ActiveSheet.AutoFilterMode = False) Then

Exit Sub

End If

ActiveSheet.Range("A1").AutoFilter

End Sub

Sub 複数列複数文字列AF()

Dim ListArray1(2) As String

Dim ListArray2(2) As String

Dim MaxRow As Long

ListArray1(0) = "田中"

ListArray1(1) = "店舗C"

ListArray1(2) = "店舗D"

ListArray2(0) = "メーカーA"

ListArray2(1) = "メーカーB"

ListArray2(2) = "メーカーC"

MaxRow = Cells(Rows.Count, 1).End(xlUp).Row

With Range(Cells(1, 1), Cells(MaxRow, 4))

.AutoFilter Field:=1, _

Criteria1:=ListArray1, _

Operator:=xlFilterValues

.AutoFilter Field:=3, _

Criteria1:=ListArray2, _

Operator:=xlFilterValues

End With

Call SetPartColorTest

Call AutoFilterOff

End Sub

フォルダ内の各ブック指定の場所からのデータ取得

Sub フォルダ内データ取得2()

Dim r As Long

Dim strDir As String

Dim strFile As String

Dim xls As New Excel.Application

Dim wb As Workbook

Dim ws As Worksheet

Dim StartTime, StopTime As Variant

'〇行から下のdelete

Rows("5:5").Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Delete Shift:=xlUp

MsgBox "※処理時間　300ファイルでおよそ1分"

StartTime = Time 'ここから実行時間のカウントを開始

' Debug.Print Timer 'ｲﾐﾃﾞｨｴｲﾄ画面へ時間を表示

Application.ScreenUpdating = False '描写を止める

strDir = ThisWorkbook.path & "\" 'このブックがある対象フォルダアドレス

strFile = Dir(strDir) '対象フォルダ内のファイルを変数へ

r = 5

Do While strFile <> "" '条件式を満たすまで繰り返す処理

Set wb = xls.Workbooks.Open(strDir & strFile)

Set ws = wb.Worksheets("Sheet1") '対象シート名

'ハイパーリンク設定

ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), Address:=strFile

'取得データ貼り付け

Range(Cells(r, 2), Cells(r, 11)).Value = ws.Range(ws.Cells(1, 1), ws.Cells(1, 10)).Value

wb.Close Savechanges:=False

strFile = Dir()

r = r + 1 '行+1行

Loop

Set xls = Nothing

Application.ScreenUpdating = True '描写を開始

' Debug.Print Timer 'ｲﾐﾃﾞｨｴｲﾄ画面へ時間を表示

StopTime = Time 'ここで実行時間のカウントを終了

StopTime = StopTime - StartTime

MsgBox "処理時間" & Minute(StopTime) & "分" & _

Second(StopTime) & "秒 "

End Sub

スクショをトリミングして貼り付け

Option Explicit

' キャプチャ収集状態なら True

Private isLogging As Boolean

' キャプチャを貼り付けるブック名を保持する

Private fileName As String

' キャプチャを取得する

Private Sub Capture()

On Error GoTo errorHandler

' クリップボードに画像が格納されていたら貼り付ける

If Application.ClipboardFormats(1) = xlClipboardFormatBitmap Then

Dim rows As Integer: rows = 27 ' 行数(元54)

Dim cols As Integer: cols = 36 ' 列数(元72)

' キャプチャを貼り付けるブックを選択する

Workbooks(fileName).Activate

' 選択しているセルを基準セルとして取得する

Dim baseCell As Variant

Set baseCell = Selection

' 下線を引く

Range(baseCell.Offset(rows, 1), baseCell.Offset(rows, cols + 1)).Select

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

End With

' 見出し用の記号をセットする

baseCell.Offset(1, 1).Value = "■"

' キャプチャ取得日時をセットする

With baseCell.Offset(1, cols - 5)

.HorizontalAlignment = xlRight

.Value = "取得日時：" & Now

End With

' クリップボードのデータを貼り付け、行数に合わせて縮小する

baseCell.Offset(2, 2).Select

ActiveSheet.Paste

With Selection.ShapeRange

.PictureFormat.CropTop = 100 '上の切り取り

.PictureFormat.CropBottom = 368 '下の切り取り

.PictureFormat.CropRight = 600 '右の切り取り

.PictureFormat.CropLeft = 20 '左の切り取り

.LockAspectRatio = msoTrue

.Height = .Height * 0.7

End With

' 次の画像を貼るために基準セルを移動し、クリップボードに現在のセルの値をコピーする (先頭を Bitmap でなくすため)

With baseCell.Offset(rows + 1, 0)

.Select

.Copy

End With

' 切り取り・コピーモードを解除する

Application.CutCopyMode = False

' 改ページ設定をする

ActiveSheet.HPageBreaks.Add Before:=ActiveCell

End If

' 1秒間隔で再実行するようタイマーをセットする

Application.OnTime Now + TimeValue("00:00:01"), "Capture", , isLogging

Exit Sub

errorHandler:

isLogging = False

End Sub

' キャプチャを開始する

Sub StartCapture()

MsgBox "キャプチャの取得を開始します。終了時は Esc キーを押下してください。"

Range("A1").Select

' Esc キーで停止できるようにしておく

Application.OnKey "{ESC}", "StopCapture"

' キャプチャを貼り付けるブック名を取得する

fileName = ActiveWorkbook.Name

' キャプチャ取得状態を設定する

isLogging = True

' キャプチャの取得を開始する

Capture

End Sub

' キャプチャを終了する

Sub StopCapture()

If isLogging = True Then

' キャプチャの取得状態を解除する

isLogging = False

' Esc キーへの登録を解除する

Application.OnKey "{ESC}", ""

MsgBox "キャプチャの取得を停止しました。"

End If

End Sub