月別アーカイブ: 2008年4月

選択オブジェクトのグラデーション化②sub

投稿日時: 投稿者: 
'選択物のグラデーション化（相手は必ず黒となる）
Sub 縦下黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 1, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=1, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 縦上黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 2, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=2, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 縦内黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 3, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=3, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 縦外黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientHorizontal, 4, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientHorizontal, Variant:=4, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 横右黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientVertical, 1, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=1, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 横左黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientVertical, 2, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=2, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 横内黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientVertical, 3, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=3, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

Sub 横外黒()
	On Error Resume Next
	Selection.ShapeRange.Fill.OneColorGradient msoGradientVertical, 4, 0.23
	Selection.Fill.OneColorGradient Style:=msoGradientVertical, Variant:=4, Degree:=0.231372549019608
	On Error GoTo 0
End Sub

選択オブジェクトのグラデーション化①main

投稿日時: 投稿者:

選択したオブジェクトの色をグラデーション化する
起動時にグラデーション用のボタンを作成＆配置

Sub Auto_open()
	Dim cbrWiz As CommandBar
	Dim cbcMenu As CommandBarControl
	Dim ctlInsert As CommandBarButton
	On Error Resume Next
	' コマンド バーが既に存在するかどうかを確認します。
	Set cbrWiz = CommandBars(CBR_INSERT)
	' コマンド バーが存在しない場合は作成します。
	If cbrWiz Is Nothing Then
		Err.Clear
		Set cbrWiz = CommandBars.Add(CBR_INSERT)
		' コマンド バーを表示します。
		cbrWiz.Visible = True
	  
		'グラデーションメニューの追加
		Set cbcMenu = cbrWiz.Controls.Add(Type:=msoControlPopup)
		cbcMenu.Caption = “Gradation"
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して縦下黒のグラデーションセット"
			.Tag = “縦下黒"
			.OnAction = “縦下黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して縦上黒のグラデーションセット"
			.Tag = “縦上黒"
			.OnAction = “縦上黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して縦内黒のグラデーションセット"
			.Tag = “縦内黒"
			.OnAction = “縦内黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して縦外黒のグラデーションセット"
			.Tag = “縦外黒"
			.OnAction = “縦外黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して横右黒のグラデーションセット"
			.Tag = “横右黒"
			.OnAction = “横右黒"
			.BeginGroup = True
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して横左黒のグラデーションセット"
			.Tag = “横左黒"
			.OnAction = “横左黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して横内黒のグラデーションセット"
			.Tag = “横内黒"
			.OnAction = “横内黒"
		End With
		Set ctlInsert = cbcMenu.Controls.Add
		With ctlInsert
			.Style = msoButtonCaption
			.Caption = “原色に対して横外黒のグラデーションセット"
			.Tag = “横外黒"
			.OnAction = “横外黒"
		End With
		
	Else
	  ' 既存のコマンド バーを表示します。
	  cbrWiz.Visible = True
	End If
End Sub

'終了時はボタンを削除する
Sub Auto_close()
	On Error Resume Next
	' 存在するコマンド バーを削除します。
	CommandBars(CBR_INSERT).Delete
End Sub

マクロ用ボタンセット

投稿日時: 投稿者: 
Sub CREATE_MACRO_BUTTON()
	'set button(size:開始x,開始y,幅x,高さy)
	ActiveSheet.Buttons.Add(100, 10, 150, 20).Select
	'set macro name
	Selection.OnAction = “macro_excel_file.xls!macro_name"
	'set button title
	Selection.Characters.Text = “MACRO TITLE NAME"
End Sub

基本OO4O利用

