Resmi Excel'e Çevirme

[Zeki Gürsoy]

Bu program ile bir resmi Excel hücrelerine çevirebilirsiniz.

Kaynak Kod:

[SIZE=2]Imports System.Threading

Public Class Form1

   Private bmp As Bitmap, th As Thread

   Private Sub BtnBrowse_Click(sender As Object, e As EventArgs) Handles BtnBrowse.Click
      Dim dlg As New OpenFileDialog With {
         .Filter = "Jpg|*.jpg;*.jpeg|Bmp|*.bmp|Gif|*.gif|Icon|*ico",
         .InitialDirectory = Environment.GetFolderPath(Environment.SpecialFolder.Desktop)
      }

      Dim res As DialogResult = dlg.ShowDialog()

      If res = DialogResult.Cancel Then Exit Sub

      bmp = New Bitmap(dlg.FileName)

      Me.PictureBox1.Image = bmp

   End Sub

   Private Sub BtnAction_Click(sender As Object, e As EventArgs) Handles BtnAction.Click
     [COLOR=darkgreen] 'Asenkron ve en yüksek CPU önceliği (hız için) prosedur çağırma...[/COLOR]
      th = New Thread(AddressOf PicToXL) With {.Priority = ThreadPriority.Highest}
      th.Start()
   End Sub

   Private Sub BtnStop_Click(sender As Object, e As EventArgs) Handles BtnStop.Click
      th.Abort()
      ResetPrgBar()
   End Sub

   Private Sub ResetPrgBar()
      PrgBar.Value = 0
   End Sub
   Private Sub PicToXL()
      Dim xl = CreateObject("Excel.Application")
      Dim wb As Object = xl.WorkBooks.Add
      Dim sh As Object = wb.WorkSheets(1)

      xl.Windows(1).Zoom = 30
      sh.Cells.ColumnWidth = 0.27[COLOR=darkgreen] '0,1 cm[/COLOR]
      sh.Cells.RowHeight = 2.25[COLOR=darkgreen] '0,1 cm[/COLOR]

      xl.Visible = True
      xl.EnableEvents = False
      xl.Calculation = -4135 [COLOR=DarkGreen]'manuel[/COLOR]

      Dim pixColor As Color, i As Integer = 0

      PrgBar.Maximum = bmp.Width * bmp.Width

      For y As Integer = 0 To bmp.Height - 1

         For x = 0 To bmp.Width - 1

            pixColor = bmp.GetPixel(x, y)

            sh.Cells(y + 1, x + 1).Interior.Color = RGB(pixColor.R, pixColor.G, pixColor.B)

            i += 1

            PrgBar.Value = i

         Next

      Next

      PrgBar.Value = 0

      MsgBox("İşlem tamamlandı.", MsgBoxStyle.Information, "Zeki GÜRSOY")

   End Sub

End Class
[/SIZE]

 

[ÖmerBey]

Teşekkürler Zeki Bey,
Daha önce bmp uzantılı dosyaları excele aktaran bir makro kodu kullanmıştım. Bu ona göre çok daha işlevsel olmuş.
Ellerinize sağlık...

 

[anemis]

Mükemmel olmuş. Teşekkürler

 

[assenucler]

Teşekkürler

Sayın Zeki Gürsoy,


Emek ve paylaşımınız için teşekkürler.

Bayram hediyesi oldu. Sağ olun, var olun.

Sevgi ve saygılar.

 

[Haluk]

Zeki Bey, elinize saglik.

Mesajinizi gorunce, eski dostlardan ALPEN'in benzer bir calismasi geldi aklima.

Konuya ilgi duyanlar icin o mesajin linki asagidadir;

http://www.excel.web.tr/f121/excelde-sanat-reloaded-t1480.html


.