Attribute VB_Name = "ModSaveImage"
' ModSaveImage.bas

Option Explicit


' Getting image to data array


'##########################################################

Private Type BITMAPFILEHEADER   ' For saving 24bpp image from picDATA()
    bType             As Integer  ' BM        2
    bSize             As Long     ' 54+(3*W+EXB)*FullH  4  FileSize B
    bReserved1        As Integer  ' 0         2
    bReserved2        As Integer  ' 0         2
    bOffBits          As Long     ' 54        4
    bHeaderSize       As Long     ' 40        4
    bWidth            As Long     ' FullW         4
    bHeight           As Long     ' FullH         4
    bNumPlanes        As Integer  ' 1         2
    bBPP              As Integer  ' 24        2
    bCompress         As Long     ' 0         4
    bBytesInImage     As Long     ' (3*W+EXB)xH     4  Image size B
    bHRES             As Long     ' 0 ignore  4
    bVRES             As Long     ' 0 ignore  4
    bUsedIndexes      As Long     ' 0 ignore  4
    bImportantIndexes As Long     ' 0 ignore  4  Total = 54
End Type

Private bARR() As Byte  ' <<<<<<<<<<<<<<

Private m_Jpeg As cJPEGi
Dim CommonDialog1 As cOSDialog

Public Function SaveThePicture(Index As Integer)
' From Form1 only

' Public gifPAL(0 To 255) As Long
' Public bA8() As Byte
' Public picDATA(), picDATAREG(), FullW,FullH

' Save: Index =  2, Viewport, 3 Whole image, 4 Selection

