none
使用VB6轉變圖片顏色 RRS feed

  • 問題

  • 請問一下

    現在要將一個黑白的圖片.bmp 轉成紅白

    我參考了一些c++的寫法 大概都是先將bmp存進陣列 進行修改 再取出

    但看到的大多為 彩色轉黑白、灰階

    不知道 可否將黑色轉為紅色


    我的想法是 將bmp存進陣列後

    抓取其黑色碼將其RGB設定為紅色RGB(255,0,0)

    不知道 在VB6中的語法為何

    亦或我的想法有錯

    還請各位前輩給予指導 



    補充一點 目前是使用LeadTools 將圖片載入  

    PicPath = App.Path & "\ShowSealA.bmp"
    LEAD1.Load PicPath, 300, 300, 1 
    2009年9月29日 上午 02:29

解答

  •     Dim x As Integer, y As Integer
        Dim lngPoint As Long
    
        Me.Picture1.AutoRedraw = True
        Me.Picture1.Width = 352
        Me.Picture1.Height = 368
        Me.Picture1.Picture = LoadPicture("d:\1.bmp")
        Me.Picture2.AutoRedraw = True
        Me.Picture2.Width = 352
        Me.Picture2.Height = 368
        
        For x = 0 To Me.Picture1.Width - 1
        
            For y = 0 To Me.Picture1.Height - 1
                DoEvents
                lngPoint = Me.Picture1.Point(x, y)
         
                If lngPoint = 0 Then
    '                Me.Picture1.PSet (x, y), RGB(255, 0, 0)
                    Me.Picture2.PSet (x, y), RGB(255, 0, 0)
                Else
                    Me.Picture2.PSet (x, y), lngPoint
                End If
            
            Next
        
        Next
        
    '    SavePicture Me.Picture1.Image, "d:\TEST.BMP"
        SavePicture Me.Picture2.Image, "d:\TEST.BMP"

    奇怪,在下試可以耶,那就照心冷大的建議,使用兩個PictureBox,應該就可以了吧...
    • 已標示為解答 烏龍茶 2009年9月30日 上午 03:49
    2009年9月30日 上午 03:34

