Top > OOoMacrobbs

OOoBaic マクロ掲示板 Edit

マクロ投稿用。




Xorshift Edit

もりお (2011-10-22 (Sat) 05:48:44)

ビットシフトを使っています。

Sub Main ()
  x = CreateXorshift ()
  MsgBox(XorshiftNext(x, 0, 100))
End Sub

Type Xorshift
  X&
  Y&
  Z&
  W&
End Type

Function CreateXorshift ()
  ins = New Xorshift
  ins.X = 123456789
  ins.Y = 362436069
  ins.Z = 521288629
  ins.W = 88675123
  CreateXorshift = ins
End Function

Function XorshiftGenerate(ins)
  t& = ins.X Xor ShiftLeft(ins.X, 11)
  ins.X = ins.Y
  ins.Y = ins.Z
  ins.Z = ins.W
  ins.W = (ins.W Xor ShiftRight(ins.W, 19)) Xor (t Xor ShiftRight(t, 8))
  XorshiftGenerate = ShiftRight(ins.W, 0)
End Function

Function XorshiftNext&(ins, min, max)
  m# = 2 ^ 32
  dif# = max - min
  lim# = m - Mod2(m, dif)
  n# = 0
  Do
    n = XorshiftGenerate(ins)
  Loop While n >= lim
  XorshiftNext = Mod2(n, dif) + min
End Function

Function Mod2(a, b)
  Mod2 = a - (Fix(a / b) * b)
End Function

Base64エンコード・デコード/Base32エンコード・デコード Edit

もりお (2011-10-22 (Sat) 05:43:11)
動的配列を使っています。

2011/12/04 15:27:06.99

BaseAddPad関数で呼んでいるCreateString関数を記載するのを忘れていましたので補いました。

Const Base64MapChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Const Base32MapChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"

Sub Main
  a = Base64Encode("foobar")
  MsgBox(a)
  
  a = Base64Decode(a)
  MsgBox(a)
  
  a = Base32Encode(a)
  MsgBox(a)
  
  a = Base32Decode(a)
  MsgBox(a)
End Sub

Function CreateString(c, num)
  s = ""
  p = c
  n = num
  Do While (n > 0)
    If ((n And 1) = 1) Then
      s = s & p
    End If
    p = p & p
    n = n \ 2
  Loop
  CreateString = s
End Function

Function StringToBytes(s)
  list = CreateList()
  For i = 1 To Len(s)
    b = Asc(Mid (s, i, 1))
    ListAdd(list, b \ &H100)
    ListAdd(list, b And &HFF)
  Next
  StringToBytes = ListToArray(list)
End Function

Function BytesToString(bytes)
  list = CreateList()
  For i = 0 To UBound(bytes) - 1 Step 2
    ListAdd(list, Chr((bytes(i) * &H100) + bytes(i + 1)))
  Next
  BytesToString = Join(ListToArray(list), "")
End Function

Function Base64Encode(str)
  Base64Encode = BaseEncode(str, 8, 6, 4, Base64MapChars)
End Function

Function Base64Decode(str)
  Base64Decode = BaseDecode(str, 6, 8, Base64MapChars)
End Function

Function Base32Encode(str)
  Base32Encode = BaseEncode(str, 8, 5, 8, Base32MapChars)
End Function

Function Base32Decode(str)
  Base32Decode = BaseDecode(str, 5, 8, Base32MapChars)  
End Function

Function BaseEncode(str, srcBit, dstBit, padLen, mapChars)
  BaseEncode = BaseAddPad(BaseBytesToString(BaseBytesConvert(srcBit, dstBit, StringToBytes(str)), mapChars), padLen)
End Function

Function BaseDecode(str, srcBit, dstBit, mapChars)
  BaseDecode = BytesToString(BaseBytesConvert(srcBit, dstBit, BaseStringToBytes(BaseDelPad(str), mapChars)))
End Function

Function BaseAddPad(str, num)
  l = Len(str) Mod num
  If l > 0 Then
    BaseAddPad = str & CreateString("=", num - l)
  Else
    BaseAddPad = str
  End If
End Function

Function BaseDelPad(str)
  BaseDelPad = Replace(str, "=", "")
End Function

Function BaseBytesToString (bytes, mapChars)
  Dim map(Len(mapChars) - 1)
  For i = 0 To Len(mapChars) - 1
    map(i) = Mid(mapChars, i + 1, 1)
  Next
  Dim a(UBound(bytes))
  For i = 0 To UBound(bytes)
    a(i) = map(bytes(i))
  Next
  BaseBytesToString = Join(a, "")
End Function

Function BaseStringToBytes (str, mapChars)
  Dim map(126)
  For i = 0 To UBound(map)
    map(i) = -1
  Next
  For i = 0 To Len(mapChars) - 1
    map(Asc(Mid(mapChars, i + 1, 1))) = i
  Next
  Dim a(Len(str) - 1)
  For i = 0 To Len(str) - 1
    a(i) = map(Asc(Mid(str, i + 1, 1)))
  Next
  BaseStringToBytes = a
