Malicious Office (OLE) / .DOT — malware analysis report

Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "modCVS"
Option Explicit

Public Const versionMajor = 4
Public Const versionMinor = 7
Public Const versionPatch = 4
Public Const versionDate = "25.03.2010"
Public Const sApplicationName = "M1 - Der Arztrechner"
Public sProduktname As String
Public sPraxisArchiveVersion As String
'Modul zum reibungslosen transfer des vba-codes in separate/diffbare dateien
'09.11.2009 (rsc) in frmPAImportOK wg. PraxisArchive Zeile auskommentiert.
'14.01.2010 (rsc) startDataTransferOLE
'14.01.2010 (rsc) TransferOLE
'14.01.2010 (rsc) RequestOLE
'14.01.2010 (rsc) VorlageOLE1
'14.01.2010 (rsc) AutoTextTransferOLE1
'14.01.2010 (rsc) AutoTextRequestOLE1
'15.01.2010 (rsc) Produktname DDE_DATA
'28.01.2010 (rsc) Tippfehler Karteikarte behoben
'12.02.2010 (rsc) PraxisArchiveVersion eingebaut
'25.03.2010 (rsc) Produktname auch in den Vorlagen eingebaut

Sub buildM1LibStdVersion()
    Dim dirpath As String
    Dim path As String
    dirpath = ThisDocument.path
    If Not (VBA.Right(dirpath, 1) = "\") Then
        dirpath = dirpath & "\modules\"
    Else
        dirpath = dirpath & "modules\"
    End If
    
    Dim componentNames As Collection
    Set componentNames = New Collection
    
    'nur in logging-version
    componentNames.Add "logger.bas"
    'ende nur in logging version
    componentNames.Add "clsLogEntry.cls"
    componentNames.Add "modAdresseingabe.bas"
    componentNames.Add "modDrucken.bas"
    componentNames.Add "modEinfügenDiktate.bas"
    componentNames.Add "ergebnis.bas"
    componentNames.Add "FormularKästchen.bas"
    componentNames.Add "modFormularÜbertragung.bas"
    componentNames.Add "frmTemplateSelection.frm"
    componentNames.Add "frmPAImportWait.frm"
    componentNames.Add "Info.bas"
    componentNames.Add "modKarteikarte.bas"
    componentNames.Add "M1ATxtFrm.frm"
    componentNames.Add "modDateiMenu.bas"
    componentNames.Add "modDocument.bas"
    componentNames.Add "modM1Autotext.bas"
    componentNames.Add "modPraxisarchiv.bas"
    componentNames.Add "modSendToM1.bas"
    componentNames.Add "modTemplate.bas"
    componentNames.Add "modTools.bas"
    componentNames.Add "modTelemedVersand.bas"
    componentNames.Add "modTextNachM1.bas"
    componentNames.Add "UnifaceList.cls"
    componentNames.Add "modAddIns.bas"
    componentNames.Add "modPraxisarchivInit.bas"
    componentNames.Add "modSerienbrief.bas"
    componentNames.Add "modStartup.bas"
    componentNames.Add "modM1Makros.bas"
    componentNames.Add "modMacroTransfer.bas"
    componentNames.Add "modButtonMacros.bas"
    componentNames.Add "modMenuMacros.bas"
    componentNames.Add "frmPAImportOK.frm"
    componentNames.Add "modReferences.bas"
    componentNames.Add "modMenu.bas"
    componentNames.Add "frmAddInManagement.frm"
    componentNames.Add "modReplaceForVBA5.bas"
        
    Dim name As Variant
    Dim vbc As VBComponent
    For Each name In componentNames
        'Set vbc = ThisDocument.VBProject.VBComponents.Import(dirpath & name)
        ThisDocument.VBProject.VBComponents.Import (dirpath & name)
        'If (vbc.name = "modMenu") Then
        '    buildMenu
        'End If
    Next name
    buildMenu

    setDocumentProperties
End Sub


'es wird natürlich davon ausgegangen, dass dieses modul bereits importiert wurde..
Sub buildM1LibLogVersion()
    Dim dirpath As String
    Dim path As String
    dirpath = ThisDocument.path
    If Not (VBA.Right(dirpath, 1) = "\") Then
        dirpath = dirpath & "\modules\"
    Else
        dirpath = dirpath & "modules\"
    End If
    
    Dim componentNames As Collection
    Set componentNames = New Collection
    
    'nur in logging-version, reihenfolge wichtig !
    componentNames.Add "QueueItem.cls"
    componentNames.Add "Queue.cls"
    componentNames.Add "clsLogEntry.cls"
    componentNames.Add "clsLog.cls"
    componentNames.Add "modAutoMacro.bas"
    'ende nur in logging version

    componentNames.Add "modAdresseingabe.bas"
    componentNames.Add "modDrucken.bas"
    componentNames.Add "modEinfügenDiktate.bas"
    componentNames.Add "ergebnis.bas"
    componentNames.Add "FormularKästchen.bas"
    componentNames.Add "modFormularÜbertragung.bas"
    componentNames.Add "frmTemplateSelection.frm"
    componentNames.Add "frmPAImportWait.frm"
    componentNames.Add "Info.bas"
    componentNames.Add "modKarteikarte.bas"
    componentNames.Add "M1ATxtFrm.frm"
    componentNames.Add "modDateiMenu.bas"
    componentNames.Add "modDocument.bas"
    componentNames.Add "modM1Autotext.bas"
    componentNames.Add "modPraxisarchiv.bas"
    componentNames.Add "modSendToM1.bas"
    componentNames.Add "modSerienbrief.bas"
    componentNames.Add "modTemplate.bas"
    componentNames.Add "modTools.bas"
    componentNames.Add "modTelemedVersand.bas"
    componentNames.Add "modTextNachM1.bas"
    componentNames.Add "UnifaceList.cls"
    componentNames.Add "modAddIns.bas"
    componentNames.Add "modPraxisarchivInit.bas"
    componentNames.Add "modStartup.bas"
    componentNames.Add "modM1Makros.bas"
    componentNames.Add "modMacroTransfer.bas"
    componentNames.Add "modButtonMacros.bas"
    componentNames.Add "modMenuMacros.bas"
    componentNames.Add "frmPAImportOK.frm"
    componentNames.Add "modReferences.bas"
    componentNames.Add "modMenu.bas"
    componentNames.Add "frmAddInManagement.frm"
    componentNames.Add "modReplaceForVBA5.bas"
        
    Dim name As Variant
    Dim vbc As VBComponent
    For Each name In componentNames
        'Set vbc = ThisDocument.VBProject.VBComponents.Import(dirpath & name)
        ThisDocument.VBProject.VBComponents.Import (dirpath & name)
        'If (vbc.name = "modMenu") Then
        '    initLogger
        '    buildMenu
        'End If
    Next name
    initLogger
    buildMenu
    
    setDocumentProperties
End Sub

Sub initLogger()
    Set logger = New clsLog
End Sub

Sub setDocumentProperties()
    'vbprojekt-name
    ThisDocument.VBProject.name = "M1_Arztbriefschreibung"
    'document-properties
    ThisDocument.BuiltInDocumentProperties("Title").Value = "M1_Arztbriefschreibung"
    ThisDocument.BuiltInDocumentProperties("subject").Value = "M1-Word Schnittstelle"
    ThisDocument.BuiltInDocumentProperties("Author").Value = "Martin Scheugenpflug"
    ThisDocument.BuiltInDocumentProperties("Manager").Value = "Dr. Martin Dahmen"
    ThisDocument.BuiltInDocumentProperties("Company").Value = "CompuMED Praxiscomputer GmbH & Co. KG"
    ThisDocument.BuiltInDocumentProperties("Comments").Value = "Globale Word-Vorlage, die Word steuert und die Kommunikation mit dem Praxisverwaltungssystem M1 realisiert."
    
    Dim versionString As String
    versionString = "V" & versionMajor & "." & versionMinor & " draft "
    If (versionPatch > 1) Then
        versionString = versionString & versionPatch
    End If
    ThisDocument.CustomDocumentProperties.Add name:="Version", _
                                                LinkToContent:=False, _
                                                Type:=msoPropertyTypeString, _
                                                Value:=versionString
    ThisDocument.CustomDocumentProperties.Add name:="vom", _
                                                LinkToContent:=False, _
                                                Type:=msoPropertyTypeString, _
                                                Value:=versionDate
    ThisDocument.CustomDocumentProperties.Add name:="VersionMajor", _
                                                LinkToContent:=False, _
                                                Type:=msoPropertyTypeNumber, _
                                                Value:=versionMajor
    ThisDocument.CustomDocumentProperties.Add name:="VersionMinor", _
                                                LinkToContent:=False, _
                                                Type:=msoPropertyTypeNumber, _
                                                Value:=versionMinor
    ThisDocument.CustomDocumentProperties.Add name:="VersionPatch", _
                                                LinkToContent:=False, _
                                                Type:=msoPropertyTypeNumber, _
                                                Value:=versionPatch
End Sub

Sub buildMenu()
    modMenu.createM1CommandBar
    modMenu.createM1SerienCommandBar
    modMenu.createM1MenuBar
End Sub


Sub exportEverything()
    Dim dirpath As String
    Dim path As String
    dirpath = ThisDocument.path
    If Not (VBA.Right(dirpath, 1) = "\") Then
        dirpath = dirpath & "\modules\"
    Else
        dirpath = dirpath & "modules\"
    End If
    Dim vbc As Variant  'VBComponent
    For Each vbc In ThisDocument.VBProject.VBComponents
        Select Case vbc.Type:
            'Case vbext_ct_ActiveXDesigner:
            '    path = dirpath & vbc.name & ".axd"
            '    Debug.Print path
            '    vbc.Export path
            Case vbext_ct_ClassModule:
                path = dirpath & vbc.name & ".cls"
                Debug.Print path
                vbc.Export path
            Case vbext_ct_Document:
                'nix tun..
            Case vbext_ct_MSForm:
                path = dirpath & vbc.name & ".frm"
                Debug.Print path
                vbc.Export path
            Case vbext_ct_StdModule:
                path = dirpath & vbc.name & ".bas"
                Debug.Print path
                vbc.Export path
            Case Else:
                'nix tun..
        End Select
    Next vbc
End Sub

Attribute VB_Name = "QueueItem"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Option Explicit
' Keep track of the next queue item,
' and the text of this item.
Public NextItem As QueueItem
Public Value As Variant

Attribute VB_Name = "Queue"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Option Explicit

Private qFront As QueueItem
Private qRear As QueueItem

Public Sub Add(varNewItem As Variant)
    Dim qNew As New QueueItem
    Set qNew.Value = varNewItem
    ' What if the queue is empty? Better point
    ' both the front and rear pointers at the
    ' new item.
    If QueueEmpty Then
        Set qFront = qNew
        Set qRear = qNew
    Else
        Set qRear.NextItem = qNew
        Set qRear = qNew
    End If
End Sub

Public Function Remove() As Variant
    ' Remove an item from the head of the
    ' list, and return its value.
    If QueueEmpty Then
        Remove = Null
    Else
        Set Remove = qFront.Value
        ' If there’s only one item
        ' in the queue, qFront and qRear
        ' will be pointing to the same node.
        ' Use the Is operator to test for that.
        If qFront Is qRear Then
            Set qFront = Nothing
            Set qRear = Nothing
        Else
            Set qFront = qFront.NextItem
        End If
    End If
End Function

Property Get QueueEmpty() As Boolean
    ' Return True if the queue contains
    ' no items.
    QueueEmpty = ((qFront Is Nothing) And (qRear Is Nothing))
End Property

Attribute VB_Name = "clsLogEntry"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Option Explicit

'Public Enum Loglevel
'    wddebug = 1
'    wdinfo     '2
'    wdwarn     '3
'    wderror    '4
'    wdfatal    '5
'End Enum

Private m_level As Integer
Private m_module As String
Private m_function As String
Private m_message As String
Private m_document As String

Private Sub Class_Initialize()
    m_level = 3
    m_module = ""
    m_function = ""
    m_message = ""
    m_document = ""
End Sub

Public Sub setLevel(l As Integer)
    m_level = l
End Sub

Public Function getLevel() As Integer
    getLevel = m_level
End Function

Public Sub setModule(m As String)
    m_module = m
End Sub

Public Function getModule() As String
    getModule = m_module
End Function

Public Sub setFunction(f As String)
    m_function = f
End Sub

Public Function getFunction() As String
    getFunction = m_function
End Function

Public Sub setMessage(msg As String)
    m_message = msg
End Sub

Public Function getMessage() As String
    getMessage = m_message
End Function

Public Sub setDocumentName(name As String)
    m_document = name
End Sub

Public Function getDocumentName() As String
    getDocumentName = m_document
End Function

Attribute VB_Name = "clsLog"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Option Explicit
'enums gibts in w97 nicht !!!
'Public Enum Loglevel
'    wddebug = 1
'    wdinfo
'    wdwarn
'    wderror
'    wdfatal
'End Enum

Private m_loglevel As Integer
Private m_fileHandle As Integer
Private m_qEntries As Queue
Private m_drainKnown As Boolean
Private m_iEntryCount As Integer

Private Sub Class_Initialize()
    m_loglevel = 3 'standard-level
    m_fileHandle = 0
    Set m_qEntries = New Queue
    m_iEntryCount = 0
    m_drainKnown = False
End Sub

Private Sub Class_Terminate()
    'datei ggf schliessen
    If (m_fileHandle <> 0) Then
        Close #m_fileHandle
    End If
End Sub

Public Sub log(entry As clsLogEntry)
    If (Not m_drainKnown) Then  ' sobald wir die datensenke kennen, aufhören zwischenzuspeichern
        If (m_iEntryCount < 100) Then   'bei 100 einträgen ist schluss mit caching
            m_qEntries.Add entry
        Else
            m_qEntries.Remove   'alte einträge sukzessive "vergessen"
            m_qEntries.Add entry
        End If
    Else
        If (entry.getLevel >= m_loglevel) Then
            Print #m_fileHandle, formatEntry(entry)
        End If
    End If
    m_iEntryCount = m_iEntryCount + 1
End Sub

Public Sub setLevel(l As Integer)
    m_loglevel = l
End Sub

Public Function getLevel() As Integer
    getLevel = m_loglevel
End Function

'wenn das schreiben in eine datei noch nicht angestossen wurde, kann hiermit der cache gelöscht werden
Public Sub clearCache()
    Set m_qEntries = New Queue
End Sub

Public Sub writeLog(id As String)
    If m_drainKnown Then    ' write log bereits aufgerufen
        Exit Sub
    End If
    'datei öffnen
    On Error GoTo failure
    m_fileHandle = VBA.FreeFile
    Dim filename As String
    filename = serverPath & "\Project\Winword\m1lib_" & id & ".log"
    Open filename For Output Access Write Lock Read Write As m_fileHandle
    Print #m_fileHandle, "LogLevel: " & getStringFromLevel(m_loglevel) & vbTab & "Cached " & m_iEntryCount & " Entries"
    'Print #m_fileHandle, "TimeStamp" & vbTab & "Level" & vbTab & "Module" & vbTab & "Proc" & vbTab & "Message"
    'alle zwischengespeicherten log-entries in datei schreiben
    Dim i As Integer
    Dim le As clsLogEntry

    Do While Not m_qEntries.QueueEmpty
        Set le = m_qEntries.Remove
        If (le.getLevel >= m_loglevel) Then
            Print #m_fileHandle, formatEntry(le)
        Else
        End If
    Loop

    Print #m_fileHandle, "End Log-Caching, start File-Logging "
    'zwischenspeichern abbrechen
    m_drainKnown = True
    'cache löschen
    Set m_qEntries = Nothing
Exit Sub
failure:
    MsgBox "M1Lib: Log: Class_Initialize: " & Err.number & vbCrLf & Err.Description
End Sub

'###################################################################
'wrapper
Public Sub logDebug(module As String, proc As String, msg As String)
    makeEntry 1, module, proc, msg
End Sub

Public Sub logInfo(module As String, proc As String, msg As String)
    makeEntry 2, module, proc, msg
End Sub

Public Sub logWarn(module As String, proc As String, msg As String)
    makeEntry 3, module, proc, msg
End Sub

Public Sub logError(module As String, proc As String, msg As String)
    makeEntry 4, module, proc, msg
End Sub

Public Sub logFatal(module As String, proc As String, msg As String)
    makeEntry 5, module, proc, msg
End Sub

'####################################################################################
'PRIVATE'S
Private Function serverPath() As String
'ServerPfad ermitteln
    serverPath = ""
    serverPath = System.PrivateProfileString("", _
            "HKEY_LOCAL_MACHINE\Software\CompuMED\M1", "RAS_LocalPath")

    If (serverPath = "") Then
        serverPath = System.PrivateProfileString("", _
            "HKEY_LOCAL_MACHINE\Software\CompuMED\M1", "ProgramPath")
    End If
End Function


Private Sub makeEntry(level As Integer, module As String, func As String, msg As String)
    Dim le As clsLogEntry
    Set le = New clsLogEntry
    le.setLevel level
    On Error GoTo errorhandler  'activedocument kann fehler generieren, falls keine dokumente da sind
    Dim docname As String
    docname = ActiveDocument.name
    le.setDocumentName docname
    On Error GoTo 0
    le.setModule module
    le.setFunction func
    le.setMessage msg
    Me.log le
Exit Sub
errorhandler:
Select Case Err.number
    Case 4248:
        docname = "-"
        Resume Next
    Case Else:
        MsgBox Err.number & vbCrLf & Err.Description
End Select
End Sub

Private Function formatEntry(entry As clsLogEntry) As String
    Dim timeStamp As String
    timeStamp = Time
    Dim logEntry As String
    logEntry = timeStamp & vbTab & getStringFromLevel(entry.getLevel)
    formatEntry = logEntry & vbTab & entry.getDocumentName & vbTab & entry.getModule & vbTab & entry.getFunction & vbTab & entry.getMessage
End Function

Private Function getStringFromLevel(level As Integer) As String
    Dim s As String
    Select Case level
        Case 1:
            s = "DEBUG"
        Case 2:
            s = "INFO"
        Case 3:
            s = "WARN"
        Case 4:
            s = "ERROR"
        Case 5:
            s = "FATAL"
    End Select
    getStringFromLevel = s
End Function

Attribute VB_Name = "modAutoMacro"
Option Explicit

Global logger As New clsLog

'AUTOMACROS: achtung: da diese vorlage zur laufzeit ein add-in ist,
'müssen wir autoexec und autoexit benutzen, und nicht autoopen und autoclose (wie bei doc's)


'hier wird alles erledigt, was wir machen möchten, wenn diese vorlage geladen wird.
'z.b. kontrollieren, ob die praxisarchiv-typ-bibliothek gelinkt ist
Sub AutoExec()
    'MsgBox "AutoExec"
    'logging initialisieren
    Set logger = New clsLog
End Sub

'autoexit wird erst dann ausgeführt, wenn dieses addin entladen wird
'vorher kann word schon alle dokumente geschlossen haben
'es taugt also nichts zur erkennung von "kreuz rechts oben"!!
Sub AutoExit()
    'ActiveDocument.Saved = False
    'SendKeys "{ESC}"
    'MsgBox "AutoExit"
End Sub



Attribute VB_Name = "modAdresseingabe"
Option Explicit

Public Sub Adresse(Maske$)
logger.logInfo "modAdresseingabe", "Adresse", "Proc start"
    Dim Empfaenger_Name As String
    Dim Empfaenger_Angaben As String
    Dim PLZ_Ort As String
    Dim Text_ As String
    Dim caption As String
    Dim dlg As Object
    Dim kanal As Variant
'MsgBox "Debug 1"
    Empfaenger_Name = WordBasic.[GetDocumentVar$]("Empfänger")
    Empfaenger_Angaben = WordBasic.[GetDocumentVar$]("Empfänger_Angaben")

If ((Empfaenger_Name <> "") And _
    (WordBasic.[FileNameFromWindow$]() = "") And _
    (Empfaenger_Angaben = "ja")) Then

    Text_ = "Für den von Ihnen ausgewählten Empfänger " + _
            Empfaenger_Name$ + _
            " sind in M1 noch keine Adressenangaben erfaßt." + VBA.Chr(13) + _
            VBA.Chr(13) + "Bitte vervollständigen Sie die Adresse:"

    WordBasic.BeginDialog 550, 225, "Microsoft Word"
        WordBasic.Text 25, 15, 500, 50, Text_
        WordBasic.Text 25, 83, 133, 13, "Straße / Hausnr.:"
        WordBasic.Text 25, 108, 135, 13, "Postleitzahl / Ort:"
        WordBasic.Text 25, 133, 64, 13, "Telefon:"
        WordBasic.Text 25, 158, 60, 13, "Anrede:"
        WordBasic.TextBox 165, 80, 365, 18, "strasse"
        WordBasic.TextBox 167, 105, 75, 18, "plz"
        WordBasic.TextBox 245, 105, 285, 18, "ort"
        WordBasic.TextBox 165, 130, 160, 18, "telefon"
        WordBasic.TextBox 165, 155, 365, 18, "anrede"
        WordBasic.OKButton 100, 195, 125, 21
        WordBasic.CancelButton 325, 194, 125, 21
    WordBasic.EndDialog

    ActiveWindow.WindowState = wdWindowStateMaximize
    
    Set dlg = WordBasic.CurValues.UserDialog

    If (WordBasic.Dialog.UserDialog(dlg)) Then
        WordBasic.setAutoText "Empfänger_Name", Empfaenger_Name, 1
        WordBasic.setAutoText "Empfänger_Anrede", dlg.anrede, 1
        PLZ_Ort = dlg.plz + " " + dlg.ort
        WordBasic.setAutoText "Empfänger_PLZ_Ort", PLZ_Ort, 1
        WordBasic.setAutoText "Empfänger_Straße_Nr", dlg.strasse, 1
        WordBasic.setAutoText "Empfänger_Anschrift", dlg.strasse + _
                        ", " + PLZ_Ort, 1
        WordBasic.setAutoText "Empfänger_Telnr", dlg.telefon, 1
        WordBasic.setAutoText "Empfänger_Adresse", Empfaenger_Name$ + _
                        VBA.Chr(13) + dlg.strasse + VBA.Chr(13) + PLZ_Ort, 1
        WordBasic.setAutoText "Empfänger_MW", "", 1
        ' das funktioniert nur im "normalen" dokument
        'ActiveDocument.Fields.Update
        'deswegen besserr das:
        modM1Autotext.fieldsUpdate
        WordBasic.SetTemplateDirty 0
    End If

End If


''' Anzeige des Dokuments in Layout-Ansicht und maximiert
With ActiveWindow
    If (.View.SplitSpecial = wdPaneNone) Then
        .ActivePane.View.Type = wdPageView
    Else
        .View.Type = wdPageView
    End If
    'Hier kann es unter office97 krachen
    '.View.ShowFieldCodes = False
    'deswegen unter word97 nichts machen
    modTools.deactivateFieldFunctions
End With
'MsgBox "Debug 2"
''' Falls vorhanden, Sprung zur Textmarke "Eingabe"
If (ActiveDocument.Bookmarks.Exists("Eingabe") = True) Then
    modTools.selectionGotoBookmark name:="Eingabe"
End If

'' Falls das Dokument Formularfelder enthält, Dokumentenschutz setzen
'V2.1: Nur Formularfelder können verändert werden
'Soll ein Dokument teilweise veränderbar sein, müssen sections eingefügt werden
'Sections sind hier noch unproblematisch, das aktualisieren der Felder muss dann
'aber für jede Section vorgenommen werden
If (WordBasic.[GetDocumentVar$]("Dokument_Typ") = "Formular") Then
    ActiveDocument.Protect wdAllowOnlyFormFields, noreset:=1, Password:="M1"
End If

'Assistant.Animation = msoAnimationGreeting
On Error GoTo errorhandler
'word-fehler-nachricht unterdrücken
Application.DisplayAlerts = wdAlertsNone
kanal = DDEInitiate(App:="uniface", topic:=Maske$)
If (kanal = 0) Then
    'versuchen die 1024er maske zu erreichen
    kanal = DDEInitiate(App:="uniface", topic:=Maske & "1024")
    If (kanal = 0) Then
        kanal = DDEInitiate(App:="uniface", topic:=Maske & "114x36")
    End If
End If
Application.DisplayAlerts = wdAlertsAll 'alle fehler anzeigen
If (kanal <> 0) Then
    '27.07.01 msh:
    caption = modTools.ApplicationCaption
    DDEPoke channel:=kanal, item:="dde_status", Data:=caption
    DDETerminate channel:=kanal
'07.11.2002 msh
Else
    'falls wir hier immernoch keinen gültigen kanal haben -> abbrechen
    MsgBox "Die Kommunikation mit M1 ist fehlgeschlagen !" & vbCrLf & _
        "Es kann zu unerwartetem Verhalten / Fehlfunktionen kommen.", vbCritical + vbOKOnly, "M1 - Arztbriefschreibung"
End If
Exit Sub
errorhandler:
Select Case Err.number
    Case 4596:  'DDeInitiate erfolglos
        Resume Next
    Case Else:
        MsgBox Err.number & " " & Err.Description
End Select
Resume Next
End Sub

Public Function AdresseOLE(Maske$) As String
logger.logInfo "modAdresseingabeOLE", "Adresse", "Proc start"
    Dim Empfaenger_Name As String
    Dim Empfaenger_Angaben As String
    Dim PLZ_Ort As String
    Dim Text_ As String
    Dim caption As String
    Dim dlg As Object
    Dim kanal As Variant
    AdresseOLE = "not ok"

'MsgBox "Debug 1"
    Empfaenger_Name = WordBasic.[GetDocumentVar$]("Empfänger")
    Empfaenger_Angaben = WordBasic.[GetDocumentVar$]("Empfänger_Angaben")

If ((Empfaenger_Name <> "") And _
    (WordBasic.[FileNameFromWindow$]() = "") And _
    (Empfaenger_Angaben = "ja")) Then

    Text_ = "Für den von Ihnen ausgewählten Empfänger " + _
            Empfaenger_Name$ + _
            " sind in M1 noch keine Adressenangaben erfaßt." + VBA.Chr(13) + _
            VBA.Chr(13) + "Bitte vervollständigen Sie die Adresse:"

    WordBasic.BeginDialog 550, 225, "Microsoft Word"
        WordBasic.Text 25, 15, 500, 50, Text_
        WordBasic.Text 25, 83, 133, 13, "Straße / Hausnr.:"
        WordBasic.Text 25, 108, 135, 13, "Postleitzahl / Ort:"
        WordBasic.Text 25, 133, 64, 13, "Telefon:"
        WordBasic.Text 25, 158, 60, 13, "Anrede:"
        WordBasic.TextBox 165, 80, 365, 18, "strasse"
        WordBasic.TextBox 167, 105, 75, 18, "plz"
        WordBasic.TextBox 245, 105, 285, 18, "ort"
        WordBasic.TextBox 165, 130, 160, 18, "telefon"
        WordBasic.TextBox 165, 155, 365, 18, "anrede"
        WordBasic.OKButton 100, 195, 125, 21
        WordBasic.CancelButton 325, 194, 125, 21
    WordBasic.EndDialog

    ActiveWindow.WindowState = wdWindowStateMaximize
    
    Set dlg = WordBasic.CurValues.UserDialog

    If (WordBasic.Dialog.UserDialog(dlg)) Then
        WordBasic.setAutoText "Empfänger_Name", Empfaenger_Name, 1
        WordBasic.setAutoText "Empfänger_Anrede", dlg.anrede, 1
        PLZ_Ort = dlg.plz + " " + dlg.ort
        WordBasic.setAutoText "Empfänger_PLZ_Ort", PLZ_Ort, 1
        WordBasic.setAutoText "Empfänger_Straße_Nr", dlg.strasse, 1
        WordBasic.setAutoText "Empfänger_Anschrift", dlg.strasse + _
                        ", " + PLZ_Ort, 1
        WordBasic.setAutoText "Empfänger_Telnr", dlg.telefon, 1
        WordBasic.setAutoText "Empfänger_Adresse", Empfaenger_Name$ + _
                        VBA.Chr(13) + dlg.strasse + VBA.Chr(13) + PLZ_Ort, 1
        WordBasic.setAutoText "Empfänger_MW", "", 1
        ' das funktioniert nur im "normalen" dokument
        'ActiveDocument.Fields.Update
        'deswegen besserr das:
        modM1Autotext.fieldsUpdate
        WordBasic.SetTemplateDirty 0
    End If

End If


''' Anzeige des Dokuments in Layout-Ansicht und maximiert
With ActiveWindow
    If (.View.SplitSpecial = wdPaneNone) Then
        .ActivePane.View.Type = wdPageView
    Else
        .View.Type = wdPageView
    End If
    'Hier kann es unter office97 krachen
    '.View.ShowFieldCodes = False
    'deswegen unter word97 nichts machen
    modTools.deactivateFieldFunctions
End With
'MsgBox "Debug 2"
''' Falls vorhanden, Sprung zur Textmarke "Eingabe"
If (ActiveDocument.Bookmarks.Exists("Eingabe") = True) Then
    modTools.selectionGotoBookmark name:="Eingabe"
End If

'' Falls das Dokument Formularfelder enthält, Dokumentenschutz setzen
'V2.1: Nur Formularfelder können verändert werden
'Soll ein Dokument teilweise veränderbar sein, müssen sections eingefügt werden
'Sections sind hier noch unproblematisch, das aktualisieren der Felder muss dann
'aber für jede Section vorgenommen werden
If (WordBasic.[GetDocumentVar$]("Dokument_Typ") = "Formular") Then
    ActiveDocument.Protect wdAllowOnlyFormFields, noreset:=1, Password:="M1"
End If

'Assistant.Animation = msoAnimationGreeting
On Error GoTo errorhandler
'word-fehler-nachricht unterdrücken
Application.DisplayAlerts = wdAlertsNone
'kanal = DDEInitiate(App:="uniface", topic:=Maske$)
'If (kanal = 0) Then
    'versuchen die 1024er maske zu erreichen
'    kanal = DDEInitiate(App:="uniface", topic:=Maske & "1024")
'    If (kanal = 0) Then
'        kanal = DDEInitiate(App:="uniface", topic:=Maske & "114x36")
'    End If
'End If
Application.DisplayAlerts = wdAlertsAll 'alle fehler anzeigen
'If (kanal <> 0) Then
    '27.07.01 msh:
'    caption = modTools.ApplicationCaption
'    DDEPoke channel:=kanal, item:="dde_status", Data:=caption
'    DDETerminate channel:=kanal
'07.11.2002 msh
'Else
    'falls wir hier immernoch keinen gültigen kanal haben -> abbrechen
'    MsgBox "Die Kommunikation mit M1 ist fehlgeschlagen !" & vbCrLf & _
'        "Es kann zu unerwartetem Verhalten / Fehlfunktionen kommen.", vbCritical + vbOKOnly, "M1 - Arztbriefschreibung"
AdresseOLE = CStr(modTools.ApplicationCaption)
'End If
Exit Function
errorhandler:
Select Case Err.number
    Case 4596:  'DDeInitiate erfolglos
        Resume Next
    Case Else:
        MsgBox Err.number & " " & Err.Description
End Select
Resume Next
End Function



Attribute VB_Name = "modDrucken"
Option Explicit

Public Sub Formular()
    logger.logInfo "modDrucken", "Formular", "Proc start"
    'Dim _Print   As DateiDrucken
    Dim Options As Object: Set Options = WordBasic.DialogRecord.ToolsOptionsPrint(False)
    WordBasic.CurValues.ToolsOptionsPrint Options
    WordBasic.ToolsOptionsPrint FormsData:=1
    'If (Dialog(_Print)) Then
    '   DateiDrucken _Print
    'End If
    ActiveDocument.PrintOut
    WordBasic.ToolsOptionsPrint Options
End Sub

Public Sub BGFormular()
Attribute BGFormular.VB_Description = "Ausdruck von BG-Formularen mit mehrfachem Durchschlag"
Attribute BGFormular.VB_ProcData.VB_Invoke_Func = "TemplateProject.BGFormulardruck.MAIN"
    logger.logInfo "modDrucken", "BGFormular", "Proc start"
'
' BGFormulardruck Makro
' Makro erstellt am 05.07.00 von Rüdiger Stratmann
'
WordBasic.BeginDialog 400, 225, "BG-Formulardruck"
    WordBasic.Text 40, 20, 307, 13, "BG-Berichte mit Durchschlägen erstellen", "Text1"
    WordBasic.CheckBox 60, 45, 285, 16, "Für den Unfallversicherungsträger", "UV"
    WordBasic.CheckBox 60, 63, 285, 16, "Für den Eigenbedarf", "Eigen"
    WordBasic.CheckBox 60, 81, 285, 16, "Für die Krankenkasse", "Kasse"
    WordBasic.CheckBox 60, 99, 285, 16, "Für den behandelnden Arzt", "Arzt"
    WordBasic.CheckBox 60, 117, 285, 16, "Für sonstige Zwecke", "sonst"
    WordBasic.CheckBox 60, 150, 285, 16, "Blankodruck", "blanko"

    WordBasic.PushButton 40, 185, 140, 21, "Ausdruck", "Druck"
    WordBasic.CancelButton 220, 185, 140, 21
WordBasic.EndDialog

Dim dlg As Object: Set dlg = WordBasic.CurValues.UserDialog
Dim Options As Object: Set Options = WordBasic.DialogRecord.ToolsOptionsPrint(False)

WordBasic.CurValues.ToolsOptionsPrint Options


dlg.UV = 1
dlg.Eigen = 1
dlg.Kasse = 1
dlg.Arzt = 1
dlg.sonst = 0

If (WordBasic.Dialog.UserDialog(dlg) = 1) Then
    If (dlg.blanko = 1) Then WordBasic.ToolsOptionsPrint FormsData:=1

    If (dlg.UV = 1) Then
        WordBasic.setformresult "BG_An", _
           "Für den Unfallversicherungsträger", 1
        WordBasic.setformresult "BG_Nr", "1", 1
        WordBasic.FilePrintDefault
    End If
    If (dlg.Eigen = 1) Then
        WordBasic.setformresult "BG_An", _
           "Für den Eigenbedarf ", 1
        WordBasic.setformresult "BG_Nr", "2", 1
        WordBasic.FilePrintDefault
    End If
    If (dlg.Kasse = 1) Then
        WordBasic.setformresult "BG_An", _
           "Für die Krankenkasse", 1
        WordBasic.setformresult "BG_Nr", "3", 1
        WordBasic.FilePrintDefault
    End If
    If (dlg.Arzt = 1) Then
        WordBasic.setformresult "BG_An", _
           "Für den behandelnden Arzt", 1
        WordBasic.setformresult "BG_Nr", "4", 1
        WordBasic.FilePrintDefault
    End If
    If (dlg.sonst = 1) Then
        WordBasic.setformresult "BG_An", _
           "Für sonstige Zwecke", 1
        WordBasic.setformresult "BG_Nr", "", 1
        WordBasic.FilePrintDefault
    End If
End If

WordBasic.ToolsOptionsPrint Options
End Sub


Attribute VB_Name = "modEinfügenDiktate"

Dim DlgUser__$()

Public Sub Main()
Attribute Main.VB_Description = "SpeechMagic-Spracheingabe einbinden"
Attribute Main.VB_ProcData.VB_Invoke_Func = "TemplateProject.EinfügenDiktate.MAIN"
    logger.logInfo "modEinfügenDiktate", "Main", "Proc start"
ReDim DlgUser__$(1)
ReDim DlgDiktat__$(0)
Dim a$, b$, d$, version$, Suchpfad$
Dim nFiles, i
Dim dlg As Object

version$ = System.PrivateProfileString("", _
            "HKEY_LOCAL_MACHINE\SOFTWARE\Philips\SpeechMagic", _
            "Version")

Suchpfad$ = System.PrivateProfileString("", _
            "HKEY_LOCAL_MACHINE\SOFTWARE\Philips\SpeechMagic\" _
            + version$, "SystemRoot") + "pdata"

WordBasic.FileFind SearchPath:=Suchpfad$, name:="dictation.doc", _
             SubDir:=1

nFiles = WordBasic.CountFoundFiles()
If (nFiles > 0) Then
    ReDim DlgUser__$(nFiles - 1)
    ReDim DlgDiktat__$(nFiles - 1)
    For i = 1 To WordBasic.CountFoundFiles()
        a$ = WordBasic.[FoundFileName$](i)
        b$ = VBA.Mid(a$, Len(Suchpfad$) + 2)
        DlgUser__$(i - 1) = VBA.Left(b$, VBA.InStr(b$, "\") - 1)
        d$ = VBA.Mid(b$, VBA.InStr(VBA.LCase(b$), "\dictations\") + 12)
        DlgDiktat__$(i - 1) = VBA.Left(d$, VBA.InStr(d$, "\") - 1)
    Next i

…