所有回覆

  •     Dim x As Integer, y As Integer
    
        Me.Picture1.AutoSize = True
        Me.Picture1.Picture = LoadPicture(App.Path & "\ShowSealA.bmp")
        
        For x = 0 To Me.Picture1.Width - 1
        
            For y = 0 To Me.Picture1.Height - 1
            
                If Me.Picture1.Point(x, y) = 0 Then
                    Me.Picture1.PSet (x, y), RGB(255, 0, 0)
                End If
            
            Next
        
        Next
        
        SavePicture Me.Picture1.Picture, "TEST.BMP"
    

    簡單的方式用PictureBox來做,圖片大時,效能會很差...
    2009年9月29日 上午 05:42
  • 首先 感謝 Joe大的回答

    但是 我測試了一下 

    上述的程式碼  無法將 圖片中 黑色的部分 轉成 紅色的說

    存出來的TEST.BMP 依然是黑白的

    我圖片是用小畫家製作 存成 24位元  點陣圖

    2009年9月29日 上午 08:20
  •     Me.Picture1.AutoRedraw = True

        SavePicture Me.Picture1.Image, "TEST.BMP"

    最前面把AutoRedraw屬性設為True,最後面改成存Image試試囉...



    • 已提議為解答 Sally150 2009年9月29日 上午 09:18
    • 已標示為解答 烏龍茶 2009年9月30日 上午 12:55
    • 已取消標示為解答 烏龍茶 2009年9月30日 上午 01:48
    2009年9月29日 上午 09:08
  • Me.Picture1.AutoRedraw = True 加了此行後 反而run不出圖 呈現忙碌狀態 最後就當了 如果只改 SavePicture Me.Picture1.Image, "TEST.BMP" 存出來的圖片依然沒有將黑色轉為紅色
    2009年9月29日 上午 09:39
  • 您的圖長寬是多少呢?AutoRedraw要設,然後在迴圈裡加入DoEvents,讓它能反應動作,此簡易方式效能很差,要耐心等候...
    2009年9月29日 上午 09:53
  •  恩 好的 再次謝謝您的回覆

    1.我在設定了 圖片的長寬厚  存出來的圖片卻只有全白的bmp (19x21)

    2.我將DoEvents加入迴圈後,存出來的圖片也是全白的bmp (19x21)  
    Private Sub Command1_Click()
    Dim x As Integer, y As Integer
    
        Me.Picture1.AutoRedraw = True
        Me.Picture1.Width = 352
        Me.Picture1.Height = 368
        Me.Picture1.Picture = LoadPicture(App.Path & "\ShowSealA.bmp")
        
        For x = 0 To Me.Picture1.Width - 1
        
            For y = 0 To Me.Picture1.Height - 1
         
                If Me.Picture1.Point(x, y) = 0 Then
                    Me.Picture1.PSet (x, y), RGB(255, 0, 0)
                    DoEvents
                End If
            
            Next
        
        Next
        
        SavePicture Me.Picture1.Image, "TEST.BMP"
    
    End Sub
    

       
       
    2009年9月30日 上午 12:55
  • 不要用同一個物件來處理,這樣 Bitmap Header 不會更新,所以表示色深不會改變。

    Set oldPicture = LoadPicture(...)
    ...

                If oldPicture.Point(x, y) = 0 Then
                    Me.Picture1.PSet (x, y), RGB(255, 0, 0)
                    DoEvents
                End If


    論壇是網友平等互助 保證解答請至 微軟技術支援服務
    2009年9月30日 上午 03:09
  •     Dim x As Integer, y As Integer
        Dim lngPoint As Long
    
        Me.Picture1.AutoRedraw = True
        Me.Picture1.Width = 352
        Me.Picture1.Height = 368
        Me.Picture1.Picture = LoadPicture("d:\1.bmp")
        Me.Picture2.AutoRedraw = True
        Me.Picture2.Width = 352
        Me.Picture2.Height = 368
        
        For x = 0 To Me.Picture1.Width - 1
        
            For y = 0 To Me.Picture1.Height - 1
                DoEvents
                lngPoint = Me.Picture1.Point(x, y)
         
                If lngPoint = 0 Then
    '                Me.Picture1.PSet (x, y), RGB(255, 0, 0)
                    Me.Picture2.PSet (x, y), RGB(255, 0, 0)
                Else
                    Me.Picture2.PSet (x, y), lngPoint
                End If
            
            Next
        
        Next
        
    '    SavePicture Me.Picture1.Image, "d:\TEST.BMP"
        SavePicture Me.Picture2.Image, "d:\TEST.BMP"

    奇怪,在下試可以耶,那就照心冷大的建議,使用兩個PictureBox,應該就可以了吧...
    • 已標示為解答 烏龍茶 2009年9月30日 上午 03:49
    2009年9月30日 上午 03:34
  • 恩  成功了

    再次

    謝謝 冷心大 與 Joe大 的指導 
    2009年9月30日 上午 03:49
  • 他應該原先 bmp 的色深是 1 bit ,要轉成 24/32 bits 的全彩檔。
    原先是全彩檔,只用黑白二色,是不受影響的,因為色深不變。


    論壇是網友平等互助 保證解答請至 微軟技術支援服務
    2009年9月30日 上午 05:57
  • 想再請問一下 心冷大

    我是利用小畫家將原本的bmp圖檔(8bit)轉成(24bit) 才可以顯示出紅色RGB(255,0,0)

    但我看了一下 bmp格式 8bit 應該是有256色 

    為什麼 我使用原圖(8bit)去執行上面程式 卻無法顯示紅色 而是 變成灰灰的

    有辦法直接讓8bit的圖片變成紅色嗎?  

    以上   謝謝 

    2009年10月1日 上午 07:48
  • 可以把圖放在類似Sky Drive網路空間,下載來試嗎...
    2009年10月1日 上午 09:14
  • 恩 

    圖片上傳了

    http://cid-c8bf6f09a8f383c3.skydrive.live.com/self.aspx/.Public/ShowSealA.bmp
    2009年10月1日 上午 09:25
  •     Me.Picture1.Picture = LoadPicture("d:\ShowSealA.bmp")
        Me.Picture1.AutoSize = True
        Me.Picture1.AutoRedraw = True
    '    Me.Picture1.Width = 352 * 15
    '    Me.Picture1.Height = 368 * 15
        Me.Picture2.AutoRedraw = True
        Me.Picture2.Width = Me.Picture1.Width
        Me.Picture2.Height = Me.Picture1.Height
    

    應該是邊界設太小,1像素等於15 Twips,參考以上設定,以舊P4 3G,512MB DDR RAM,五分鐘完成不到十分之一,可以考慮用其它方法了...


    2009年10月1日 上午 09:51
  • 256 色用的是顏色索引表,雖然大部分前面 19 色不太會動,但也要確認你顏色索引表是對應到那個顏色。
    論壇是網友平等互助 保證解答請至 微軟技術支援服務
    2009年10月1日 上午 10:11
  • 恩 效率的確不好 不過 我將 內建的PictureBox 

    換成 LeadTools 的元件後  還在忍受範圍

    現在比較疑惑的 是 原圖(8bit) 轉不出紅色 要修改成 24bit 才行 

    2009年10月1日 上午 10:54
  • 心冷大的意思是 我不能用 RGB(255,0,0)

    要改用 #FF0000 嗎 ?

    2009年10月1日 上午 10:57

  • http://zh.wikipedia.org/zh-tw/BMP

    您的8bit BMP圖應該是灰階而不是256色,所以只好改成24bit 吧,改用GetBitmapBits,SetBitmapBits,BitBlt API,效能會好很多...
    2009年10月2日 上午 04:21
  • 又有問題想請教大家了

    小弟在網路上參考到某篇文章

    將程式碼修改過後

    可以順利將黑色的bmp圖(24bit) 轉成 紅色的

    速度也非常快

    但是 他只顯示在FORM上

    小弟 不知道該如何把它  另存出來

    我看了一下可能是要用到 下列兩個方法 

    GdipSaveImageToFile
            
    GdipSaveGraphics

    但我試了很久 都失敗

    不知道 各位先進知道 是否知道他的語法

    或是 小弟有哪邊 想錯了 都請大家多多指導 謝謝

    最後先祝大家雙十節快樂

    Option Explicit
    
    Dim bitmap As Long, rc As RECTL
    Dim data() As Long
    
    Dim graphics As Long
    
    Private Sub Form_Load()
        InitGDIPlus
        
        GdipCreateBitmapFromFile StrPtr("C:\Documents and Settings\admin\桌面\TEST\1.bmp"), bitmap
        GdipGetImageWidth bitmap, rc.Right
        GdipGetImageHeight bitmap, rc.Bottom
        
        ReDim data(rc.Right - 1, rc.Bottom - 1)
    
        Dim BmpData As BitmapData
        With BmpData
            .Width = rc.Right
            .Height = rc.Bottom
            
            .PixelFormat = GpPixelFormat.PixelFormat32bppARGB
            .scan0 = VarPtr(data(0, 0))
            .stride = 4 * CLng(rc.Right)
        End With
    
        GdipBitmapLockBits bitmap, rc, ImageLockModeUserInputBuf Or ImageLockModeWrite Or ImageLockModeRead, GpPixelFormat.PixelFormat32bppARGB, BmpData
        
        Dim i As Long, j As Long, s As String
        For i = 0 To rc.Bottom - 1
            For j = 0 To rc.Right - 1
               If data(j, i) = &HFF000000 Then
                  data(j, i) = &HFFFF0000
               End If
            Next
        Next
        
        GdipBitmapUnlockBits bitmap, BmpData
        
        GdipCreateFromHDC Me.hDC, graphics
        
        GdipDrawImageRectI graphics, bitmap, 0, 0, rc.Right, rc.Bottom
        
        
        'GdipSaveImageToFile
            
        'GdipSaveGraphics
       
        
        GdipDeleteGraphics graphics
        
        GdipDisposeImage bitmap
        
        TerminateGDIPlus
        
        
      
    End Sub
    2009年10月2日 下午 03:26
  • http://cid-c8bf6f09a8f383c3.skydrive.live.com/self.aspx/.Public/TEST.rar

    附上程式碼 如果大家願意幫小弟 測一下的話 ....  謝謝
    2009年10月9日 上午 09:44
  • '    GdipCreateFromHDC Me.hDC, graphics
        GdipCreateFromHDC Me.Picture1.hDC, graphics



    原创转载 :: VB6 GDI+ 基础教程


    放個PictureBox設為圖的大小,然後設hDC,就可以用SavePicture了,或參考以上其它範例和說明...
    2009年10月9日 下午 02:09
  • 太感謝了...

    小弟實在獲益良多...
    2009年10月9日 下午 02:33