OOoMacrobbs

new_OOo3 (2009-03-25 (水) 09:52:29)

sub Main

dim document as object
dim dispatcher as object

document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")

dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "ToPoint"
args1(0).Value = "$A$1"

dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())

dim args2(0) as new com.sun.star.beans.PropertyValue
args2(0).Name = "Color"
args2(0).Value = RGB(0,255,0)　’←赤：(255,0,0)　青：(0,0,255)

dispatcher.executeDispatch(document, ".uno:Color", "", 0, args2())

end sub

マルチバイト文字列のエスケープ

はにゃ?? (2007-11-16 (金) 21:49:28)

設定ファイルにマルチバイト文字をエスケープして入力したいときの文字列変換用。

Sub LabelConvert
  sLabel = "マルチバイト文字列"
  
  sLabel = EscapeString(sLabel)
  For i = 1 To Len(sLabel)
    sChar = Mid(sLabel,i,1)
    If Asc(sChar) < 127 Then
      sConverted = sConverted & sChar
    Else
      sConverted = sConverted & "&#x" & Hex(Asc(sChar)) & ";"
    End If
  Next i
  
  InputBox ,,sConverted
End Sub

' & &amp;, < &lt;, > &gt; " &quot; ' &apos;
Function EscapeString( sString ) As String
  sTxt = sString
  sSearch = Array("&","<",">","'","""")
  sReplace = Array("&amp;","&lt;","&gt;","&apos;","&quot;")
  For i = 0 To 4
    sSearchString = sSearch(i)
    nPos = InStr(sTxt,sSearchString)
    nSearchLen = Len(sSearchString)
    sReplaceString = sReplace(i)
    nReplaceLen = Len(sReplaceString)
    While nPos <> 0
      sTxt = Mid(sTxt,1,nPos -1) & sReplaceString & Mid(sTxt,nPos +nSearchLen)
      nPos = InStr(nPos +nReplaceLen,sTxt,sSearchString)
    WEnd
  Next i
  EscapeString = sTxt
End Function

Writer ハイパーリンクの削除

はにゃ?? (2007-11-08 (木) 18:48:57)

Writer でリンクを設定したあとで文章をつなげて書くとずっとリンクが付いてくる。リンクの部分削除がうまくできないのでマクロで行う。
Sub removeHyperLink
  oDoc = ThisComponent
  oSelection = oDoc.getCurrentSelection()
  If oSelection.supportsService("com.sun.star.text.TextRanges") Then
    oRange = oSelection.getByIndex(0)
    With oRange
      .HyperLinkURL = ""
      .HyperLinkTarget = ""
      .HyperLinkName = ""
    End With
  End If
End Sub

ハイパーリンクの削除

hyperlink can not be removed by hyperlink dialogue
- http://qa.openoffice.org/issues/show_bug.cgi?id=7311

また、Ctrl + Shift + Space で書式をデフォルトに戻すとハイパーリンクが消えるそうです。

はにゃ?? 2007-11-12 (月) 01:09:23

配列クイックソート文字列用

はにゃ?? (2007-09-21 (金) 01:57:10)

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

配列クイックソート数値用

はにゃ?? (2007-09-21 (金) 01:56:07)

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

コマンド実行用

はにゃ?? (2007-06-13 (水) 21:00:55)

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

パス置換用

はにゃ?? (2006-11-14 (火) 03:01:32)

Function GetSubstitutedPath( sPath As String )
  GetSubstitutedPath() = CreateUnoService( _
    "com.sun.star.util.PathSubstitution").substituteVariables( sPath,true )
End Function

sPath = GetSubstitutedPath( "$(inst)/program" )

など結構利用できる。
http://api.openoffice.org/docs/common/ref/com/sun/star/util/PathSubstitution.html

パス設定取得用

はにゃ?? (2006-11-14 (火) 02:40:56)

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 用

はにゃ?? (2006-11-12 (日) 22:17:46)

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 用

はにゃ?? (2006-11-12 (日) 22:16:43)

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

長いテキスト表示用ダイアログコピーボタン付き

はにゃ?? (2006-11-12 (日) 02:12:34)

コピーボタンを付けた長いテキスト表示用ダイアログ 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

長いテキスト表示用ダイアログ

はにゃ?? (2006-11-12 (日) 00:25:27)

改行を含む長いテキストを表示するときに

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 作成２

はにゃ?? (2006-11-11 (土) 23:48:44)

ランタイムでコントロールを作成するときに、モデルオブジェクトのプロパティを設定する必要があるとき用

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 作成

はにゃ?? (2006-11-11 (土) 23:47:43)

ランタイムでコントロールを作成するときに

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 用

はにゃ?? (2006-11-11 (土) 23:46:18)

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

配列の最後に要素を追加

はにゃ?? (2006-11-08 (水) 02:44:35)

Variant 型もしくは単一の型の配列でしか使えません。

Function array_push( sourceArray, Item )
  nU = UBound(sourceArray)
  ReDim Preserve sourceArray(nU+1)
  sourceArray(nU+1) = Item
End Function

ファイルを開くダイアログを開いて、選択されたファイル URL を取得

はにゃ?? (2006-11-08 (水) 02:37:17)

用途に応じてフィルタを追加して使用してください。

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

OOoMacrobbs

Menu

Search

recent(15)

OOoBaic マクロ掲示板

株価取得マクロ

文字に色をつけるマクロ