実行中のIEを探し制御

投稿日時: 投稿者:
返信 
Sub All_IE_Close()

	Dim ObjIE As Object
	Dim ObjShell As Object
	Dim ObjWindow As Object

	Set ObjShell = CreateObject("Shell.Application")
	'全shellをチェックしてIEならClose
	For Each ObjWindow In ObjShell.Windows
		If TypeName(ObjWindow.Document) = "HTMLDocument" Then ObjWindow.Quit
	Next

	'1だけメインのIEを起動する
	Set ObjIE = CreateObject("InternetExplorer.application")
	ObjIE.Visible = True
	ObjIE.Navigate "http://xxxxxxxxxx"

End Sub

Sub Go()

	Dim ObjIE As Object
	Dim ObjShell As Object
	Dim ObjWindow As Object
	Dim wkTEXT As String, intISR As Integer
	Dim txtISR As String, intEnd As Integer, Y As Integer

	Set ObjShell = CreateObject("Shell.Application")
	'全shellをチェック
	For Each ObjWindow In ObjShell.Windows
		'IEならば
		If TypeName(ObjWindow.Document) = "HTMLDocument" Then
			Set ObjIE = ObjWindow
			'フィールドに値をセット＆クリック＆3秒待ち
			ObjIE.Document.forms(1).Item("xxxx").Value = "xxx"
			ObjIE.Document.all("xxxxx").click
			Application.Wait Time:=Now + TimeValue("00:00:03")
			'結果HTMLから必要な文字列の取り出し
			wkTEXT = ObjIE.Document.body.innerText
			intISR = InStr(1, wkTEXT, "ISR ")
			intEnd = InStr(1, wkTEXT, "xxxx")
			'値が見つかれば
			If intISR > 0 Then
				txtISR = Trim(Mid(wkTEXT, intISR + 4, intEnd – intISR – 6))
				Debug.Print txtISR
			End If
			'強制終了
			MsgBox "Done!"
			End
		End If
	Next

End Sub

文字列検索関数

投稿日時: 投稿者:
返信 
Function Xlookup(CUST_NAME As String, GetColumn As String)

	Dim X As Integer, CY As Long
	'カラム番号取得
	GetColumn = UCase(GetColumn)
	If GetColumn < "A" Or GetColumn > "O" Then
		'A~O以外はエラー
		Xlookup = "Err Column"
		Exit Function
	End If

	' calculate column Aが1列目とする
	X = Asc(UCase(GetColumn)) – 64
	'顧客名取得＆株 削除＆Trim
	CUST_NAME = Trim(Replace(CUST_NAME, "(株)", ""))
	'検索して見つかったY座標取得
	CY = find_string(CUST_NAME)
	If CY = 0 Then
		'見つからなかった場合
		Xlookup = "UnFound"
		Exit Function
	End If
	'見つかった場合は指定の列の値を返す
	Xlookup = Sheets("MST").Cells(CY, X)

End Function

Function find_string(NM As String)
	Dim Y As Long
	'見つからなかった場合はエラーにならないようにする
	On Error Resume Next
	If IsError(Sheets("MST").Cells.Find(What:=NM).Row) Then
		'見つからなかった場合はゼロを返す
		Y = 0
	Else
		'見つかった場合はY座標を返す
		Y = Sheets("MST").Cells.Find(What:=NM).Row
	End If

	On Error GoTo 0
	find_string = Y

End Function

IE:frame処理

投稿日時: 投稿者:

参照設定にて下記の２つを有効にする
MS Internet Controls :IEのため
MS HTML Object Library :フレーム処理

該当のURLを開いて、左フレーム内のURLをクリック
上フレームのTEXTBOXに値をセットしてSUBMIT
右フレームに出てきた値(結果)を取り出す

Private Sub html_go()
	Dim IE As InternetExplorer
	Dim objFRAME As FramesCollection
	Dim objDOC As HTMLDocument

	Set IE = CreateObject("internetExplorer.application")

	IE.Navigate "http://~~~/"
	IE.Visible = True
	Do While IE.Busy = True: DoEvents: Loop

	Set objFRAME = IE.Document.frames
	'NAME=lview　のフレーム内処理
	Set objDOC = objFRAME("F_left").Document
	objDOC.all.Item(23).Click 'HWInfo click
	Do While IE.Busy = True: DoEvents: Loop

	Set objFRAME = IE.Document.frames
	'NAME=tview　のフレーム内処理
	Set objDOC = objFRAME("F_top").Document

	objDOC.all("text box").Value = "値"
	objDOC.forms(0).submit
	Do While IE.Busy = True: DoEvents: Loop

	'NAME=rview　のフレーム内処理
	Set objDOC = objFRAME("F_right").Document
	strHTML = objDOC.all(0).innerText

	Debug.Print strHTML
	Set IE = Nothing
	MsgBox "done!"
End Sub

ODBC linkリフレッシュ