End Function

Function BaseBytesConvert(srcBit, dstBit, bytes)
  list = CreateList()
  mask = (2 ^ dstBit) - 1
  buf = 0
  move = 0
  For i = 0 To UBound(bytes)
    buf = ((buf And ((2 ^ move) - 1)) * (2 ^ srcBit)) + bytes(i)
    move = move + srcBit
    Do While move >= dstBit
      move = move - dstBit
      ListAdd(list, (buf \ (2 ^ move)) And mask)
    Loop
  Next
  If srcBit > dstBit Then
    If move > 0 Then
      ListAdd(list, (buf * (2 ^ (dstBit - move))) And mask)
    End If
  End If
  BaseBytesConvert = ListToArray(list)
End Function

ビットシフト Edit

もりお (2011-10-22 (Sat) 05:35:57)

Function ShiftRight#(value&, number%)
  n% = number Mod 32
  If n = 0 Then
    If (value And &H80000000) <> 0 Then
      ShiftRight = (2 ^ 32) + value
    Else
      ShiftRight = value
    End If
    Exit Function
  End If
  v& = 0
  If n < 31 Then
    v = (value And (Not &H80000000)) \ (2 ^ n)
  End If
  If (value And &H80000000) <> 0 Then
    v = v Or (2 ^ (31 - n))
  End If
  ShiftRight = v
End Function

Function ShiftLeft&(value&, number%)
  n% = number Mod 32
  If n = 0 Then
    ShiftLeft = value
    Exit Function
  End If
  mask& = (2 ^ (31 - n)) - 1
  v& = (value And mask) * (2 ^ n)
  If (value And (2 ^ (31 - n))) <> 0 Then
    v = v Or &H80000000
  End If
  ShiftLeft = v
End Function

動的配列 Edit

もりお (2011-10-22 (Sat) 05:23:42)

Sub Main ()
  list = CreateList()
  For i = 1 To 10
    ListAdd(list, i)
  Next
  For i = 1 To 5
    ListDel(list, 0)
  Next
  MsgBox(Join(ListToArray(list), " "))
End Sub

Type ArrayList
  Data
  Count
  Size
End Type

Function CreateList(Optional size)
  If IsMissing(size) Then size = 10
  ins = New ArrayList
  ins.Count = 0
  ins.Size = size
  Dim data(size - 1)
  ins.Data = data
  CreateList = ins
End Function

Sub ListAdd(ins, elm)
  If ins.Size <= ins.Count Then
    ins.Size = ins.Size * 2
    data = ins.Data
    ReDim Preserve data(ins.Size - 1)
    ins.Data = data
  End If
  ins.Data(ins.Count) = elm
  ins.Count = ins.Count + 1
End Sub

Sub ListDel(ins, idx)
  If idx >= ins.Count Then Exit Sub
  For i = idx To ins.Count - 2
    ins.Data(i) = ins.Data(i + 1)
  Next
  ins.Data(ins.Count - 1) = Empty
  ins.Count = ins.Count - 1
  If ins.Count < (ins.Size \ 2) Then
    ins.Size = ins.Size \ 2
    data = ins.Data
    ReDim Preserve data(ins.Size - 1)
    ins.Data = data
  End If
End Sub

Function ListToArray(ins)
  If ins.Count = 0 Then
    ListToArray = Array()
    Exit Function
  End If
  data = ins.Data
  ReDim Preserve data(ins.Count - 1)
  ListToArray = data
End Function

マージソート Edit

もりお (2011-10-18 (Tue) 07:16:31)

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

株価取得マクロ Edit

new_OOo3 (2009-04-23 (木) 11:42:07)

下記URLにて、会社毎の株価を簡単に取得できるマクロを組みました。
皆様、一度試して、コメントを頂けます様お願いします。

URL : http://openoffice3.web.fc2.com/


文字に色をつけるマクロ Edit

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


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

はにゃ?? (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 ハイパーリンクの削除 Edit

はにゃ?? (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
  • ハイパーリンクの削除

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

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

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

はにゃ?? (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

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

はにゃ?? (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

コマンド実行用 Edit

はにゃ?? (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

パス置換用 Edit

はにゃ?? (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


パス設定取得用 Edit

はにゃ?? (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 用 Edit

はにゃ?? (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 用 Edit

はにゃ?? (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

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

はにゃ?? (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

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

はにゃ?? (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 作成 2 Edit

はにゃ?? (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 作成 Edit

はにゃ?? (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 用 Edit

はにゃ?? (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

配列の最後に要素を追加 Edit

はにゃ?? (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 を取得 Edit

はにゃ?? (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


Reload   New Lower page making Edit Freeze Diff Upload Copy Rename   Front page List of pages Search Recent changes Backup   Help   RSS of recent changes