投稿者「xvax」のアーカイブ

IEを呼び出し＆URL指定で開く

投稿日時: 投稿者: 
'FIELDをWクリックしたら、IE呼び出し
Private Sub FIELD_DblClick(Cancel As Integer)
	'
	Dim IE As Object
	'IE準備
	Set IE = CreateObject(“internetExplorer.application")
	'IE起動＆URL開く
	IE.Navigate “http://~~~~?xxx=" & ZZZ.Value
	'IE表示
	IE.Visible = True
	'表示終わるまで待機
	Do While IE.Busy = True: DoEvents: Loop
	'リソース開放
	Set IE = Nothing
	'
End Sub

APIを使ってログイン名を取得

投稿日時: 投稿者: 
'Windowsログイン名取得API
Private Declare Function GetUserName Lib “ADVAPI32.dll" _
	Alias “GetUserNameA" _
	(ByVal lpBuffer As String, nSize As Long) As Long

Sub test()
	Dim strBuffer As String
	Dim lngLngs As Long
	Dim lngRet As Long
	Dim Get_User As String
	'
	' Bufferを確保
	strBuffer = String(256, Chr(0))
	lngLngs = Len(strBuffer)
	'
	' ログインユーザー名取得
	lngRet = GetUserName(strBuffer, lngLngs)
	Get_User = UCase(Left$(strBuffer, InStr(1, strBuffer, Chr(0)) – 1))
	'
	MsgBox Get_User
	'
End Sub

全シート内PIVOTをリフレッシュ

投稿日時: 投稿者: 
'全シート内のPIVOTを無条件リフレッシュ
Sub ALL_PIVOT_UPDATE()

	If MsgBox(“全Pivotを一括更新します。" & vbCrLf & _
		“1Pivot xx秒ほどかかります。", vbYesNo) <> vbYes Then Exit Sub
	
	'PIVOTが無いシートはエラーになるため、無視するように設定
	On Error Resume Next
	'全シートを順番に更新
	For i = 1 To ActiveWorkbook.Sheets.Count
		Sheets(i).Activate
		'PIVOTのリフレッシュ
		ActiveWorkbook.Sheets(i).PivotTables(1).PivotCache.Refresh
	Next
	'エラー処理を有効にする
	On Error GoTo 0
	
	MsgBox “done!"

End Sub

ACCESS内容を動的PIVOTにする

投稿日時: 投稿者:

MS-ACCESS内のクエリーをPIVOT化する(リンクされているためリフレッシュ可能)
更にそのPIVOTからグラフを作成する
sample table field: shohin,month,bunsi,bunbo

Sub make_pivot(Tbl$, PVN As Integer, GOAL As Boolean)
	'Tbl$ = 対象のTable/クエリー名
	Dim PV As Variant, i As Integer
	'ソース情報(MDB)の取り出し文を作成
	a1$ = “ODBC;DSN=MS Access Database;"
	a2$ = “DBQ=\\file_server\path\FIR09.mdb;"
	a3$ = “DefaultDir=\\file_server\path;"
	a4$ = “DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;"
	'pivot名称(内部用)
	PV = “pivot" & PVN
	'PIVOT用に新規シート作成
	Worksheets.Add
	'PVOTシート名はTable名とする
	ActiveSheet.Name = Tbl$
	Range(“B4").Select
	'PIVOT作成
	With ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
		.Connection = Array(Array(a1$), Array(a2$), Array(a3$), Array(a4$))
		.CommandType = xlCmdSql
		.CommandText = Array(“SELECT * FROM “ & Tbl$)
		.CreatePivotTable TableDestination:=“R3C1", TableName:=PV, DefaultVersion:=xlPivotTableVersion10
	End With
	
	On Error Resume Next
	'RATEフィールドの追加(DBには無いField)
	ActiveSheet.PivotTables(PV).CalculatedFields.Add “RATE", “=bunshi/bunbo", True
	ActiveSheet.PivotTables(PV).PivotFields(“RATE").Orientation = xlDataField
	Range(“B4").Select
	
	'グラフ作成
	Charts.Add
	ActiveChart.SetSourceData Source:=Sheets(Tbl$).Range(“B4")
	ActiveChart.Location Where:=xlLocationAsNewSheet
	ActiveChart.ChartArea.Select
	ActiveChart.ChartType = xlColumnClustered
	ActiveChart.Location Where:=xlLocationAsNewSheet
	ActiveWindow.Zoom = 100
	ActiveChart.Axes(xlValue).Select
	Selection.TickLabels.NumberFormatLocal = “0.00%"
	ActiveChart.ChartArea.Select
	Selection.AutoScaleFont = True
	With Selection.Font
		.Name = “Verdana"
		.Size = 8
		.Strikethrough = False
		.Superscript = False
		.Subscript = False
		.OutlineFont = False
		.Shadow = False
		.Underline = xlUnderlineStyleNone
		.ColorIndex = xlAutomatic
		.Background = xlAutomatic
	End With
	
	'グラフに縦横フィールド名セット
	ActiveChart.PivotLayout.PivotTable.PivotFields(“shohin").Orientation = xlRowField
	ActiveChart.PivotLayout.PivotTable.PivotFields(“shohin").Position = 1
	ActiveChart.PivotLayout.PivotTable.PivotFields(“month").Orientation = xlColumnField
	ActiveChart.PivotLayout.PivotTable.PivotFields(“month").Position = 1
	'bunboの合計をを値としてセット
	ActiveChart.PivotLayout.PivotTable.AddDataField ActiveChart.PivotLayout. _
		PivotTable.PivotFields(“bunbo"), “合計 / bunbo", xlSum
	   
	On Error GoTo 0
	'グラフシートの名前をセット
	ActiveSheet.Name = Tbl$ & “グラフ"
	
	'凡例の表示
	ActiveChart.ChartArea.Select
	ActiveChart.HasLegend = True
	'凡例の場所設定
	ActiveChart.Legend.Select
	Selection.Position = xlBottom
	ActiveChart.Deselect
	
End Sub

選択オブジェクトのグラデーション化②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