Dim Title$, Filt$, InDir$
Dim FIndex As Long
Dim BHIDATAREGG As BITMAPINFOHEADER
Dim mHDC As Long, mBMPold As Long
' For save selection
Dim SrcX As Long, SrcY As Long
Dim SrcW As Long, SrcH As Long
Dim resp As Long
Dim r As RECT
Dim iw As Integer
Dim ih As Integer
   Select Case Index
   Case 2
      If Not aHasGDI Then
         Title$ = "Save displayed viewport (BMP,JPEG or GIF)"
      Else
         Title$ = "Save displayed viewport (BMP,JPEG,GIF,PNG,TIF)"
      End If
   Case 3
      If Not aHasGDI Then
         Title$ = "Save whole image (BMP,JPEG or GIF)"
      Else
         Title$ = "Save whole image (BMP,JPEG,GIF,PNG,TIF)"
      End If
   Case 4
      If Not aHasGDI Then
         Title$ = "Save selection (BMP,JPEG or GIF)"
      Else
         Title$ = "Save selection (BMP,JPEG,GIF,PNG,TIF)"
      End If
      If Form1.SHP(0).Width < 8 Or Form1.SHP(0).Height < 8 Then
         MsgBox "Selection too small (ie < 8)", vbCritical, "PaintRR"
         Screen.MousePointer = vbDefault
         Form1.picDRAW.MousePointer = vbCrosshair
         Exit Function
      End If
   End Select
   If Not aHasGDI Then
      Filt$ = "Windows Bitmap (*.bmp)|*.bmp|"
      Filt$ = Filt$ & "JPEG-JFIF Compliant, 85% quality, (*.jpg)|*.jpg|"
      Filt$ = Filt$ & "Graphics Interchange Format 87a (*.gif)|*.gif"
   Else
      Filt$ = "Windows Bitmap (*.bmp)|*.bmp|"
      Filt$ = Filt$ & "JPEG-JFIF Compliant, 85% quality, (*.jpg)|*.jpg|"
      Filt$ = Filt$ & "Graphics Interchange Format 87a (*.gif)|*.gif|"
      Filt$ = Filt$ & "Portable Networks Graphics (*.png)|*.png|"
      Filt$ = Filt$ & "Tagged Image File Format (*.tif)|*.tif"
   End If
   SaveSpec$ = ""
   InDir$ = SavePath$
   Set CommonDialog1 = New cOSDialog
   CommonDialog1.ShowSave SaveSpec$, Title$, Filt$, InDir$, "", Form1.hwnd, FIndex
   Set CommonDialog1 = Nothing
   ' Avoid click through
   GetWindowRect Form1.cmdDrawZoom.hwnd, r
   SetCursorPos r.Left + 10, r.TOp + 10
   
   If Len(SaveSpec$) = 0 Then
      Screen.MousePointer = vbDefault
      Exit Function
   End If
   ' FIndex = 1 bmp
   ' FIndex = 2 jpg
   ' FIndex = 3 gif
   ' FIndex = 4 png
   ' FIndex = 5 tif
   
   If FIndex = 4 Then ' PNG save
      resp = MsgBox("NB. PNGs will save with no transparency.  Continue?  ", vbQuestion + vbYesNo, "Saving PNG")
      If resp = vbNo Then
         SaveSpec$ = ""
         Exit Function
      End If
   End If
   
   Select Case Index
   Case 2, 3, 4
      Select Case FIndex
      Case 1
         FixExtension SaveSpec$, ".bmp"
      Case 2
         FixExtension SaveSpec$, ".jpg"
      Case 3
         FixExtension SaveSpec$, ".gif"
      Case 4
         FixExtension SaveSpec$, ".png"
      Case 5
         FixExtension SaveSpec$, ".tif"
      End Select
   End Select
   
   SavePath$ = GetPath(SaveSpec$)
   
   Select Case Index
   Case 2   ' SAVE VIEWPORT
      Select Case FIndex
      Case 1   ' Save viewport, bmp
         Form1.picDRAW.Picture = Form1.picDRAW.Image
         SavePicture Form1.picDRAW.Image, SaveSpec$
      Case 2   ' Save viewport, jpg
         Form1.picDRAW.Picture = Form1.picDRAW.Image
         If SaveHDCJPEG(SaveSpec$, Form1.picDRAW.hDC, Form1.picDRAW.Width, Form1.picDRAW.Height) <> 0 Then
            MsgBox "JPEG Saving failed", vbCritical, "PaintRR"
            SaveSpec$ = ""
         End If
      Case 3   ' Save viewport, gif
         iw = Form1.picDRAW.Width
         ih = Form1.picDRAW.Height
         With BHIDATAREGG
            .biSize = 40
            .biPlanes = 1
            .biWidth = iw
            .biHeight = ih
            .biBitCount = 32
         End With
         ReDim picDATAREG(0 To 3, 0 To iw - 1, 0 To ih - 1)
   
         ' Transfer pixel colors to picDATAREG() from picDRAW
         mHDC = CreateCompatibleDC(0)
         mBMPold = SelectObject(mHDC, Form1.picDRAW.Image)
         GetDIBits mHDC, Form1.picDRAW.Image, 0, ih, picDATAREG(0, 0, 0), BHIDATAREGG, 0
         SelectObject mHDC, mBMPold
         DeleteDC mHDC
         DeleteObject mBMPold
         
         ReduceTo256 picDATAREG(), 256, True  ' Returns gifPAL() & bA8()
         Unload frm256Colors
         a256 = False
         DoEvents
         
         iw = Int(iw)
         ih = Int(ih)
         MSaveGIF SaveSpec$, bA8(), iw, ih, gifPAL(), True
         
      Case 4, 5  ' Save viewport, png or tif
         Form1.picDRAW.Picture = Form1.picDRAW.Image
         If SavePictureFromHDC(Form1.picDRAW.Image, SaveSpec$) = False Then
             MsgBox "Error Saving " & SaveSpec$, vbCritical
         End If
      End Select

   Case 3   ' SAVE WHOLE IMAGE
      Select Case FIndex
      Case 1   ' Save whole image, bmp
      
