VBA – ページ 7 – テックメモ

2016-11-102020-05-10

VBA SQL実験用①(Access(mdb))

SQLの挙動を調べるのにエクセルから手軽にSQLを発行

Sub test()

Application.CommandBars("cell").Reset

End Sub

Sub auto_open()

With Application.CommandBars("cell").Controls.Add
.OnAction = "t"
.Caption = "テーブル作成・登録"
End With

With Application.CommandBars("cell").Controls.Add
.OnAction = "tt"
.Caption = "SQL実行"
End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2
  Application.CommandBars("cell").Controls("テーブル作成・登録").Delete
  Application.CommandBars("cell").Controls("SQL実行").Delete
Next i

End Sub

Sub t()

With ActiveSheet

tbl = InputBox("テーブル名")

Set cn = CreateObject("adodb.connection")
cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\SQL実験.mdb"

'テーブル削除

On Error Resume Next
cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0
fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

  Select Case Right(.Cells(Selection(1).Row, c).Value, 1)
    Case "s"
    tmp = "varchar" 'charは短いテキスト(varcharは可変長), textは長いテキスト
    Case "i"
    tmp = "integer"
  End Select
  
  fld = fld & .Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

fld = Left(fld, Len(fld) - 1)
q = "create table " & tbl & " (id integer identity(1,1) primary key," & fld & ")": Debug.Print q
cn.Execute q

'データ登録

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

  fld = fld & .Cells(Selection(1).Row, c).Value & ","

Next c

fld = Left(fld, Len(fld) - 1)

For r = (Selection(1).Row) + 1 To Selection(Selection.Count).Row

  For cc = Selection(1).Column To Selection(Selection.Count).Column
  
    rec = rec & "'" & .Cells(r, cc).Value & "'" & ","
  
  Next cc

  rec = Left(rec, Len(rec) - 1)
  
  q = "insert into " & tbl & " (" & fld & ") values (" & rec & ")": Debug.Print q
  cn.Execute q

  rec = ""
  
Next r

cn.Close
Set cn = Nothing

MsgBox "done"

End With

End Sub

Sub tt()

With ActiveSheet

Set cn = CreateObject("adodb.connection")
Set rn = CreateObject("adodb.recordset")

cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\SQL実験.mdb"
rn.Open ActiveCell.Value, cn

'フィールド作成

i = 0
For c = Selection(1).Column To (Selection(1).Column + rn.Fields.Count) - 1
  ActiveCell.Offset(1, i).Value = rn.Fields(i).Name
  i = i + 1
Next c

'データ読込

ActiveCell.Offset(2, 0).CopyFromRecordset rn

rn.Close
Set rn = Nothing

cn.Close
Set cn = Nothing

End With

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

Sub test()

Application.CommandBars("cell").Reset

End Sub

Sub auto_open()

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

.OnAction = "t"

.Caption = "テーブル作成・登録"

End With

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

.OnAction = "tt"

.Caption = "SQL実行"

End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2

Application.CommandBars("cell").Controls("テーブル作成・登録").Delete

Application.CommandBars("cell").Controls("SQL実行").Delete

Next i

End Sub

Sub t()

With ActiveSheet

tbl = InputBox("テーブル名")

Set cn = CreateObject("adodb.connection")

cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\SQL実験.mdb"

'テーブル削除

On Error Resume Next

cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

Select Case Right(.Cells(Selection(1).Row, c).Value, 1)

Case "s"

tmp = "varchar" 'charは短いテキスト(varcharは可変長), textは長いテキスト

Case "i"

tmp = "integer"

End Select

fld = fld & .Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

fld = Left(fld, Len(fld) - 1)

q = "create table " & tbl & " (id integer identity(1,1) primary key," & fld & ")": Debug.Print q

cn.Execute q

'データ登録

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

fld = fld & .Cells(Selection(1).Row, c).Value & ","

Next c

fld = Left(fld, Len(fld) - 1)

For r = (Selection(1).Row) + 1 To Selection(Selection.Count).Row

For cc = Selection(1).Column To Selection(Selection.Count).Column