投稿日時: 投稿者:
返信 
Sub OO4O()
	Dim EmpDynaset As Object
	Dim OraSession As Object
	Dim OraDatabase As Object
	Dim strSQL As String
	On Local Error Resume Next
	'
	'Connect
	Set OraSession = CreateObject(“OracleInProcServer.XOraSession")
	If Err <> 0 Then
		MsgBox “データベースに接続出来ません。" & vbCrLf _
		  & “CreateObject – Oracle oo4o エラー" & vbCrLf _
		  & “ORACLEクライアントはインストールされていますか？"
		End
	End If
	'
	Set OraDatabase = OraSession.OpenDatabase(“DSN NAME", “USERID/PASSWORD", 0&)
	If Err <> 0 Then
		MsgBox “データベースに接続出来ません。" & vbCrLf _
		  & Err & “: “ & Error & vbCrLf _
		  & “DB接続の設定内容に問題があります。" & vbCrLf _
		  & “Cドライブ内からTNSNAMES.ORAファイルを探し管理者宛に送付してください"
		End
	End If
	'
	On Error GoTo 0
	'SQL
	strSQL = “SELECT * FROM TABLE_NAME WHERE FIELD='A'"
	'Execute
	Set EmpDynaset = OraDatabase.CreateDynaset(strSQL, 0&)
	'loop
	Do While Not EmpDynaset.EOF
		Debug.Assert EmpDynaset(“FIELD_NAME").Value
		EmpDynaset.MoveNext
	End If
	'
	EmpDynaset.Close
	'
	MsgBox “Done!"
	'
End Sub

IEフォームに値をセットしてSUBMIT

投稿日時: 投稿者:
返信

Excel C列の値をIE上のフィールドにセットしてSUBMIT

Sub batch_all_check()

	Dim IE As Object
	Dim LenX As Integer, PP As String
	Dim Y As Integer, HTML As String
	
	Set IE = CreateObject(“internetExplorer.application")
	IE.Navigate “https://www.xxx"
	IE.Visible = True
	
	Do While IE.Busy = True: DoEvents: Loop
	Do While IE.Busy = True: DoEvents: Loop
	Do While IE.Busy = True: DoEvents: Loop
	
	For Y = 3 To 4002
		
		PP = Cells(Y, 3)
		If PP = “" Then Exit For
		
		PP = UCase(Replace(PP, “-", “"))
		LenX = Len(PP)
		
		If LenX <> 20 Then
			Cells(Y, 5) = “length error"
			Exit For
		End If
	
		Do While IE.Busy = True: DoEvents: Loop
		'文字列を分解してそれぞれのフィールドにセット
		IE.Document.Form1.igtxtwtxedPidPart01.Focus
		IE.Document.Form1.igtxtwtxedPidPart01.Value = Left(PP, 2)
		IE.Document.Form1.igtxtwtxedPidPart02.Focus
		IE.Document.Form1.igtxtwtxedPidPart02.Value = Mid(PP, 3, 6)
		IE.Document.Form1.igtxtwtxedPidPart03.Focus
		IE.Document.Form1.igtxtwtxedPidPart03.Value = Mid(PP, 9, 5)
		IE.Document.Form1.igtxtwtxedPidPart04.Focus
		IE.Document.Form1.igtxtwtxedPidPart04.Value = Mid(PP, 14, 3)
		IE.Document.Form1.igtxtwtxedPidPart05.Focus
		IE.Document.Form1.igtxtwtxedPidPart05.Value = Mid(PP, 17, 4)
		IE.Document.Form1.igtxtwtxedPidPart01.Focus
		'theform.submit()
		IE.Document.Form1.identify_btnVerify.Click
		'ボタン(SUBMIT)をクリック
		Do While IE.Busy = True: DoEvents: Loop
		Do While IE.Busy = True: DoEvents: Loop
		Do While IE.Busy = True: DoEvents: Loop
		'html取り込み
		HTML = IE.Document.Body.innerHTml
	
		If InStr(1, HTML, “***") > 0 Then
			Cells(Y, 5) = “Hit"
		Else
			Cells(Y, 5) = “???"
		End If
	Next
	
	MsgBox “Done!"
	Set IE = Nothing

End Sub

関数：US日付を日本日付に変換

投稿日時: 投稿者:
返信

USなどm/d/yyyyの日付データを日本式(yyyy/m/d)に変更する

Function USDATE(strDATE As Variant) As Variant
	'引数：日付文字列(m/d/yyyy)
	'結果：8桁の日付文字列を日付に変更
	'例）"2/10/2006"を指定した場合結果は、"2006/2/10"となる
	Dim wkSTR As String
	
	strDATE = Trim(strDATE)
	
	'm/d/yyyy HH:MM:SSなど空白の後に時刻があれば取り除く
	If InStr(1, strDATE, " “) > 0 Then strDATE = Left(strDATE, InStr(1, strDATE, " “) – 1)
	
	'末尾4桁が年数なら、日付変換処理
	If InStr(1, “1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009", Right(strDATE, 4)) > 0 Then
		'先頭の月日を取り出し
		wkSTR = Left(strDATE, Len(strDATE) – 5)
		strDATE = CDate(Right(strDATE, 4) & “/" & wkSTR)
	Else
		strDATE = “?"
	End If
	'return
	USDATE = strDATE
	
End Function

Refresh DBリンク

投稿日時: 投稿者:
返信 
Sub OO4O()
	'ODBCリンクを新アカウントでリフレッシュする
	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

	If IsNull(Me.txtID.Value) Or IsNull(Me.txtPASS.Value) Then
		MsgBox “ID/パスワードをセットしてください"
		Exit Sub
	End If

	For Each MyTbl In CurrentDb.TableDefs
		wkTBL = MyTbl.Name
		WKSRCTBL = MyTbl.SourceTableName
		'ODBC link?
		If MyTbl.Attributes And dbAttachedODBC Then
			'DSN CHECK
			wkLEN = InStr(1, MyTbl.Connect, “DSN=") + 4
			wkDSN = Mid(MyTbl.Connect, wkLEN, InStr(wkLEN, MyTbl.Connect, “;") – wkLEN)
			'USER CHECK
			wkLEN = InStr(1, MyTbl.Connect, “UID=") + 4
			wkUID = UCase(Mid(MyTbl.Connect, wkLEN, InStr(wkLEN, MyTbl.Connect, “;") – wkLEN))

			'DSN MATCH and USER ID match?
			If wkDSN = txtDSN.Value And ((wkUID = UCase(Me.txtID.Value) And _
				chkUID.Value = True) Or chkUID.Value = False) Then
				'SUB link
				AUTO_LINK wkTBL, WKSRCTBL, wkDSN, Me.txtID.Value, Me.txtPASS.Value, Me.chkPW
			End If
		End If
	Next
	'
	MsgBox “done!"
End Sub

Sub AUTO_LINK(dbtable As String, dbname As String, _
	dsn As String, uid As String, pwd As String, flgpw As Boolean)
	'current table name, source table name, DSN,UID,PWD,SAVE password
	Dim db As Database, TblDef As TableDef
	Dim prp As DAO.Property

	On Error Resume Next
	'Delete current link
	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
	'include password
	If flgpw Then TblDef.Attributes = dbAttachSavePWD
	'make link
	db.TableDefs.Append TblDef
	'set link account in memo field
	Set prp = TblDef.CreateProperty(“Description", dbText, dsn & “:" & uid)
	TblDef.Properties.Append prp
	TblDef.Properties.Refresh

	'refresh table list
	TblDef.RefreshLink

End Sub

VBA:XML作成

投稿日時: 投稿者:
返信 
'MDRを読み込んで新規XMLファイルを作成するVBAプログラム
Sub export_xml()

	Dim xdoc As New DOMDocument, xtree As IXMLDOMElement
	Dim PI As IXMLDOMProcessingInstruction
	Dim LOB As IXMLDOMElement, FAM As IXMLDOMElement
	Dim BRAND As IXMLDOMElement
	Dim RS As Recordset
	
	'xml header
	Set PI = xdoc.createProcessingInstruction(“xml", “version='1.0′")
	Call xdoc.appendChild(PI)
	'root tree
	Set xtree = xdoc.createElement(“PRODUCT")
	Call xdoc.appendChild(xtree)
	'get data from database
	Set RS = CurrentDb.OpenRecordset(“select * from xxxx")
	
	Do While Not RS.EOF
		'親
		Set LOB = xdoc.createElement(“LOB")
		Call LOB.setAttribute(“NAME", RS!PRODUCT)
			'子1
			Set FAM = xdoc.createElement(“FAMILY")
			FAM.Text = RS!FAMILY
			Call FAM.setAttribute(“CODE", RS!FAMILY_ID)
			Call LOB.appendChild(FAM)
			'子2
			Set BRAND = xdoc.createElement(“BRAND")
			BRAND.Text = RS!BRAND
			Call BRAND.setAttribute(“CODE", RS!BRAND_CD)
			Call LOB.appendChild(BRAND)
		'親書き出し
		Call xtree.appendChild(LOB)
		'next record
		RS.MoveNext
	Loop
	'db close
	RS.Close
	'xml保存
	xdoc.Save (“c:\temp\test.xml")

End Sub