Top > OOoMacrobbs OOoBaic マクロ掲示板
マクロ投稿用。
Xorshift
Base64エンコード・デコード/Base32エンコード・デコード
ビットシフト
動的配列
マージソート
2011/11/03 関数を分割して、挿入ソートを行うようにしました。 Sub Main() a = Array(3, 2, 1) Mergesort(a, "Number") MsgBox(Join(a, ",")) End Sub Function Comp(a, b, compType) If (compType = "Number") Then Comp = NumberComp(a, b) End If End Function Function NumberComp(a, b) If (a < b) Then NumberComp = -1 ElseIf (a > b) Then NumberComp = 1 Else NumberComp = 0 End If End Function Sub Mergesort(a, compType) Dim i, u, j, i2, r i = 6 u = UBound(a) For j = 0 To u - 1 Step i r = j + i - 1 If (r > u) Then r = u End If Insertionsort(a, j, r, compType) Next Dim b(u) Do While (i <= u) i2 = i + i For j = 0 To u - i Step i2 r = j + i2 - 1 If (r > u) Then r = u End If Merge(a, b, j, j + i - 1, j + i, r, compType) Next i = i2 Loop End Sub Sub Insertionsort(a, l, r, compType) Dim i, j, e For i = l + 1 To r j = i e = a(j) For j = i To l + 1 Step -1 If (Comp(a(j - 1), e, compType) <= 0) Then Exit For End If a(j) = a(j - 1) Next a(j) = e Next End Sub Sub Merge(a, b, ll, lr, rl, rr, compType) If (Comp(a(lr), a(rl), compType) <= 0) Then Exit Sub End If Dim l, r, n For l = ll To lr b(l) = a(l) Next l = ll r = rl For n = ll To rr If (l > lr) Then Exit Sub End If If (r > rr) Then Exit For End If If (Comp(a(r), b(l), compType) < 0) Then a(n) = a(r) r = r + 1 Else a(n) = b(l) l = l + 1 End If Next For l = l To lr a(n) = b(l) n = n + 1 Next End Sub 株価取得マクロ
文字に色をつけるマクロ
マルチバイト文字列のエスケープ
Writer ハイパーリンクの削除
また、Ctrl + Shift + Space で書式をデフォルトに戻すとハイパーリンクが消えるそうです。
配列クイックソート 文字列用
Function strqsort( a, i, j ) If NOT ( i = j ) AND ( i >= 0 AND j >= 0 ) Then p = strpivot( a, i, j ) If ( p <> -1 ) Then k = strpartition( a, i, j, a(p) ) strqsort( a, i, k -1 ) strqsort( a, k, j ) End If End If End Function Function strpartition( a, i, j, x ) l = i r = j y = x Do While ( l <= r ) Do While ( l <= j ) AND ( StrComp( a(l), y ) = -1 )'a(l) < y ) l = l + 1 Loop Do While ( r >= i ) AND ( StrComp( a(r), y ) >= 0 )'a(r) >= y ) r = r - 1 Loop If ( l > r ) Then Exit Do t = a(l) a(l) = a(r) a(r) = t l = l + 1 r = r - 1 Loop strpartition = l End Function Function strpivot( a, i, j ) k = i + 1 Do while ( k <= j ) AND ( StrComp( a(i), a(k) ) = 0 )'a(i) = a(k) ) k = k + 1 If k > j Then Exit Do Loop If ( k > j ) Then k = -1 Else If ( StrComp( a(i), a(k) ) >= 0 ) Then'a(i) >= a(k) ) Then k = i End If End If strpivot = k End Function 配列クイックソート 数値用
Function qsort( a, i, j ) If NOT ( i = j ) Then p = pivot( a, i, j ) If ( p <> -1 ) Then k = partition( a, i, j, a(p) ) qsort( a, i, k -1 ) qsort( a, k, j ) End If End If End Function Function partition( a, i, j, x ) l = i r = j y = x Do While ( l <= r ) Do While ( l <= j ) AND ( a(l) < y ) l = l + 1 Loop Do While ( r >= i ) AND ( a(r) >= y ) r = r - 1 Loop If ( l > r ) Then Exit Do t = a(l) a(l) = a(r) a(r) = t l = l + 1 r = r - 1 Loop partition = l End Function Function pivot( a, i, j ) k = i + 1 Do while ( k <= j ) AND ( a(i) = a(k) ) k = k + 1 If k > j Then Exit Do Loop If ( k > j ) Then k = -1 Else If ( a(i) >= a(k) ) Then k = i End If End If pivot = k End Function コマンド実行用
sub Dispatch( sCommand As String, oLocFrame As Object) dim dispatcher as object dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dispatcher.executeDispatch(oLocFrame, sCommand, "", 0, Array()) end sub パス置換用
Function GetSubstitutedPath( sPath As String ) GetSubstitutedPath() = CreateUnoService( _ "com.sun.star.util.PathSubstitution").substituteVariables( sPath,true ) End Function sPath = GetSubstitutedPath( "$(inst)/program" ) など結構利用できる。
パス設定取得用
Function GetPath( sPathName As String ) As String GetPath() = CreateUnoService( _ "com.sun.star.util.PathSettings").getPropertyValue( sPathName ) End Function 取得したいパス名は下記参照 http://api.openoffice.org/docs/common/ref/com/sun/star/util/PathSettings.html Point struct 用
Function MakePoint( nX As Long, nY As Long ) As com.sun.star.awt.Point Dim aPoint As New com.sun.star.awt.Point aPoint.X = nX aPoint.Y = nY MakePoint() = aPoint End Function Size struct 用
Function MakeSize( nWidth As Long, nHeight As Long ) As com.sun.star.awt.Size Dim aSize As New com.sun.star.awt.Size aSize.Width = nWidth aSize.Height = nHeight MakeSize() = aSize End Function 長いテキスト表示用ダイアログ コピーボタン付き
コピーボタンを付けた長いテキスト表示用ダイアログ OpenOffice.org を終了すると貼り付けできなくなるはず Global sTxtCString As String Sub Txtc( Optional sShowText As String ) Dim oDialogModel As Object, oDialog As Object Dim oManager As Object Dim oTextModel As Object, oClose As Object, oCopy As Object Dim oButtonListener As Object oManager = GetProcessServiceManager() oDialogModel = oManager.createInstance("com.sun.star.awt.UnoControlDialogModel") With oDialogModel .setPropertyValue("Name","Dialog") .setPropertyValue( "PositionX", 100 ) .setPropertyValue( "PositionY", 60 ) .setPropertyValue( "Height", 175 ) .setPropertyValue( "Width", 157 ) .setPropertyValue( "Title", "Menu" ) End With oTextModel = oDialogModel.createInstance("com.sun.star.awt.UnoControlEditModel") With oTextModel .setPropertyValue( "Name", "Contents" ) .setPropertyValue( "PositionX", 4 ) .setPropertyValue( "PositionY", 21 ) .setPropertyValue( "Width", 149 ) .setPropertyValue( "Height", 150 ) .setPropertyValue("MultiLine",true) .setPropertyValue("VScroll",true) .setPropertyValue("HardLineBreaks",false) .setPropertyValue("Border",2) End With oClose = oDialogModel.createInstance("com.sun.star.awt.UnoControlButtonModel") With oClose .setPropertyValue( "Name", "Close" ) .setPropertyValue( "PositionX", 123 ) .setPropertyValue( "PositionY", 3 ) .setPropertyValue( "Width", 30 ) .setPropertyValue( "Height", 14 ) .setPropertyValue("Label","Close") .setPropertyValue("PushButtonType",2) End With oButtonListener = CreateUnoListener( "ButtonAction_", "com.sun.star.awt.XActionListener" ) oCopy = oDialogModel.createInstance("com.sun.star.awt.UnoControlButtonModel") With oCopy .setPropertyValue( "Name", "Copy" ) .setPropertyValue( "PositionX", 88 ) .setPropertyValue( "PositionY", 3 ) .setPropertyValue( "Width", 30 ) .setPropertyValue( "Height", 14 ) .setPropertyValue("Label","~Copy") End With With oDialogModel .insertByName("Contents",oTextModel) .insertByName("Close",oClose) .insertByName("Copy",oCopy) End With oDialog = oManager.createInstance("com.sun.star.awt.UnoControlDialog") oDialog.setModel(oDialogModel) With oDialog.getControl("Copy") .ActionCommand = "COPY" .addActionListener(oButtonListener) End With oDialogModel.Contents.Text = sShowText oDialog.setTitle( "TxtDialog" ) oDialog.setVisible(true) oDialog.execute() oDialog.dispose() End Sub Sub ButtonAction_actionPerformed( e ) On Error Goto ErrorHandler c = e.ActionCommand Select Case c Case "COPY" CopyToClipboard() End Select Exit Sub ErrorHandler: End Sub Sub ButtonAction_disposing() End Sub Sub CopyToClipBoard() Dim null As Object oClip = CreateUnoService("com.sun.star.datatransfer.clipboard.SystemClipboard") oTR = createUnoListener("Tr_", "com.sun.star.datatransfer.XTransferable") oClip.setContents(oTR,null) sTxtCString = oDialogModel.Contents.Text End Sub Function Tr_getTransferData(aFlavor as com.sun.star.datatransfer.DataFlavor) If (aFlavor.MimeType = "text/plain;charset=utf-16") Then Tr_getTransferData() = sTxtCString End If End Function Function Tr_getTransferDataFlavors() Dim aFlavor As new com.sun.star.datatransfer.DataFlavor aFlavor.MimeType = "text/plain;charset=utf-16" aFlavor.HumanPresentableName = "Unicode-Text" Tr_getTransferDataFlavors() = array(aFlavor) End Function Function Tr_isDataFlavorSupported(aFlavor as com.sun.star.datatransfer.DataFlavor) as Boolean If aFlavor.MimeType = "text/plain;charset=utf-16" Then Tr_isDataFlavorSupported = true Else Tr_isDataFlavorSupported = false End If End Function 長いテキスト表示用ダイアログ
改行を含む長いテキストを表示するときに Sub Txt( Optional sShowText As String ) Dim oDialogModel As Object, oDialog As Object Dim oManager As Object Dim oTextModel As Object, oClose As Object oManager = GetProcessServiceManager() oDialogModel = oManager.createInstance("com.sun.star.awt.UnoControlDialogModel") With oDialogModel .setPropertyValue("Name","Dialog") .setPropertyValue( "PositionX", 100 ) .setPropertyValue( "PositionY", 60 ) .setPropertyValue( "Height", 175 ) .setPropertyValue( "Width", 157 ) .setPropertyValue( "Title", "Menu" ) End With oTextModel = oDialogModel.createInstance("com.sun.star.awt.UnoControlEditModel" With oTextModel .setPropertyValue( "Name", "Contents" ) .setPropertyValue( "PositionX", 4 ) .setPropertyValue( "PositionY", 21 ) .setPropertyValue( "Width", 149 ) .setPropertyValue( "Height", 150 ) .setPropertyValue("MultiLine",true) .setPropertyValue("VScroll",true) .setPropertyValue("HardLineBreaks",false) .setPropertyValue("Border",2) End With oClose = oDialogModel.createInstance("com.sun.star.awt.UnoControlButtonModel") With oClose .setPropertyValue( "Name", "Close" ) .setPropertyValue( "PositionX", 123 ) .setPropertyValue( "PositionY", 3 ) .setPropertyValue( "Width", 30 ) .setPropertyValue( "Height", 14 ) .setPropertyValue("Label","Close") .setPropertyValue("PushButtonType",2) End With With oDialogModel .insertByName("Contents",oTextModel) .insertByName("Close",oClose) End With oDialog = oManager.createInstance("com.sun.star.awt.UnoControlDialog") oDialog.setModel(oDialogModel) oDialogModel.Contents.Text = sShowText oDialog.setTitle( "TxtDialog" ) oDialog.setVisible(true) oDialog.execute() oDialog.dispose() End Sub UnoControl 作成 2
ランタイムでコントロールを作成するときに、モデルオブジェクトの プロパティを設定する必要があるとき用 Function CreateCtrWithProp( CtrType, oToolkit, oWindow, aPosSize, aPropNames, aPropValues ) Dim oCtr As Object, oCtrModel As Object oCtr = createUnoService("com.sun.star.awt.UnoControl" & CtrType ) oCtrModel = createUnoService("com.sun.star.awt.UnoControl" & CtrType & "Model" ) oCtrModel.setPropertyValues( aPropNames, aPropValues ) With oCtr .setModel(oCtrModel) .createPeer( oToolkit, oWindow ) .setPosSize( aPosSize.X, aPosSize.Y, aPosSize.Width, aPosSize.Height, _ com.sun.star.awt.PosSize.POSSIZE ) End With CreateCtrWithProp() = oCtr 'model can be got from returned value End Function UnoControl 作成
ランタイムでコントロールを作成するときに Function CreateCtr( CtrType, oToolkit, oWindow, aPosSize ) Dim oCtr As Object, oCtrModel As Object oCtr = createUnoService("com.sun.star.awt.UnoControl" & CtrType ) oCtrModel = createUnoService("com.sun.star.awt.UnoControl" & CtrType & "Model" ) With oCtr .setModel(oCtrModel) .createPeer( oToolkit, oWindow ) .setPosSize( aPosSize.X, aPosSize.Y, aPosSize.Width, aPosSize.Height, _ com.sun.star.awt.PosSize.POSSIZE ) End With CreateCtr() = oCtr 'model can be got from returned value End Function Rectangle struct 用
Function MakeRect( nX, nY, nWidth, nHeight ) As com.sun.star.awt.Rectangle oRect = createUnoStruct("com.sun.star.awt.Rectangle") With oRect .X = nX .Y = nY .Width = nWidth .Height = nHeight End With MakeRect() = oRect End Function 配列の最後に要素を追加
Variant 型もしくは単一の型の配列でしか使えません。 Function array_push( sourceArray, Item ) nU = UBound(sourceArray) ReDim Preserve sourceArray(nU+1) sourceArray(nU+1) = Item End Function ファイルを開くダイアログを開いて、選択されたファイル URL を取得
用途に応じてフィルタを追加して使用してください。 Function FileSelection() As String Dim oFilePicker As Object Dim sFileURL As String Dim sFiles As Variant Dim nAccept As Integer Dim nAny(0) As Long nAny(0) = _ com.sun.star.ui.dialogs.TemplateDescription.FILEOPEN_SIMPLE oFilePicker = _ createUnoService("com.sun.star.ui.dialogs.FilePicker") With oFilePicker .Initialize( nAny() ) .AppendFilter( "All Files (*.*)", "*.*" ) .setCurrentFilter ( "All Files (*.*)" ) End With nAccept = oFilePicker.execute() If nAccept = 1 Then ' changed = 1 sFiles = oFilePicker.getFiles() sFileURL = sFiles(0) FileSelection() = sFileURL End If End Function |