投稿日時: 投稿者: 
Private Sub btnGO_Click()
	
	Dim wkTBL As String, wkLEN As String, wkDSN As String
	Dim WKSRCTBL As String, wkUID
	Dim MyTbl As DAO.TableDef
	Dim prp As DAO.Property
	
	For Each MyTbl In CurrentDb.TableDefs
		wkTBL = MyTbl.Name
		WKSRCTBL = MyTbl.SourceTableName
		If MyTbl.Attributes And dbAttachedODBC Then
			wkLEN = InStr(1, MyTbl.Connect, “DSN=") + 4
			wkDSN = Mid(MyTbl.Connect, wkLEN, InStr(wkLEN, MyTbl.Connect, “;") – wkLEN)
			'call link
			AUTO_LINK wkTBL, WKSRCTBL, wkDSN, “userid", “password"
			End If
		End If
	Next
	
	MsgBox “done!"
	Exit Sub
End Sub

Sub AUTO_LINK(dbtable As String, dbname As String, dsn As String, uid As String, pwd As String)
	
	Dim db As Database, TblDef As TableDef
	Dim prp As DAO.Property, flgpw As Boolean
	
	flgpw = True 'save password in link
	On Error Resume Next
	'delete
	DoCmd.DeleteObject acTable, dbtable
	On Error GoTo 0
	Set db = DBEngine.Workspaces(0).Databases(0)
	
	Set TblDef = db.CreateTableDef(dbtable)
	TblDef.Connect = “ODBC;DSN=" & dsn & “;UID=" & uid & “;PWD=" & pwd
	TblDef.SourceTableName = dbname
	If flgpw Then
		TblDef.Attributes = dbAttachSavePWD
	End If
	
	db.TableDefs.Append TblDef
	
	Set prp = TblDef.CreateProperty(“Description", dbText, dsn & “:" & uid)
	TblDef.Properties.Append prp
	TblDef.Properties.Refresh
	TblDef.RefreshLink
End Sub

クエリ内容をテキストSQLよりインポート

投稿日時: 投稿者: 
Private Sub btnGO_Click()
	
	Dim wkTBL As String, wkLEN As String, wkDSN As String
	Dim WKSRCTBL As String, wkUID
	Dim MyTbl As DAO.TableDef
	Dim prp As DAO.Property
	
	For Each MyTbl In CurrentDb.TableDefs
		wkTBL = MyTbl.Name
		WKSRCTBL = MyTbl.SourceTableName
		If MyTbl.Attributes And dbAttachedODBC Then
			wkLEN = InStr(1, MyTbl.Connect, “DSN=") + 4
			wkDSN = Mid(MyTbl.Connect, wkLEN, InStr(wkLEN, MyTbl.Connect, “;") – wkLEN)
			'call link
			AUTO_LINK wkTBL, WKSRCTBL, wkDSN, “userid", “password"
			End If
		End If
	Next
	
	MsgBox “done!"
	Exit Sub
End Sub

Sub AUTO_LINK(dbtable As String, dbname As String, dsn As String, uid As String, pwd As String)
	
	Dim db As Database, TblDef As TableDef
	Dim prp As DAO.Property, flgpw As Boolean
	
	flgpw = True 'save password in link
	On Error Resume Next
	'delete
	DoCmd.DeleteObject acTable, dbtable
	On Error GoTo 0
	Set db = DBEngine.Workspaces(0).Databases(0)
	
	Set TblDef = db.CreateTableDef(dbtable)
	TblDef.Connect = “ODBC;DSN=" & dsn & “;UID=" & uid & “;PWD=" & pwd
	TblDef.SourceTableName = dbname
	If flgpw Then
		TblDef.Attributes = dbAttachSavePWD
	End If
	
	db.TableDefs.Append TblDef
	
	Set prp = TblDef.CreateProperty(“Description", dbText, dsn & “:" & uid)
	TblDef.Properties.Append prp
	TblDef.Properties.Refresh
	TblDef.RefreshLink
End Sub

クエリ名とSQLをテキスト出力

投稿日時: 投稿者: 
Sub クエリをテキスト出力する()
	Dim dbs As Database
	Dim intCount As Integer
	Dim QDF As QueryDef
	
	Open “c:\temp\export_query.txt" For Output As #1
	Set dbs = CurrentDb
	
	For intCount = 0 To dbs.QueryDefs.Count – 1
		Set QDF = dbs.QueryDefs(intCount)
		Print #1, QDF.Name
		Print #1, QDF.SQL
		'Debug.Print QDF.SQL
	Next
	
	Close
End Sub

Export name of Query

投稿日時: 投稿者: 
Sub Sample()
	Dim mymydb  As Database
	
	Set mydb = CurrentDb
	
	Debug.Print "すべてのクエリ名を出力します"
	For Each myqer In mydb.QueryDefs
		Debug.Print myqer.Name
	Next
End Sub

XAMPP Debugger

投稿日時: 投稿者:

下記をphp.iniに追加。

[Zend]
zend_extension_manager.debug_server_ts = “C:\xampp\php\zendOptimizer\lib\Debugger”
zend_debugger.deny_hosts = all
zend_debugger.allow_hosts = 127.0.0.1
zend_debugger.expose_remotely = always

php_debugger