'''
' Could check number of colors and if 2 then save as 1bpp :-

' See frmGFX,  mnuSave2ColorBMP_Click()

' Public Function SaveBMP2(FSpec$, bARR() As Byte, bWidth As Long, bHeight As Long, _
'                Optional Color1 As Long = vbBlack, Optional Color2 As Long = vbWhite) As Boolean
' SaveBMP2(SaveSpec$, picDATA(), FullW, FullH, Color1, Color2)
'''
      
         If Not SaveBMP24(SaveSpec$, picDATA(), FullW, FullH) Then
            MsgBox "Saving whole image - failed", vbCritical, "PaintRR"
            SaveSpec$ = ""
         End If

      Case 2   ' Save whole image, jpg
         SaveDATAREGJPEG SaveSpec$, picDATA(), FullW, FullH, 0, 0

      Case 3   ' Save whole image, gif
         ReduceTo256 picDATA(), 256, True  ' Returns gifPAL() & bA8()
         Unload frm256Colors
         a256 = False
         DoEvents
         
         iw = Int(FullW)
         ih = Int(FullH)
         MSaveGIF SaveSpec$, bA8(), iw, ih, gifPAL(), True
      Case 4, 5  ' Save whole image, png & tif
         ' Need to fill Form1.picCopy from picDATA()
         Form1.picCopy.Width = FullW
         Form1.picCopy.Height = FullH
         Form1.picCopy.Refresh

         picDATATopicCopy Form1.picCopy

         If SavePictureFromHDC(Form1.picCopy.Image, SaveSpec$) = False Then
             MsgBox "Error Saving " & SaveSpec$, vbCritical
         End If
      End Select

   Case 4   ' SAVE SELECTION

      'With Form1

         Make_picCopy Form1, SrcX, SrcY, SrcW, SrcH
         Form1.picCopy.Refresh
         ' picCopy image selection surrounded by black
         
         Select Case FIndex
         Case 1    ' Save selection, bmp
            SavePicture Form1.picCopy.Image, SaveSpec$
         Case 2    ' Save selection, jpg
            SaveHDCJPEG SaveSpec$, Form1.picCopy.hDC, SrcW, SrcH
         Case 3    ' Save selection, gif
            iw = Form1.picCopy.Width
            ih = Form1.picCopy.Height
            With BHIDATAREGG
               .biSize = 40
               .biPlanes = 1
               .biWidth = iw
               .biHeight = ih
               .biBitCount = 32
            End With
            ReDim bARR(0 To 3, 0 To iw - 1, 0 To ih - 1)
            ' Transfer pixel colors to bARR() from picSelect
            mHDC = CreateCompatibleDC(0)
            mBMPold = SelectObject(mHDC, Form1.picCopy.Image)
            GetDIBits mHDC, Form1.picCopy.Image, 0, ih, bARR(0, 0, 0), BHIDATAREGG, 0
            SelectObject mHDC, mBMPold
            DeleteDC mHDC
            DeleteObject mBMPold
            
            ReduceTo256 bARR(), 256, True  ' Returns gifPAL() & bA8()
            Unload frm256Colors
            a256 = False
            DoEvents
            
            iw = Int(iw)
            ih = Int(ih)
            MSaveGIF SaveSpec$, bA8(), iw, ih, gifPAL(), True
         Case 4, 5  ' Save selection, png & tif
            If SavePictureFromHDC(Form1.picCopy.Image, SaveSpec$) = False Then
                MsgBox "Error Saving " & SaveSpec$, vbCritical
            End If
         End Select
         Clear_picSelect Form1
         
      'End With
      
   End Select
   Screen.MousePointer = vbDefault
End Function


Public Function SaveBMP24(FSpec$, INpicDATA() As Byte, bWidth As Long, bHeight As Long) As Boolean
' Private bARR() As Byte  ' <<<<<<<<<<<<<<
' INpicDATA() = picDATA(0 To 3, 0 To FullW - 1, 0 To FullH - 1)  32 bpp array