rec = rec & "'" & .Cells(r, cc).Value & "'" & ","

Next cc

rec = Left(rec, Len(rec) - 1)

q = "insert into " & tbl & " (" & fld & ") values (" & rec & ")": Debug.Print q

cn.Execute q

rec = ""

Next r

cn.Close

Set cn = Nothing

MsgBox "done"

End With

End Sub

Sub tt()

With ActiveSheet

Set cn = CreateObject("adodb.connection")

Set rn = CreateObject("adodb.recordset")

cn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\SQL実験.mdb"

rn.Open ActiveCell.Value, cn

'フィールド作成

i = 0

For c = Selection(1).Column To (Selection(1).Column + rn.Fields.Count) - 1

ActiveCell.Offset(1, i).Value = rn.Fields(i).Name

i = i + 1

Next c

'データ読込

ActiveCell.Offset(2, 0).CopyFromRecordset rn

rn.Close

Set rn = Nothing

cn.Close

Set cn = Nothing

End With

End Sub

2016-09-292016-12-23

VBA Seleniumの操作

SeleniumWrapper Type Libraryの参照設定を追加する。

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	driver.Start "ie", "https://www.google.co.jp/"

	'driver.setImplicitWait (500)

	driver.get ("/")
	driver.findElementById("lst-ib").SendKeys "Selenium"
	driver.findElementByName("btnG").Click

	driver.findElementByLinkText("Selenium WebDriverでWebアプリのテストが変わる - IT", 5000).Click

	'driver.stop
	MsgBox ""
  
End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver

	Call driver.Start("ie", "https://www.google.co.jp/")
	Call driver.get("/cgi-bin/idxsearch.cgi")

	Call driver.findElementByName("Y_TYPE").AsSelect.selectByIndex(1) '0はじまり
	'Call driver.findElementByName("Y_TYPE").AsSelect.selectBytext("いずれかの用語を含む")

End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver

	Call driver.Start("ie", "https://www.google.co.jp/")
	Call driver.get("/cgi-bin/idxsearch.cgi")

	Call driver.findElementsByName("H_YOMI_GUN").Item(3).Click
    
End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	Call driver.Start("ie", "https://www.google.co.jp/")
	Call driver.get("search/servlet/Procedure?CLASSNAME=GTAEGOVMSTSEARCH")

	Dim collection As WebElementCollection

	Set collection = driver.findElementsByName("HushoSeqNo")

	collection.Item(0).Click
	collection.Item(1).Click
	collection.Item(2).Click
	collection.Item(3).Click

End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	Call driver.Start("ie", "https://www.google.co.jp/")
	Call driver.get("/")

	driver.findElementByCssSelector("#one-content > a:nth-child(1) > img:nth-child(1)").Click

End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	Call driver.Start("ie", "http://www.google.com/")
	Call driver.get("/")

	MsgBox driver.URL

End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	driver.Start "ie", "http://www.google.com/"
	driver.get "/"
	driver.findElementByName("q").SendKeys ("さばの味噌煮")
	driver.findElementByName("btnG").Click

	Call driver.waitForTextPresent("に関連する検索キーワード")
	'Call driver.toClipBoard(driver.findElementByTagName("body").Text)

End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	Call driver.Start("ie", "http://www.google.com/")
	Call driver.get("/")

	driver.windowMaximize

End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	driver.Start "ie", "http://www.google.com/"
	driver.get "/"
	driver.findElementByName("q").SendKeys ("xxx")
	driver.findElementByName("btnG").Click

	driver.waitForTextPresent ("に関連する検索キーワード")
	driver.getScreenshot().Copy
	driver.getScreenshot().SaveAs ("SABA_NO_MISO_NI.bmp")

End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	driver.Start "ie", "http://homepage3.nifty.com/abe-hiroshi/"
	driver.setImplicitWait 1000000
	driver.get "/"

	Dim frameUrl: frameUrl = driver.findElementsByTagName("frame").Item(1).getAttribute("src")
	driver.get frameUrl

End Sub

