Mit ComatePlus Image im Word-Header platzieren

Windowsspezifisches Forum , API ,..
Beiträge, die plattformübergreifend sind, gehören ins 'Allgemein'-Forum.
Benutzeravatar
mk-soft
Beiträge: 3695
Registriert: 24.11.2004 13:12
Wohnort: Germany

Re: Mit ComatePlus Image im Word-Header platzieren

Beitrag von mk-soft »

Hi Meier,

Wenn es mit VBA geht, geht es vielleicht auch mit VBScript.
Ich habe mein Modul 'ActiveScript' in der Beta Version schon gut am laufen.
In diesen kann man die Runtime Variablen von Purebasic verwenden und mit den AddOn 'SmartTags' Variablen von Type Variant austauschen.

Einfach ein Script schreiben und aufrufen.

Hier mal ein Anfang. (Update)

Code: Alles auswählen

;-TOP

; Comment   : Modul ActiveScipt Example 1

; Link to ActiveScript  : https://www.purebasic.fr/english/viewtopic.php?f=12&t=71399
; Link to VariantHelper : https://www.purebasic.fr/english/viewtopic.php?f=14&t=40150

; ***************************************************************************************

XIncludeFile "Modul_ActiveScript.pb"
XIncludeFile "Modul_SmartTags.pb"
XIncludeFile "VariantHelper_Include.pb"

UseModule ActiveScript
UseModule ActiveSmartTags

; -------------------------------------------------------------------------------------