Dim BFH As BITMAPFILEHEADER ' 54 bytes
Dim fnum As Long
Dim BytesPerScanLine As Long
Dim ExtraBytes As Long
Dim ix As Long, iy As Long
Dim iB As Long
On Error GoTo SaveBMPError

   BytesPerScanLine = (3 * bWidth + 3) And &HFFFFFFFC
   ExtraBytes = BytesPerScanLine - 3 * bWidth
   With BFH
      .bType = &H4D42    ' BM
      .bWidth = bWidth
      .bHeight = bHeight
      .bSize = 54 + BytesPerScanLine * Abs(bHeight)
      .bOffBits = 54
      .bHeaderSize = 40
      .bNumPlanes = 1
      .bBPP = 24
      .bBytesInImage = BytesPerScanLine * Abs(bHeight)
   End With
   ' 24bpp image map.  Fill from 32bpp image map.
   ReDim bARR(0 To 3 * bWidth - 1 + ExtraBytes, 0 To Abs(bHeight) - 1)
   For iy = 0 To Abs(bHeight) - 1
      iB = 0
      For ix = 0 To bWidth - 1
         iB = 3 * ix
         bARR(iB, iy) = INpicDATA(0, ix, iy)
         bARR(iB + 1, iy) = INpicDATA(1, ix, iy)
         bARR(iB + 2, iy) = INpicDATA(2, ix, iy)
      Next ix
   Next iy
   
   If FileExists(FSpec$) Then
      Kill FSpec$
      DoEvents
   End If
   
   fnum = FreeFile
   Open FSpec$ For Binary As fnum
   Put #fnum, , BFH
   Put #fnum, , bARR()  '<<<<<<<<<<<<
   Close #fnum
   Erase bARR()
   SaveBMP24 = True
   On Error GoTo 0
   Exit Function
'=======
SaveBMPError:
   Close
   SaveBMP24 = False
End Function

Public Sub SaveDATAREGJPEG(SaveSpec$, BDATA() As Byte, _
                        ByVal wide As Long, _
                        ByVal hite As Long, _
                        Optional ByVal SrcLeft As Long = 0, _
                        Optional ByVal SrcTop As Long = 0)

' bDATA() = picDATA(0 To 3, 0 To FullW - 1, 0 To FullH - 1)
' TEST
'Dim U1 As Long, U2 As Long
'U1 = UBound(bDATA(), 2)
'U2 = UBound(bDATA(), 3)

Dim ret As Long
   'Using Default Frequencies & Quality
   ' & No comments
   Set m_Jpeg = New cJPEGi
   'm_Jpeg.SetSamplingFrequencies 2, 2, 1, 1, 1, 1
   m_Jpeg.SetSamplingFrequencies 1, 1, 1, 1, 1, 1    ' Better quality but about 15% larger.
   m_Jpeg.Quality = 85
   m_Jpeg.Comment = "RRPaint©. "
   m_Jpeg.SampleDATA BDATA(), wide, hite, SrcLeft, SrcTop
   If FileExists(SaveSpec$) Then
      Kill SaveSpec$
      DoEvents
   End If
   ret = m_Jpeg.SaveFile(SaveSpec$)

   If ret = 3 Then
      MsgBox "Failed to save file"
      SaveSpec$ = ""
   End If

   Set m_Jpeg = Nothing
End Sub

Public Function SaveHDCJPEG(SaveSpec$, lHDC As Long, ByVal wide As Long, ByVal hite As Long) As Long
Dim ret As Long
   'Using Default Frequencies & Quality
   Set m_Jpeg = New cJPEGi
   'm_Jpeg.SetSamplingFrequencies 2, 2, 1, 1, 1, 1    ' Default
   m_Jpeg.SetSamplingFrequencies 1, 1, 1, 1, 1, 1    ' Better quality but about 15% larger.
   m_Jpeg.Quality = 85
   m_Jpeg.Comment = "RRPaint©. "
   If m_Jpeg.SampleHDC(lHDC, wide, hite) <> 0 Then
      Set m_Jpeg = Nothing
      SaveHDCJPEG = 1
      Exit Function
   End If
   
   If FileExists(SaveSpec$) Then
      Kill SaveSpec$
      DoEvents
   End If
   ret = m_Jpeg.SaveFile(SaveSpec$)
   
   If ret = 3 Then
      MsgBox "Failed to save file"
   End If
   
   Set m_Jpeg = Nothing
End Function