Sub test()

	Dim driver As New SeleniumWrapper.WebDriver
	'driver.startRemotely "ie", "http://192.168.0.26:4444/wd/hub" "http://news.yahoo.com"
	'別途インストールが必要

End Sub

Sub test()

	Dim driver As New WebDriver
	Call driver.Start("ie", "http://www.red.oit-net.jp/")
	Call driver.get("/tatsuya/java/winopen.htm")

	Dim beforeHwd As String
	'既存のハンドルを保存
	beforeHwd = driver.WindowHandle 'Returns the handle of the current window.

	driver.findElementByCssSelector("table.waku:nth-child(13) > tbody:nth-child(1) > tr:nth-child(1) > td:nth-child(1) > form:nth-child(3) > input:nth-child(1)").Click

	'新しいウィンドウを開く

	'既存のウィンドウとは違うウィンドウを探す
	Dim Hwds
	Hwds = driver.WindowHandles ' Returns the handles of all windows within the current session.
	Dim window: For Each window In Hwds
	If window <> beforeHwd Then
	    driver.switchToWindow window 'ここで新しいウィンドウに切り替える
	    driver.get "/" '新しいウィンドウに対する操作
	    driver.Close '新しいウィンドウに対する操作
	End If
	Next

	'もとのウィドウに戻している。
	Set driver = driver.switchToWindow(beforeHwd) 'Switches focus to the specified window.
	driver.get "/tatsuya"
    
End Sub

Sub test()

	Dim selenium As New SeleniumWrapper.WebDriver
	selenium.Start "ie", "http://www.google.com/"
	selenium.Open "/"
	selenium.Type "name=q", "seleniumVBA"
	selenium.Click "name=btnG"
	selenium.Wait 1000
	selenium.getScreenshot().Copy
	selenium.stop
	Sheets(1).Range("A10").PasteSpecial
   
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

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

driver.Start "ie", "https://www.google.co.jp/"

'driver.setImplicitWait (500)

driver.get ("/")

driver.findElementById("lst-ib").SendKeys "Selenium"

driver.findElementByName("btnG").Click

driver.findElementByLinkText("Selenium WebDriverでWebアプリのテストが変わる - IT", 5000).Click

'driver.stop

MsgBox ""

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

Call driver.Start("ie", "https://www.google.co.jp/")

Call driver.get("/cgi-bin/idxsearch.cgi")

Call driver.findElementByName("Y_TYPE").AsSelect.selectByIndex(1) '0はじまり

'Call driver.findElementByName("Y_TYPE").AsSelect.selectBytext("いずれかの用語を含む")

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

Call driver.Start("ie", "https://www.google.co.jp/")

Call driver.get("/cgi-bin/idxsearch.cgi")

Call driver.findElementsByName("H_YOMI_GUN").Item(3).Click

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

Call driver.Start("ie", "https://www.google.co.jp/")

Call driver.get("search/servlet/Procedure?CLASSNAME=GTAEGOVMSTSEARCH")

Dim collection As WebElementCollection

Set collection = driver.findElementsByName("HushoSeqNo")

collection.Item(0).Click

collection.Item(1).Click

collection.Item(2).Click

collection.Item(3).Click

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

Call driver.Start("ie", "https://www.google.co.jp/")

Call driver.get("/")

driver.findElementByCssSelector("#one-content > a:nth-child(1) > img:nth-child(1)").Click

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

Call driver.Start("ie", "http://www.google.com/")

Call driver.get("/")

MsgBox driver.URL

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

driver.Start "ie", "http://www.google.com/"

driver.get "/"

driver.findElementByName("q").SendKeys ("さばの味噌煮")

driver.findElementByName("btnG").Click

Call driver.waitForTextPresent("に関連する検索キーワード")

'Call driver.toClipBoard(driver.findElementByTagName("body").Text)

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

Call driver.Start("ie", "http://www.google.com/")

Call driver.get("/")

driver.windowMaximize

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

driver.Start "ie", "http://www.google.com/"

driver.get "/"

driver.findElementByName("q").SendKeys ("xxx")

driver.findElementByName("btnG").Click