Procedure ArrayToSafeArray(Array Strings.s(1), LBound = 0)
  Protected rgsabound.SAFEARRAYBOUND, *psa.SAFEARRAY, Index, UBound
  
  UBound = ArraySize(Strings())
  rgsabound\lLbound = LBound
  rgsabound\cElements = UBound + 1
 
  *psa = SafeArrayCreate_(#VT_VARIANT, 1, rgsabound)
  If *psa
    For Index = 0 To UBound
      *psa\pvData\Value[Index]\vt = #VT_BSTR
      *psa\pvData\Value[Index]\bstrVal = T_BSTR(Strings(Index))
    Next
    ProcedureReturn *psa
  Else
    ProcedureReturn 0
  EndIf
EndProcedure

; -------------------------------------------------------------------------------------

Procedure ListToSafeArray(List Strings.s(), LBound = 0)
  Protected rgsabound.SAFEARRAYBOUND, *psa.SAFEARRAY, Index, Size
  
  Size = ListSize(Strings())
  If Size
    rgsabound\lLbound = LBound
    rgsabound\cElements = Size
   
    *psa = SafeArrayCreate_(#VT_VARIANT, 1, rgsabound)
    If *psa
      index = 0
      ForEach Strings()
        *psa\pvData\Value[Index]\vt = #VT_BSTR
        *psa\pvData\Value[Index]\bstrVal = T_BSTR(Strings())
        index + 1
      Next
      ProcedureReturn *psa
    Else
      ProcedureReturn 0
    EndIf
  Else
    ProcedureReturn 0
  EndIf
  
EndProcedure

; -------------------------------------------------------------------------------------

Procedure SafeArrayToVariant(*Var.Variant, *SafeArray.SAFEARRAY)
  If *Var And *SafeArray
    *Var\vt = #VT_ARRAY | #VT_VARIANT
    *Var\parray = *SafeArray
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf
EndProcedure

; -------------------------------------------------------------------------------------

Global vbs.s, name.s, *psa_files, *psa_text
Global Dim files.s(3)
Global NewList Text.s()

; Varible als Rumtime definieren zum Zugriff aus VB-Script
Runtime name

; Daten anlegen
name = "test.xls"
files(0) = "Image-1.jpg"
files(1) = "Image-2.jpg"
files(2) = "Image-3.jpg"
files(3) = "Image-4.jpg"

AddElement(Text()) : Text() = "Hello World"
AddElement(Text()) : Text() = "I like Purebasic"

; Das Array in ein SafeArray wandeln
*psa_files = ArrayToSafeArray(files())
; Das SafeArray zum SmartTag zuweisen
SafeArrayToVariant(SmartTags("files"), *psa_files)

; Die Liste in ein SafeArray wandeln
*psa_text = ListToSafeArray(Text())
; Das SafeArray zum SmartTag zuweisen
SafeArrayToVariant(SmartTags("texte"), *psa_text)

; VB-Script schreiben
vbs + "Dim name, file, files, texte, result" + #LF$
vbs + "" + #LF$
vbs + "name = Runtime.String('name')" + #LF$
vbs + "result = 'Name: ' & name & vbNewLine" + #LF$
vbs + "" + #LF$
vbs + "files = SmartTags('files')" + #LF$
vbs + "texte = SmartTags('texte')" + #LF$
vbs + "" + #LF$
vbs + "result = result & vbNewline & 'Array:' & vbNewline" + #LF$
vbs + "If IsArray(files) Then" + #LF$
vbs + "  For Each file In Files" + #LF$
vbs + "    result = result & file & vbNewLine" + #LF$
vbs + "   Next" + #LF$
vbs + "Else" + #LF$
vbs + "  result = 'No Array'" + #LF$
vbs + "End If" + #LF$
vbs + "" + #LF$
vbs + "result = result & vbNewline & 'List:' & vbNewline" + #LF$
vbs + "If IsArray(texte) Then" + #LF$
vbs + "  result = result & texte(0) & vbNewLine" + #LF$
vbs + "  result = result & texte(1) & vbNewLine" + #LF$
vbs + "Else" + #LF$
vbs + "  result = 'No Array'" + #LF$
vbs + "End If" + #LF$
vbs + "" + #LF$
vbs + "MsgBox result" + #LF$
vbs + "" + #LF$

vbs = ReplaceString(vbs, "'", #DQUOTE$)

; VB-Script ausführen 
If NewActiveScript()
  AddObject("SmartTags", NewSmartTags())
  Debug "**********************************"
  Debug vbs
  Debug "**********************************"
  ParseScriptText(vbs)
  Debug "**********************************"
  FreeActiveScript()
EndIf
Alles ist möglich, fragt sich nur wie...
Projekte ThreadToGUI / EventDesigner V3 / OOP-BaseClass-Modul
Downloads auf MyWebspace / OneDrive
Meier
Beiträge: 21
Registriert: 18.01.2018 17:02

Re: Mit ComatePlus Image im Word-Header platzieren

Beitrag von Meier »

Hallo mk-soft,

danke für deinen Ansatz. Ich werde es gleich ausprobieren, wenn ich wieder da bin. Bin zur Zeit nur mit Smartphone bewaffnet außer Landes.

@Peter: Ich habe gesehen, dass du auch tolle Lösungen mit XML-Dateien + ComatePlus gepostet hast. Vielleicht wäre das ein weiterer Ansatz?

Viele Grüße
Meier
Meier
Beiträge: 21
Registriert: 18.01.2018 17:02

Re: Mit ComatePlus Image im Word-Header platzieren

Beitrag von Meier »

Hallo zusammen,

@mk-soft: Ich habe es mir angesehen, aber so ganz haben Anpassungen bei mir noch nicht funktioniert...

Dann bin ich aber über die Lösung zu dem Ansatz von Peter gestolpert... :bounce:

Ich muss nicht in die nächste Zeile, sondern in die untere Zelle. Denn drumherum ist eine Tabelle, bei der die Linien weggemacht wurden.

Ich muss also das Tabellen-Objekt behandeln. Und dann war es ganz einfach.

Hier der Ansatz von Peter mit meinen Änderungen:

Code: Alles auswählen

XIncludeFile "../COMatePLUS.pbi"

EnableExplicit

Procedure InsertImageToWordHeader(WordFilename.s, ImageFilename.s)
 
  Protected oWordApplication.COMateObject
  Protected oActiveDocument.COMateObject
  Protected oSection.COMateObject
  Protected oHeader.COMateObject
  Protected oRange.COMateObject
  Protected oRange2.COMateObject
  Protected oTable.COMateObject
  
 
  Debug "CreateObject"
  oWordApplication = COMate_CreateObject("Word.Application")
  Debug COMate_GetLastErrorDescription()
 
  If oWordApplication
   
    Debug "Application.Visible=#True"
    oWordApplication\SetProperty("Application\Visible=#True")
    Debug COMate_GetLastErrorDescription()
   
    ; Open the document.
    Debug "Documents\Open"
    oWordApplication\Invoke("Documents\Open('" + WordFilename + "')")
    Debug COMate_GetLastErrorDescription()
   
    ; ####
   
    Debug "oActiveDocument"
    oActiveDocument = oWordApplication\GetObjectProperty("ActiveDocument")
    Debug COMate_GetLastErrorDescription()
   
    If oActiveDocument
     
      Debug "oSection..."
      oSection = oActiveDocument\GetObjectProperty("Sections(1)")
      Debug COMate_GetLastErrorDescription()
     
      If oSection
       
        Debug "oHeader..."
        oHeader = oSection\GetObjectProperty("Headers(1)") ; 1 = wdHeaderFooterPrimary
        Debug COMate_GetLastErrorDescription()
       
        If oHeader
        
          Debug "oRange..."
          oRange = oHeader\GetObjectProperty("Range")
          Debug COMate_GetLastErrorDescription()
         
          If oRange
            
            Debug "oTable..."
            oTable = oRange\GetObjectProperty("Tables(1)")
            Debug COMate_GetLastErrorDescription()
            
            If oTable
              
              Debug "oRange2"
              oRange2 = otable\GetObjectProperty("Cell(2,1)\Range")
              Debug COMate_GetLastErrorDescription()
              
              If oRange2
                
                Debug "AddPicture..."
                oRange2\Invoke("InlineShapes\AddPicture('" + ImageFilename + "')")
                Debug COMate_GetLastErrorDescription()
                
                oRange2\Release()
              Else
                Debug "!oRange2"
              EndIf
              oTable\Release()
            Else
              Debug "!oTable"
            EndIf
            oRange\Release()
          Else
            Debug "!oRange"
          EndIf
          oHeader\Release()
        Else
          Debug "!oHeader"
        EndIf
        oSection\Release()
      Else
        Debug "!oSection"
      EndIf
      oActiveDocument\Release()
    Else
      Debug "!oActiveDocument"
    EndIf
   
    oWordApplication\Release()
   
    Debug "Ready!"
   
  Else
   
    Debug "Failed to create application object."
    Debug COMate_GetLastErrorDescription()
   
  EndIf
 
EndProcedure

InsertImageToWordHeader("D:\test.xml", "D:\test.jpg")


Vielen Dank euch beiden und viele Grüße

Meier
Antworten