Private Sub ExportMap()
    'Verzeichnis und Dateinamen zum Speichern des Bildes auswählen
    Dim expDim As Integer
    Dim expDimX As Integer
    Dim expDimY As Integer
    Dim sFile As String
    ' Textdatei zum Lesen öffnen
    Set oStream = oFSO.OpenTextFile(App.Path & "\mapper.con", ForReading)
    gfxpfad = oStream.ReadLine
    ' Textfile schließen
        oStream.Close
    With dlgCommonDialog
        .DialogTitle = "Speichern"
        .CancelError = False
        'Zu erledigen: Festlegen der Flags und Attribute des 
        ' Standarddialog-Steuerelements
        .Filter = "Exportierte Map Files (*.bmp*)|*.bmp*"
        .InitDir = App.Path & "\maps"
        .ShowSave
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    If Not Right(sFile, 4) = ".bmp" Then
        sFile = sFile + ".bmp"
    End If
    MsgBar Me, "Karte wird exportiert", True
    'Größe der Karte ermitteln
    If felderx = feldery Then expDim = felderx
    If felderx > feldery Then
        expDim = felderx
    Else
        expDim = feldery
    End If
    zoomz = -80
    expDimX = (118 - (118 / 100 * Abs(zoomz))) * expDim
    expDimY = (60 - (60 / 100 * Abs(zoomz))) * expDim
    posX = Round(expDimX / 2) - (59 - (59 / 100 * Abs(zoomz)))
    posY = -120 - (-120 / 100 * Abs(zoomz))
    countX = 59 - (59 / 100 * Abs(zoomz))
    countY = 30 - (30 / 100 * Abs(zoomz))
    zoomx1 = zoomx - (zoomx / 100 * Abs(zoomz))
    zoomy1 = zoomy - (zoomy / 100 * Abs(zoomz))
    Debug.Print expDimX & "/" & expDimY
    With Quelle
        .Visible = True
        .BorderStyle = 0
        .AutoRedraw = True
        .AutoSize = False
        .ScaleMode = vbPixels
        .Width = expDimX
        .Height = expDimY
    End With
    For tabd = 1 To feldery
        For tabe = 1 To felderx
            indexGfx = Karte(tabe, tabd)
            posxx = posX + (countX * tabe) - (countX * tabd)
            posyy = posY + (countY * tabe) + (countY * tabd)
            If Tabelle.RecordCount > 0 And Not Tabelle.BOF Then Tabelle.MoveFirst
            gfxZahl = Tabelle.RecordCount
            Tabelle.Index = "IndexA"
            Tabelle.Seek "=", indexGfx
            pic1 = LoadPicture(gfxpfad & "\terrain\" & Tabelle("Pfad"))
            Quelle.PaintPicture wiesem.Picture, posxx, posyy, zoomx1, zoomy1, , _
              , , , vbMergePaint
            Quelle.PaintPicture pic1.Picture, posxx, posyy, zoomx1, zoomy1, , , _
            , , vbSrcAnd
        Next tabe
    Next tabd
    BildSpeichern Quelle, sFile
    zoomz = 0
    With Quelle
        .Visible = False
        .BorderStyle = 0
        .AutoRedraw = True
        .AutoSize = False
        .ScaleMode = vbPixels
        .Width = 10
        .Height = 10
        .Cls
    End With
    MsgBox "Bild erfolgreich exportiert", vbInformation, "Hinweis"
End Sub

Private Sub BildSpeichern(oContainer As Object, ByVal sFile As String)
      ' Inhalt einer Form/PictureBox als Bild speichern
      Dim FrmOldScaleMode As Integer
      Dim PicOldScaleMode As Integer
      Dim OldAutoRedraw As Boolean
 
      ' Scale-Mode auf Pixel setzen
      FrmOldScaleMode = Me.ScaleMode
      Me.ScaleMode = vbPixels
 
      ' Eigenschaften der 2. PictureBox, die als
      ' Zwischenspeicher dient
      With Ziel
        .Visible = False
        .BorderStyle = 0
        .AutoRedraw = True
        .ScaleMode = vbPixels
 
        ' 2. PictureBox über das Container-Objekt legen
        With oContainer
          PicOldScaleMode = .ScaleMode
          .ScaleMode = vbPixels
          Ziel.Move 0, 0, .ScaleWidth, .ScaleHeight
          Me.ScaleMode = FrmOldScaleMode
          OldAutoRedraw = .AutoRedraw
 
          ' Inhalt des Containers in die 2. PictureBox kopieren
          .AutoRedraw = False
          BitBlt Ziel.hdc, 0, 0, .ScaleWidth, .ScaleHeight, _
            .hdc, 0, 0, vbSrcCopy
          .AutoRedraw = OldAutoRedraw
          .ScaleMode = PicOldScaleMode
        End With
 
        ' Inhalt der 2. PictureBox als Bitmap speichern
        SavePicture .Image, sFile
        .Cls
        .AutoRedraw = False
      End With
      MsgBar Me, ""
End Sub