driver.waitForTextPresent ("に関連する検索キーワード")

driver.getScreenshot().Copy

driver.getScreenshot().SaveAs ("SABA_NO_MISO_NI.bmp")

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

driver.Start "ie", "http://homepage3.nifty.com/abe-hiroshi/"

driver.setImplicitWait 1000000

driver.get "/"

Dim frameUrl: frameUrl = driver.findElementsByTagName("frame").Item(1).getAttribute("src")

driver.get frameUrl

End Sub

Sub test()

Dim driver As New SeleniumWrapper.WebDriver

'driver.startRemotely "ie", "http://192.168.0.26:4444/wd/hub" "http://news.yahoo.com"

'別途インストールが必要

End Sub

Sub test()

Dim driver As New WebDriver

Call driver.Start("ie", "http://www.red.oit-net.jp/")

Call driver.get("/tatsuya/java/winopen.htm")

Dim beforeHwd As String

'既存のハンドルを保存

beforeHwd = driver.WindowHandle 'Returns the handle of the current window.

driver.findElementByCssSelector("table.waku:nth-child(13) > tbody:nth-child(1) > tr:nth-child(1) > td:nth-child(1) > form:nth-child(3) > input:nth-child(1)").Click

'新しいウィンドウを開く

'既存のウィンドウとは違うウィンドウを探す

Dim Hwds

Hwds = driver.WindowHandles ' Returns the handles of all windows within the current session.

Dim window: For Each window In Hwds

If window <> beforeHwd Then

driver.switchToWindow window 'ここで新しいウィンドウに切り替える

driver.get "/" '新しいウィンドウに対する操作

driver.Close '新しいウィンドウに対する操作

End If

'もとのウィドウに戻している。

Set driver = driver.switchToWindow(beforeHwd) 'Switches focus to the specified window.

driver.get "/tatsuya"

End Sub

Sub test()

Dim selenium As New SeleniumWrapper.WebDriver

selenium.Start "ie", "http://www.google.com/"

selenium.Open "/"

selenium.Type "name=q", "seleniumVBA"

selenium.Click "name=btnG"

selenium.Wait 1000

selenium.getScreenshot().Copy

selenium.stop

Sheets(1).Range("A10").PasteSpecial

End Sub

2016-09-292016-09-29

VBA 複数のシートを結合

複数のシートを結合後に、特定の列が空白、0、数値以外の行を削除する。

Sub Cp()
For Each w In Sheets
    If w.Name = "集計" Then Sheets("集計").Delete
Next w
Sheets.Add Before:=Sheets(1)
ActiveSheet.Name = "集計"
For Each w In Worksheets
    If w.Name <> "集計" Then
        If Sheets("集計").UsedRange.Rows.Count = 1 Then
            r = 1
        Else
            r = Sheets("集計").UsedRange.Rows.Count + 1
        End If
        w.UsedRange.Copy
        Sheets("集計").Cells(r, 1).PasteSpecial Paste:=xlPasteValues
        Sheets("集計").Cells(r, 1).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        w.UsedRange.ClearContents
    End If
Next w
c = 19 '判断列
k = 2
For i = 1 To Sheets("集計").UsedRange.Rows.Count
    Application.StatusBar = "削除中 ... " & i
    If Sheets("集計").Cells(k, c).Value = "" Or Sheets("集計").Cells(k, c).Value = 0 Or IsNumeric(Sheets("集計").Cells(k, c).Value) = False Then
        Sheets("集計").Rows(k).Delete
    Else
        k = k + 1
    End If
Next i
For Each w In Sheets
    If w.Name <> "集計" Then w.Delete
Next w
Application.StatusBar = False
MsgBox "done"
End Sub

Sub Cp()

For Each w In Sheets

If w.Name = "集計" Then Sheets("集計").Delete

Next w

Sheets.Add Before:=Sheets(1)

ActiveSheet.Name = "集計"

For Each w In Worksheets

If w.Name <> "集計" Then

If Sheets("集計").UsedRange.Rows.Count = 1 Then

r = 1

Else

r = Sheets("集計").UsedRange.Rows.Count + 1

End If

w.UsedRange.Copy

Sheets("集計").Cells(r, 1).PasteSpecial Paste:=xlPasteValues

Sheets("集計").Cells(r, 1).PasteSpecial Paste:=xlPasteFormats

Application.CutCopyMode = False

w.UsedRange.ClearContents

End If

Next w

c = 19 '判断列

k = 2

For i = 1 To Sheets("集計").UsedRange.Rows.Count

Application.StatusBar = "削除中 ... " & i

If Sheets("集計").Cells(k, c).Value = "" Or Sheets("集計").Cells(k, c).Value = 0 Or IsNumeric(Sheets("集計").Cells(k, c).Value) = False Then

Sheets("集計").Rows(k).Delete

Else

k = k + 1

End If

Next i

For Each w In Sheets

If w.Name <> "集計" Then w.Delete

Next w

Application.StatusBar = False

MsgBox "done"

End Sub

2016-09-282017-01-15

VBAでPOSTしてPHPでJANを発行してMySQLに登録する

以前、Web、バーコードを使って何か作ろうとしたことがあった。

<?php

/*
create database vba_post;
use vba_post
create table post_tb(id int not null primary key auto_increment, value varchar(255));
*/

Application::main();

class Application{
	
	static function con(){
		return new PDO("mysql:dbname=vba_post;host=localhost;charset=utf8","root","123");
	}
	
	static function h($s){
		return htmlspecialchars ($s,ENT_QUOTES);
	}
	
	static function jan($s){
		
		$buf = "20" . str_pad($s, 10, "0", STR_PAD_LEFT);
		$o = $buf[0] + $buf[2] + $buf[4] + $buf[6] + $buf[8] + $buf[10];
		$e = $buf[1] + $buf[3] + $buf[5] + $buf[7] + $buf[9] + $buf[11];
		$e *= 3;
		$digi = 10 - substr(($e + $o),-1);
		if($digi == 10){ $digi = 0; }
		
		return $buf . $digi;
	}
	
	static function main(){
		
		if(array_key_exists("update",$_POST) && $_POST["update"] === "save"){
			
			$d = self::con();
			$d->setAttribute(PDO::ATTR_ERRMODE, PDO::ERRMODE_EXCEPTION);
			
			try{
				
				$d->beginTransaction();

				$s = $d->query("show table status like 'post_tb'"); 
				$id = $s->fetch();

				$p = $d->prepare("insert into post_tb (value) values (:v)");
				$p->execute(array(
					":v" => self::h($_POST['value'])
				));

				$d->commit();
				echo self::jan($id['Auto_increment']);
				
			}catch(PDOException $e){
				
				$d->rollback();
				echo "false";
				
			}	
			
		}
		
	}
	
}

<?php

create database vba_post;

use vba_post

create table post_tb(id int not null primary key auto_increment, value varchar(255));

Application::main();

class Application{

static function con(){

return new PDO("mysql:dbname=vba_post;host=localhost;charset=utf8","root","123");

}

static function h($s){

return htmlspecialchars ($s,ENT_QUOTES);

}

static function jan($s){

$buf = "20" . str_pad($s, 10, "0", STR_PAD_LEFT);

$o = $buf[0] + $buf[2] + $buf[4] + $buf[6] + $buf[8] + $buf[10];

$e = $buf[1] + $buf[3] + $buf[5] + $buf[7] + $buf[9] + $buf[11];

$e *= 3;

$digi = 10 - substr(($e + $o),-1);

if($digi == 10){ $digi = 0; }

return $buf . $digi;

}

static function main(){

if(array_key_exists("update",$_POST) && $_POST["update"] === "save"){

$d = self::con();

$d->setAttribute(PDO::ATTR_ERRMODE, PDO::ERRMODE_EXCEPTION);

try{

$d->beginTransaction();

$s = $d->query("show table status like 'post_tb'");

$id = $s->fetch();

$p = $d->prepare("insert into post_tb (value) values (:v)");

$p->execute(array(

":v" => self::h($_POST['value'])

));

$d->commit();

echo self::jan($id['Auto_increment']);

}catch(PDOException $e){

$d->rollback();

echo "false";

}

VBAでPOSTする

Private Sub CommandButton1_Click()

Dim url As String
url = "http://192.168.1.4/request/index.php"

Dim xmlhttp As Object
Set xmlhttp = CreateObject("msxml2.xmlhttp")

Dim paramStr As String
Dim retCd As String

On Error GoTo e

For i = 2 To ActiveSheet.UsedRange.Rows.Count

    paramStr = "&update=save&value=" & Cells(i, 1).Value
    xmlhttp.Open "POST", url, False
    xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlhttp.send (paramStr)
    
    Cells(i, 2).Value = xmlhttp.Status
    Cells(i, 3).Value = xmlhttp.responseText

Next i

Set xmlhttp = Nothing
MsgBox "done!"

Exit Sub

e:

    Set xmlhttp = Nothing
    MsgBox i & "行目でエラーが発生しました。"

End Sub

Private Sub CommandButton1_Click()

Dim url As String

url = "http://192.168.1.4/request/index.php"

Dim xmlhttp As Object

Set xmlhttp = CreateObject("msxml2.xmlhttp")

Dim paramStr As String

Dim retCd As String

On Error GoTo e

For i = 2 To ActiveSheet.UsedRange.Rows.Count

paramStr = "&update=save&value=" & Cells(i, 1).Value

xmlhttp.Open "POST", url, False

xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

xmlhttp.send (paramStr)

Cells(i, 2).Value = xmlhttp.Status

Cells(i, 3).Value = xmlhttp.responseText

Next i

Set xmlhttp = Nothing

MsgBox "done!"

Exit Sub

Set xmlhttp = Nothing

MsgBox i & "行目でエラーが発生しました。"

End Sub

おまけ

Sub test()

Set xh = CreateObject("msxml2.xmlhttp")
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.AddCode "function jsonParse(s) { return eval('(' + s + ')'); }"

xh.Open "POST", "http://xxx.com/index.php", False
xh.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xh.send ("&save=do")

If xh.Status = 200 Then

    Set js = sc.CodeObject.jsonParse(xh.ResponseText)
    MsgBox js.Name
    
End If

End Sub

Sub test()

Set xh = CreateObject("msxml2.xmlhttp")

Set sc = CreateObject("ScriptControl")

sc.Language = "JScript"

sc.AddCode "function jsonParse(s) { return eval('(' + s + ')'); }"

xh.Open "POST", "http://xxx.com/index.php", False

xh.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

xh.send ("&save=do")

If xh.Status = 200 Then

Set js = sc.CodeObject.jsonParse(xh.ResponseText)

MsgBox js.Name

End If

End Sub

2016-09-272020-01-16

VBA フォルダ・ファイルのリンクの一覧

業務上のファイルをフォルダ管理している中小企業は多いと思います。業務別にフォルダを作っていたり、個人別にフォルダを作っていたり。

フォルダやファイルにエクセルからアクセスできると便利かと思い作成してみた。

Sub auto_open()
 
'参照設定　Microsoft Scripting Runtime

On Error Resume Next
 
Application.CommandBars("cell").Controls("作成").Delete
Application.CommandBars("cell").Controls("作成").Delete
 
With Application.CommandBars("cell").Controls.Add
  .Caption = "作成"
  .OnAction = "main"
End With
 
End Sub

Sub auto_close()
 
On Error Resume Next
 
Application.CommandBars("cell").Controls("作成").Delete
Application.CommandBars("cell").Controls("作成").Delete
 
End Sub

Sub main()
    
ActiveSheet.Cells.ClearContents
ActiveSheet.Cells.ColumnWidth = 5

Dim obj As FileSystemObject
Set obj = New FileSystemObject

Call func(obj.GetFolder(ActiveWorkbook.Path), 0, 0)

Set obj = Nothing
 
End Sub
 
Sub func(ByVal f As Folder, ByRef r As Long, ByVal c As Long)
 
r = r + 1
c = c + 1

ActiveSheet.Cells(r, c).Value = f.Name
ActiveSheet.Hyperlinks.Add anchor:=Cells(r, c), Address:=f.Path

Dim k As Folder

For Each k In f.SubFolders
  Call func(k, r, c)
Next k

c = c + 1

Dim i As File

For Each i In f.Files
    
  If 0 = InStr(i.Name, ActiveWorkbook.Name) Then
  
    r = r + 1
    
    ActiveSheet.Cells(r, c).Value = i.Name
    ActiveSheet.Hyperlinks.Add anchor:=Cells(r, c), Address:=i.Path

  End If

Next i

Set f = Nothing
    
End Sub

Sub auto_open()

'参照設定　Microsoft Scripting Runtime

On Error Resume Next

Application.CommandBars("cell").Controls("作成").Delete

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

.Caption = "作成"

.OnAction = "main"

End With

End Sub

Sub auto_close()

On Error Resume Next

Application.CommandBars("cell").Controls("作成").Delete

End Sub

Sub main()

ActiveSheet.Cells.ClearContents

ActiveSheet.Cells.ColumnWidth = 5

Dim obj As FileSystemObject

Set obj = New FileSystemObject

Call func(obj.GetFolder(ActiveWorkbook.Path), 0, 0)

Set obj = Nothing

End Sub

Sub func(ByVal f As Folder, ByRef r As Long, ByVal c As Long)

r = r + 1

c = c + 1

ActiveSheet.Cells(r, c).Value = f.Name

ActiveSheet.Hyperlinks.Add anchor:=Cells(r, c), Address:=f.Path

Dim k As Folder

For Each k In f.SubFolders

Call func(k, r, c)

Next k

c = c + 1

Dim i As File

For Each i In f.Files

If 0 = InStr(i.Name, ActiveWorkbook.Name) Then

r = r + 1

ActiveSheet.Cells(r, c).Value = i.Name

ActiveSheet.Hyperlinks.Add anchor:=Cells(r, c), Address:=i.Path

End If

Next i

Set f = Nothing

End Sub

2016-09-27

VBA IEを起動して検索順位を調べる

特定のワードでドメインが何番目のページにいるかを知りたいときに。
A列にドメイン名、B列にキーワードを入れて使う。

'参照設定
'Microsoft HTML Object Library
'Microsoft Internet Controls

#If VBA7 Then
  Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
  Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

Sub ieWait(obj As InternetExplorer)

Do While obj.Busy = True Or obj.ReadyState <> 4
  DoEvents
  Sleep 1000
Loop

Do While obj.document.ReadyState <> "complete"
  DoEvents
  Sleep 1000
Loop

Sleep Int((3000 - 1000 + 1) * Rnd + 1000)

End Sub

Sub auto_open()

Application.CommandBars("cell").Reset

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

  .OnAction = "main"
  .Caption = "KeyCheck"

End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2

  Application.CommandBars("cell").Controls("KeyCheck").Delete
  
Next i

End Sub

Sub main()

Dim ie As InternetExplorer
Set ie = CreateObject("InternetExplorer.Application")

With ie

  .Visible = True: .Top = 0: .Left = 0: .Width = 500: .Height = 500
  
End With

c = 9

Do While Sheets("検索順位").Cells(1, c).Value <> ""

  c = c + 1
  
Loop

Sheets("検索順位").Cells(1, c).Value = Month(Date) & "/" & Day(Date)

r = 2

Do While Sheets("検索順位").Cells(r, 1).Value <> ""

  Call func(r, c, ie)
  
  r = r + 1

Loop

ie.Quit
Set ie = Nothing

MsgBox "done"

End Sub

Sub func(r, c, ie As InternetExplorer)

ie.navigate "http://www.yahoo.co.jp"

Call ieWait(ie)

ie.document.getElementById("srchtxt").Value = Sheets("検索順位").Cells(r, 2).Text
ie.document.getElementById("srchbtn").Click

Call ieWait(ie)
    
If InStr(ie.document.body.innerText, Sheets("検索順位").Cells(r, 1).Text) <> 0 Then

  Sheets("検索順位").Cells(r, c) = 1
  
  DoEvents
  Sleep Int((3000 - 1000 + 1) * Rnd + 1000)
  
  Exit Sub

Else

  ie.navigate "JavaScript:scrollTo(0," & ie.document.body.ScrollHeight & ")"
      
End If

For pages = 2 To 10

  For Each anchor In ie.document.all.tags("a")
    
    If Len(anchor.Text) <= 2 And Val(anchor.Text) = pages Then
      
      ie.navigate anchor.href
      
      Call ieWait(ie)

      If InStr(ie.document.body.innerText, Sheets("検索順位").Cells(r, 1).Text) <> 0 Then
      
        Sheets("検索順位").Cells(r, c) = pages
        
        DoEvents
        Sleep Int((3000 - 1000 + 1) * Rnd + 1000)
        
        Exit Sub
        
      Else
        
        ie.navigate "JavaScript:scrollTo(0," & ie.document.body.ScrollHeight & ")"
      
      End If

      Exit For
    
    End If
  
  Next anchor
    
Next pages

DoEvents
Sleep Int((3000 - 1000 + 1) * Rnd + 1000)
        
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

'参照設定

'Microsoft HTML Object Library

'Microsoft Internet Controls

#If VBA7 Then

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)

#Else

Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)

#End If

Sub ieWait(obj As InternetExplorer)

Do While obj.Busy = True Or obj.ReadyState <> 4

DoEvents

Sleep 1000

Loop

Do While obj.document.ReadyState <> "complete"

DoEvents

Sleep 1000

Loop

Sleep Int((3000 - 1000 + 1) * Rnd + 1000)

End Sub

Sub auto_open()

Application.CommandBars("cell").Reset

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

.OnAction = "main"

.Caption = "KeyCheck"

End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2

Application.CommandBars("cell").Controls("KeyCheck").Delete

Next i

End Sub

Sub main()

Dim ie As InternetExplorer

Set ie = CreateObject("InternetExplorer.Application")

With ie

.Visible = True: .Top = 0: .Left = 0: .Width = 500: .Height = 500

End With

c = 9

Do While Sheets("検索順位").Cells(1, c).Value <> ""

c = c + 1

Loop

Sheets("検索順位").Cells(1, c).Value = Month(Date) & "/" & Day(Date)

r = 2

Do While Sheets("検索順位").Cells(r, 1).Value <> ""

Call func(r, c, ie)

r = r + 1

Loop

ie.Quit

Set ie = Nothing

MsgBox "done"

End Sub

Sub func(r, c, ie As InternetExplorer)

ie.navigate "http://www.yahoo.co.jp"

Call ieWait(ie)

ie.document.getElementById("srchtxt").Value = Sheets("検索順位").Cells(r, 2).Text

ie.document.getElementById("srchbtn").Click

Call ieWait(ie)

If InStr(ie.document.body.innerText, Sheets("検索順位").Cells(r, 1).Text) <> 0 Then

Sheets("検索順位").Cells(r, c) = 1

DoEvents

Sleep Int((3000 - 1000 + 1) * Rnd + 1000)

Exit Sub

Else

ie.navigate "JavaScript:scrollTo(0," & ie.document.body.ScrollHeight & ")"

End If

For pages = 2 To 10

For Each anchor In ie.document.all.tags("a")

If Len(anchor.Text) <= 2 And Val(anchor.Text) = pages Then

ie.navigate anchor.href

Call ieWait(ie)

If InStr(ie.document.body.innerText, Sheets("検索順位").Cells(r, 1).Text) <> 0 Then

Sheets("検索順位").Cells(r, c) = pages

DoEvents

Sleep Int((3000 - 1000 + 1) * Rnd + 1000)

Exit Sub

Else

ie.navigate "JavaScript:scrollTo(0," & ie.document.body.ScrollHeight & ")"

End If

Exit For

End If

Next anchor

DoEvents

Sleep Int((3000 - 1000 + 1) * Rnd + 1000)

End Sub